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

GNUmakefile

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

Nmakefile

@@ -14,18 +14,17 @@ CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
 
 !IF "$(PLATFORM)" == "x86-32"
 LINK_FLAGS = $(LINK_FLAGS) /safeseh
-PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
+PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj
 !ELSEIF "$(PLATFORM)" == "x86-64"
-PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
+PLAF_DLL_OBJS = vm\os-windows-x86.64.obj
 !ENDIF
 
 ML_FLAGS = /nologo /safeseh
 
-EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
+EXE_OBJS = vm/main-windows.obj vm\factor.res
 
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm\os-windows.obj \
-	vm\os-windows-nt.obj \
 	vm\aging_collector.obj \
 	vm\alien.obj \
 	vm\arrays.obj \
@@ -56,7 +55,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm\jit.obj \
 	vm\math.obj \
 	vm\mvm.obj \
-	vm\mvm-windows-nt.obj \
+	vm\mvm-windows.obj \
 	vm\nursery_collector.obj \
 	vm\object_start_map.obj \
 	vm\objects.obj \

basis/alien/c-types/c-types-tests.factor

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

basis/alien/c-types/c-types.factor

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

basis/alien/data/data-docs.factor

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

basis/alien/data/data.factor

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

basis/alien/parser/parser-tests.factor

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

basis/alien/parser/parser.factor

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

basis/alien/prettyprint/prettyprint-tests.factor

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

basis/alien/syntax/syntax.factor

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

basis/bootstrap/image/download/download.factor

@@ -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?
-    [
+    [ [ file-checksum ] [ download-checksum ] bi = not ]
-        [ md5 checksum-file hex-string ]
+    [ drop t ]
-        [ download-checksums at ]
+    if ;
-        bi = not
-    ] [ drop t ] if ;
 
 : verify-image ( image -- )
     need-new-image? [ "Boot image corrupt" throw ] when ;

basis/bootstrap/image/image.factor

@@ -15,12 +15,7 @@ generalizations ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
-    [ dup "winnt" = "winnt" "unix" ? ] dip
+    [ "winnt" = "winnt" "unix" ? ] dip "-" glue ;
-    {
-        { "ppc" [ drop "-ppc" append ] }
-        { "x86.32" [ nip "-x86.32" append ] }
-        { "x86.64" [ nip "-x86.64" append ] }
-    } case ;
 
 : 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 ( -- )

basis/bootstrap/io/io.factor

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

basis/bootstrap/stage2.factor

@@ -72,8 +72,7 @@ SYMBOL: bootstrap-time
     (command-line) parse-command-line
 
     ! Set dll paths
-    os wince? [ "windows.ce" require ] when
+    os windows? [ "windows" require ] when
-    os winnt? [ "windows.nt" require ] when
 
     "staging" get "deploy-vocab" get or [
         "stage2: deployment mode" print

basis/cairo/ffi/ffi.factor

@@ -1,15 +1,13 @@
-! Copyright (c) 2007 Sampo Vuori
+! Copyright (C) 2007 Sampo Vuori.
-! Copyright (c) 2008 Matthew Willis
+! Copyright (C) 2008 Matthew Willis.
-!
+! Copyright (C) 2010 Anton Gorenko.
-
+! See http://factorcode.org/license.txt for BSD license.
-
-! Adapted from cairo.h, version 1.5.14
-! License: http://factorcode.org/license.txt
-
 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
+CALLBACK: void
-: cairo-destroy-func ( quot -- callback )
+cairo_destroy_func_t ( void* data ) ;
-    [ void { pointer: void } cdecl ] dip alien-callback ; inline
 
 ! 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
+ENUM: cairo_content_t
-CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000
+    { CAIRO_CONTENT_COLOR HEX: 1000 }
-CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000
+    { CAIRO_CONTENT_ALPHA HEX: 2000 }
-CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
+    { CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 } ;
 
-TYPEDEF: void* cairo_write_func_t
+CALLBACK: cairo_status_t
-: cairo-write-func ( quot -- callback )
+cairo_write_func_t ( void* closure, uchar* data, uint length ) ;
-    [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
 
-TYPEDEF: void* cairo_read_func_t
+CALLBACK: cairo_status_t
-: cairo-read-func ( quot -- callback )
+cairo_read_func_t ( void* closure, uchar* data, uint length ) ;
-    [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
 
 ! Functions for manipulating state objects
+
 FUNCTION: cairo_t*
 cairo_create ( cairo_surface_t* target ) ;
 
@@ -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 ) ;
 
@@ -359,6 +368,25 @@ STRUCT: cairo_glyph_t
     { 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 }
     { y_bearing double }
@@ -488,6 +516,9 @@ cairo_show_text ( cairo_t* cr, c-string utf8 ) ;
 FUNCTION: void
 cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
 
+FUNCTION: void
+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 ) ;
 
@@ -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
@@ -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_A1 ;
-    CAIRO_FORMAT_RGB16_565 ;
 
 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 ) ;

basis/calendar/calendar-docs.factor

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

basis/channels/remote/remote-docs.factor

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

basis/checksums/internet/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/checksums/internet/internet-tests.factor

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

basis/checksums/internet/internet.factor

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

basis/checksums/internet/summary.txt

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

basis/classes/struct/struct-tests.factor

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

basis/classes/struct/struct.factor

@@ -48,13 +48,18 @@ M: struct >c-ptr
     2 slot { c-ptr } declare ; inline
 
 M: struct equal?
-    {
+    over struct? [
-        [ [ class ] bi@ = ]
+        2dup [ class ] bi@ = [
+            2dup [ >c-ptr ] both?
             [ [ >c-ptr ] [ binary-object ] bi* memory= ]
-    } 2&& ; inline
+            [ [ >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
 

basis/cocoa/application/application.factor

@@ -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
+USING: alien alien.c-types alien.syntax io kernel namespaces
-core-foundation.strings cocoa.messages cocoa cocoa.classes
+core-foundation core-foundation.strings cocoa.messages cocoa
-cocoa.runtime sequences init summary kernel.private
+cocoa.classes cocoa.runtime sequences init summary
-assocs ;
+kernel.private assocs ;
 IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;

basis/cocoa/subclassing/subclassing.factor

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

basis/combinators/random/authors.txt

@@ -0,0 +1 @@
+Jon Harper

basis/combinators/random/random-docs.factor

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

basis/combinators/random/random-tests.factor

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

basis/combinators/random/random.factor

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

basis/command-line/command-line-docs.factor

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

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -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
+! We can't make any assumptions about heap-ac between
-! calls, since they might callback into Factor code
+! 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

basis/compiler/cfg/alias-analysis/alias-analysis.factor

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

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

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

basis/compiler/cfg/builder/alien/alien.factor

@@ -54,8 +54,8 @@ IN: compiler.cfg.builder.alien
         (caller-parameters)
     ] with-param-regs* ;
 
-: prepare-caller-return ( params -- reg-outputs )
+: prepare-caller-return ( params -- reg-outputs dead-outputs )
-    return>> [ { } ] [ base-type load-return ] if-void ;
+    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 ]
+            [ params>> callee-parameters ##callback-inputs ]
-            [ box-parameters ]
+            [ params>> box-parameters ]
-            [
+            [ child>> emit-callback-body ]
-                [
+            [ params>> callee-return ##callback-outputs ]
-                    make-kill-block
+            [ params>> callback-stack-cleanup ]
-                    quot>> ##alien-callback
-                ] emit-trivial-block
-            ]
-            [ callee-return ##callback-outputs ]
-            [ callback-stack-cleanup ]
         } cleave
 
         end-word

basis/compiler/cfg/builder/builder-tests.factor

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

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -53,8 +53,8 @@ M: insn visit-insn drop ;
 : (collect-copies) ( cfg -- )
     [
         phis get clear-assoc
-        instructions>> [ visit-insn ] each
+        [ visit-insn ] each
-    ] each-basic-block ;
+    ] simple-analysis ;
 
 : collect-copies ( cfg -- )
     H{ } clone copies set

basis/compiler/cfg/dce/dce.factor

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

basis/compiler/cfg/debugger/debugger.factor

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

basis/compiler/cfg/def-use/def-use.factor

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

basis/compiler/cfg/dependence/dependence.factor

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

basis/compiler/cfg/finalization/finalization.factor

@@ -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.write-barrier compiler.cfg.save-contexts
-compiler.cfg.build-stack-frame compiler.cfg.linear-scan
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
-compiler.cfg.stacks.uninitialized ;
+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

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

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

basis/compiler/cfg/instructions/instructions.factor

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

basis/compiler/cfg/intrinsics/float/float.factor

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

basis/compiler/cfg/intrinsics/intrinsics.factor

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

basis/compiler/cfg/linear-scan/allocation/allocation.factor

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

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -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,6 +163,7 @@ M: insn assign-registers-in-insn drop ;
     } cleave ;
 
 :: assign-registers-in-block ( bb -- )
+    bb kill-block?>> [
         bb [
             [
                 bb begin-block
@@ -171,7 +177,8 @@ M: insn assign-registers-in-insn drop ;
                 ] each
                 bb compute-live-out
             ] V{ } make
-    ] change-instructions drop ;
+        ] change-instructions drop
+    ] unless ;
 
 : assign-registers ( live-intervals cfg -- )
     [ init-assignment ] dip

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -171,6 +171,7 @@ M: clobber-insn compute-sync-points*
 M: insn compute-sync-points* drop ;
 
 : compute-live-intervals-step ( bb -- )
+    dup kill-block?>> [ drop ] [
         {
             [ block-from from set ]
             [ block-to to set ]
@@ -182,7 +183,8 @@ M: insn compute-sync-points* drop ;
                     bi
                 ] each
             ]
-    } cleave ;
+        } cleave
+    ] if ;
 
 : init-live-intervals ( -- )
     H{ } clone live-intervals set

basis/compiler/cfg/linear-scan/resolve/resolve.factor

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

basis/compiler/cfg/liveness/liveness-tests.factor

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

basis/compiler/cfg/optimizer/optimizer.factor

@@ -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.dce ;
-compiler.cfg.write-barrier ;
 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-dead-code ;
-    eliminate-write-barriers ;

basis/compiler/cfg/representations/coalescing/coalescing.factor

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

basis/compiler/cfg/save-contexts/save-contexts-tests.factor

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

basis/compiler/cfg/save-contexts/save-contexts.factor

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

basis/compiler/cfg/ssa/construction/construction-tests.factor

@@ -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
@@ -111,3 +113,88 @@ V{ } 6 test-bb
     4 get instructions>>
     clean-up-phis
 ] 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

basis/compiler/cfg/ssa/construction/construction.factor

@@ -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
+! Iterated dominance frontiers are computed using the DJ Graph
-! compiler.cfg.ssa.construction.tdmsc.
+! 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",
+! the Construction and Destruction of Static Single Assignment
-! however we construct pruned SSA, not semi-pruned SSA.
+! 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
+! Maps basic blocks to sequences of ##phi instructions
-SYMBOL: inserting-phi-nodes
+SYMBOL: inserting-phis
 
-: insert-phi-node-later ( vreg bb -- )
+: insert-phi-later ( vreg bb -- )
-    2dup live-in key? [
     [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
-        inserting-phi-nodes get push-at
+    inserting-phis get push-at ;
-    ] [ 2drop ] if ;
 
-: compute-phi-nodes-for ( vreg bbs -- )
+: compute-phis-for ( vreg bbs -- )
-    keys merge-set [ insert-phi-node-later ] with each ;
+    keys merge-set [ insert-phi-later ] with each ;
 
-: compute-phi-nodes ( -- )
+: compute-phis ( -- )
-    H{ } clone inserting-phi-nodes set
+    H{ } clone inserting-phis set
-    defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ;
+    defs-multi get defs get '[ _ at compute-phis-for ] assoc-each ;
 
-: insert-phi-nodes-in ( phis bb -- )
+! Maps vregs to ##phi instructions
-    [ append ] change-instructions drop ;
+SYMBOL: phis
 
-: insert-phi-nodes ( -- )
+! Worklist of used vregs, to calculate used phis
-    inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
+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
+: rename-phis ( bb -- )
-    ssa-rename-insn-defs ;
+    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-phis ]
         [ rename-insns ]
         [ rename-successors-phis ]
         [
             pushed get
             [ dom-children [ rename-in-block ] each ] dip
             pushed set
-    ] tri
+        ]
+    } 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 ]
+        [ compute-defs compute-phis ]
-        [ rename ]
+        [ rename compute-live-phis insert-phis ]
         [ ]
     } cleave ;

basis/compiler/cfg/ssa/destruction/destruction.factor

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

basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor

@@ -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 ]
+    [ swap record-insn ] each-index
-    [ [ local-def-indices get ] dip def-indices get set-at ]
+    local-def-indices get basic-block get def-indices get set-at
-    [ [ local-kill-indices get ] dip kill-indices get set-at ]
+    local-kill-indices get basic-block get kill-indices get set-at ;
-    tri ;
 
 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 ;

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

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

basis/compiler/cfg/write-barrier/write-barrier.factor

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

basis/compiler/codegen/codegen.factor

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

basis/compiler/tests/alien.factor

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

basis/compiler/tests/linkage-errors.factor

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

basis/compiler/tests/optimizer.factor

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

basis/compiler/tests/redefine25.factor

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

basis/compiler/tests/x87-regression.factor

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

basis/compiler/tree/builder/builder.factor

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

basis/compiler/tree/checker/checker.factor

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

basis/compiler/tree/cleanup/cleanup-tests.factor

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

basis/compiler/tree/cleanup/cleanup.factor

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

basis/compiler/tree/combinators/combinators.factor

@@ -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
+USING: assocs combinators combinators.short-circuit fry kernel
-arrays stack-checker.inlining namespaces compiler.tree
+locals accessors sequences compiler.utilities arrays
-math.order ;
+stack-checker.inlining namespaces compiler.tree math.order ;
 IN: compiler.tree.combinators
 
-: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
+:: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
-    dup dup '[
+    nodes [
-        _ [
+        quot
-            dup #branch? [
+        [
-                children>> [ _ each-node ] each
+            {
-            ] [
+                { [ dup #branch? ] [ children>> [ quot each-node ] each ] }
-                dup #recursive? [
+                { [ dup #recursive? ] [ child>> quot each-node ] }
-                    child>> _ each-node
+                { [ dup #alien-callback? ] [ child>> quot each-node ] }
-                ] [ drop ] if
+                [ drop ]
-            ] if
+            } cond
         ] bi
     ] each ; inline recursive
 
-: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
+:: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
-    dup dup '[
+    nodes [
-        @
+        quot call
-        dup #branch? [
+        {
-            [ [ _ map-nodes ] map ] change-children
+            { [ dup #branch? ] [ [ [ quot map-nodes ] map ] change-children ] }
-        ] [
+            { [ dup #recursive? ] [ [ quot map-nodes ] change-child ] }
-            dup #recursive? [
+            { [ dup #alien-callback? ] [ [ quot map-nodes ] change-child ] }
-                [ _ map-nodes ] change-child
+            [ ]
-            ] when
+        } cond
-        ] if
     ] map-flat ; inline recursive
 
-: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
+:: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
-    dup dup '[
+    nodes [
-        _ keep swap [ drop t ] [
+        {
-            dup #branch? [
+            quot
-                children>> [ _ contains-node? ] any?
+            [
-            ] [
+                {
-                dup #recursive? [
+                    { [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] }
-                    child>> _ contains-node?
+                    { [ dup #recursive? ] [ child>> quot contains-node? ] }
-                ] [ drop f ] if
+                    { [ dup #alien-callback? ] [ child>> quot contains-node? ] }
-            ] if
+                    [ drop f ]
-        ] if
+                } cond
+            ]
+        } 1||
     ] any? ; inline recursive
 
 : select-children ( seq flags -- seq' )

basis/compiler/tree/dead-code/simple/simple.factor

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

basis/compiler/tree/debugger/debugger.factor

@@ -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 swap
-    dup word? [ 1array ] when
+    [ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make
-    '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
+    intersect empty? ;
-    contains-node? not ;

basis/compiler/tree/escape-analysis/nodes/nodes.factor

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

basis/compiler/tree/escape-analysis/simple/simple.factor

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

basis/compiler/tree/normalization/normalization.factor

@@ -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 ;
+        rename-node-values
+    ] with-scope ;
+
+M: #alien-callback normalize*
+    [ normalize ] change-child ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -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
+! Unlike the other words in math.libm, fsqrt is not inline
-flog fpow fsqrt facosh fasinh fatanh } [
+! since it has an intrinsic, so we need to give it outputs here.
-    { float } "default-output-classes" set-word-prop
+\ fsqrt { float } "default-output-classes" set-word-prop
-] each
 
 ! Find a less repetitive way of doing this
 \ float-min { float float } "input-classes" set-word-prop

basis/compiler/tree/propagation/nodes/nodes.factor

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

basis/compiler/tree/propagation/propagation-tests.factor

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

basis/compiler/tree/propagation/simple/simple.factor

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

basis/compiler/tree/recursive/recursive-tests.factor

@@ -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 -- ? )
+    swap [
         [
-        {
+            dup {
-            [ drop #recursive? ]
+                [ #recursive? ]
-            [ drop label>> loop?>> ]
+                [ label>> loop?>> ]
-            [ swap label>> word>> eq? ]
+            } 1&& [ label>> word>> , ] [ drop ] if
-        } 2&&
+        ] each-node
-    ] curry contains-node? ;
+    ] V{ } make member? ;
 
 : label-is-not-loop? ( nodes word -- ? )
+    swap [
         [
-        {
+            dup {
-            [ drop #recursive? ]
+                [ #recursive? ]
-            [ drop label>> loop?>> not ]
+                [ label>> loop?>> not ]
-            [ swap label>> word>> eq? ]
+            } 1&& [ label>> word>> , ] [ drop ] if
-        } 2&&
+        ] each-node
-    ] curry contains-node? ;
+    ] V{ } make member? ;
 
 : loop-test-1 ( a -- )
     dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive

basis/compiler/tree/recursive/recursive.factor

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

basis/compiler/tree/tree.factor

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

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

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

basis/concurrency/combinators/combinators-docs.factor

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

basis/concurrency/distributed/distributed-docs.factor

@@ -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."
+"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." $nl
-{ $subsections start-node }
 "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"

basis/concurrency/distributed/distributed-tests.factor

@@ -1,20 +1,28 @@
 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
@@ -25,9 +33,7 @@ IN: concurrency.distributed.tests
 
     [ 8 ] [
         5 self 2array
-    test-node "thread-a" <remote-thread> send
+        test-node-client "thread-a" <remote-thread> send
-
+        100 seconds receive-timeout
-    receive
     ] unit-test
-
+] with-threaded-server
-[ ] [ test-node stop-node ] unit-test

basis/concurrency/distributed/distributed.factor

@@ -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>
+    id>> [ insecure-addr ] dip <remote-thread> (serialize) ;
-    (serialize) ;
 
 : stop-node ( node -- )
     f swap send-remote-message ;

basis/concurrency/semaphores/semaphores-docs.factor

@@ -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"
+ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"
-"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
 "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

basis/cpu/architecture/architecture.factor

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

basis/cpu/x86/32/32.factor

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

basis/cpu/x86/32/bootstrap.factor

@@ -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
+    ! Reset return value since its bogus right now, to avoid
-
+    ! confusing the GC
-    ! Save ds, rs registers
+    ESP -4 [+] 0 MOV
-    jit-load-vm
-    jit-save-context
 
     ! 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
+    jit-save-quot-and-param
-    EDX ds-reg MOV
-    ds-reg 8 SUB
 
     ! Make the new context active
+    jit-load-vm
+    jit-save-context
     EAX jit-switch-context
 
-    ! Push parameter
+    jit-push-param
-    EAX EDX -4 [+] MOV
-    ds-reg 4 ADD
-    ds-reg [] EAX MOV
 
     ! 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-and-delete
-    jit-start-context
 ] \ (start-context-and-delete) define-sub-primitive

basis/cpu/x86/64/64.factor

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

basis/cpu/x86/64/bootstrap.factor

@@ -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
+    ! Reset return value since its bogus right now, to avoid
-
+    ! confusing the GC
-    ! Save ds, rs registers
+    RSP -8 [+] 0 MOV
-    jit-save-context
 
     ! 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-and-delete
-    jit-start-context
 ] \ (start-context-and-delete) define-sub-primitive

basis/cpu/x86/sse/sse.factor

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

basis/cpu/x86/x86-tests.factor

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

basis/cpu/x86/x86.factor

@@ -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 -- )
+M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- )
-    reg-inputs stack-inputs reg-outputs cleanup stack-size [
+    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 ( -- )

basis/cpu/x86/x87/x87.factor

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

basis/db/db-docs.factor

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

basis/db/sqlite/lib/lib.factor

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