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

Conflicts:
	basis/cairo/ffi/ffi.factor
	basis/pango/cairo/cairo.factor
	basis/pango/layouts/layouts.factor
db4
Anton Gorenko 2010-09-26 23:24:30 +06:00
commit d5a7f99bea
514 changed files with 7283 additions and 4661 deletions

View File

@ -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

View File

@ -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:

View File

@ -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

View File

@ -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 -- )
{

View File

@ -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:"

View File

@ -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 ;

View File

@ -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...

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

12
basis/bootstrap/image/image.factor Normal file → Executable file
View File

@ -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 ( -- )

View File

@ -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

View File

@ -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

View File

@ -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 ) ;

View File

@ -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:"

View File

@ -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 "

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
Internet (RFC 1071) checksum algorithm

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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! ;

View File

@ -0,0 +1 @@
Jon Harper

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -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." } }
} ;

View File

@ -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

View File

@ -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 ]

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 }
}
] [

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ] }

View File

@ -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 )

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 }

View File

@ -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 ;

View File

@ -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>

View File

@ -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 }

View File

@ -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 -- ? )

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 >=

View File

@ -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

View File

@ -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

View File

@ -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 )
[

View File

@ -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 ;

View File

@ -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

View File

@ -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* ;

View File

@ -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' )

View File

@ -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 ;

View File

@ -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? ;

View File

@ -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* ]

View File

@ -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) ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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) ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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"

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

73
basis/cpu/x86/32/bootstrap.factor Normal file → Executable file
View File

@ -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

View File

@ -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 ;

56
basis/cpu/x86/64/bootstrap.factor Normal file → Executable file
View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ( -- )

View File

@ -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

View File

@ -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."

View File

@ -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