Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: basis/cairo/ffi/ffi.factor basis/pango/cairo/cairo.factor basis/pango/layouts/layouts.factordb4
Anton Gorenko
commit
d5a7f99bea
|
|
@ -96,7 +96,6 @@ help:
|
|||
@echo "macosx-ppc"
|
||||
@echo "solaris-x86-32"
|
||||
@echo "solaris-x86-64"
|
||||
@echo "wince-arm"
|
||||
@echo "winnt-x86-32"
|
||||
@echo "winnt-x86-64"
|
||||
@echo ""
|
||||
|
|
@ -162,9 +161,6 @@ winnt-x86-64:
|
|||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
|
||||
|
||||
wince-arm:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
|
||||
|
||||
ifdef CONFIG
|
||||
|
||||
macosx.app: factor
|
||||
|
|
@ -219,7 +215,4 @@ clean:
|
|||
rm -f libfactor-ffi-test.*
|
||||
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
|
||||
|
||||
tags:
|
||||
etags vm/*.{cpp,hpp,mm,S,c}
|
||||
|
||||
.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app
|
||||
|
|
|
|||
11
Nmakefile
11
Nmakefile
|
|
@ -14,18 +14,17 @@ CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
|
|||
|
||||
!IF "$(PLATFORM)" == "x86-32"
|
||||
LINK_FLAGS = $(LINK_FLAGS) /safeseh
|
||||
PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj
|
||||
!ELSEIF "$(PLATFORM)" == "x86-64"
|
||||
PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
|
||||
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj
|
||||
!ENDIF
|
||||
|
||||
ML_FLAGS = /nologo /safeseh
|
||||
|
||||
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
|
||||
EXE_OBJS = vm/main-windows.obj vm\factor.res
|
||||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm\os-windows.obj \
|
||||
vm\os-windows-nt.obj \
|
||||
vm\aging_collector.obj \
|
||||
vm\alien.obj \
|
||||
vm\arrays.obj \
|
||||
|
|
@ -56,7 +55,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm\jit.obj \
|
||||
vm\math.obj \
|
||||
vm\mvm.obj \
|
||||
vm\mvm-windows-nt.obj \
|
||||
vm\mvm-windows.obj \
|
||||
vm\nursery_collector.obj \
|
||||
vm\object_start_map.obj \
|
||||
vm\objects.obj \
|
||||
|
|
@ -68,7 +67,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm\to_tenured_collector.obj \
|
||||
vm\tuples.obj \
|
||||
vm\utilities.obj \
|
||||
vm\vm.obj \
|
||||
vm\vm.obj \
|
||||
vm\words.obj
|
||||
|
||||
.cpp.obj:
|
||||
|
|
|
|||
|
|
@ -33,6 +33,8 @@ TYPEDEF: int MyInt
|
|||
|
||||
[ 32 ] [ { int 8 } heap-size ] unit-test
|
||||
|
||||
[ ] [ pointer: { int 8 } heap-size pointer: void heap-size assert= ] unit-test
|
||||
|
||||
TYPEDEF: char MyChar
|
||||
|
||||
[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@ CONSULT: c-type-protocol c-type-name
|
|||
c-type ;
|
||||
|
||||
PREDICATE: typedef-word < c-type-word
|
||||
"c-type" word-prop c-type-name? ;
|
||||
"c-type" word-prop [ c-type-name? ] [ array? ] bi or ;
|
||||
|
||||
: typedef ( old new -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -15,8 +15,6 @@ HELP: <c-object>
|
|||
{ $description "Creates a byte array suitable for holding a value with the given C type." }
|
||||
{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
{ <c-object> malloc-object } related-words
|
||||
|
||||
HELP: memory>byte-array
|
||||
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||
|
|
@ -28,12 +26,6 @@ HELP: malloc-array
|
|||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
|
||||
|
||||
HELP: malloc-object
|
||||
{ $values { "type" "a C type" } { "alien" alien } }
|
||||
{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
|
||||
|
||||
HELP: malloc-byte-array
|
||||
{ $values { "byte-array" byte-array } { "alien" alien } }
|
||||
{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
|
||||
|
|
@ -92,7 +84,6 @@ ARTICLE: "malloc" "Manual memory management"
|
|||
$nl
|
||||
"Allocating a C datum with a fixed address:"
|
||||
{ $subsections
|
||||
malloc-object
|
||||
malloc-byte-array
|
||||
}
|
||||
"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
|
||||
|
|
|
|||
|
|
@ -22,16 +22,25 @@ GENERIC: <c-array> ( len c-type -- array )
|
|||
M: word <c-array>
|
||||
c-array-constructor execute( len -- array ) ; inline
|
||||
|
||||
M: pointer <c-array>
|
||||
drop void* <c-array> ;
|
||||
|
||||
GENERIC: (c-array) ( len c-type -- array )
|
||||
|
||||
M: word (c-array)
|
||||
c-(array)-constructor execute( len -- array ) ; inline
|
||||
|
||||
M: pointer (c-array)
|
||||
drop void* (c-array) ;
|
||||
|
||||
GENERIC: <c-direct-array> ( alien len c-type -- array )
|
||||
|
||||
M: word <c-direct-array>
|
||||
c-direct-array-constructor execute( alien len -- array ) ; inline
|
||||
|
||||
M: pointer <c-direct-array>
|
||||
drop void* <c-direct-array> ;
|
||||
|
||||
: malloc-array ( n type -- array )
|
||||
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
|
||||
|
||||
|
|
@ -44,12 +53,6 @@ M: word <c-direct-array>
|
|||
: (c-object) ( type -- array )
|
||||
heap-size (byte-array) ; inline
|
||||
|
||||
: malloc-object ( type -- alien )
|
||||
1 swap heap-size calloc ; inline
|
||||
|
||||
: (malloc-object) ( type -- alien )
|
||||
heap-size malloc ; inline
|
||||
|
||||
: malloc-byte-array ( byte-array -- alien )
|
||||
binary-object [ nip malloc dup ] 2keep memcpy ;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,23 +23,43 @@ CONSTANT: eleven 11
|
|||
[ pointer: int* ] [ "int**" parse-c-type ] unit-test
|
||||
[ pointer: int** ] [ "int***" parse-c-type ] unit-test
|
||||
[ pointer: int*** ] [ "int****" parse-c-type ] unit-test
|
||||
[ { pointer: int 3 } ] [ "int*[3]" parse-c-type ] unit-test
|
||||
[ { pointer: void 3 } ] [ "void*[3]" parse-c-type ] unit-test
|
||||
[ pointer: { int 3 } ] [ "int[3]*" parse-c-type ] unit-test
|
||||
[ c-string ] [ "c-string" parse-c-type ] unit-test
|
||||
[ char2 ] [ "char2" parse-c-type ] unit-test
|
||||
[ pointer: char2 ] [ "char2*" parse-c-type ] unit-test
|
||||
|
||||
[ "void[3]" parse-c-type ] must-fail
|
||||
[ "int[3" parse-c-type ] must-fail
|
||||
[ "int[3][4" parse-c-type ] must-fail
|
||||
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
|
||||
] with-file-vocabs
|
||||
|
||||
FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
|
||||
|
||||
[ (( arg1 arg2 -- void* )) ] [
|
||||
\ alien-parser-function-effect-test "declared-effect" word-prop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ \ alien-parser-function-effect-test inline? ] unit-test
|
||||
|
||||
FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
|
||||
|
||||
[ (( arg1 arg2 -- void* )) ] [
|
||||
\ (alien-parser-function-effect-test) "declared-effect" word-prop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ \ (alien-parser-function-effect-test) inline? ] unit-test
|
||||
|
||||
CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ;
|
||||
|
||||
[ (( arg1 arg2 -- void* )) ] [
|
||||
\ alien-parser-callback-effect-test "callback-effect" word-prop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ \ alien-parser-callback-effect-test inline? ] unit-test
|
||||
|
||||
! Reported by mnestic
|
||||
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
|
||||
|
||||
|
|
|
|||
|
|
@ -12,21 +12,29 @@ SYMBOL: current-library
|
|||
: parse-c-type-name ( name -- word )
|
||||
dup search [ ] [ no-word ] ?if ;
|
||||
|
||||
: parse-array-type ( name -- dims c-type )
|
||||
DEFER: (parse-c-type)
|
||||
|
||||
ERROR: bad-array-type ;
|
||||
|
||||
: parse-array-type ( name -- c-type )
|
||||
"[" split unclip
|
||||
[ [ "]" ?tail drop parse-word ] map ] dip ;
|
||||
[ [ "]" ?tail [ bad-array-type ] unless parse-word ] map ]
|
||||
[ (parse-c-type) ]
|
||||
bi* prefix ;
|
||||
|
||||
: (parse-c-type) ( string -- type )
|
||||
{
|
||||
{ [ dup "void" = ] [ drop void ] }
|
||||
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
|
||||
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
|
||||
{ [ dup search ] [ parse-c-type-name ] }
|
||||
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
|
||||
{ [ CHAR: ] over member? ] [ parse-array-type ] }
|
||||
{ [ dup search ] [ parse-c-type-name ] }
|
||||
[ dup search [ ] [ no-word ] ?if ]
|
||||
} cond ;
|
||||
|
||||
: c-array? ( c-type -- ? )
|
||||
{ [ array? ] [ first { [ c-type-word? ] [ pointer? ] } 1|| ] } 1&& ;
|
||||
|
||||
: valid-c-type? ( c-type -- ? )
|
||||
{ [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
|
||||
{ [ c-array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
|
||||
|
||||
: parse-c-type ( string -- type )
|
||||
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: alien.c-types alien.prettyprint alien.syntax
|
||||
io.streams.string see tools.test prettyprint ;
|
||||
io.streams.string see tools.test prettyprint
|
||||
io.encodings.ascii ;
|
||||
IN: alien.prettyprint.tests
|
||||
|
||||
CONSTANT: FOO 10
|
||||
|
|
@ -9,7 +10,7 @@ FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
|
|||
[ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
FUNCTION: int function_test
|
||||
( float x, int[4][FOO] y, char* z, ushort* w ) ;
|
||||
( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
|
||||
" ] [
|
||||
[ \ function_test see ] with-string-writer
|
||||
] unit-test
|
||||
|
|
@ -20,11 +21,28 @@ FUNCTION-ALIAS: function-test int function_test
|
|||
[ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
FUNCTION-ALIAS: function-test int function_test
|
||||
( float x, int[4][FOO] y, char* z, ushort* w ) ;
|
||||
( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
|
||||
" ] [
|
||||
[ \ function-test see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
TYPEDEF: c-string[ascii] string-typedef
|
||||
TYPEDEF: char[1][2][3] array-typedef
|
||||
|
||||
[ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
TYPEDEF: c-string[ascii] string-typedef
|
||||
" ] [
|
||||
[ \ string-typedef see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "USING: alien.c-types alien.syntax ;
|
||||
IN: alien.prettyprint.tests
|
||||
TYPEDEF: char[1][2][3] array-typedef
|
||||
" ] [
|
||||
[ \ array-typedef see ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
C-TYPE: opaque-c-type
|
||||
|
||||
[ "USING: alien.syntax ;
|
||||
|
|
|
|||
|
|
@ -16,11 +16,11 @@ SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
|
|||
SYNTAX: LIBRARY: scan current-library set ;
|
||||
|
||||
SYNTAX: FUNCTION:
|
||||
(FUNCTION:) make-function define-declared ;
|
||||
(FUNCTION:) make-function define-inline ;
|
||||
|
||||
SYNTAX: FUNCTION-ALIAS:
|
||||
scan-token create-function
|
||||
(FUNCTION:) (make-function) define-declared ;
|
||||
(FUNCTION:) (make-function) define-inline ;
|
||||
|
||||
SYNTAX: CALLBACK:
|
||||
(CALLBACK:) define-inline ;
|
||||
|
|
|
|||
|
|
@ -10,13 +10,17 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
|
|||
url "checksums.txt" >url derive-url http-get nip
|
||||
string-lines [ " " split1 ] { } map>assoc ;
|
||||
|
||||
: file-checksum ( image -- checksum )
|
||||
md5 checksum-file hex-string ;
|
||||
|
||||
: download-checksum ( image -- checksum )
|
||||
download-checksums at ;
|
||||
|
||||
: need-new-image? ( image -- ? )
|
||||
dup exists?
|
||||
[
|
||||
[ md5 checksum-file hex-string ]
|
||||
[ download-checksums at ]
|
||||
bi = not
|
||||
] [ drop t ] if ;
|
||||
[ [ file-checksum ] [ download-checksum ] bi = not ]
|
||||
[ drop t ]
|
||||
if ;
|
||||
|
||||
: verify-image ( image -- )
|
||||
need-new-image? [ "Boot image corrupt" throw ] when ;
|
||||
|
|
|
|||
|
|
@ -15,12 +15,7 @@ generalizations ;
|
|||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
[ dup "winnt" = "winnt" "unix" ? ] dip
|
||||
{
|
||||
{ "ppc" [ drop "-ppc" append ] }
|
||||
{ "x86.32" [ nip "-x86.32" append ] }
|
||||
{ "x86.64" [ nip "-x86.64" append ] }
|
||||
} case ;
|
||||
[ "winnt" = "winnt" "unix" ? ] dip "-" glue ;
|
||||
|
||||
: my-arch ( -- arch )
|
||||
os name>> cpu name>> arch ;
|
||||
|
|
@ -35,7 +30,6 @@ IN: bootstrap.image
|
|||
{
|
||||
"winnt-x86.32" "unix-x86.32"
|
||||
"winnt-x86.64" "unix-x86.64"
|
||||
"linux-ppc" "macosx-ppc"
|
||||
} ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -207,6 +201,8 @@ SPECIAL-OBJECT: jit-declare-word 41
|
|||
SPECIAL-OBJECT: c-to-factor-word 42
|
||||
SPECIAL-OBJECT: lazy-jit-compile-word 43
|
||||
SPECIAL-OBJECT: unwind-native-frames-word 44
|
||||
SPECIAL-OBJECT: fpu-state-word 45
|
||||
SPECIAL-OBJECT: set-fpu-state-word 46
|
||||
|
||||
SPECIAL-OBJECT: callback-stub 48
|
||||
|
||||
|
|
@ -546,6 +542,8 @@ M: quotation '
|
|||
\ c-to-factor c-to-factor-word set
|
||||
\ lazy-jit-compile lazy-jit-compile-word set
|
||||
\ unwind-native-frames unwind-native-frames-word set
|
||||
\ fpu-state fpu-state-word set
|
||||
\ set-fpu-state set-fpu-state-word set
|
||||
undefined-def undefined-quot set ;
|
||||
|
||||
: emit-special-objects ( -- )
|
||||
|
|
|
|||
|
|
@ -6,6 +6,6 @@ IN: bootstrap.io
|
|||
"io.backend." {
|
||||
{ [ "io-backend" get ] [ "io-backend" get ] }
|
||||
{ [ os unix? ] [ "unix." os name>> append ] }
|
||||
{ [ os winnt? ] [ "windows.nt" ] }
|
||||
{ [ os windows? ] [ "windows" ] }
|
||||
} cond append require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -72,8 +72,7 @@ SYMBOL: bootstrap-time
|
|||
(command-line) parse-command-line
|
||||
|
||||
! Set dll paths
|
||||
os wince? [ "windows.ce" require ] when
|
||||
os winnt? [ "windows.nt" require ] when
|
||||
os windows? [ "windows" require ] when
|
||||
|
||||
"staging" get "deploy-vocab" get or [
|
||||
"stage2: deployment mode" print
|
||||
|
|
|
|||
|
|
@ -1,15 +1,13 @@
|
|||
! Copyright (c) 2007 Sampo Vuori
|
||||
! Copyright (c) 2008 Matthew Willis
|
||||
!
|
||||
|
||||
|
||||
! Adapted from cairo.h, version 1.5.14
|
||||
! License: http://factorcode.org/license.txt
|
||||
|
||||
! Copyright (C) 2007 Sampo Vuori.
|
||||
! Copyright (C) 2008 Matthew Willis.
|
||||
! Copyright (C) 2010 Anton Gorenko.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.destructors alien.libraries
|
||||
alien.syntax classes.struct combinators kernel system ;
|
||||
|
||||
IN: cairo.ffi
|
||||
|
||||
! Adapted from cairo.h, version 1.8.10
|
||||
|
||||
<< {
|
||||
{ [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
|
||||
{ [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] }
|
||||
|
|
@ -37,9 +35,8 @@ STRUCT: cairo_matrix_t
|
|||
|
||||
TYPEDEF: void* cairo_pattern_t
|
||||
|
||||
TYPEDEF: void* cairo_destroy_func_t
|
||||
: cairo-destroy-func ( quot -- callback )
|
||||
[ void { pointer: void } cdecl ] dip alien-callback ; inline
|
||||
CALLBACK: void
|
||||
cairo_destroy_func_t ( void* data ) ;
|
||||
|
||||
! See cairo.h for details
|
||||
STRUCT: cairo_user_data_key_t
|
||||
|
|
@ -70,22 +67,28 @@ ENUM: cairo_status_t
|
|||
CAIRO_STATUS_INVALID_INDEX
|
||||
CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
|
||||
CAIRO_STATUS_TEMP_FILE_ERROR
|
||||
CAIRO_STATUS_INVALID_STRIDE ;
|
||||
CAIRO_STATUS_INVALID_STRIDE
|
||||
CAIRO_STATUS_FONT_TYPE_MISMATCH
|
||||
CAIRO_STATUS_USER_FONT_IMMUTABLE
|
||||
CAIRO_STATUS_USER_FONT_ERROR
|
||||
CAIRO_STATUS_NEGATIVE_COUNT
|
||||
CAIRO_STATUS_INVALID_CLUSTERS
|
||||
CAIRO_STATUS_INVALID_SLANT
|
||||
CAIRO_STATUS_INVALID_WEIGHT ;
|
||||
|
||||
TYPEDEF: int cairo_content_t
|
||||
CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000
|
||||
CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000
|
||||
CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
|
||||
ENUM: cairo_content_t
|
||||
{ CAIRO_CONTENT_COLOR HEX: 1000 }
|
||||
{ CAIRO_CONTENT_ALPHA HEX: 2000 }
|
||||
{ CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 } ;
|
||||
|
||||
TYPEDEF: void* cairo_write_func_t
|
||||
: cairo-write-func ( quot -- callback )
|
||||
[ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
|
||||
|
||||
TYPEDEF: void* cairo_read_func_t
|
||||
: cairo-read-func ( quot -- callback )
|
||||
[ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
|
||||
CALLBACK: cairo_status_t
|
||||
cairo_write_func_t ( void* closure, uchar* data, uint length ) ;
|
||||
|
||||
CALLBACK: cairo_status_t
|
||||
cairo_read_func_t ( void* closure, uchar* data, uint length ) ;
|
||||
|
||||
! Functions for manipulating state objects
|
||||
|
||||
FUNCTION: cairo_t*
|
||||
cairo_create ( cairo_surface_t* target ) ;
|
||||
|
||||
|
|
@ -116,7 +119,7 @@ FUNCTION: void
|
|||
cairo_push_group ( cairo_t* cr ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
|
||||
cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
|
||||
|
||||
FUNCTION: cairo_pattern_t*
|
||||
cairo_pop_group ( cairo_t* cr ) ;
|
||||
|
|
@ -125,6 +128,7 @@ FUNCTION: void
|
|||
cairo_pop_group_to_source ( cairo_t* cr ) ;
|
||||
|
||||
! Modify state
|
||||
|
||||
ENUM: cairo_operator_t
|
||||
CAIRO_OPERATOR_CLEAR
|
||||
|
||||
|
|
@ -234,6 +238,7 @@ FUNCTION: void
|
|||
cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
|
||||
|
||||
! Path creation functions
|
||||
|
||||
FUNCTION: void
|
||||
cairo_new_path ( cairo_t* cr ) ;
|
||||
|
||||
|
|
@ -274,6 +279,7 @@ FUNCTION: void
|
|||
cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
|
||||
|
||||
! Painting functions
|
||||
|
||||
FUNCTION: void
|
||||
cairo_paint ( cairo_t* cr ) ;
|
||||
|
||||
|
|
@ -305,6 +311,7 @@ FUNCTION: void
|
|||
cairo_show_page ( cairo_t* cr ) ;
|
||||
|
||||
! Insideness testing
|
||||
|
||||
FUNCTION: cairo_bool_t
|
||||
cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
|
||||
|
||||
|
|
@ -312,6 +319,7 @@ FUNCTION: cairo_bool_t
|
|||
cairo_in_fill ( cairo_t* cr, double x, double y ) ;
|
||||
|
||||
! Rectangular extents
|
||||
|
||||
FUNCTION: void
|
||||
cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
|
||||
|
||||
|
|
@ -319,6 +327,7 @@ FUNCTION: void
|
|||
cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
|
||||
|
||||
! Clipping
|
||||
|
||||
FUNCTION: void
|
||||
cairo_reset_clip ( cairo_t* cr ) ;
|
||||
|
||||
|
|
@ -355,9 +364,28 @@ TYPEDEF: void* cairo_scaled_font_t
|
|||
TYPEDEF: void* cairo_font_face_t
|
||||
|
||||
STRUCT: cairo_glyph_t
|
||||
{ index ulong }
|
||||
{ x double }
|
||||
{ y double } ;
|
||||
{ index ulong }
|
||||
{ x double }
|
||||
{ y double } ;
|
||||
|
||||
FUNCTION: cairo_glyph_t*
|
||||
cairo_glyph_allocate ( int num_glyphs ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_glyph_free ( cairo_glyph_t* glyphs ) ;
|
||||
|
||||
STRUCT: cairo_text_cluster_t
|
||||
{ num_bytes int }
|
||||
{ num_glyphs int } ;
|
||||
|
||||
FUNCTION: cairo_text_cluster_t*
|
||||
cairo_text_cluster_allocate ( int num_clusters ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_text_cluster_free ( cairo_text_cluster_t* clusters ) ;
|
||||
|
||||
ENUM: cairo_text_cluster_flags_t
|
||||
{ CAIRO_TEXT_CLUSTER_FLAG_BACKWARD HEX: 00000001 } ;
|
||||
|
||||
STRUCT: cairo_text_extents_t
|
||||
{ x_bearing double }
|
||||
|
|
@ -489,7 +517,10 @@ FUNCTION: void
|
|||
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_text_path ( cairo_t* cr, c-string utf8 ) ;
|
||||
cairo_show_text_glyphs ( cairo_t* cr, c-string utf8, int utf8_len, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_cluster_t* clusters, int num_clusters, cairo_text_cluster_flags_t cluster_flags ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_text_path ( cairo_t* cr, c-string utf8 ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
|
||||
|
|
@ -521,7 +552,8 @@ ENUM: cairo_font_type_t
|
|||
CAIRO_FONT_TYPE_TOY
|
||||
CAIRO_FONT_TYPE_FT
|
||||
CAIRO_FONT_TYPE_WIN32
|
||||
CAIRO_FONT_TYPE_QUARTZ ;
|
||||
CAIRO_FONT_TYPE_QUARTZ
|
||||
CAIRO_FONT_TYPE_USER ;
|
||||
|
||||
FUNCTION: cairo_font_type_t
|
||||
cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
|
||||
|
|
@ -567,6 +599,9 @@ cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, c-string utf8
|
|||
FUNCTION: void
|
||||
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
|
||||
|
||||
FUNCTION: cairo_status_t
|
||||
cairo_scaled_font_text_to_glyphs ( cairo_scaled_font_t* scaled_font, double x, double y, c-string utf8, int utf8_len, cairo_glyph_t** glyphs, int* num_glyphs, cairo_text_cluster_t** clusters, int* num_clusters, cairo_text_cluster_flags_t* cluster_flags ) ;
|
||||
|
||||
FUNCTION: cairo_font_face_t*
|
||||
cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
|
||||
|
||||
|
|
@ -576,9 +611,73 @@ cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matr
|
|||
FUNCTION: void
|
||||
cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_scaled_font_get_scale_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* scale_matrix ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
|
||||
|
||||
! Toy fonts
|
||||
|
||||
FUNCTION: cairo_font_face_t*
|
||||
cairo_toy_font_face_create ( c-string family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
|
||||
|
||||
FUNCTION: c-string
|
||||
cairo_toy_font_face_get_family ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
FUNCTION: cairo_font_slant_t
|
||||
cairo_toy_font_face_get_slant ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
FUNCTION: cairo_font_weight_t
|
||||
cairo_toy_font_face_get_weight ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
! User fonts
|
||||
|
||||
FUNCTION: cairo_font_face_t*
|
||||
cairo_user_font_face_create ( ) ;
|
||||
|
||||
! User-font method signatures
|
||||
|
||||
CALLBACK: cairo_status_t
|
||||
cairo_user_scaled_font_init_func_t ( cairo_scaled_font_t* scaled_font, cairo_t* cr, cairo_font_extents_t* extents ) ;
|
||||
|
||||
CALLBACK: cairo_status_t
|
||||
cairo_user_scaled_font_render_glyph_func_t ( cairo_scaled_font_t* scaled_font, ulong glyph, cairo_t* cr, cairo_text_extents_t* extents ) ;
|
||||
|
||||
CALLBACK: cairo_status_t
|
||||
cairo_user_scaled_font_text_to_glyphs_func_t ( cairo_scaled_font_t* scaled_font, char* utf8, int utf8_len, cairo_glyph_t** glyphs, int* num_glyphs, cairo_text_cluster_t** clusters, int* num_clusters, cairo_text_cluster_flags_t* cluster_flags ) ;
|
||||
|
||||
CALLBACK: cairo_status_t
|
||||
cairo_user_scaled_font_unicode_to_glyph_func_t ( cairo_scaled_font_t* scaled_font, ulong unicode, ulong* glyph_index ) ;
|
||||
|
||||
! User-font method setters
|
||||
|
||||
FUNCTION: void
|
||||
cairo_user_font_face_set_init_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_init_func_t init_func ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_user_font_face_set_render_glyph_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_render_glyph_func_t render_glyph_func ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_user_font_face_set_text_to_glyphs_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_text_to_glyphs_func_t text_to_glyphs_func ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_user_font_face_set_unicode_to_glyph_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_unicode_to_glyph_func_t unicode_to_glyph_func ) ;
|
||||
|
||||
! User-font method getters
|
||||
|
||||
FUNCTION: cairo_user_scaled_font_init_func_t
|
||||
cairo_user_font_face_get_init_func ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
FUNCTION: cairo_user_scaled_font_render_glyph_func_t
|
||||
cairo_user_font_face_get_render_glyph_func ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
FUNCTION: cairo_user_scaled_font_text_to_glyphs_func_t
|
||||
cairo_user_font_face_get_text_to_glyphs_func ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
FUNCTION: cairo_user_scaled_font_unicode_to_glyph_func_t
|
||||
cairo_user_font_face_get_unicode_to_glyph_func ( cairo_font_face_t* font_face ) ;
|
||||
|
||||
! Query functions
|
||||
|
||||
FUNCTION: cairo_operator_t
|
||||
|
|
@ -649,9 +748,9 @@ UNION-STRUCT: cairo_path_data_t
|
|||
{ header cairo_path_data_t-header } ;
|
||||
|
||||
STRUCT: cairo_path_t
|
||||
{ status cairo_status_t }
|
||||
{ data cairo_path_data_t* }
|
||||
{ num_data int } ;
|
||||
{ status cairo_status_t }
|
||||
{ data cairo_path_data_t* }
|
||||
{ num_data int } ;
|
||||
|
||||
FUNCTION: cairo_path_t*
|
||||
cairo_copy_path ( cairo_t* cr ) ;
|
||||
|
|
@ -750,20 +849,25 @@ cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, do
|
|||
FUNCTION: void
|
||||
cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_surface_get_fallback_resolution ( cairo_surface_t* surface, double* x_pixels_per_inch, double* y_pixels_per_inch ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_surface_copy_page ( cairo_surface_t* surface ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_surface_show_page ( cairo_surface_t* surface ) ;
|
||||
|
||||
FUNCTION: cairo_bool_t
|
||||
cairo_surface_has_show_text_glyphs ( cairo_surface_t* surface ) ;
|
||||
|
||||
! Image-surface functions
|
||||
|
||||
ENUM: cairo_format_t
|
||||
CAIRO_FORMAT_ARGB32
|
||||
CAIRO_FORMAT_RGB24
|
||||
CAIRO_FORMAT_A8
|
||||
CAIRO_FORMAT_A1
|
||||
CAIRO_FORMAT_RGB16_565 ;
|
||||
CAIRO_FORMAT_A1 ;
|
||||
|
||||
FUNCTION: cairo_surface_t*
|
||||
cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
|
||||
|
|
@ -834,7 +938,7 @@ ENUM: cairo_pattern_type_t
|
|||
CAIRO_PATTERN_TYPE_SOLID
|
||||
CAIRO_PATTERN_TYPE_SURFACE
|
||||
CAIRO_PATTERN_TYPE_LINEAR
|
||||
CAIRO_PATTERN_TYPE_RADIA ;
|
||||
CAIRO_PATTERN_TYPE_RADIAL ;
|
||||
|
||||
FUNCTION: cairo_pattern_type_t
|
||||
cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
|
||||
|
|
@ -898,7 +1002,7 @@ cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double*
|
|||
! Matrix functions
|
||||
|
||||
FUNCTION: void
|
||||
cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
|
||||
cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
|
||||
|
||||
FUNCTION: void
|
||||
cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
|
||||
|
|
|
|||
|
|
@ -519,7 +519,7 @@ HELP: since-1970
|
|||
{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
|
||||
|
||||
ARTICLE: "calendar" "Calendar"
|
||||
"The two data types used throughout the calendar library:"
|
||||
"The " { $vocab-link "calendar" } " vocabulary defines two data types and a set of operations on them:"
|
||||
{ $subsections
|
||||
timestamp
|
||||
duration
|
||||
|
|
@ -533,13 +533,12 @@ ARTICLE: "calendar" "Calendar"
|
|||
now
|
||||
gmt
|
||||
}
|
||||
"Converting between timestamps:"
|
||||
"Time zones:"
|
||||
{ $subsections
|
||||
>local-time
|
||||
>gmt
|
||||
convert-timezone
|
||||
}
|
||||
"Converting between timezones:"
|
||||
{ $subsections convert-timezone }
|
||||
"Timestamps relative to each other:"
|
||||
{ $subsections "relative-timestamps" }
|
||||
"Operations on units of time:"
|
||||
|
|
@ -548,9 +547,10 @@ ARTICLE: "calendar" "Calendar"
|
|||
"months"
|
||||
"days"
|
||||
}
|
||||
"Both " { $link timestamp } "s and " { $link duration } "s implement the " { $link "math.order" } "."
|
||||
$nl
|
||||
"Meta-data about the calendar:"
|
||||
{ $subsections "calendar-facts" }
|
||||
;
|
||||
{ $subsections "calendar-facts" } ;
|
||||
|
||||
ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic"
|
||||
"Adding timestamps and durations, or durations and durations:"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup channels concurrency.distributed ;
|
||||
USING: channels concurrency.distributed help.markup help.syntax
|
||||
io.servers.connection ;
|
||||
IN: channels.remote
|
||||
|
||||
HELP: <remote-channel>
|
||||
|
|
@ -45,9 +46,9 @@ HELP: publish
|
|||
ARTICLE: { "remote-channels" "remote-channels" } "Remote Channels"
|
||||
"Remote channels are channels that can be accessed by other Factor instances. It uses distributed concurrency to serialize and send data between channels."
|
||||
$nl
|
||||
"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-node } "."
|
||||
"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-server } "."
|
||||
$nl
|
||||
{ $snippet "\"myhost.com\" 9001 start-node" }
|
||||
{ $snippet "\"myhost.com\" 9001 start-server" }
|
||||
$nl
|
||||
"Once the node is started, channels can be published using " { $link publish }
|
||||
" to be accessed remotely. " { $link publish } " returns an id which a remote node "
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: checksums checksums.internet tools.test ;
|
||||
|
||||
IN: checksums
|
||||
|
||||
[ B{ 255 255 } ] [ { } internet checksum-bytes ] unit-test
|
||||
[ B{ 254 255 } ] [ { 1 } internet checksum-bytes ] unit-test
|
||||
[ B{ 254 253 } ] [ { 1 2 } internet checksum-bytes ] unit-test
|
||||
[ B{ 251 253 } ] [ { 1 2 3 } internet checksum-bytes ] unit-test
|
||||
|
||||
: test-data ( -- bytes )
|
||||
B{
|
||||
HEX: 00 HEX: 01
|
||||
HEX: f2 HEX: 03
|
||||
HEX: f4 HEX: f5
|
||||
HEX: f6 HEX: f7
|
||||
} ;
|
||||
|
||||
[ B{ 34 13 } ] [ test-data internet checksum-bytes ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: checksums grouping io.binary kernel math sequences ;
|
||||
|
||||
IN: checksums.internet
|
||||
|
||||
SINGLETON: internet ! RFC 1071
|
||||
|
||||
INSTANCE: internet checksum
|
||||
|
||||
M: internet checksum-bytes
|
||||
drop 0 swap 2 <sliced-groups> [ le> + ] each
|
||||
[ -16 shift ] [ HEX: ffff bitand ] bi +
|
||||
[ -16 shift ] keep + bitnot 2 >le ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Internet (RFC 1071) checksum algorithm
|
||||
|
|
@ -245,6 +245,8 @@ STRUCT: struct-test-equality-1
|
|||
STRUCT: struct-test-equality-2
|
||||
{ y int } ;
|
||||
|
||||
[ 0 ] [ struct-test-equality-1 new hashcode ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
struct-test-equality-1 <struct> 5 >>x
|
||||
|
|
@ -474,3 +476,9 @@ CONSULT: struct-test-delegate struct-test-delegator del>> ;
|
|||
7 >>a
|
||||
8 >>b
|
||||
] unit-test
|
||||
|
||||
SPECIALIZED-ARRAY: void*
|
||||
|
||||
STRUCT: silly-array-field-test { x int*[3] } ;
|
||||
|
||||
[ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
|
||||
|
|
|
|||
|
|
@ -48,13 +48,18 @@ M: struct >c-ptr
|
|||
2 slot { c-ptr } declare ; inline
|
||||
|
||||
M: struct equal?
|
||||
{
|
||||
[ [ class ] bi@ = ]
|
||||
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
|
||||
} 2&& ; inline
|
||||
over struct? [
|
||||
2dup [ class ] bi@ = [
|
||||
2dup [ >c-ptr ] both?
|
||||
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
|
||||
[ [ >c-ptr not ] both? ]
|
||||
if
|
||||
] [ 2drop f ] if
|
||||
] [ 2drop f ] if ; inline
|
||||
|
||||
M: struct hashcode*
|
||||
binary-object <direct-uchar-array> hashcode* ; inline
|
||||
binary-object over
|
||||
[ <direct-uchar-array> hashcode* ] [ 3drop 0 ] if ; inline
|
||||
|
||||
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2006, 2010 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax io kernel namespaces core-foundation
|
||||
core-foundation.strings cocoa.messages cocoa cocoa.classes
|
||||
cocoa.runtime sequences init summary kernel.private
|
||||
assocs ;
|
||||
USING: alien alien.c-types alien.syntax io kernel namespaces
|
||||
core-foundation core-foundation.strings cocoa.messages cocoa
|
||||
cocoa.classes cocoa.runtime sequences init summary
|
||||
kernel.private assocs ;
|
||||
IN: cocoa.application
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
|
|
|||
|
|
@ -95,16 +95,8 @@ SYNTAX: CLASS:
|
|||
[ [ make-local ] map ] H{ } make-assoc
|
||||
(parse-lambda) <lambda> ?rewrite-closures first ;
|
||||
|
||||
: method-effect ( quadruple -- effect )
|
||||
[ third ] [ second void? { } { "x" } ? ] bi <effect> ;
|
||||
|
||||
: check-method ( quadruple -- )
|
||||
[ fourth infer ] [ method-effect ] bi
|
||||
2dup effect<= [ 2drop ] [ effect-error ] if ;
|
||||
|
||||
SYNTAX: METHOD:
|
||||
scan-c-type
|
||||
parse-selector
|
||||
parse-method-body [ swap ] 2dip 4array
|
||||
dup check-method
|
||||
suffix! ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Jon Harper
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
! Copyright (C) 2010 Jon Harper.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs help.markup help.syntax kernel quotations
|
||||
combinators.random.private sequences ;
|
||||
IN: combinators.random
|
||||
|
||||
HELP: call-random
|
||||
{ $values { "seq" "a sequence of quotations" } }
|
||||
{ $description "Calls a random quotation from the given sequence of quotations." } ;
|
||||
|
||||
HELP: execute-random
|
||||
{ $values { "seq" "a sequence of words" } }
|
||||
{ $description "Executes a random word from the given sequence of quotations." } ;
|
||||
|
||||
HELP: ifp
|
||||
{ $values
|
||||
{ "p" "a number between 0 and 1" } { "true" quotation } { "false" quotation }
|
||||
}
|
||||
{ $description "Calls the " { $snippet "true" } " quotation with probability " { $snippet "p" }
|
||||
" and the " { $snippet "false" } " quotation with probability (1-" { $snippet "p" } ")." } ;
|
||||
|
||||
HELP: casep
|
||||
{ $values
|
||||
{ "assoc" "a sequence of probability/quotations pairs with an optional quotation at the end" }
|
||||
}
|
||||
{ $description "Calls the different quotations randomly with the given probability. The optional quotation at the end "
|
||||
"will be given a probability so that the sum of the probabilities is one. Therefore, the sum of the probabilities "
|
||||
"must be exactly one when no default quotation is given, or between zero and one when it is given. "
|
||||
"Additionally, all probabilities must be numbers between 0 and 1. "
|
||||
"These rules are enforced during the macro expansion by throwing " { $link bad-probabilities } " "
|
||||
"if they are not respected." }
|
||||
{ $examples
|
||||
"The following two forms will output 1 with 0.2 probability, 2 with 0.3 probability and 3 with 0.5 probability"
|
||||
{ $code
|
||||
"USING: combinators.random ;"
|
||||
"{ { 0.2 [ 1 ] }"
|
||||
" { 0.3 [ 2 ] }"
|
||||
" { 0.5 [ 3 ] } } casep ."
|
||||
}
|
||||
$nl
|
||||
{ $code
|
||||
"USING: combinators.random ;"
|
||||
"{ { 0.2 [ 1 ] }"
|
||||
" { 0.3 [ 2 ] }"
|
||||
" { [ 3 ] } } casep ."
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
{ $see-also casep* } ;
|
||||
|
||||
HELP: casep*
|
||||
{ $values
|
||||
{ "assoc" "a sequence of probability/word pairs with an optional quotation at the end" }
|
||||
}
|
||||
{ $description "Calls the different quotations randomly with the given probability. Unlike " { $link casep } ", "
|
||||
"the probabilities are interpreted as conditional probabilities. "
|
||||
"All probabilities must be numbers between 0 and 1. "
|
||||
"The sequence must end with a pair whose probability is one, or a quotation."
|
||||
"These rules are enforced during the macro expansion by throwing " { $link bad-probabilities } " "
|
||||
"if they are not respected." }
|
||||
{ $examples
|
||||
"The following two forms will output 1 with 0.5 probability, 2 with 0.25 probability and 3 with 0.25 probability"
|
||||
{ $code
|
||||
"USING: combinators.random ;"
|
||||
"{ { 0.5 [ 1 ] }"
|
||||
" { 0.5 [ 2 ] }"
|
||||
" { 1 [ 3 ] } } casep* ."
|
||||
}
|
||||
$nl
|
||||
{ $code
|
||||
"USING: combinators.random ;"
|
||||
"{ { 0.5 [ 1 ] }"
|
||||
" { 0.5 [ 2 ] }"
|
||||
" { [ 3 ] } } casep* ."
|
||||
}
|
||||
|
||||
}
|
||||
{ $see-also casep } ;
|
||||
|
||||
HELP: unlessp
|
||||
{ $values
|
||||
{ "p" "a number between 0 and 1" } { "false" quotation }
|
||||
}
|
||||
{ $description "Variant of " { $link ifp } " with no " { $snippet "true" } " quotation." } ;
|
||||
|
||||
HELP: whenp
|
||||
{ $values
|
||||
{ "p" "a number between 0 and 1" } { "true" quotation }
|
||||
}
|
||||
{ $description "Variant of " { $link ifp } " with no " { $snippet "false" } " quotation." } ;
|
||||
|
||||
ARTICLE: "combinators.random" "Random combinators"
|
||||
"The " { $vocab-link "combinators.random" } " vocabulary implements simple combinators to easily express random choices"
|
||||
" between multiple code paths."
|
||||
$nl
|
||||
"For all these combinators, the stack effect of the different given quotations or words must be the same."
|
||||
$nl
|
||||
"Variants of if, when and unless:"
|
||||
{ $subsections
|
||||
ifp
|
||||
whenp
|
||||
unlessp }
|
||||
"Variants of case:"
|
||||
{ $subsections
|
||||
casep
|
||||
casep*
|
||||
call-random
|
||||
execute-random
|
||||
} ;
|
||||
|
||||
ABOUT: "combinators.random"
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
! Copyright (C) 2010 Jon Harper.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test combinators.random combinators.random.private ;
|
||||
IN: combinators.random.tests
|
||||
|
||||
[ 1 ] [ 1 [ 1 ] [ 2 ] ifp ] unit-test
|
||||
[ 2 ] [ 0 [ 1 ] [ 2 ] ifp ] unit-test
|
||||
|
||||
[ 3 ]
|
||||
[ { { 0 [ 1 ] }
|
||||
{ 0 [ 2 ] }
|
||||
{ 1 [ 3 ] }
|
||||
[ 4 ]
|
||||
} casep ] unit-test
|
||||
|
||||
[ 4 ]
|
||||
[ { { 0 [ 1 ] }
|
||||
{ 0 [ 2 ] }
|
||||
{ 0 [ 3 ] }
|
||||
[ 4 ]
|
||||
} casep ] unit-test
|
||||
|
||||
[ 1 1 ] [ 1 {
|
||||
{ 1 [ 1 ] }
|
||||
{ 0 [ 2 ] }
|
||||
{ 0 [ 3 ] }
|
||||
[ 4 ]
|
||||
} casep ] unit-test
|
||||
|
||||
[ 1 4 ] [ 1 {
|
||||
{ 0 [ 1 ] }
|
||||
{ 0 [ 2 ] }
|
||||
{ 0 [ 3 ] }
|
||||
[ 4 ]
|
||||
} casep ] unit-test
|
||||
|
||||
[ 2 ] [ 0.7 {
|
||||
{ 0.3 [ 1 ] }
|
||||
{ 0.5 [ 2 ] }
|
||||
[ 2 ] } (casep) ] unit-test
|
||||
|
||||
[ { { 1/3 [ 1 ] }
|
||||
{ 1/3 [ 2 ] }
|
||||
{ 1/3 [ 3 ] } } ]
|
||||
[ { [ 1 ] [ 2 ] [ 3 ] } call-random>casep ] unit-test
|
||||
|
||||
[ { { 1/2 [ 1 ] }
|
||||
{ 1/4 [ 2 ] }
|
||||
{ 1/4 [ 3 ] } } ]
|
||||
[ { { 1/2 [ 1 ] }
|
||||
{ 1/2 [ 2 ] }
|
||||
{ 1 [ 3 ] } } direct>conditional ] unit-test
|
||||
|
||||
[ { { 1/2 [ 1 ] }
|
||||
{ 1/4 [ 2 ] }
|
||||
{ [ 3 ] } } ]
|
||||
[ { { 1/2 [ 1 ] }
|
||||
{ 1/2 [ 2 ] }
|
||||
{ [ 3 ] } } direct>conditional ] unit-test
|
||||
|
||||
[ f ] [ { { 0.6 [ 1 ] }
|
||||
{ 0.6 [ 2 ] } } good-probabilities? ] unit-test
|
||||
[ f ] [ { { 0.3 [ 1 ] }
|
||||
{ 0.6 [ 2 ] } } good-probabilities? ] unit-test
|
||||
[ f ] [ { { -0.6 [ 1 ] }
|
||||
{ 1.4 [ 2 ] } } good-probabilities? ] unit-test
|
||||
[ f ] [ { { -0.6 [ 1 ] }
|
||||
[ 2 ] } good-probabilities? ] unit-test
|
||||
[ t ] [ { { 0.6 [ 1 ] }
|
||||
[ 2 ] } good-probabilities? ] unit-test
|
||||
[ t ] [ { { 0.6 [ 1 ] }
|
||||
{ 0.4 [ 2 ] } } good-probabilities? ] unit-test
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
! Copyright (C) 2010 Jon Harper.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs combinators combinators.short-circuit
|
||||
kernel macros math math.order quotations random sequences
|
||||
summary ;
|
||||
IN: combinators.random
|
||||
|
||||
: ifp ( p true false -- ) [ 0 1 uniform-random-float > ] 2dip if ; inline
|
||||
: whenp ( p true -- ) [ ] ifp ; inline
|
||||
: unlessp ( p false -- ) [ [ ] ] dip ifp ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: with-drop ( quot -- quot' ) [ drop ] prepend ; inline
|
||||
|
||||
: prepare-pair ( pair -- pair' )
|
||||
first2 [ [ [ - ] [ < ] 2bi ] curry ] [ with-drop ] bi* 2array ;
|
||||
|
||||
ERROR: bad-probabilities assoc ;
|
||||
|
||||
M: bad-probabilities summary
|
||||
drop "The probabilities do not satisfy the rules stated in the docs." ;
|
||||
|
||||
: good-probabilities? ( assoc -- ? )
|
||||
dup last pair? [
|
||||
keys { [ sum 1 number= ] [ [ 0 1 between? ] all? ] } 1&&
|
||||
] [
|
||||
but-last keys { [ sum 0 1 between? ] [ [ 0 1 between? ] all? ] } 1&&
|
||||
] if ;
|
||||
|
||||
! Useful for unit-tests (no random part)
|
||||
: (casep>quot) ( assoc -- quot )
|
||||
dup good-probabilities? [
|
||||
[ dup pair? [ prepare-pair ] [ with-drop ] if ] map
|
||||
cond>quot
|
||||
] [ bad-probabilities ] if ;
|
||||
|
||||
MACRO: (casep) ( assoc -- ) (casep>quot) ;
|
||||
|
||||
: casep>quot ( assoc -- quot )
|
||||
(casep>quot) [ 0 1 uniform-random-float ] prepend ;
|
||||
|
||||
: (conditional-probabilities) ( seq i -- p )
|
||||
[ dup 0 > [ head [ 1 swap - ] [ * ] map-reduce ] [ 2drop 1 ] if ] [ swap nth ] 2bi * ;
|
||||
|
||||
: conditional-probabilities ( seq -- seq' )
|
||||
dup length iota [ (conditional-probabilities) ] with map ;
|
||||
|
||||
: (direct>conditional) ( assoc -- assoc' )
|
||||
[ keys conditional-probabilities ] [ values ] bi zip ;
|
||||
|
||||
: direct>conditional ( assoc -- assoc' )
|
||||
dup last pair? [ (direct>conditional) ] [
|
||||
unclip-last [ (direct>conditional) ] [ suffix ] bi*
|
||||
] if ;
|
||||
|
||||
: call-random>casep ( seq -- assoc )
|
||||
[ length recip ] keep [ 2array ] with map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: casep ( assoc -- ) casep>quot ;
|
||||
|
||||
MACRO: casep* ( assoc -- ) direct>conditional casep>quot ;
|
||||
|
||||
MACRO: call-random ( seq -- ) call-random>casep casep>quot ;
|
||||
|
||||
MACRO: execute-random ( seq -- )
|
||||
[ 1quotation ] map call-random>casep casep>quot ;
|
||||
|
|
@ -87,7 +87,7 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
|
|||
"The following command line switches can be passed to a bootstrapped Factor image:"
|
||||
{ $table
|
||||
{ { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } }
|
||||
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
|
||||
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui.tools" } " or " { $vocab-link "none" } "." } }
|
||||
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
|
||||
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -288,20 +288,20 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
||||
! We can't make any assumptions about heap-ac between alien
|
||||
! calls, since they might callback into Factor code
|
||||
! We can't make any assumptions about heap-ac between
|
||||
! instructions which can call back into Factor code
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##slot-imm f 2 0 1 0 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
|
@ -311,7 +311,7 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##slot-imm f 2 0 1 0 }
|
||||
}
|
||||
] [
|
||||
|
|
@ -319,7 +319,7 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
|
@ -330,7 +330,7 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
T{ ##peek f 1 D 1 }
|
||||
T{ ##peek f 2 D 2 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 2 0 1 0 }
|
||||
}
|
||||
] [
|
||||
|
|
@ -339,7 +339,7 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
T{ ##peek f 1 D 1 }
|
||||
T{ ##peek f 2 D 2 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
|
@ -348,14 +348,101 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } 0 0 "free" }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
||||
! We can't eliminate stores on any alias class across a GC-ing
|
||||
! instruction
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##copy f 2 1 any-rep }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##copy f 2 1 any-rep }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##peek f 2 D 2 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 2 0 1 0 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##peek f 2 D 2 }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##slot-imm f 1 0 1 0 }
|
||||
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 1 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
||||
! Make sure that gc-map-insns which are also vreg-insns are
|
||||
! handled properly
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 2 0 1 0 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 0 }
|
||||
T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
|
||||
T{ ##set-slot-imm f 2 0 1 0 }
|
||||
} test-alias-analysis
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -218,7 +218,7 @@ GENERIC: analyze-aliases ( insn -- insn' )
|
|||
|
||||
M: insn analyze-aliases ;
|
||||
|
||||
M: vreg-insn analyze-aliases
|
||||
: def-acs ( insn -- insn' )
|
||||
! If an instruction defines a value with a non-integer
|
||||
! representation it means that the value will be boxed
|
||||
! anywhere its used as a tagged pointer. Boxing allocates
|
||||
|
|
@ -229,6 +229,9 @@ M: vreg-insn analyze-aliases
|
|||
[ set-heap-ac ] [ set-new-ac ] if
|
||||
] each-def-rep ;
|
||||
|
||||
M: vreg-insn analyze-aliases
|
||||
def-acs ;
|
||||
|
||||
M: ##phi analyze-aliases
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
|
|
@ -286,6 +289,29 @@ M: ##compare analyze-aliases
|
|||
analyze-aliases
|
||||
] when ;
|
||||
|
||||
: clear-live-slots ( -- )
|
||||
heap-ac get ac>vregs [ live-slots get at clear-assoc ] each ;
|
||||
|
||||
: clear-recent-stores ( -- )
|
||||
recent-stores get values [ clear-assoc ] each ;
|
||||
|
||||
M: gc-map-insn analyze-aliases
|
||||
! Can't use call-next-method here because of a limitation, gah
|
||||
def-acs
|
||||
clear-recent-stores ;
|
||||
|
||||
M: factor-call-insn analyze-aliases
|
||||
def-acs
|
||||
clear-recent-stores
|
||||
clear-live-slots ;
|
||||
|
||||
GENERIC: eliminate-dead-stores ( insn -- ? )
|
||||
|
||||
M: ##set-slot-imm eliminate-dead-stores
|
||||
insn#>> dead-stores get in? not ;
|
||||
|
||||
M: insn eliminate-dead-stores drop t ;
|
||||
|
||||
: reset-alias-analysis ( -- )
|
||||
recent-stores get clear-assoc
|
||||
vregs>acs get clear-assoc
|
||||
|
|
@ -298,20 +324,6 @@ M: ##compare analyze-aliases
|
|||
\ ##vm-field set-new-ac
|
||||
\ ##alien-global set-new-ac ;
|
||||
|
||||
M: factor-call-insn analyze-aliases
|
||||
call-next-method
|
||||
heap-ac get ac>vregs [
|
||||
[ live-slots get at clear-assoc ]
|
||||
[ recent-stores get at clear-assoc ] bi
|
||||
] each ;
|
||||
|
||||
GENERIC: eliminate-dead-stores ( insn -- ? )
|
||||
|
||||
M: ##set-slot-imm eliminate-dead-stores
|
||||
insn#>> dead-stores get in? not ;
|
||||
|
||||
M: insn eliminate-dead-stores drop t ;
|
||||
|
||||
: alias-analysis-step ( insns -- insns' )
|
||||
reset-alias-analysis
|
||||
[ local-live-in [ set-heap-ac ] each ]
|
||||
|
|
|
|||
|
|
@ -35,11 +35,8 @@ M: ##unbox compute-stack-frame* drop vm-frame-required ;
|
|||
M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
|
||||
M: ##callback-inputs compute-stack-frame* drop vm-frame-required ;
|
||||
M: ##callback-outputs compute-stack-frame* drop vm-frame-required ;
|
||||
M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
|
||||
M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
|
||||
|
||||
M: ##call compute-stack-frame* drop frame-required ;
|
||||
M: ##alien-callback compute-stack-frame* drop frame-required ;
|
||||
M: ##spill compute-stack-frame* drop frame-required ;
|
||||
M: ##reload compute-stack-frame* drop frame-required ;
|
||||
|
||||
|
|
|
|||
|
|
@ -54,8 +54,8 @@ IN: compiler.cfg.builder.alien
|
|||
(caller-parameters)
|
||||
] with-param-regs* ;
|
||||
|
||||
: prepare-caller-return ( params -- reg-outputs )
|
||||
return>> [ { } ] [ base-type load-return ] if-void ;
|
||||
: prepare-caller-return ( params -- reg-outputs dead-outputs )
|
||||
return>> [ { } ] [ base-type load-return ] if-void { } ;
|
||||
|
||||
: caller-stack-frame ( params -- cleanup stack-size )
|
||||
[ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
|
||||
|
|
@ -173,24 +173,22 @@ M: #alien-assembly emit-node
|
|||
: needs-frame-pointer ( -- )
|
||||
cfg get t >>frame-pointer? drop ;
|
||||
|
||||
: emit-callback-body ( nodes -- )
|
||||
[ last #return? t assert= ] [ but-last emit-nodes ] bi ;
|
||||
|
||||
M: #alien-callback emit-node
|
||||
params>> dup xt>> dup
|
||||
dup params>> xt>> dup
|
||||
[
|
||||
needs-frame-pointer
|
||||
|
||||
begin-word
|
||||
|
||||
{
|
||||
[ callee-parameters ##callback-inputs ]
|
||||
[ box-parameters ]
|
||||
[
|
||||
[
|
||||
make-kill-block
|
||||
quot>> ##alien-callback
|
||||
] emit-trivial-block
|
||||
]
|
||||
[ callee-return ##callback-outputs ]
|
||||
[ callback-stack-cleanup ]
|
||||
[ params>> callee-parameters ##callback-inputs ]
|
||||
[ params>> box-parameters ]
|
||||
[ child>> emit-callback-body ]
|
||||
[ params>> callee-return ##callback-outputs ]
|
||||
[ params>> callback-stack-cleanup ]
|
||||
} cleave
|
||||
|
||||
end-word
|
||||
|
|
|
|||
|
|
@ -161,13 +161,6 @@ IN: compiler.cfg.builder.tests
|
|||
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
|
||||
] each
|
||||
|
||||
: count-insns ( quot insn-check -- ? )
|
||||
[ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
|
||||
count ; inline
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
count-insns 0 > ; inline
|
||||
|
||||
[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
||||
[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
|
||||
|
|
|
|||
|
|
@ -53,8 +53,8 @@ M: insn visit-insn drop ;
|
|||
: (collect-copies) ( cfg -- )
|
||||
[
|
||||
phis get clear-assoc
|
||||
instructions>> [ visit-insn ] each
|
||||
] each-basic-block ;
|
||||
[ visit-insn ] each
|
||||
] simple-analysis ;
|
||||
|
||||
: collect-copies ( cfg -- )
|
||||
H{ } clone copies set
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces sequences
|
||||
USING: accessors arrays assocs kernel namespaces sequences
|
||||
compiler.cfg.instructions compiler.cfg.def-use
|
||||
compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ;
|
||||
FROM: namespaces => set ;
|
||||
|
|
@ -99,6 +99,19 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
|
|||
|
||||
M: ##write-barrier-imm live-insn? src>> live-vreg? ;
|
||||
|
||||
: filter-alien-outputs ( outputs -- live-outputs dead-outputs )
|
||||
[ first live-vreg? ] partition
|
||||
[ first3 2array nip ] map ;
|
||||
|
||||
M: alien-call-insn live-insn?
|
||||
dup reg-outputs>> filter-alien-outputs [ >>reg-outputs ] [ >>dead-outputs ] bi*
|
||||
drop t ;
|
||||
|
||||
M: ##callback-inputs live-insn?
|
||||
[ filter-alien-outputs drop ] change-reg-outputs
|
||||
[ filter-alien-outputs drop ] change-stack-outputs
|
||||
drop t ;
|
||||
|
||||
M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
|
||||
|
||||
M: insn live-insn? drop t ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel words sequences quotations namespaces io vectors
|
||||
arrays hashtables classes.tuple accessors prettyprint
|
||||
arrays hashtables classes.tuple math accessors prettyprint
|
||||
prettyprint.config assocs prettyprint.backend prettyprint.custom
|
||||
prettyprint.sections parser compiler.tree.builder
|
||||
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
|
||||
|
|
@ -125,3 +125,10 @@ M: rs-loc pprint* \ R pprint-loc ;
|
|||
bi append
|
||||
] map concat
|
||||
] map concat >hashtable representations set ;
|
||||
|
||||
: count-insns ( quot insn-check -- ? )
|
||||
[ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
|
||||
count ; inline
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
count-insns 0 > ; inline
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors assocs arrays classes combinators
|
|||
compiler.units fry generalizations sequences.generalizations
|
||||
generic kernel locals namespaces quotations sequences sets slots
|
||||
words compiler.cfg.instructions compiler.cfg.instructions.syntax
|
||||
compiler.cfg.rpo ;
|
||||
compiler.cfg.rpo compiler.cfg ;
|
||||
FROM: namespaces => set ;
|
||||
FROM: sets => members ;
|
||||
IN: compiler.cfg.def-use
|
||||
|
|
@ -91,17 +91,17 @@ SYMBOLS: defs insns ;
|
|||
: compute-defs ( cfg -- )
|
||||
H{ } clone [
|
||||
'[
|
||||
dup instructions>> [
|
||||
[ basic-block get ] dip [
|
||||
_ set-def-of
|
||||
] with each
|
||||
] each-basic-block
|
||||
] simple-analysis
|
||||
] keep defs set ;
|
||||
|
||||
: compute-insns ( cfg -- )
|
||||
H{ } clone [
|
||||
'[
|
||||
instructions>> [
|
||||
[
|
||||
dup _ set-def-of
|
||||
] each
|
||||
] each-basic-block
|
||||
] simple-analysis
|
||||
] keep insns set ;
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@ UNION: slot-insn
|
|||
UNION: memory-insn
|
||||
##load-memory ##load-memory-imm
|
||||
##store-memory ##store-memory-imm
|
||||
##write-barrier ##write-barrier-imm
|
||||
alien-call-insn
|
||||
slot-insn ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,15 +2,16 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.cfg.representations
|
||||
compiler.cfg.scheduling compiler.cfg.gc-checks
|
||||
compiler.cfg.save-contexts compiler.cfg.ssa.destruction
|
||||
compiler.cfg.build-stack-frame compiler.cfg.linear-scan
|
||||
compiler.cfg.stacks.uninitialized ;
|
||||
compiler.cfg.write-barrier compiler.cfg.save-contexts
|
||||
compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
|
||||
compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ;
|
||||
IN: compiler.cfg.finalization
|
||||
|
||||
: finalize-cfg ( cfg -- cfg' )
|
||||
select-representations
|
||||
schedule-instructions
|
||||
insert-gc-checks
|
||||
eliminate-write-barriers
|
||||
dup compute-uninitialized-sets
|
||||
insert-save-contexts
|
||||
destruct-ssa
|
||||
|
|
|
|||
|
|
@ -277,7 +277,7 @@ V{
|
|||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##alien-invoke f "malloc" f T{ gc-map } }
|
||||
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
||||
T{ ##allot f 1 64 byte-array }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
|
@ -299,7 +299,7 @@ V{
|
|||
! The GC check should come after the alien-invoke
|
||||
[
|
||||
V{
|
||||
T{ ##alien-invoke f "malloc" f T{ gc-map } }
|
||||
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
||||
T{ ##check-nursery-branch f 64 cc<= 3 4 }
|
||||
}
|
||||
] [ 0 get successors>> first instructions>> ] unit-test
|
||||
|
|
@ -311,9 +311,9 @@ V{
|
|||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##alien-invoke f "malloc" f T{ gc-map } }
|
||||
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
||||
T{ ##allot f 1 64 byte-array }
|
||||
T{ ##alien-invoke f "malloc" f T{ gc-map } }
|
||||
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
||||
T{ ##allot f 2 64 byte-array }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
|
@ -334,7 +334,7 @@ V{
|
|||
|
||||
[
|
||||
V{
|
||||
T{ ##alien-invoke f "malloc" f T{ gc-map } }
|
||||
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
||||
T{ ##check-nursery-branch f 64 cc<= 3 4 }
|
||||
}
|
||||
] [
|
||||
|
|
@ -346,7 +346,7 @@ V{
|
|||
[
|
||||
V{
|
||||
T{ ##allot f 1 64 byte-array }
|
||||
T{ ##alien-invoke f "malloc" f T{ gc-map } }
|
||||
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
||||
T{ ##check-nursery-branch f 64 cc<= 5 6 }
|
||||
}
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -256,17 +256,6 @@ FOLDABLE-INSN: ##sqrt
|
|||
def: dst/double-rep
|
||||
use: src/double-rep ;
|
||||
|
||||
! libc intrinsics
|
||||
FOLDABLE-INSN: ##unary-float-function
|
||||
def: dst/double-rep
|
||||
use: src/double-rep
|
||||
literal: func ;
|
||||
|
||||
FOLDABLE-INSN: ##binary-float-function
|
||||
def: dst/double-rep
|
||||
use: src1/double-rep src2/double-rep
|
||||
literal: func ;
|
||||
|
||||
! Single/double float conversion
|
||||
FOLDABLE-INSN: ##single>double-float
|
||||
def: dst/double-rep
|
||||
|
|
@ -673,21 +662,18 @@ literal: boxer gc-map ;
|
|||
! { vreg rep stack#/reg }
|
||||
|
||||
VREG-INSN: ##alien-invoke
|
||||
literal: reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map ;
|
||||
literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map ;
|
||||
|
||||
VREG-INSN: ##alien-indirect
|
||||
use: src/int-rep
|
||||
literal: reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map ;
|
||||
literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map ;
|
||||
|
||||
VREG-INSN: ##alien-assembly
|
||||
literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ;
|
||||
literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot gc-map ;
|
||||
|
||||
VREG-INSN: ##callback-inputs
|
||||
literal: reg-outputs stack-outputs ;
|
||||
|
||||
INSN: ##alien-callback
|
||||
literal: quot ;
|
||||
|
||||
VREG-INSN: ##callback-outputs
|
||||
literal: reg-inputs ;
|
||||
|
||||
|
|
@ -886,8 +872,6 @@ alien-call-insn
|
|||
! will be in a register.
|
||||
UNION: clobber-insn
|
||||
hairy-clobber-insn
|
||||
##unary-float-function
|
||||
##binary-float-function
|
||||
##unbox
|
||||
##box
|
||||
##box-long-long ;
|
||||
|
|
|
|||
|
|
@ -9,9 +9,3 @@ IN: compiler.cfg.intrinsics.float
|
|||
|
||||
: emit-float-unordered-comparison ( cc -- )
|
||||
'[ _ ^^compare-float-unordered ] binary-op ; inline
|
||||
|
||||
: emit-unary-float-function ( func -- )
|
||||
'[ _ ^^unary-float-function ] unary-op ;
|
||||
|
||||
: emit-binary-float-function ( func -- )
|
||||
'[ _ ^^binary-float-function ] binary-op ;
|
||||
|
|
|
|||
|
|
@ -123,31 +123,6 @@ IN: compiler.cfg.intrinsics
|
|||
{ math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-float-functions ( -- )
|
||||
{
|
||||
{ math.libm:facos [ drop "acos" emit-unary-float-function ] }
|
||||
{ math.libm:fasin [ drop "asin" emit-unary-float-function ] }
|
||||
{ math.libm:fatan [ drop "atan" emit-unary-float-function ] }
|
||||
{ math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] }
|
||||
{ math.libm:fcos [ drop "cos" emit-unary-float-function ] }
|
||||
{ math.libm:fsin [ drop "sin" emit-unary-float-function ] }
|
||||
{ math.libm:ftan [ drop "tan" emit-unary-float-function ] }
|
||||
{ math.libm:fcosh [ drop "cosh" emit-unary-float-function ] }
|
||||
{ math.libm:fsinh [ drop "sinh" emit-unary-float-function ] }
|
||||
{ math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
|
||||
{ math.libm:fexp [ drop "exp" emit-unary-float-function ] }
|
||||
{ math.libm:flog [ drop "log" emit-unary-float-function ] }
|
||||
{ math.libm:flog10 [ drop "log10" emit-unary-float-function ] }
|
||||
{ math.libm:fpow [ drop "pow" emit-binary-float-function ] }
|
||||
{ math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
|
||||
{ math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
|
||||
{ math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
|
||||
{ math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] }
|
||||
{ math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] }
|
||||
{ math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] }
|
||||
{ math.private:float-mod [ drop "fmod" emit-binary-float-function ] }
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-min/max ( -- )
|
||||
{
|
||||
{ math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
|
||||
|
|
|
|||
|
|
@ -62,8 +62,8 @@ M: live-interval handle
|
|||
|
||||
M: sync-point handle ( sync-point -- )
|
||||
[ n>> deactivate-intervals ]
|
||||
[ handle-sync-point ]
|
||||
[ n>> activate-intervals ]
|
||||
[ handle-sync-point ]
|
||||
tri ;
|
||||
|
||||
: smallest-heap ( heap1 heap2 -- heap )
|
||||
|
|
|
|||
|
|
@ -39,6 +39,11 @@ SYMBOL: pending-interval-assoc
|
|||
drop leader vreg rep-of lookup-spill-slot
|
||||
] unless ;
|
||||
|
||||
ERROR: not-spilled-error vreg ;
|
||||
|
||||
: vreg>spill-slot ( vreg -- spill-slot )
|
||||
dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
|
||||
|
||||
: vregs>regs ( vregs -- assoc )
|
||||
[ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
|
||||
|
||||
|
|
@ -144,7 +149,7 @@ M: vreg-insn assign-registers-in-insn
|
|||
|
||||
M: gc-map-insn assign-registers-in-insn
|
||||
[ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
|
||||
[ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ]
|
||||
[ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ]
|
||||
bi ;
|
||||
|
||||
M: insn assign-registers-in-insn drop ;
|
||||
|
|
@ -158,20 +163,22 @@ M: insn assign-registers-in-insn drop ;
|
|||
} cleave ;
|
||||
|
||||
:: assign-registers-in-block ( bb -- )
|
||||
bb [
|
||||
[
|
||||
bb begin-block
|
||||
bb kill-block?>> [
|
||||
bb [
|
||||
[
|
||||
{
|
||||
[ insn#>> 1 - prepare-insn ]
|
||||
[ insn#>> prepare-insn ]
|
||||
[ assign-registers-in-insn ]
|
||||
[ , ]
|
||||
} cleave
|
||||
] each
|
||||
bb compute-live-out
|
||||
] V{ } make
|
||||
] change-instructions drop ;
|
||||
bb begin-block
|
||||
[
|
||||
{
|
||||
[ insn#>> 1 - prepare-insn ]
|
||||
[ insn#>> prepare-insn ]
|
||||
[ assign-registers-in-insn ]
|
||||
[ , ]
|
||||
} cleave
|
||||
] each
|
||||
bb compute-live-out
|
||||
] V{ } make
|
||||
] change-instructions drop
|
||||
] unless ;
|
||||
|
||||
: assign-registers ( live-intervals cfg -- )
|
||||
[ init-assignment ] dip
|
||||
|
|
|
|||
|
|
@ -171,18 +171,20 @@ M: clobber-insn compute-sync-points*
|
|||
M: insn compute-sync-points* drop ;
|
||||
|
||||
: compute-live-intervals-step ( bb -- )
|
||||
{
|
||||
[ block-from from set ]
|
||||
[ block-to to set ]
|
||||
[ handle-live-out ]
|
||||
[
|
||||
instructions>> <reversed> [
|
||||
[ compute-live-intervals* ]
|
||||
[ compute-sync-points* ]
|
||||
bi
|
||||
] each
|
||||
]
|
||||
} cleave ;
|
||||
dup kill-block?>> [ drop ] [
|
||||
{
|
||||
[ block-from from set ]
|
||||
[ block-to to set ]
|
||||
[ handle-live-out ]
|
||||
[
|
||||
instructions>> <reversed> [
|
||||
[ compute-live-intervals* ]
|
||||
[ compute-sync-points* ]
|
||||
bi
|
||||
] each
|
||||
]
|
||||
} cleave
|
||||
] if ;
|
||||
|
||||
: init-live-intervals ( -- )
|
||||
H{ } clone live-intervals set
|
||||
|
|
|
|||
|
|
@ -99,7 +99,9 @@ SYMBOL: temp
|
|||
2dup compute-mappings perform-mappings ;
|
||||
|
||||
: resolve-block-data-flow ( bb -- )
|
||||
dup successors>> [ resolve-edge-data-flow ] with each ;
|
||||
dup kill-block?>> [ drop ] [
|
||||
dup successors>> [ resolve-edge-data-flow ] with each
|
||||
] if ;
|
||||
|
||||
: resolve-data-flow ( cfg -- )
|
||||
needs-predecessors
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ V{
|
|||
T{ ##unbox f 37 29 "alien_offset" int-rep }
|
||||
T{ ##unbox f 38 28 "to_double" double-rep }
|
||||
T{ ##unbox f 39 36 "to_cell" int-rep }
|
||||
T{ ##alien-invoke f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
|
||||
T{ ##alien-invoke f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } { } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
|
||||
T{ ##box f 41 40 "from_signed_cell" int-rep T{ gc-map } }
|
||||
T{ ##replace f 41 D 0 }
|
||||
T{ ##branch }
|
||||
|
|
|
|||
|
|
@ -9,8 +9,7 @@ compiler.cfg.ssa.construction
|
|||
compiler.cfg.alias-analysis
|
||||
compiler.cfg.value-numbering
|
||||
compiler.cfg.copy-prop
|
||||
compiler.cfg.dce
|
||||
compiler.cfg.write-barrier ;
|
||||
compiler.cfg.dce ;
|
||||
IN: compiler.cfg.optimizer
|
||||
|
||||
: optimize-cfg ( cfg -- cfg' )
|
||||
|
|
@ -23,5 +22,4 @@ IN: compiler.cfg.optimizer
|
|||
alias-analysis
|
||||
value-numbering
|
||||
copy-propagation
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers ;
|
||||
eliminate-dead-code ;
|
||||
|
|
|
|||
|
|
@ -11,10 +11,10 @@ SYMBOL: components
|
|||
|
||||
: init-components ( cfg components -- )
|
||||
'[
|
||||
instructions>> [
|
||||
[
|
||||
defs-vregs [ _ add-atom ] each
|
||||
] each
|
||||
] each-basic-block ;
|
||||
] simple-analysis ;
|
||||
|
||||
GENERIC# visit-insn 1 ( insn disjoint-set -- )
|
||||
|
||||
|
|
@ -28,10 +28,10 @@ M: insn visit-insn 2drop ;
|
|||
|
||||
: merge-components ( cfg components -- )
|
||||
'[
|
||||
instructions>> [
|
||||
[
|
||||
_ visit-insn
|
||||
] each
|
||||
] each-basic-block ;
|
||||
] simple-analysis ;
|
||||
|
||||
: compute-components ( cfg -- )
|
||||
<disjoint-set>
|
||||
|
|
|
|||
|
|
@ -4,26 +4,8 @@ compiler.cfg.save-contexts kernel namespaces tools.test
|
|||
cpu.x86.assembler.operands cpu.architecture ;
|
||||
IN: compiler.cfg.save-contexts.tests
|
||||
|
||||
0 vreg-counter set-global
|
||||
H{ } clone representations set
|
||||
|
||||
V{
|
||||
T{ ##unary-float-function f 2 3 "sqrt" }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
0 get insert-save-context
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##save-context f 1 2 }
|
||||
T{ ##unary-float-function f 2 3 "sqrt" }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [
|
||||
0 get instructions>>
|
||||
] unit-test
|
||||
|
||||
V{
|
||||
T{ ##add f 1 2 3 }
|
||||
T{ ##branch }
|
||||
|
|
|
|||
|
|
@ -1,20 +1,22 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
|
||||
compiler.cfg.rpo cpu.architecture kernel sequences vectors
|
||||
combinators.short-circuit ;
|
||||
IN: compiler.cfg.save-contexts
|
||||
|
||||
! Insert context saves.
|
||||
|
||||
GENERIC: needs-save-context? ( insn -- ? )
|
||||
|
||||
M: ##unary-float-function needs-save-context? drop t ;
|
||||
M: ##binary-float-function needs-save-context? drop t ;
|
||||
M: gc-map-insn needs-save-context? drop t ;
|
||||
M: insn needs-save-context? drop f ;
|
||||
|
||||
: bb-needs-save-context? ( insn -- ? )
|
||||
instructions>> [ needs-save-context? ] any? ;
|
||||
{
|
||||
[ kill-block?>> not ]
|
||||
[ instructions>> [ needs-save-context? ] any? ]
|
||||
} 1&& ;
|
||||
|
||||
GENERIC: modifies-context? ( insn -- ? )
|
||||
|
||||
|
|
|
|||
|
|
@ -10,6 +10,16 @@ IN: compiler.cfg.ssa.construction.tests
|
|||
0 vreg-counter set-global
|
||||
0 basic-block set-global ;
|
||||
|
||||
: test-ssa ( -- )
|
||||
cfg new 0 get >>entry
|
||||
dup cfg set
|
||||
construct-ssa
|
||||
drop ;
|
||||
|
||||
: clean-up-phis ( insns -- insns' )
|
||||
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
|
||||
|
||||
! Test 1
|
||||
reset-counters
|
||||
|
||||
V{
|
||||
|
|
@ -38,12 +48,6 @@ V{
|
|||
1 3 edge
|
||||
2 3 edge
|
||||
|
||||
: test-ssa ( -- )
|
||||
cfg new 0 get >>entry
|
||||
dup cfg set
|
||||
construct-ssa
|
||||
drop ;
|
||||
|
||||
[ ] [ test-ssa ] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -69,9 +73,6 @@ V{
|
|||
}
|
||||
] [ 2 get instructions>> ] unit-test
|
||||
|
||||
: clean-up-phis ( insns -- insns' )
|
||||
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##phi f 6 H{ { 1 4 } { 2 5 } } }
|
||||
|
|
@ -83,6 +84,7 @@ V{
|
|||
clean-up-phis
|
||||
] unit-test
|
||||
|
||||
! Test 2
|
||||
reset-counters
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
|
@ -110,4 +112,89 @@ V{ } 6 test-bb
|
|||
] [
|
||||
4 get instructions>>
|
||||
clean-up-phis
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
! Test 3
|
||||
reset-counters
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-integer f 3 3 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-integer f 3 4 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
0 { 1 2 3 } edges
|
||||
1 4 edge
|
||||
2 4 edge
|
||||
3 4 edge
|
||||
|
||||
[ ] [ test-ssa ] unit-test
|
||||
|
||||
[ V{ } ] [ 4 get instructions>> [ ##phi? ] filter ] unit-test
|
||||
|
||||
! Test 4
|
||||
reset-counters
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-integer f 0 4 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-integer f 0 4 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 6 test-bb
|
||||
|
||||
V{
|
||||
T{ ##return }
|
||||
} 7 test-bb
|
||||
|
||||
0 { 1 6 } edges
|
||||
1 { 2 3 4 } edges
|
||||
2 5 edge
|
||||
3 5 edge
|
||||
4 5 edge
|
||||
5 7 edge
|
||||
6 7 edge
|
||||
|
||||
[ ] [ test-ssa ] unit-test
|
||||
|
||||
[ V{ } ] [ 5 get instructions>> [ ##phi? ] filter ] unit-test
|
||||
|
||||
[ V{ } ] [ 7 get instructions>> [ ##phi? ] filter ] unit-test
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel accessors sequences fry assocs
|
||||
sets math combinators
|
||||
sets math combinators deques dlists
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.instructions
|
||||
|
|
@ -15,12 +14,18 @@ compiler.cfg.ssa.construction.tdmsc ;
|
|||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.ssa.construction
|
||||
|
||||
! The phi placement algorithm is implemented in
|
||||
! compiler.cfg.ssa.construction.tdmsc.
|
||||
! Iterated dominance frontiers are computed using the DJ Graph
|
||||
! method in compiler.cfg.ssa.construction.tdmsc.
|
||||
|
||||
! The renaming algorithm is based on "Practical Improvements to
|
||||
! the Construction and Destruction of Static Single Assignment Form",
|
||||
! however we construct pruned SSA, not semi-pruned SSA.
|
||||
! the Construction and Destruction of Static Single Assignment
|
||||
! Form".
|
||||
|
||||
! We construct pruned SSA without computing live sets, by
|
||||
! building a dependency graph for phi instructions, marking the
|
||||
! transitive closure of a vertex as live if it is referenced by
|
||||
! some non-phi instruction. Thanks to Cameron Zwarich for the
|
||||
! trick.
|
||||
|
||||
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683
|
||||
|
||||
|
|
@ -50,31 +55,32 @@ M: vreg-insn compute-insn-defs
|
|||
[ compute-insn-defs ] with each
|
||||
] simple-analysis ;
|
||||
|
||||
! Maps basic blocks to sequences of vregs
|
||||
SYMBOL: inserting-phi-nodes
|
||||
! Maps basic blocks to sequences of ##phi instructions
|
||||
SYMBOL: inserting-phis
|
||||
|
||||
: insert-phi-node-later ( vreg bb -- )
|
||||
2dup live-in key? [
|
||||
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
|
||||
inserting-phi-nodes get push-at
|
||||
] [ 2drop ] if ;
|
||||
: insert-phi-later ( vreg bb -- )
|
||||
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
|
||||
inserting-phis get push-at ;
|
||||
|
||||
: compute-phi-nodes-for ( vreg bbs -- )
|
||||
keys merge-set [ insert-phi-node-later ] with each ;
|
||||
: compute-phis-for ( vreg bbs -- )
|
||||
keys merge-set [ insert-phi-later ] with each ;
|
||||
|
||||
: compute-phi-nodes ( -- )
|
||||
H{ } clone inserting-phi-nodes set
|
||||
defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ;
|
||||
: compute-phis ( -- )
|
||||
H{ } clone inserting-phis set
|
||||
defs-multi get defs get '[ _ at compute-phis-for ] assoc-each ;
|
||||
|
||||
: insert-phi-nodes-in ( phis bb -- )
|
||||
[ append ] change-instructions drop ;
|
||||
! Maps vregs to ##phi instructions
|
||||
SYMBOL: phis
|
||||
|
||||
: insert-phi-nodes ( -- )
|
||||
inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
|
||||
! Worklist of used vregs, to calculate used phis
|
||||
SYMBOL: used-vregs
|
||||
|
||||
! Maps vregs to renaming stacks
|
||||
SYMBOLS: stacks pushed ;
|
||||
|
||||
: init-renaming ( -- )
|
||||
H{ } clone phis set
|
||||
<hashed-dlist> used-vregs set
|
||||
H{ } clone stacks set ;
|
||||
|
||||
: gen-name ( vreg -- vreg' )
|
||||
|
|
@ -84,8 +90,12 @@ SYMBOLS: stacks pushed ;
|
|||
[ conjoin stacks get push-at ]
|
||||
if ;
|
||||
|
||||
: (top-name) ( vreg -- vreg' )
|
||||
stacks get at [ f ] [ last ] if-empty ;
|
||||
|
||||
: top-name ( vreg -- vreg' )
|
||||
stacks get at last ;
|
||||
(top-name)
|
||||
dup [ dup used-vregs get push-front ] when ;
|
||||
|
||||
RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
|
||||
|
||||
|
|
@ -98,17 +108,22 @@ M: vreg-insn rename-insn
|
|||
[ ssa-rename-insn-defs ]
|
||||
bi ;
|
||||
|
||||
M: ##phi rename-insn
|
||||
ssa-rename-insn-defs ;
|
||||
: rename-phis ( bb -- )
|
||||
inserting-phis get at [
|
||||
[
|
||||
[ ssa-rename-insn-defs ]
|
||||
[ dup dst>> phis get set-at ] bi
|
||||
] each
|
||||
] when* ;
|
||||
|
||||
: rename-insns ( bb -- )
|
||||
instructions>> [ rename-insn ] each ;
|
||||
|
||||
: rename-successor-phi ( phi bb -- )
|
||||
swap inputs>> [ top-name ] change-at ;
|
||||
swap inputs>> [ (top-name) ] change-at ;
|
||||
|
||||
: rename-successor-phis ( succ bb -- )
|
||||
[ inserting-phi-nodes get at ] dip
|
||||
[ inserting-phis get at ] dip
|
||||
'[ _ rename-successor-phi ] each ;
|
||||
|
||||
: rename-successors-phis ( bb -- )
|
||||
|
|
@ -119,26 +134,56 @@ M: ##phi rename-insn
|
|||
|
||||
: rename-in-block ( bb -- )
|
||||
H{ } clone pushed set
|
||||
[ rename-insns ]
|
||||
[ rename-successors-phis ]
|
||||
[
|
||||
pushed get
|
||||
[ dom-children [ rename-in-block ] each ] dip
|
||||
pushed set
|
||||
] tri
|
||||
{
|
||||
[ rename-phis ]
|
||||
[ rename-insns ]
|
||||
[ rename-successors-phis ]
|
||||
[
|
||||
pushed get
|
||||
[ dom-children [ rename-in-block ] each ] dip
|
||||
pushed set
|
||||
]
|
||||
} cleave
|
||||
pop-stacks ;
|
||||
|
||||
: rename ( cfg -- )
|
||||
init-renaming
|
||||
entry>> rename-in-block ;
|
||||
|
||||
! Live phis
|
||||
SYMBOL: live-phis
|
||||
|
||||
: live-phi? ( ##phi -- ? )
|
||||
dst>> live-phis get key? ;
|
||||
|
||||
: compute-live-phis ( -- )
|
||||
H{ } clone live-phis set
|
||||
used-vregs get [
|
||||
phis get at [
|
||||
[
|
||||
dst>>
|
||||
[ live-phis get conjoin ]
|
||||
[ phis get delete-at ]
|
||||
bi
|
||||
]
|
||||
[ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi
|
||||
] when*
|
||||
] slurp-deque ;
|
||||
|
||||
: insert-phis-in ( phis bb -- )
|
||||
[ [ live-phi? ] filter! ] dip
|
||||
[ append ] change-instructions drop ;
|
||||
|
||||
: insert-phis ( -- )
|
||||
inserting-phis get
|
||||
[ swap insert-phis-in ] assoc-each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: construct-ssa ( cfg -- cfg' )
|
||||
{
|
||||
[ compute-live-sets ]
|
||||
[ compute-merge-sets ]
|
||||
[ compute-defs compute-phi-nodes insert-phi-nodes ]
|
||||
[ rename ]
|
||||
[ compute-defs compute-phis ]
|
||||
[ rename compute-live-phis insert-phis ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
|
|
|||
|
|
@ -103,12 +103,9 @@ M: ##phi prepare-insn
|
|||
[ dst>> ] [ inputs>> values ] bi
|
||||
[ maybe-eliminate-copy ] with each ;
|
||||
|
||||
: prepare-block ( bb -- )
|
||||
instructions>> [ prepare-insn ] each ;
|
||||
|
||||
: prepare-coalescing ( cfg -- )
|
||||
init-coalescing
|
||||
[ prepare-block ] each-basic-block ;
|
||||
[ [ prepare-insn ] each ] simple-analysis ;
|
||||
|
||||
: process-copies ( -- )
|
||||
copies get [ maybe-eliminate-copy ] assoc-each ;
|
||||
|
|
|
|||
|
|
@ -38,13 +38,12 @@ M: insn record-insn
|
|||
|
||||
SYMBOLS: def-indices kill-indices ;
|
||||
|
||||
: compute-local-live-ranges ( bb -- )
|
||||
: compute-local-live-ranges ( insns -- )
|
||||
H{ } clone local-def-indices set
|
||||
H{ } clone local-kill-indices set
|
||||
[ instructions>> [ swap record-insn ] each-index ]
|
||||
[ [ local-def-indices get ] dip def-indices get set-at ]
|
||||
[ [ local-kill-indices get ] dip kill-indices get set-at ]
|
||||
tri ;
|
||||
[ swap record-insn ] each-index
|
||||
local-def-indices get basic-block get def-indices get set-at
|
||||
local-kill-indices get basic-block get kill-indices get set-at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -53,7 +52,7 @@ PRIVATE>
|
|||
|
||||
H{ } clone def-indices set
|
||||
H{ } clone kill-indices set
|
||||
[ compute-local-live-ranges ] each-basic-block ;
|
||||
[ compute-local-live-ranges ] simple-analysis ;
|
||||
|
||||
: def-index ( vreg bb -- n )
|
||||
def-indices get at at ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,154 @@
|
|||
USING: compiler.cfg.instructions compiler.cfg.write-barrier
|
||||
tools.test ;
|
||||
IN: compiler.cfg.write-barrier.tests
|
||||
|
||||
! Do need a write barrier on a random store.
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 1 }
|
||||
T{ ##set-slot f 2 1 3 }
|
||||
T{ ##write-barrier f 1 3 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##peek f 1 }
|
||||
T{ ##set-slot f 2 1 3 }
|
||||
T{ ##write-barrier f 1 3 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 1 }
|
||||
T{ ##set-slot-imm f 2 1 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##peek f 1 }
|
||||
T{ ##set-slot-imm f 2 1 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
! Don't need a write barrier on freshly allocated objects.
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##set-slot f 2 1 3 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##set-slot f 2 1 3 }
|
||||
T{ ##write-barrier f 1 3 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##set-slot-imm f 2 1 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##set-slot-imm f 2 1 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
! Do need a write barrier if there's a subroutine call between
|
||||
! the allocation and the store.
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##box }
|
||||
T{ ##set-slot f 2 1 3 }
|
||||
T{ ##write-barrier f 1 3 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##box }
|
||||
T{ ##set-slot f 2 1 3 }
|
||||
T{ ##write-barrier f 1 3 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##box }
|
||||
T{ ##set-slot-imm f 2 1 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 1 }
|
||||
T{ ##box }
|
||||
T{ ##set-slot-imm f 2 1 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
! ##copy instructions
|
||||
[
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##set-slot-imm f 3 1 }
|
||||
T{ ##write-barrier-imm f 2 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##set-slot-imm f 3 1 }
|
||||
T{ ##write-barrier-imm f 2 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##set-slot-imm f 3 2 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##set-slot-imm f 3 2 }
|
||||
T{ ##write-barrier-imm f 1 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##copy f 3 2 }
|
||||
T{ ##set-slot-imm f 3 1 }
|
||||
T{ ##write-barrier-imm f 2 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##copy f 3 2 }
|
||||
T{ ##set-slot-imm f 3 1 }
|
||||
T{ ##write-barrier-imm f 2 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##copy f 3 2 }
|
||||
T{ ##set-slot-imm f 4 1 }
|
||||
T{ ##write-barrier-imm f 3 }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##copy f 2 1 }
|
||||
T{ ##copy f 3 2 }
|
||||
T{ ##set-slot-imm f 4 1 }
|
||||
T{ ##write-barrier-imm f 3 }
|
||||
} write-barriers-step
|
||||
] unit-test
|
||||
|
|
@ -6,23 +6,39 @@ sequences sets ;
|
|||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.write-barrier
|
||||
|
||||
! This pass must run after GC check insertion and scheduling.
|
||||
|
||||
SYMBOL: fresh-allocations
|
||||
|
||||
SYMBOL: mutated-objects
|
||||
|
||||
SYMBOL: copies
|
||||
|
||||
: resolve-copy ( src -- dst )
|
||||
copies get ?at drop ;
|
||||
|
||||
GENERIC: eliminate-write-barrier ( insn -- ? )
|
||||
|
||||
: fresh-allocation ( vreg -- )
|
||||
fresh-allocations get conjoin ;
|
||||
|
||||
M: ##allot eliminate-write-barrier
|
||||
dst>> fresh-allocations get conjoin t ;
|
||||
dst>> fresh-allocation t ;
|
||||
|
||||
: mutated-object ( vreg -- )
|
||||
resolve-copy mutated-objects get conjoin ;
|
||||
|
||||
M: ##set-slot eliminate-write-barrier
|
||||
obj>> mutated-objects get conjoin t ;
|
||||
obj>> mutated-object t ;
|
||||
|
||||
M: ##set-slot-imm eliminate-write-barrier
|
||||
obj>> mutated-objects get conjoin t ;
|
||||
obj>> mutated-object t ;
|
||||
|
||||
: needs-write-barrier? ( insn -- ? )
|
||||
{ [ fresh-allocations get key? not ] [ mutated-objects get key? ] } 1&& ;
|
||||
resolve-copy {
|
||||
[ fresh-allocations get key? not ]
|
||||
[ mutated-objects get key? ]
|
||||
} 1&& ;
|
||||
|
||||
M: ##write-barrier eliminate-write-barrier
|
||||
src>> needs-write-barrier? ;
|
||||
|
|
@ -30,14 +46,18 @@ M: ##write-barrier eliminate-write-barrier
|
|||
M: ##write-barrier-imm eliminate-write-barrier
|
||||
src>> needs-write-barrier? ;
|
||||
|
||||
M: gc-map-insn eliminate-write-barrier
|
||||
fresh-allocations get clear-assoc ;
|
||||
|
||||
M: ##copy eliminate-write-barrier
|
||||
"Run copy propagation first" throw ;
|
||||
[ src>> resolve-copy ] [ dst>> ] bi copies get set-at t ;
|
||||
|
||||
M: insn eliminate-write-barrier drop t ;
|
||||
|
||||
: write-barriers-step ( insns -- insns' )
|
||||
H{ } clone fresh-allocations set
|
||||
H{ } clone mutated-objects set
|
||||
H{ } clone copies set
|
||||
[ eliminate-write-barrier ] filter! ;
|
||||
|
||||
: eliminate-write-barriers ( cfg -- cfg )
|
||||
|
|
|
|||
|
|
@ -170,8 +170,6 @@ CODEGEN: ##div-float %div-float
|
|||
CODEGEN: ##min-float %min-float
|
||||
CODEGEN: ##max-float %max-float
|
||||
CODEGEN: ##sqrt %sqrt
|
||||
CODEGEN: ##unary-float-function %unary-float-function
|
||||
CODEGEN: ##binary-float-function %binary-float-function
|
||||
CODEGEN: ##single>double-float %single>double-float
|
||||
CODEGEN: ##double>single-float %double>single-float
|
||||
CODEGEN: ##integer>float %integer>float
|
||||
|
|
@ -293,5 +291,4 @@ CODEGEN: ##alien-invoke %alien-invoke
|
|||
CODEGEN: ##alien-indirect %alien-indirect
|
||||
CODEGEN: ##alien-assembly %alien-assembly
|
||||
CODEGEN: ##callback-inputs %callback-inputs
|
||||
CODEGEN: ##alien-callback %alien-callback
|
||||
CODEGEN: ##callback-outputs %callback-outputs
|
||||
|
|
|
|||
|
|
@ -45,6 +45,8 @@ FUNCTION: void ffi_test_0 ;
|
|||
FUNCTION: int ffi_test_1 ;
|
||||
[ 3 ] [ ffi_test_1 ] unit-test
|
||||
|
||||
[ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
|
||||
|
||||
FUNCTION: int ffi_test_2 int x int y ;
|
||||
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
|
||||
[ "hi" 3 ffi_test_2 ] must-fail
|
||||
|
|
@ -821,3 +823,25 @@ TUPLE: some-tuple x ;
|
|||
aa-indirect-1 >>x
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Write barrier elimination was being done before scheduling and
|
||||
! GC check insertion, and didn't take subroutine calls into
|
||||
! account. Oops...
|
||||
: write-barrier-elim-in-wrong-place ( -- obj )
|
||||
! A callback used below
|
||||
void { } cdecl [ compact-gc ] alien-callback
|
||||
! Allocate an object A in the nursery
|
||||
1 f <array>
|
||||
! Subroutine call promotes the object to tenured
|
||||
swap void { } cdecl alien-indirect
|
||||
! Allocate another object B in the nursery, store it into
|
||||
! the first
|
||||
1 f <array> over set-first
|
||||
! Now object A's card should be marked and minor GC should
|
||||
! promote B to aging
|
||||
minor-gc
|
||||
! Do stuff
|
||||
[ 100 [ ] times ] infer.
|
||||
;
|
||||
|
||||
[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: tools.test namespaces assocs alien.syntax kernel
|
||||
compiler.errors accessors alien ;
|
||||
compiler.errors accessors alien alien.c-types ;
|
||||
FROM: alien.libraries => add-library ;
|
||||
IN: compiler.tests.linkage-errors
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ quotations classes classes.algebra classes.tuple.private
|
|||
continuations growable namespaces hints alien.accessors
|
||||
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
||||
compiler.test definitions generic.single shuffle math.order
|
||||
compiler.cfg.debugger classes.struct alien.syntax alien.data ;
|
||||
compiler.cfg.debugger classes.struct alien.syntax alien.data
|
||||
alien.c-types ;
|
||||
IN: compiler.tests.optimizer
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
|
|
@ -291,6 +292,9 @@ PREDICATE: list < improper-list
|
|||
[ list instance? ] compile-call
|
||||
] unit-test
|
||||
|
||||
! <tuple> type function bustage
|
||||
[ T{ cons } 7 ] [ cons tuple-layout [ [ <tuple> ] [ length ] bi ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
: interval-inference-bug ( obj -- obj x )
|
||||
dup "a" get { array-capacity } declare >=
|
||||
|
|
|
|||
|
|
@ -0,0 +1,34 @@
|
|||
USING: tools.test compiler.units classes.mixin definitions
|
||||
kernel kernel.private ;
|
||||
IN: compiler.tests.redefine25
|
||||
|
||||
MIXIN: empty-mixin
|
||||
|
||||
: empty-mixin-test-1 ( a -- ? ) empty-mixin? ;
|
||||
|
||||
TUPLE: a-superclass ;
|
||||
|
||||
: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ;
|
||||
|
||||
TUPLE: empty-mixin-member < a-superclass ;
|
||||
|
||||
[ f ] [ empty-mixin-member new empty-mixin? ] unit-test
|
||||
[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
|
||||
[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ empty-mixin-member \ empty-mixin add-mixin-instance
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ t ] [ empty-mixin-member new empty-mixin? ] unit-test
|
||||
[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
|
||||
[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ empty-mixin forget
|
||||
\ empty-mixin-member forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
IN: compiler.tests.x87-regression
|
||||
USING: math.floats.env alien.syntax alien.c-types compiler.test
|
||||
tools.test kernel math ;
|
||||
|
||||
LIBRARY: libm
|
||||
FUNCTION: double sqrt ( double x ) ;
|
||||
|
||||
[ { } ] [
|
||||
4.0 [ [ 100 [ dup sqrt drop ] times ] collect-fp-exceptions nip ] compile-call
|
||||
] unit-test
|
||||
|
|
@ -20,10 +20,6 @@ M: callable (build-tree) infer-quot-here ;
|
|||
: check-no-compile ( word -- )
|
||||
dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
|
||||
|
||||
: check-effect ( word effect -- )
|
||||
swap required-stack-effect 2dup effect<=
|
||||
[ 2drop ] [ effect-error ] if ;
|
||||
|
||||
: inline-recursive? ( word -- ? )
|
||||
[ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
|
||||
|
||||
|
|
@ -33,7 +29,7 @@ M: callable (build-tree) infer-quot-here ;
|
|||
M: word (build-tree)
|
||||
[ check-no-compile ]
|
||||
[ word-body infer-quot-here ]
|
||||
[ current-effect check-effect ] tri ;
|
||||
[ required-stack-effect check-effect ] tri ;
|
||||
|
||||
: build-tree-with ( in-stack word/quot -- nodes )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -188,7 +188,7 @@ M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
|||
|
||||
M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
|
||||
|
||||
M: #alien-callback check-stack-flow* drop ;
|
||||
M: #alien-callback check-stack-flow* child>> check-stack-flow ;
|
||||
|
||||
M: #declare check-stack-flow* drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -519,3 +519,30 @@ cell-bits 32 = [
|
|||
14 ndrop
|
||||
] cleaned-up-tree nodes>quot
|
||||
] unit-test
|
||||
|
||||
USING: alien alien.c-types ;
|
||||
|
||||
[ t ] [
|
||||
[ int { } cdecl [ 2 2 + ] alien-callback ]
|
||||
{ + } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ double { double double } cdecl [ + ] alien-callback ]
|
||||
\ + inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ double { double double } cdecl [ + ] alien-callback ]
|
||||
\ float+ inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ char { char char } cdecl [ + ] alien-callback ]
|
||||
\ fixnum+fast inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]
|
||||
\ >c-ptr inlined?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -182,4 +182,7 @@ M: #recursive cleanup*
|
|||
[ cleanup ] change-child
|
||||
dup label>> calls>> empty? [ flatten-recursive ] when ;
|
||||
|
||||
M: #alien-callback cleanup*
|
||||
[ cleanup ] change-child ;
|
||||
|
||||
M: node cleanup* ;
|
||||
|
|
|
|||
|
|
@ -1,46 +1,47 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs fry kernel accessors sequences compiler.utilities
|
||||
arrays stack-checker.inlining namespaces compiler.tree
|
||||
math.order ;
|
||||
USING: assocs combinators combinators.short-circuit fry kernel
|
||||
locals accessors sequences compiler.utilities arrays
|
||||
stack-checker.inlining namespaces compiler.tree math.order ;
|
||||
IN: compiler.tree.combinators
|
||||
|
||||
: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
|
||||
dup dup '[
|
||||
_ [
|
||||
dup #branch? [
|
||||
children>> [ _ each-node ] each
|
||||
] [
|
||||
dup #recursive? [
|
||||
child>> _ each-node
|
||||
] [ drop ] if
|
||||
] if
|
||||
:: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
|
||||
nodes [
|
||||
quot
|
||||
[
|
||||
{
|
||||
{ [ dup #branch? ] [ children>> [ quot each-node ] each ] }
|
||||
{ [ dup #recursive? ] [ child>> quot each-node ] }
|
||||
{ [ dup #alien-callback? ] [ child>> quot each-node ] }
|
||||
[ drop ]
|
||||
} cond
|
||||
] bi
|
||||
] each ; inline recursive
|
||||
|
||||
: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
|
||||
dup dup '[
|
||||
@
|
||||
dup #branch? [
|
||||
[ [ _ map-nodes ] map ] change-children
|
||||
] [
|
||||
dup #recursive? [
|
||||
[ _ map-nodes ] change-child
|
||||
] when
|
||||
] if
|
||||
:: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
|
||||
nodes [
|
||||
quot call
|
||||
{
|
||||
{ [ dup #branch? ] [ [ [ quot map-nodes ] map ] change-children ] }
|
||||
{ [ dup #recursive? ] [ [ quot map-nodes ] change-child ] }
|
||||
{ [ dup #alien-callback? ] [ [ quot map-nodes ] change-child ] }
|
||||
[ ]
|
||||
} cond
|
||||
] map-flat ; inline recursive
|
||||
|
||||
: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
|
||||
dup dup '[
|
||||
_ keep swap [ drop t ] [
|
||||
dup #branch? [
|
||||
children>> [ _ contains-node? ] any?
|
||||
] [
|
||||
dup #recursive? [
|
||||
child>> _ contains-node?
|
||||
] [ drop f ] if
|
||||
] if
|
||||
] if
|
||||
:: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
|
||||
nodes [
|
||||
{
|
||||
quot
|
||||
[
|
||||
{
|
||||
{ [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] }
|
||||
{ [ dup #recursive? ] [ child>> quot contains-node? ] }
|
||||
{ [ dup #alien-callback? ] [ child>> quot contains-node? ] }
|
||||
[ drop f ]
|
||||
} cond
|
||||
]
|
||||
} 1||
|
||||
] any? ; inline recursive
|
||||
|
||||
: select-children ( seq flags -- seq' )
|
||||
|
|
|
|||
|
|
@ -117,3 +117,6 @@ M: #terminate remove-dead-code*
|
|||
|
||||
M: #alien-node remove-dead-code*
|
||||
maybe-drop-dead-outputs ;
|
||||
|
||||
M: #alien-callback remove-dead-code*
|
||||
[ (remove-dead-code) ] change-child ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: kernel assocs match fry accessors namespaces make effects
|
|||
sequences sequences.private quotations generic macros arrays
|
||||
prettyprint prettyprint.backend prettyprint.custom
|
||||
prettyprint.sections math words combinators
|
||||
combinators.short-circuit io sorting hints
|
||||
combinators.short-circuit io sorting hints sets
|
||||
compiler.tree
|
||||
compiler.tree.recursive
|
||||
compiler.tree.normalization
|
||||
|
|
@ -22,6 +22,7 @@ compiler.tree.identities
|
|||
compiler.tree.dead-code
|
||||
compiler.tree.modular-arithmetic ;
|
||||
FROM: fry => _ ;
|
||||
FROM: namespaces => set ;
|
||||
RENAME: _ match => __
|
||||
IN: compiler.tree.debugger
|
||||
|
||||
|
|
@ -128,7 +129,8 @@ M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
|
|||
|
||||
M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
|
||||
|
||||
M: #alien-callback node>quot params>> , \ #alien-callback , ;
|
||||
M: #alien-callback node>quot
|
||||
[ params>> , ] [ child>> nodes>quot , ] bi \ #alien-callback , ;
|
||||
|
||||
M: node node>quot drop ;
|
||||
|
||||
|
|
@ -222,7 +224,6 @@ SYMBOL: node-count
|
|||
] with-scope ;
|
||||
|
||||
: inlined? ( quot seq/word -- ? )
|
||||
[ cleaned-up-tree ] dip
|
||||
dup word? [ 1array ] when
|
||||
'[ dup #call? [ word>> _ member? ] [ drop f ] if ]
|
||||
contains-node? not ;
|
||||
dup word? [ 1array ] when swap
|
||||
[ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make
|
||||
intersect empty? ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ SYMBOL: next-node
|
|||
: each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... )
|
||||
dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
|
||||
|
||||
: (escape-analysis) ( node -- )
|
||||
: (escape-analysis) ( nodes -- )
|
||||
[
|
||||
[ node-defs-values introduce-values ]
|
||||
[ escape-analysis* ]
|
||||
|
|
|
|||
|
|
@ -100,4 +100,5 @@ M: #alien-node escape-analysis*
|
|||
[ out-d>> unknown-allocations ]
|
||||
bi ;
|
||||
|
||||
M: #alien-callback escape-analysis* drop ;
|
||||
M: #alien-callback escape-analysis*
|
||||
child>> (escape-analysis) ;
|
||||
|
|
|
|||
|
|
@ -109,8 +109,13 @@ M: #call-recursive normalize*
|
|||
M: node normalize* ;
|
||||
|
||||
: normalize ( nodes -- nodes' )
|
||||
dup count-introductions make-values
|
||||
H{ } clone rename-map set
|
||||
[ (normalize) ] [ nip ] 2bi
|
||||
[ #introduce prefix ] unless-empty
|
||||
rename-node-values ;
|
||||
[
|
||||
dup count-introductions make-values
|
||||
H{ } clone rename-map set
|
||||
[ (normalize) ] [ nip ] 2bi
|
||||
[ #introduce prefix ] unless-empty
|
||||
rename-node-values
|
||||
] with-scope ;
|
||||
|
||||
M: #alien-callback normalize*
|
||||
[ normalize ] change-child ;
|
||||
|
|
|
|||
|
|
@ -319,10 +319,9 @@ generic-comparison-ops [
|
|||
] [ 2drop object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{ facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp
|
||||
flog fpow fsqrt facosh fasinh fatanh } [
|
||||
{ float } "default-output-classes" set-word-prop
|
||||
] each
|
||||
! Unlike the other words in math.libm, fsqrt is not inline
|
||||
! since it has an intrinsic, so we need to give it outputs here.
|
||||
\ fsqrt { float } "default-output-classes" set-word-prop
|
||||
|
||||
! Find a less repetitive way of doing this
|
||||
\ float-min { float float } "input-classes" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors kernel assocs
|
||||
compiler.tree
|
||||
|
|
@ -16,7 +16,7 @@ GENERIC: annotate-node ( node -- )
|
|||
|
||||
GENERIC: propagate-around ( node -- )
|
||||
|
||||
: (propagate) ( node -- )
|
||||
: (propagate) ( nodes -- )
|
||||
[ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
|
||||
|
||||
: extract-value-info ( values -- assoc )
|
||||
|
|
|
|||
|
|
@ -9,12 +9,18 @@ compiler.tree.debugger compiler.tree.checker slots.private words
|
|||
hashtables classes assocs locals specialized-arrays system
|
||||
sorting math.libm math.floats.private math.integers.private
|
||||
math.intervals quotations effects alien alien.data sets
|
||||
strings.private ;
|
||||
strings.private vocabs ;
|
||||
FROM: math => float ;
|
||||
SPECIALIZED-ARRAY: double
|
||||
SPECIALIZED-ARRAY: void*
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
[ { } ] [
|
||||
all-words [
|
||||
"input-classes" word-prop [ class? ] all? not
|
||||
] filter
|
||||
] unit-test
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ M: #declare propagate-before
|
|||
recover ;
|
||||
|
||||
: predicate-output-infos/class ( info class -- info )
|
||||
[ class>> ] dip compare-classes
|
||||
[ class>> ] dip evaluate-class-predicate
|
||||
dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
|
||||
|
||||
: predicate-output-infos ( info class -- info )
|
||||
|
|
@ -153,4 +153,6 @@ M: #call propagate-after
|
|||
|
||||
M: #alien-node propagate-before propagate-alien-invoke ;
|
||||
|
||||
M: #alien-callback propagate-around child>> (propagate) ;
|
||||
|
||||
M: #return annotate-node dup in-d>> (annotate-node) ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test kernel combinators.short-circuit math sequences accessors
|
||||
USING: tools.test kernel combinators.short-circuit math sequences accessors make
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.combinators
|
||||
|
|
@ -12,22 +12,24 @@ IN: compiler.tree.recursive.tests
|
|||
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
|
||||
|
||||
: label-is-loop? ( nodes word -- ? )
|
||||
[
|
||||
{
|
||||
[ drop #recursive? ]
|
||||
[ drop label>> loop?>> ]
|
||||
[ swap label>> word>> eq? ]
|
||||
} 2&&
|
||||
] curry contains-node? ;
|
||||
swap [
|
||||
[
|
||||
dup {
|
||||
[ #recursive? ]
|
||||
[ label>> loop?>> ]
|
||||
} 1&& [ label>> word>> , ] [ drop ] if
|
||||
] each-node
|
||||
] V{ } make member? ;
|
||||
|
||||
: label-is-not-loop? ( nodes word -- ? )
|
||||
[
|
||||
{
|
||||
[ drop #recursive? ]
|
||||
[ drop label>> loop?>> not ]
|
||||
[ swap label>> word>> eq? ]
|
||||
} 2&&
|
||||
] curry contains-node? ;
|
||||
swap [
|
||||
[
|
||||
dup {
|
||||
[ #recursive? ]
|
||||
[ label>> loop?>> not ]
|
||||
} 1&& [ label>> word>> , ] [ drop ] if
|
||||
] each-node
|
||||
] V{ } make member? ;
|
||||
|
||||
: loop-test-1 ( a -- )
|
||||
dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive
|
||||
|
|
|
|||
|
|
@ -61,6 +61,9 @@ M: #recursive node-call-graph
|
|||
M: #branch node-call-graph
|
||||
children>> [ (build-call-graph) ] with each ;
|
||||
|
||||
M: #alien-callback node-call-graph
|
||||
child>> (build-call-graph) ;
|
||||
|
||||
M: node node-call-graph 2drop ;
|
||||
|
||||
SYMBOLS: not-loops recursive-nesting ;
|
||||
|
|
|
|||
|
|
@ -154,10 +154,11 @@ TUPLE: #alien-assembly < #alien-node in-d out-d ;
|
|||
: #alien-assembly ( params -- node )
|
||||
\ #alien-assembly new-alien-node ;
|
||||
|
||||
TUPLE: #alien-callback < node params ;
|
||||
TUPLE: #alien-callback < node params child ;
|
||||
|
||||
: #alien-callback ( params -- node )
|
||||
: #alien-callback ( params child -- node )
|
||||
\ #alien-callback new
|
||||
swap >>child
|
||||
swap >>params ;
|
||||
|
||||
: node, ( node -- ) stack-visitor get push ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ compiler.tree.cleanup compiler.tree.escape-analysis
|
|||
compiler.tree.tuple-unboxing compiler.tree.checker
|
||||
compiler.tree.def-use kernel accessors sequences math
|
||||
math.private sorting math.order binary-search sequences.private
|
||||
slots.private ;
|
||||
slots.private alien alien.c-types ;
|
||||
IN: compiler.tree.tuple-unboxing.tests
|
||||
|
||||
: test-unboxing ( quot -- )
|
||||
|
|
@ -35,6 +35,7 @@ TUPLE: empty-tuple ;
|
|||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||
[ [ <=> ] sort ]
|
||||
[ [ <=> ] with search ]
|
||||
[ cons boa car>> void { } cdecl [ ] alien-callback ]
|
||||
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
|
||||
|
||||
! A more complicated example
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ $nl
|
|||
parallel-cleave
|
||||
parallel-spread
|
||||
parallel-napply
|
||||
} ;
|
||||
}
|
||||
"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjuction with the above combinators to limit the maximum number of concurrent operations." ;
|
||||
|
||||
ABOUT: "concurrency.combinators"
|
||||
|
|
|
|||
|
|
@ -1,22 +1,9 @@
|
|||
USING: help.markup help.syntax concurrency.messaging threads ;
|
||||
IN: concurrency.distributed
|
||||
|
||||
HELP: local-node
|
||||
{ $var-description "A variable containing the node the current thread is running on." } ;
|
||||
|
||||
HELP: start-node
|
||||
{ $values { "port" "a port number between 0 and 65535" } }
|
||||
{ $description "Starts a node server for receiving messages from remote Factor instances." } ;
|
||||
|
||||
ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example"
|
||||
"For a Factor instance to be able to send and receive distributed "
|
||||
"concurrency messages it must first have " { $link start-node } " called."
|
||||
$nl
|
||||
"In one factor instance call " { $link start-node } " with the port 9000, "
|
||||
"and in another with the port 9001."
|
||||
$nl
|
||||
"In this example the Factor instance associated with port 9000 will run "
|
||||
"a thread that sits receiving messages and printing the received message "
|
||||
"a thread that receives and prints messages "
|
||||
"in the listener. The code to start the thread is: "
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
|
|
@ -50,12 +37,10 @@ $nl
|
|||
" or " { $link reply } " call." ;
|
||||
|
||||
ARTICLE: "concurrency.distributed" "Distributed message passing"
|
||||
"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite."
|
||||
{ $subsections start-node }
|
||||
"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." $nl
|
||||
"Instances of " { $link thread } " can be sent to remote threads, at which point they are converted to objects holding the thread ID and the current node's host name:"
|
||||
{ $subsections remote-thread }
|
||||
"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket."
|
||||
{ $subsections "concurrency.distributed.example" } ;
|
||||
|
||||
|
||||
ABOUT: "concurrency.distributed"
|
||||
|
|
|
|||
|
|
@ -1,33 +1,39 @@
|
|||
USING: tools.test concurrency.distributed kernel io.files
|
||||
io.files.temp io.directories arrays io.sockets system
|
||||
io.files.temp io.directories arrays io.sockets system calendar
|
||||
combinators threads math sequences concurrency.messaging
|
||||
continuations accessors prettyprint ;
|
||||
continuations accessors prettyprint io.servers.connection ;
|
||||
FROM: concurrency.messaging => receive send ;
|
||||
IN: concurrency.distributed.tests
|
||||
|
||||
: test-node ( -- addrspec )
|
||||
CONSTANT: test-ip "127.0.0.1"
|
||||
|
||||
: test-node-server ( -- threaded-server )
|
||||
{
|
||||
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
|
||||
{ [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
|
||||
{ [ os windows? ] [ test-ip 0 <inet4> ] }
|
||||
} cond <node-server> ;
|
||||
|
||||
: test-node-client ( -- addrspec )
|
||||
{
|
||||
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
|
||||
{ [ os windows? ] [ test-ip insecure-port <inet4> ] }
|
||||
} cond ;
|
||||
|
||||
|
||||
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
|
||||
|
||||
[ ] [ test-node dup (start-node) ] unit-test
|
||||
test-node-server [
|
||||
[ ] [
|
||||
[
|
||||
receive first2 [ 3 + ] dip send
|
||||
"thread-a" unregister-remote-thread
|
||||
] "Thread A" spawn
|
||||
"thread-a" register-remote-thread
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
receive first2 [ 3 + ] dip send
|
||||
"thread-a" unregister-remote-thread
|
||||
] "Thread A" spawn
|
||||
"thread-a" register-remote-thread
|
||||
] unit-test
|
||||
|
||||
[ 8 ] [
|
||||
5 self 2array
|
||||
test-node "thread-a" <remote-thread> send
|
||||
|
||||
receive
|
||||
] unit-test
|
||||
|
||||
[ ] [ test-node stop-node ] unit-test
|
||||
[ 8 ] [
|
||||
5 self 2array
|
||||
test-node-client "thread-a" <remote-thread> send
|
||||
100 seconds receive-timeout
|
||||
] unit-test
|
||||
] with-threaded-server
|
||||
|
|
@ -22,8 +22,6 @@ PRIVATE>
|
|||
: get-remote-thread ( name -- thread )
|
||||
dup registered-remote-threads at [ ] [ threads at ] ?if ;
|
||||
|
||||
SYMBOL: local-node
|
||||
|
||||
: handle-node-client ( -- )
|
||||
deserialize
|
||||
[ first2 get-remote-thread send ] [ stop-this-server ] if* ;
|
||||
|
|
@ -34,12 +32,6 @@ SYMBOL: local-node
|
|||
"concurrency.distributed" >>name
|
||||
[ handle-node-client ] >>handler ;
|
||||
|
||||
: (start-node) ( addrspec addrspec -- )
|
||||
local-node set-global <node-server> start-server* ;
|
||||
|
||||
: start-node ( port -- )
|
||||
host-name over <inet> (start-node) ;
|
||||
|
||||
TUPLE: remote-thread node id ;
|
||||
|
||||
C: <remote-thread> remote-thread
|
||||
|
|
@ -52,8 +44,7 @@ M: remote-thread send ( message thread -- )
|
|||
send-remote-message ;
|
||||
|
||||
M: thread (serialize) ( obj -- )
|
||||
id>> [ local-node get-global ] dip <remote-thread>
|
||||
(serialize) ;
|
||||
id>> [ insecure-addr ] dip <remote-thread> (serialize) ;
|
||||
|
||||
: stop-node ( node -- )
|
||||
f swap send-remote-message ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: concurrency.semaphores
|
|||
USING: help.markup help.syntax kernel quotations calendar ;
|
||||
|
||||
HELP: semaphore
|
||||
{ $class-description "The class of counting semaphores." } ;
|
||||
{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link <semaphore> } "." } ;
|
||||
|
||||
HELP: <semaphore>
|
||||
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
|
||||
|
|
@ -29,19 +29,39 @@ HELP: with-semaphore
|
|||
{ $values { "semaphore" semaphore } { "quot" quotation } }
|
||||
{ $description "Calls the quotation with the semaphore held." } ;
|
||||
|
||||
ARTICLE: "concurrency.semaphores" "Counting semaphores"
|
||||
"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1."
|
||||
$nl
|
||||
ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"
|
||||
"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:"
|
||||
{ $code
|
||||
"SYMBOL: expensive-section"
|
||||
"10 <semaphore> expensive-section set-global"
|
||||
"requests ["
|
||||
"requests"
|
||||
"10 <semaphore> '["
|
||||
" ..."
|
||||
" expensive-section [ do-expensive-stuff ] with-semaphore"
|
||||
" _ [ do-expensive-stuff ] with-semaphore"
|
||||
" ..."
|
||||
"] parallel-map"
|
||||
}
|
||||
"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:"
|
||||
{ $code
|
||||
"""USING: concurrency.combinators concurrency.semaphores
|
||||
fry http.client kernel urls ;
|
||||
|
||||
{
|
||||
URL" http://www.apple.com"
|
||||
URL" http://www.google.com"
|
||||
URL" http://www.ibm.com"
|
||||
URL" http://www.hp.com"
|
||||
URL" http://www.oracle.com"
|
||||
}
|
||||
2 <semaphore> '[
|
||||
_ [
|
||||
http-get nip
|
||||
] with-semaphore
|
||||
] parallel-map"""
|
||||
} ;
|
||||
|
||||
ARTICLE: "concurrency.semaphores" "Counting semaphores"
|
||||
"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1."
|
||||
{ $subsections "concurrency.semaphores.examples" }
|
||||
"Creating semaphores:"
|
||||
{ $subsections
|
||||
semaphore
|
||||
|
|
|
|||
|
|
@ -292,8 +292,6 @@ HOOK: %div-float cpu ( dst src1 src2 -- )
|
|||
HOOK: %min-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %max-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %sqrt cpu ( dst src -- )
|
||||
HOOK: %unary-float-function cpu ( dst src func -- )
|
||||
HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
|
||||
|
||||
HOOK: %single>double-float cpu ( dst src -- )
|
||||
HOOK: %double>single-float cpu ( dst src -- )
|
||||
|
|
@ -602,16 +600,14 @@ HOOK: %save-context cpu ( temp1 temp2 -- )
|
|||
|
||||
HOOK: %c-invoke cpu ( symbols dll gc-map -- )
|
||||
|
||||
HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
|
||||
HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- )
|
||||
|
||||
HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
|
||||
HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- )
|
||||
|
||||
HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
|
||||
HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot gc-map -- )
|
||||
|
||||
HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
|
||||
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
||||
HOOK: %callback-outputs cpu ( reg-inputs -- )
|
||||
|
||||
HOOK: stack-cleanup cpu ( stack-size return abi -- n )
|
||||
|
|
|
|||
|
|
@ -148,6 +148,13 @@ M: x86.32 %store-reg-param ( vreg rep reg -- )
|
|||
{ double-rep [ drop \ FLDL double-rep store-float-return ] }
|
||||
} case ;
|
||||
|
||||
M: x86.32 %discard-reg-param ( rep reg -- )
|
||||
drop {
|
||||
{ int-rep [ ] }
|
||||
{ float-rep [ ST0 FSTP ] }
|
||||
{ double-rep [ ST0 FSTP ] }
|
||||
} case ;
|
||||
|
||||
:: call-unbox-func ( src func -- )
|
||||
EAX src tagged-rep %copy
|
||||
4 save-vm-ptr
|
||||
|
|
@ -186,25 +193,10 @@ M: x86.32 %begin-callback ( -- )
|
|||
4 stack@ 0 MOV
|
||||
"begin_callback" f f %c-invoke ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
[ EAX ] dip %load-reference
|
||||
EAX quot-entry-point-offset [+] CALL ;
|
||||
|
||||
M: x86.32 %end-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
"end_callback" f f %c-invoke ;
|
||||
|
||||
M:: x86.32 %unary-float-function ( dst src func -- )
|
||||
src double-rep 0 %store-stack-param
|
||||
func "libm" load-library f %c-invoke
|
||||
dst double-rep %load-return ;
|
||||
|
||||
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
|
||||
src1 double-rep 0 %store-stack-param
|
||||
src2 double-rep 8 %store-stack-param
|
||||
func "libm" load-library f %c-invoke
|
||||
dst double-rep %load-return ;
|
||||
|
||||
: funny-large-struct-return? ( return abi -- ? )
|
||||
#! MINGW ABI incompatibility disaster
|
||||
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
|
||||
|
|
|
|||
|
|
@ -64,9 +64,6 @@ IN: bootstrap.x86
|
|||
ds-reg ctx-reg context-datastack-offset [+] MOV
|
||||
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
|
||||
|
||||
: jit-scrub-return ( n -- )
|
||||
ESP swap [+] 0 MOV ;
|
||||
|
||||
[
|
||||
! ctx-reg is preserved across the call because it is non-volatile
|
||||
! in the C ABI
|
||||
|
|
@ -115,24 +112,28 @@ IN: bootstrap.x86
|
|||
! Windows-specific setup
|
||||
ctx-reg jit-update-seh
|
||||
|
||||
! Clear x87 stack, but preserve rounding mode and exception flags
|
||||
ESP 2 SUB
|
||||
ESP [] FNSTCW
|
||||
FNINIT
|
||||
ESP [] FLDCW
|
||||
ESP 2 ADD
|
||||
|
||||
! Load arguments
|
||||
EAX ESP stack-frame-size [+] MOV
|
||||
EDX ESP stack-frame-size 4 + [+] MOV
|
||||
|
||||
! Unwind stack frames
|
||||
ESP EDX MOV
|
||||
0 jit-scrub-return
|
||||
|
||||
jit-jump-quot
|
||||
] \ unwind-native-frames define-sub-primitive
|
||||
|
||||
[
|
||||
ESP 2 SUB
|
||||
ESP [] FNSTCW
|
||||
FNINIT
|
||||
AX ESP [] MOV
|
||||
ESP 2 ADD
|
||||
] \ fpu-state define-sub-primitive
|
||||
|
||||
[
|
||||
ESP stack-frame-size [+] FLDCW
|
||||
] \ set-fpu-state define-sub-primitive
|
||||
|
||||
[
|
||||
! Load callstack object
|
||||
temp3 ds-reg [] MOV
|
||||
|
|
@ -251,11 +252,9 @@ IN: bootstrap.x86
|
|||
|
||||
! Contexts
|
||||
: jit-switch-context ( reg -- )
|
||||
-4 jit-scrub-return
|
||||
|
||||
! Save ds, rs registers
|
||||
jit-load-vm
|
||||
jit-save-context
|
||||
! Reset return value since its bogus right now, to avoid
|
||||
! confusing the GC
|
||||
ESP -4 [+] 0 MOV
|
||||
|
||||
! Make the new context the current one
|
||||
ctx-reg swap MOV
|
||||
|
|
@ -277,6 +276,10 @@ IN: bootstrap.x86
|
|||
EDX ds-reg -4 [+] MOV
|
||||
ds-reg 8 SUB
|
||||
|
||||
! Save ds, rs registers
|
||||
jit-load-vm
|
||||
jit-save-context
|
||||
|
||||
! Make the new context active
|
||||
EAX jit-switch-context
|
||||
|
||||
|
|
@ -292,23 +295,30 @@ IN: bootstrap.x86
|
|||
|
||||
[ jit-set-context ] \ (set-context) define-sub-primitive
|
||||
|
||||
: jit-save-quot-and-param ( -- )
|
||||
EDX ds-reg MOV
|
||||
ds-reg 8 SUB ;
|
||||
|
||||
: jit-push-param ( -- )
|
||||
EAX EDX -4 [+] MOV
|
||||
ds-reg 4 ADD
|
||||
ds-reg [] EAX MOV ;
|
||||
|
||||
: jit-start-context ( -- )
|
||||
! Create the new context in return-reg
|
||||
jit-load-vm
|
||||
jit-save-context
|
||||
ESP [] vm-reg MOV
|
||||
"new_context" jit-call
|
||||
|
||||
! Save pointer to quotation and parameter
|
||||
EDX ds-reg MOV
|
||||
ds-reg 8 SUB
|
||||
jit-save-quot-and-param
|
||||
|
||||
! Make the new context active
|
||||
jit-load-vm
|
||||
jit-save-context
|
||||
EAX jit-switch-context
|
||||
|
||||
! Push parameter
|
||||
EAX EDX -4 [+] MOV
|
||||
ds-reg 4 ADD
|
||||
ds-reg [] EAX MOV
|
||||
jit-push-param
|
||||
|
||||
! Windows-specific setup
|
||||
jit-install-seh
|
||||
|
|
@ -334,7 +344,20 @@ IN: bootstrap.x86
|
|||
jit-set-context
|
||||
] \ (set-context-and-delete) define-sub-primitive
|
||||
|
||||
: jit-start-context-and-delete ( -- )
|
||||
jit-load-vm
|
||||
jit-load-context
|
||||
ESP [] vm-reg MOV
|
||||
ESP 4 [+] ctx-reg MOV
|
||||
"reset_context" jit-call
|
||||
|
||||
jit-save-quot-and-param
|
||||
ctx-reg jit-switch-context
|
||||
jit-push-param
|
||||
|
||||
EAX EDX [] MOV
|
||||
jit-jump-quot ;
|
||||
|
||||
[
|
||||
jit-delete-current-context
|
||||
jit-start-context
|
||||
jit-start-context-and-delete
|
||||
] \ (start-context-and-delete) define-sub-primitive
|
||||
|
|
|
|||
|
|
@ -95,6 +95,9 @@ M:: x86.64 %load-reg-param ( vreg rep reg -- )
|
|||
M:: x86.64 %store-reg-param ( vreg rep reg -- )
|
||||
reg vreg rep %copy ;
|
||||
|
||||
M: x86.64 %discard-reg-param ( rep reg -- )
|
||||
2drop ;
|
||||
|
||||
M:: x86.64 %unbox ( dst src func rep -- )
|
||||
param-reg-0 src tagged-rep %copy
|
||||
param-reg-1 %mov-vm-ptr
|
||||
|
|
@ -116,30 +119,10 @@ M: x86.64 %begin-callback ( -- )
|
|||
param-reg-1 0 MOV
|
||||
"begin_callback" f f %c-invoke ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
[ param-reg-0 ] dip %load-reference
|
||||
param-reg-0 quot-entry-point-offset [+] CALL ;
|
||||
|
||||
M: x86.64 %end-callback ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
"end_callback" f f %c-invoke ;
|
||||
|
||||
: float-function-param ( i src -- )
|
||||
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
|
||||
|
||||
M:: x86.64 %unary-float-function ( dst src func -- )
|
||||
0 src float-function-param
|
||||
func "libm" load-library f %c-invoke
|
||||
dst double-rep %load-return ;
|
||||
|
||||
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
|
||||
! src1 might equal dst; otherwise it will be a spill slot
|
||||
! src2 is always a spill slot
|
||||
0 src1 float-function-param
|
||||
1 src2 float-function-param
|
||||
func "libm" load-library f %c-invoke
|
||||
dst double-rep %load-return ;
|
||||
|
||||
M: x86.64 %prepare-var-args ( -- ) RAX RAX XOR ;
|
||||
|
||||
M: x86.64 stack-cleanup 3drop 0 ;
|
||||
|
|
|
|||
|
|
@ -62,9 +62,6 @@ IN: bootstrap.x86
|
|||
ds-reg ctx-reg context-datastack-offset [+] MOV
|
||||
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
|
||||
|
||||
: jit-scrub-return ( n -- )
|
||||
RSP swap [+] 0 MOV ;
|
||||
|
||||
[
|
||||
! ctx-reg is preserved across the call because it is non-volatile
|
||||
! in the C ABI
|
||||
|
|
@ -102,15 +99,8 @@ IN: bootstrap.x86
|
|||
\ (call) define-combinator-primitive
|
||||
|
||||
[
|
||||
! Clear x87 stack, but preserve rounding mode and exception flags
|
||||
RSP 2 SUB
|
||||
RSP [] FNSTCW
|
||||
FNINIT
|
||||
RSP [] FLDCW
|
||||
|
||||
! Unwind stack frames
|
||||
RSP arg2 MOV
|
||||
0 jit-scrub-return
|
||||
|
||||
! Load VM pointer into vm-reg, since we're entering from
|
||||
! C code
|
||||
|
|
@ -124,6 +114,21 @@ IN: bootstrap.x86
|
|||
jit-jump-quot
|
||||
] \ unwind-native-frames define-sub-primitive
|
||||
|
||||
[
|
||||
RSP 2 SUB
|
||||
RSP [] FNSTCW
|
||||
FNINIT
|
||||
AX RSP [] MOV
|
||||
RSP 2 ADD
|
||||
] \ fpu-state define-sub-primitive
|
||||
|
||||
[
|
||||
RSP 2 SUB
|
||||
RSP [] arg1 16-bit-version-of MOV
|
||||
RSP [] FLDCW
|
||||
RSP 2 ADD
|
||||
] \ set-fpu-state define-sub-primitive
|
||||
|
||||
[
|
||||
! Load callstack object
|
||||
arg4 ds-reg [] MOV
|
||||
|
|
@ -228,10 +233,9 @@ IN: bootstrap.x86
|
|||
|
||||
! Contexts
|
||||
: jit-switch-context ( reg -- )
|
||||
-8 jit-scrub-return
|
||||
|
||||
! Save ds, rs registers
|
||||
jit-save-context
|
||||
! Reset return value since its bogus right now, to avoid
|
||||
! confusing the GC
|
||||
RSP -8 [+] 0 MOV
|
||||
|
||||
! Make the new context the current one
|
||||
ctx-reg swap MOV
|
||||
|
|
@ -257,6 +261,7 @@ IN: bootstrap.x86
|
|||
|
||||
: jit-set-context ( -- )
|
||||
jit-pop-context-and-param
|
||||
jit-save-context
|
||||
arg1 jit-switch-context
|
||||
RSP 8 ADD
|
||||
jit-push-param ;
|
||||
|
|
@ -269,16 +274,17 @@ IN: bootstrap.x86
|
|||
ds-reg 16 SUB ;
|
||||
|
||||
: jit-start-context ( -- )
|
||||
! Create the new context in return-reg
|
||||
! Create the new context in return-reg. Have to save context
|
||||
! twice, first before calling new_context() which may GC,
|
||||
! and again after popping the two parameters from the stack.
|
||||
jit-save-context
|
||||
arg1 vm-reg MOV
|
||||
"new_context" jit-call
|
||||
|
||||
jit-pop-quot-and-param
|
||||
|
||||
jit-save-context
|
||||
return-reg jit-switch-context
|
||||
|
||||
jit-push-param
|
||||
|
||||
jit-jump-quot ;
|
||||
|
||||
[ jit-start-context ] \ (start-context) define-sub-primitive
|
||||
|
|
@ -294,7 +300,17 @@ IN: bootstrap.x86
|
|||
jit-set-context
|
||||
] \ (set-context-and-delete) define-sub-primitive
|
||||
|
||||
: jit-start-context-and-delete ( -- )
|
||||
jit-load-context
|
||||
arg1 vm-reg MOV
|
||||
arg2 ctx-reg MOV
|
||||
"reset_context" jit-call
|
||||
|
||||
jit-pop-quot-and-param
|
||||
ctx-reg jit-switch-context
|
||||
jit-push-param
|
||||
jit-jump-quot ;
|
||||
|
||||
[
|
||||
jit-delete-current-context
|
||||
jit-start-context
|
||||
jit-start-context-and-delete
|
||||
] \ (start-context-and-delete) define-sub-primitive
|
||||
|
|
|
|||
|
|
@ -919,6 +919,5 @@ M: x86 %vector>scalar %copy ;
|
|||
M: x86 %scalar>vector %copy ;
|
||||
|
||||
enable-float-intrinsics
|
||||
enable-float-functions
|
||||
enable-float-min/max
|
||||
enable-fsqrt
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
IN: cpu.x86.tests
|
||||
USING: cpu.x86.features tools.test math.libm kernel.private math
|
||||
compiler.cfg.instructions compiler.cfg.debugger kernel ;
|
||||
|
||||
[ ] [
|
||||
[ { float } declare fsqrt ]
|
||||
[ ##sqrt? ] contains-insn?
|
||||
sse2?
|
||||
assert=
|
||||
] unit-test
|
||||
|
|
@ -631,6 +631,8 @@ HOOK: %load-reg-param cpu ( vreg rep reg -- )
|
|||
|
||||
HOOK: %store-reg-param cpu ( vreg rep reg -- )
|
||||
|
||||
HOOK: %discard-reg-param cpu ( rep reg -- )
|
||||
|
||||
: %load-return ( dst rep -- )
|
||||
dup return-reg %load-reg-param ;
|
||||
|
||||
|
|
@ -641,24 +643,25 @@ HOOK: %prepare-var-args cpu ( -- )
|
|||
|
||||
HOOK: %cleanup cpu ( n -- )
|
||||
|
||||
:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- )
|
||||
:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
|
||||
stack-inputs [ first3 %store-stack-param ] each
|
||||
reg-inputs [ first3 %store-reg-param ] each
|
||||
%prepare-var-args
|
||||
quot call
|
||||
cleanup %cleanup
|
||||
reg-outputs [ first3 %load-reg-param ] each ; inline
|
||||
reg-outputs [ first3 %load-reg-param ] each
|
||||
dead-outputs [ first2 %discard-reg-param ] each ; inline
|
||||
|
||||
M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
|
||||
M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- )
|
||||
'[ _ _ _ %c-invoke ] emit-alien-insn ;
|
||||
|
||||
M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
|
||||
reg-inputs stack-inputs reg-outputs cleanup stack-size [
|
||||
M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- )
|
||||
reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
|
||||
src ?spill-slot CALL
|
||||
gc-map gc-map-here
|
||||
] emit-alien-insn ;
|
||||
|
||||
M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
|
||||
M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot gc-map -- )
|
||||
'[ _ _ gc-map set call( -- ) ] emit-alien-insn ;
|
||||
|
||||
HOOK: %begin-callback cpu ( -- )
|
||||
|
|
|
|||
|
|
@ -99,5 +99,4 @@ M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
|
|||
[ [ FUCOMI ] compare-op ] (%compare-float-branch) ;
|
||||
|
||||
enable-float-intrinsics
|
||||
enable-float-functions
|
||||
enable-fsqrt
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ HELP: dispose-statements
|
|||
{ $description "Disposes an associative list of statements." } ;
|
||||
|
||||
HELP: statement
|
||||
{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
|
||||
{ $description "A " { $snippet "statement" } " stores the information about a statement, such as the SQL statement text, the in/out parameters, and type information." } ;
|
||||
|
||||
HELP: result-set
|
||||
{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
|
||||
|
|
|
|||
|
|
@ -165,7 +165,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
|||
} case ;
|
||||
|
||||
: sqlite-row ( handle -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
dup sqlite-#columns [ sqlite-column ] with { } map-integers ;
|
||||
|
||||
: sqlite-step-has-more-rows? ( prepared -- ? )
|
||||
{
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue