From bbc3c01a8b6586289deedb4cca5514c3b5cd2489 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 29 Jul 2008 19:53:00 -0700 Subject: [PATCH 01/26] clean up game-input.backend init so that loading a backend does not ruin the game-input-backend var and so that client code does not need to explicitly load game-input.backend itself --- extra/game-input/backend/backend.factor | 21 ++++++++++++++----- extra/game-input/backend/dinput/dinput.factor | 9 ++++++-- extra/game-input/backend/iokit/iokit.factor | 6 ++++-- extra/game-input/game-input.factor | 14 ++++++++++--- extra/joystick-demo/joystick-demo.factor | 2 +- extra/key-caps/key-caps.factor | 2 +- 6 files changed, 40 insertions(+), 14 deletions(-) diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor index 451bbf1c34..a31b9d6649 100644 --- a/extra/game-input/backend/backend.factor +++ b/extra/game-input/backend/backend.factor @@ -1,8 +1,19 @@ -USING: kernel system combinators parser ; +USING: multiline system parser combinators ; IN: game-input.backend -<< { - { [ os macosx? ] [ "game-input.backend.iokit" use+ ] } - { [ os windows? ] [ "game-input.backend.dinput" use+ ] } +STRING: set-backend-for-macosx +USING: namespaces game-input.backend.iokit game-input ; +iokit-game-input-backend game-input-backend set-global +; + +STRING: set-backend-for-windows +USING: namespaces game-input.backend.dinput game-input ; +dinput-game-input-backend game-input-backend set-global +; + +{ + { [ os macosx? ] [ set-backend-for-macosx eval ] } + { [ os windows? ] [ set-backend-for-windows eval ] } { [ t ] [ ] } -} cond >> +} cond + diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor index 69b2d41962..73c9f511a1 100755 --- a/extra/game-input/backend/dinput/dinput.factor +++ b/extra/game-input/backend/dinput/dinput.factor @@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input) close-device-change-window delete-dinput ; +M: dinput-game-input-backend (reset-game-input) + { + +dinput+ +keyboard-device+ +keyboard-state+ + +controller-devices+ +controller-guids+ + +device-change-window+ +device-change-handle+ + } [ f swap set-global ] each ; + M: dinput-game-input-backend get-controllers +controller-devices+ get [ drop controller boa ] { } assoc>map ; @@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; - -dinput-game-input-backend game-input-backend set-global diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor index 1871569227..dcdfa6d192 100755 --- a/extra/game-input/backend/iokit/iokit.factor +++ b/extra/game-input/backend/iokit/iokit.factor @@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input) ] } cleave ; +M: iokit-game-input-backend (reset-game-input) + { +hid-manager+ +keyboard-state+ +controller-states+ } + [ f swap set-global ] each ; + M: iokit-game-input-backend (close-game-input) +hid-manager+ get-global [ +hid-manager+ global [ @@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state ) M: iokit-game-input-backend calibrate-controller ( controller -- ) drop ; - -iokit-game-input-backend game-input-backend set-global diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 4d25b06ead..208c8476fc 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -1,26 +1,34 @@ USING: arrays accessors continuations kernel symbols -combinators.lib sequences namespaces init ; +combinators.lib sequences namespaces init vocabs ; IN: game-input SYMBOLS: game-input-backend game-input-opened ; HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- ) +HOOK: (reset-game-input) game-input-backend ( -- ) : game-input-opened? ( -- ? ) game-input-opened get ; - : open-game-input ( -- ) + load-game-input-backend game-input-opened? [ (open-game-input) game-input-opened on diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index c39a4b0b1c..b5289dbcbf 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -1,6 +1,6 @@ USING: ui ui.gadgets sequences kernel arrays math colors ui.render math.vectors accessors fry ui.gadgets.packs game-input -game-input.backend ui.gadgets.labels ui.gadgets.borders alarms +ui.gadgets.labels ui.gadgets.borders alarms calendar locals combinators.lib strings ui.gadgets.buttons combinators math.parser assocs threads ; IN: joystick-demo diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 4161b94908..cb946a1062 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -1,4 +1,4 @@ -USING: game-input game-input.backend game-input.scancodes +USING: game-input game-input.scancodes kernel ui.gadgets ui.gadgets.buttons sequences accessors words arrays assocs math calendar fry alarms ui ui.gadgets.borders ui.gestures ; From b42cb5434e2b7176746a2349d0b94c1aa31b5c0c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 29 Jul 2008 21:02:37 -0700 Subject: [PATCH 02/26] Rebuild windows.com.wrapper objects on image init --- extra/windows/com/wrapper/wrapper.factor | 53 +++++++++++++++++------- 1 file changed, 39 insertions(+), 14 deletions(-) diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 40c61dfbe7..782ebae516 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -1,11 +1,11 @@ -USING: alien alien.c-types windows.com.syntax +USING: alien alien.c-types windows.com.syntax init windows.com.syntax.private windows.com continuations kernel namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units -destructors fry math.parser generalizations ; +destructors fry math.parser generalizations sets ; IN: windows.com.wrapper -TUPLE: com-wrapper vtbls disposed ; +TUPLE: com-wrapper callbacks vtbls disposed ; malloc ( byte-array -- alien ) [ byte-length malloc ] [ over byte-array>memory ] bi ; : (callback-word) ( function-name interface-name counter -- word ) @@ -99,7 +103,7 @@ unless [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ] dip compose ; -: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl ) +: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) (thunk) (thunked-quots) swap [ find-com-interface-definition family-tree-functions ] keep (next-vtbl-counter) '[ @@ -114,12 +118,12 @@ unless first2 (finish-thunk) ] bi* "stdcall" swap compile-alien-callback - ] 2map >c-void*-array - (byte-array-to-malloced-buffer) ; + ] 2map ; -: (make-vtbls) ( implementations -- vtbls ) +: (make-callbacks) ( implementations -- sequence ) dup [ first ] map (make-iunknown-methods) - [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ; + [ >r >r first2 r> r> swap (make-interface-callbacks) ] + curry map-index ; : (malloc-wrapped-object) ( wrapper -- wrapped-object ) vtbls>> length "void*" heap-size * @@ -127,13 +131,34 @@ unless over 1 0 rot set-ulong-nth ; +: (callbacks>vtbl) ( callbacks -- vtbl ) + [ execute ] map >c-void*-array byte-array>malloc ; +: (callbacks>vtbls) ( callbacks -- vtbls ) + [ (callbacks>vtbl) ] map ; + +: (allocate-wrapper) ( wrapper -- ) + dup callbacks>> (callbacks>vtbls) >>vtbls + f >>disposed drop ; + +: (init-hook) ( -- ) + +live-wrappers+ get-global [ (allocate-wrapper) ] each + H{ } +wrapped-objects+ set-global ; + +[ (init-hook) ] "windows.com.wrapper" add-init-hook + PRIVATE> +: allocate-wrapper ( wrapper -- ) + [ (allocate-wrapper) ] + [ +live-wrappers+ get adjoin ] bi ; + : ( implementations -- wrapper ) - (make-vtbls) f com-wrapper boa ; + (make-callbacks) f f com-wrapper boa + dup allocate-wrapper ; M: com-wrapper dispose* - vtbls>> [ free ] each ; + [ [ free ] each f ] change-vtbls + +live-wrappers+ get-global delete ; : com-wrap ( object wrapper -- wrapped-object ) [ vtbls>> ] [ (malloc-wrapped-object) ] bi From 393d8ba0a73dd2314c08f1b4ddd599eae77506cb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 29 Jul 2008 21:23:47 -0700 Subject: [PATCH 03/26] typo --- basis/windows/com/com-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index cd67fd19d2..289581a929 100755 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -45,7 +45,7 @@ C: test-implementation } } { "IUnrelated" { [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ spin x>> * + ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ From 101065e74f8e7f6c9e29b193dee288cf60fad848 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 31 Jul 2008 21:37:39 -0700 Subject: [PATCH 04/26] Executable images --- core/bootstrap/primitives.factor | 1 + core/memory/memory-docs.factor | 5 +++ core/memory/memory.factor | 4 ++ vm/factor.c | 13 ++---- vm/factor.h | 3 -- vm/image.c | 75 ++++++++++++++++++++++++++------ vm/image.h | 9 +++- vm/primitives.c | 1 + 8 files changed, 85 insertions(+), 26 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5d7d5e0d2c..24c1da41de 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -532,6 +532,7 @@ tuple { "dll-valid?" "alien" } { "unimplemented" "kernel.private" } { "gc-reset" "memory" } + { "(save-image*)" "memory" } } [ >r first2 r> make-primitive ] each-index diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 1213245863..b8aabd10cf 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -5,6 +5,7 @@ ARTICLE: "images" "Images" "The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:" { $subsection save } { $subsection save-image } +{ $subsection save-image* } { $subsection save-image-and-exit } "To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "." { $see-also "tools.memory" } ; @@ -56,6 +57,10 @@ HELP: save-image ( path -- ) { $values { "path" "a pathname string" } } { $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists." } ; +HELP: save-image* ( path arguments -- ) +{ $values { "path" "a pathname string" } { "arguments" "a commandline string" } } +{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. The image is formatted so that Unix systems can execute the image directly using the shellscript #! syntax. The saved image will start the current VM with the given commandline arguments when executed." } ; + HELP: save-image-and-exit ( path -- ) { $values { "path" "a pathname string" } } { $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. This word compacts the code heap and immediately exits Factor, since the Factor VM cannot continue executing after compiled code blocks have been moved around." } ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index cb5c5bf7e4..2a702097f4 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -13,3 +13,7 @@ IN: memory pusher [ each-object ] dip >array ; inline : save ( -- ) image save-image ; + +: save-image* ( path args -- ) + "#!" vm append swap "-shebang\n" 3array " " join + (save-image*) ; inline diff --git a/vm/factor.c b/vm/factor.c index e81152bd99..8bdf67ec18 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -140,13 +140,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded CELL i; - posix_argc = argc; - posix_argv = safe_malloc(argc * sizeof(F_CHAR*)); - posix_argv[0] = safe_strdup(argv[0]); - for(i = 1; i < argc; i++) { - posix_argv[i] = safe_strdup(argv[i]); if(factor_arg(argv[i],STR_FORMAT("-datastack=%d"),&p.ds_size)); else if(factor_arg(argv[i],STR_FORMAT("-retainstack=%d"),&p.rs_size)); else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count)); @@ -160,6 +155,10 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded p.fep = true; else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0) p.image = argv[i] + 3; + else if(STRCMP(argv[i],STR_FORMAT("-shebang")) == 0 && i < argc) + { + p.image = argv[--argc]; + } else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0) p.console = true; else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0) @@ -194,10 +193,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded c_to_factor_toplevel(userenv[BOOT_ENV]); unnest_stacks(); - - for(i = 0; i < argc; i++) - free(posix_argv[i]); - free(posix_argv); } char *factor_eval_string(char *string) diff --git a/vm/factor.h b/vm/factor.h index a0632c3138..3117e054d3 100644 --- a/vm/factor.h +++ b/vm/factor.h @@ -1,6 +1,3 @@ -int posix_argc; -F_CHAR **posix_argv; - DLLEXPORT void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded); DLLEXPORT char *factor_eval_string(char *string); DLLEXPORT void factor_eval_free(char *result); diff --git a/vm/image.c b/vm/image.c index a0fa48d504..d6436573b4 100755 --- a/vm/image.c +++ b/vm/image.c @@ -80,6 +80,12 @@ void load_image(F_PARAMETERS *p) F_HEADER h; fread(&h,sizeof(F_HEADER),1,file); + if(h.magic_bytes[0] == '#' && h.magic_bytes[1] == '!') + { + fseek(file,IMAGE_SHEBANG_BLOCK_SIZE,SEEK_SET); + fread(&h,sizeof(F_HEADER),1,file); + } + if(h.magic != IMAGE_MAGIC) fatal_error("Bad image: magic number check failed",h.magic); @@ -101,21 +107,10 @@ void load_image(F_PARAMETERS *p) } /* Save the current image to disk */ -bool save_image(const F_CHAR *filename) +static bool save_image_to_file(FILE *file) { - FILE* file; - F_HEADER h; - - FPRINTF(stderr,"*** Saving %s...\n",filename); - - file = OPEN_WRITE(filename); - if(file == NULL) - { - fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); - return false; - } - F_ZONE *tenured = &data_heap->generations[TENURED]; + F_HEADER h; h.magic = IMAGE_MAGIC; h.version = IMAGE_VERSION; @@ -161,6 +156,49 @@ bool save_image(const F_CHAR *filename) return true; } +bool save_image(const F_CHAR *filename) +{ + FILE* file; + + FPRINTF(stderr,"*** Saving %s...\n",filename); + + file = OPEN_WRITE(filename); + if(file == NULL) + { + fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); + return false; + } + + + return save_image_to_file(file); +} + +bool save_image_shebang(const F_CHAR *filename, const char *shebang) +{ + FILE* file; + + FPRINTF(stderr,"*** Saving %s...\n",filename); + + file = OPEN_WRITE(filename); + if(file == NULL) + { + fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); + return false; + } + + unsigned char shebang_block[IMAGE_SHEBANG_BLOCK_SIZE]; + strncpy(shebang_block,shebang,IMAGE_SHEBANG_BLOCK_SIZE-1); + shebang_block[IMAGE_SHEBANG_BLOCK_SIZE-1] = 0; + + if(fwrite(shebang_block,IMAGE_SHEBANG_BLOCK_SIZE,1,file) != 1) + { + fprintf(stderr,"Save #! block failed: %s\n",strerror(errno)); + return false; + } + + return save_image_to_file(file); +} + DEFINE_PRIMITIVE(save_image) { /* do a full GC to push everything into tenured space */ @@ -169,6 +207,17 @@ DEFINE_PRIMITIVE(save_image) save_image(unbox_native_string()); } +DEFINE_PRIMITIVE(save_image_shebang) +{ + /* do a full GC to push everything into tenured space */ + gc(); + + char *shebang = unbox_char_string(); + F_CHAR *path = unbox_native_string(); + + save_image_shebang(path, shebang); +} + DEFINE_PRIMITIVE(save_image_and_exit) { F_CHAR *path = unbox_native_string(); diff --git a/vm/image.h b/vm/image.h index 9e582fc6c6..8393f73a6c 100755 --- a/vm/image.h +++ b/vm/image.h @@ -1,8 +1,13 @@ #define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_VERSION 4 +#define IMAGE_SHEBANG_BLOCK_SIZE 512 + typedef struct { - CELL magic; + union { + CELL magic; + char magic_bytes[sizeof(CELL)]; + }; CELL version; /* all pointers in the image file are relocated from relocation_base to here when the image is loaded */ @@ -39,8 +44,10 @@ typedef struct { void load_image(F_PARAMETERS *p); void init_objects(F_HEADER *h); bool save_image(const F_CHAR *file); +bool save_image_shebang(const F_CHAR *file, const char *shebang); DECLARE_PRIMITIVE(save_image); +DECLARE_PRIMITIVE(save_image_shebang); DECLARE_PRIMITIVE(save_image_and_exit); /* relocation base of currently loaded image's data heap */ diff --git a/vm/primitives.c b/vm/primitives.c index b5d9403342..91f6eea0e4 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -149,4 +149,5 @@ void *primitives[] = { primitive_dll_validp, primitive_unimplemented, primitive_gc_reset, + primitive_save_image_shebang, }; From c6d1bd6b256b6547dbdc2ad467e351d5abc588db Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 Aug 2008 06:40:30 -0700 Subject: [PATCH 05/26] Revert "Executable images" This reverts commit 101065e74f8e7f6c9e29b193dee288cf60fad848. --- core/bootstrap/primitives.factor | 1 - core/memory/memory-docs.factor | 5 --- core/memory/memory.factor | 4 -- vm/factor.c | 13 ++++-- vm/factor.h | 3 ++ vm/image.c | 75 ++++++-------------------------- vm/image.h | 9 +--- vm/primitives.c | 1 - 8 files changed, 26 insertions(+), 85 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 24c1da41de..5d7d5e0d2c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -532,7 +532,6 @@ tuple { "dll-valid?" "alien" } { "unimplemented" "kernel.private" } { "gc-reset" "memory" } - { "(save-image*)" "memory" } } [ >r first2 r> make-primitive ] each-index diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index b8aabd10cf..1213245863 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -5,7 +5,6 @@ ARTICLE: "images" "Images" "The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:" { $subsection save } { $subsection save-image } -{ $subsection save-image* } { $subsection save-image-and-exit } "To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "." { $see-also "tools.memory" } ; @@ -57,10 +56,6 @@ HELP: save-image ( path -- ) { $values { "path" "a pathname string" } } { $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists." } ; -HELP: save-image* ( path arguments -- ) -{ $values { "path" "a pathname string" } { "arguments" "a commandline string" } } -{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. The image is formatted so that Unix systems can execute the image directly using the shellscript #! syntax. The saved image will start the current VM with the given commandline arguments when executed." } ; - HELP: save-image-and-exit ( path -- ) { $values { "path" "a pathname string" } } { $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. This word compacts the code heap and immediately exits Factor, since the Factor VM cannot continue executing after compiled code blocks have been moved around." } ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 2a702097f4..cb5c5bf7e4 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -13,7 +13,3 @@ IN: memory pusher [ each-object ] dip >array ; inline : save ( -- ) image save-image ; - -: save-image* ( path args -- ) - "#!" vm append swap "-shebang\n" 3array " " join - (save-image*) ; inline diff --git a/vm/factor.c b/vm/factor.c index 8bdf67ec18..e81152bd99 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -140,8 +140,13 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded CELL i; + posix_argc = argc; + posix_argv = safe_malloc(argc * sizeof(F_CHAR*)); + posix_argv[0] = safe_strdup(argv[0]); + for(i = 1; i < argc; i++) { + posix_argv[i] = safe_strdup(argv[i]); if(factor_arg(argv[i],STR_FORMAT("-datastack=%d"),&p.ds_size)); else if(factor_arg(argv[i],STR_FORMAT("-retainstack=%d"),&p.rs_size)); else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count)); @@ -155,10 +160,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded p.fep = true; else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0) p.image = argv[i] + 3; - else if(STRCMP(argv[i],STR_FORMAT("-shebang")) == 0 && i < argc) - { - p.image = argv[--argc]; - } else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0) p.console = true; else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0) @@ -193,6 +194,10 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded c_to_factor_toplevel(userenv[BOOT_ENV]); unnest_stacks(); + + for(i = 0; i < argc; i++) + free(posix_argv[i]); + free(posix_argv); } char *factor_eval_string(char *string) diff --git a/vm/factor.h b/vm/factor.h index 3117e054d3..a0632c3138 100644 --- a/vm/factor.h +++ b/vm/factor.h @@ -1,3 +1,6 @@ +int posix_argc; +F_CHAR **posix_argv; + DLLEXPORT void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded); DLLEXPORT char *factor_eval_string(char *string); DLLEXPORT void factor_eval_free(char *result); diff --git a/vm/image.c b/vm/image.c index d6436573b4..a0fa48d504 100755 --- a/vm/image.c +++ b/vm/image.c @@ -80,12 +80,6 @@ void load_image(F_PARAMETERS *p) F_HEADER h; fread(&h,sizeof(F_HEADER),1,file); - if(h.magic_bytes[0] == '#' && h.magic_bytes[1] == '!') - { - fseek(file,IMAGE_SHEBANG_BLOCK_SIZE,SEEK_SET); - fread(&h,sizeof(F_HEADER),1,file); - } - if(h.magic != IMAGE_MAGIC) fatal_error("Bad image: magic number check failed",h.magic); @@ -107,11 +101,22 @@ void load_image(F_PARAMETERS *p) } /* Save the current image to disk */ -static bool save_image_to_file(FILE *file) +bool save_image(const F_CHAR *filename) { - F_ZONE *tenured = &data_heap->generations[TENURED]; + FILE* file; F_HEADER h; + FPRINTF(stderr,"*** Saving %s...\n",filename); + + file = OPEN_WRITE(filename); + if(file == NULL) + { + fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); + return false; + } + + F_ZONE *tenured = &data_heap->generations[TENURED]; + h.magic = IMAGE_MAGIC; h.version = IMAGE_VERSION; h.data_relocation_base = tenured->start; @@ -156,49 +161,6 @@ static bool save_image_to_file(FILE *file) return true; } -bool save_image(const F_CHAR *filename) -{ - FILE* file; - - FPRINTF(stderr,"*** Saving %s...\n",filename); - - file = OPEN_WRITE(filename); - if(file == NULL) - { - fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); - return false; - } - - - return save_image_to_file(file); -} - -bool save_image_shebang(const F_CHAR *filename, const char *shebang) -{ - FILE* file; - - FPRINTF(stderr,"*** Saving %s...\n",filename); - - file = OPEN_WRITE(filename); - if(file == NULL) - { - fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); - return false; - } - - unsigned char shebang_block[IMAGE_SHEBANG_BLOCK_SIZE]; - strncpy(shebang_block,shebang,IMAGE_SHEBANG_BLOCK_SIZE-1); - shebang_block[IMAGE_SHEBANG_BLOCK_SIZE-1] = 0; - - if(fwrite(shebang_block,IMAGE_SHEBANG_BLOCK_SIZE,1,file) != 1) - { - fprintf(stderr,"Save #! block failed: %s\n",strerror(errno)); - return false; - } - - return save_image_to_file(file); -} - DEFINE_PRIMITIVE(save_image) { /* do a full GC to push everything into tenured space */ @@ -207,17 +169,6 @@ DEFINE_PRIMITIVE(save_image) save_image(unbox_native_string()); } -DEFINE_PRIMITIVE(save_image_shebang) -{ - /* do a full GC to push everything into tenured space */ - gc(); - - char *shebang = unbox_char_string(); - F_CHAR *path = unbox_native_string(); - - save_image_shebang(path, shebang); -} - DEFINE_PRIMITIVE(save_image_and_exit) { F_CHAR *path = unbox_native_string(); diff --git a/vm/image.h b/vm/image.h index 8393f73a6c..9e582fc6c6 100755 --- a/vm/image.h +++ b/vm/image.h @@ -1,13 +1,8 @@ #define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_VERSION 4 -#define IMAGE_SHEBANG_BLOCK_SIZE 512 - typedef struct { - union { - CELL magic; - char magic_bytes[sizeof(CELL)]; - }; + CELL magic; CELL version; /* all pointers in the image file are relocated from relocation_base to here when the image is loaded */ @@ -44,10 +39,8 @@ typedef struct { void load_image(F_PARAMETERS *p); void init_objects(F_HEADER *h); bool save_image(const F_CHAR *file); -bool save_image_shebang(const F_CHAR *file, const char *shebang); DECLARE_PRIMITIVE(save_image); -DECLARE_PRIMITIVE(save_image_shebang); DECLARE_PRIMITIVE(save_image_and_exit); /* relocation base of currently loaded image's data heap */ diff --git a/vm/primitives.c b/vm/primitives.c index 91f6eea0e4..b5d9403342 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -149,5 +149,4 @@ void *primitives[] = { primitive_dll_validp, primitive_unimplemented, primitive_gc_reset, - primitive_save_image_shebang, }; From 9a84cfe6568f41d03d70d4dbe3eff1f78c1787eb Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 1 Aug 2008 19:59:18 -0300 Subject: [PATCH 06/26] irc.client: Fix user quit notification --- extra/irc/client/client-tests.factor | 17 ++++++++++++++++- extra/irc/client/client.factor | 27 +++++++-------------------- 2 files changed, 23 insertions(+), 21 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index e021ff4ff4..1b338df442 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -160,7 +160,7 @@ IN: irc.client.tests } cleave ] unit-test -! Namelist notification +! Namelist change notification { T{ participant-changed f f f } } [ { ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client @@ -172,4 +172,19 @@ IN: irc.client.tests [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] [ terminate-irc ] } cleave + ] unit-test + +{ T{ participant-changed f "somedude" +part+ } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 813de0f57c..99922b1fb5 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -88,10 +88,11 @@ SYMBOL: current-irc-client : irc-stream> ( -- stream ) irc> stream>> ; : irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; +: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) - [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline + [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -147,24 +148,6 @@ DEFER: me? "JOIN " irc-write [ [ " :" ] dip 3append ] when* irc-print ; -: /PART ( channel text -- ) - [ "PART " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: /KICK ( channel who -- ) - [ "KICK " irc-write irc-write ] dip - " " irc-write irc-print ; - -: /PRIVMSG ( nick line -- ) - [ "PRIVMSG " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: /ACTION ( nick line -- ) - [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ; - -: /QUIT ( text -- ) - "QUIT :" irc-write irc-print ; - : /PONG ( text -- ) "PONG " irc-write irc-print ; @@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- ) M: quit handle-incoming-irc ( quit -- ) [ dup prefix>> parse-name listeners-with-participant [ to-listener ] with each ] - [ prefix>> parse-name remove-participant-from-all ] [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] tri ; +! FIXME: implement this +! M: mode handle-incoming-irc ( mode -- ) call-next-method ; +! M: nick handle-incoming-irc ( nick -- ) call-next-method ; + : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; From 710bc04b6ff9040887f0c5b7ec757da0e29d9cf5 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sat, 2 Aug 2008 15:54:02 -0400 Subject: [PATCH 07/26] irc.ui: Fixed color bugs --- extra/irc/ui/ui.factor | 36 +++++++++++++++--------------------- 1 file changed, 15 insertions(+), 21 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 662fca6d79..d899b75d8d 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel threads combinators concurrency.mailboxes - sequences strings hashtables splitting fry assocs hashtables + sequences strings hashtables splitting fry assocs hashtables colors ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels @@ -24,14 +24,8 @@ TUPLE: irc-tab < frame listener client userlist ; : write-color ( str color -- ) foreground associate format ; -: red { 0.5 0 0 1 } ; -: green { 0 0.5 0 1 } ; -: blue { 0 0 1 1 } ; -: black { 0 0 0 1 } ; - -: colors H{ { +operator+ { 0 0.5 0 1 } } - { +voice+ { 0 0 1 1 } } - { +normal+ { 0 0 0 1 } } } ; +: dark-red T{ rgba f 0.5 0.0 0.0 1 } ; +: dark-green T{ rgba f 0.0 0.5 0.0 1 } ; : dot-or-parens ( string -- string ) dup empty? [ drop "." ] @@ -65,21 +59,21 @@ M: own-message write-irc message>> write ; M: join write-irc - "* " green write-color + "* " dark-green write-color prefix>> parse-name write - " has entered the channel." green write-color ; + " has entered the channel." dark-green write-color ; M: part write-irc - "* " red write-color + "* " dark-red write-color [ prefix>> parse-name write ] keep - " has left the channel" red write-color - trailing>> dot-or-parens red write-color ; + " has left the channel" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; M: quit write-irc - "* " red write-color + "* " dark-red write-color [ prefix>> parse-name write ] keep - " has left IRC" red write-color - trailing>> dot-or-parens red write-color ; + " has left IRC" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; : full-mode ( message -- mode ) parameters>> rest " " sjoin ; @@ -97,13 +91,13 @@ M: unhandled write-irc line>> blue write-color ; M: irc-end write-irc - drop "* You have left IRC" red write-color ; + drop "* You have left IRC" dark-red write-color ; M: irc-disconnected write-irc - drop "* Disconnected" red write-color ; + drop "* Disconnected" dark-red write-color ; M: irc-connected write-irc - drop "* Connected" green write-color ; + drop "* Connected" dark-green write-color ; M: irc-listener-end write-irc drop ; @@ -130,7 +124,7 @@ GENERIC: handle-inbox ( tab message -- ) : update-participants ( tab -- ) [ userlist>> [ clear-gadget ] keep ] [ listener>> participants>> ] bi - [ +operator+ green filter-participants ] + [ +operator+ dark-green filter-participants ] [ +voice+ blue filter-participants ] [ +normal+ black filter-participants ] tri drop ; From d14efabed37ce9c9727924fbf8be34aa72db18db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Aug 2008 20:21:25 -0500 Subject: [PATCH 08/26] Working on escape analysis --- .../allocations/allocations.factor | 26 +++- .../escape-analysis/branches/branches.factor | 10 +- .../escape-analysis-tests.factor | 130 ++++++++++++++++++ .../escape-analysis/escape-analysis.factor | 1 + .../tree/escape-analysis/simple/simple.factor | 3 + 5 files changed, 164 insertions(+), 6 deletions(-) create mode 100644 unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor index 7600a3b5a2..59febb3801 100644 --- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel math +USING: assocs namespaces sequences kernel math combinators sets stack-checker.state compiler.tree.copy-equiv ; IN: compiler.tree.escape-analysis.allocations @@ -13,7 +13,11 @@ SYMBOL: allocations resolve-copy allocations get at ; : record-allocation ( allocation value -- ) - allocations get set-at ; + { + { [ dup not ] [ 2drop ] } + { [ over not ] [ allocations get delete-at drop ] } + [ allocations get set-at ] + } cond ; : record-allocations ( allocations values -- ) [ record-allocation ] 2each ; @@ -25,4 +29,20 @@ SYMBOL: allocations SYMBOL: slot-merging : merge-slots ( values -- value ) - [ introduce-value ] [ slot-merging get set-at ] [ ] tri ; + dup [ ] contains? [ + + [ introduce-value ] + [ slot-merging get set-at ] + [ ] tri + ] [ drop f ] if ; + +! If an allocation's slot appears in this set, the allocation +! is disqualified from unboxing. +SYMBOL: disqualified + +: disqualify ( slot-value -- ) + [ disqualified get conjoin ] + [ slot-merging get at [ disqualify ] each ] bi ; + +: escaping-allocation? ( value -- ? ) + allocation [ [ disqualified get key? ] contains? ] [ t ] if* ; diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor index 23e53fd4fe..1bd6973369 100644 --- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor +++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces sequences +USING: accessors kernel namespaces sequences sets +stack-checker.branches compiler.tree compiler.tree.propagation.branches compiler.tree.escape-analysis.nodes @@ -12,6 +13,9 @@ SYMBOL: children-escape-data M: #branch escape-analysis* live-children sift [ (escape-analysis) ] each ; +: disqualify-allocations ( allocations -- ) + [ [ disqualify ] each ] each ; + : (merge-allocations) ( values -- allocation ) [ [ allocation ] map dup [ ] all? [ @@ -19,8 +23,8 @@ M: #branch escape-analysis* flip [ (merge-allocations) ] [ [ merge-slots ] map ] bi [ record-allocations ] keep - ] [ drop f ] if - ] [ drop f ] if + ] [ disqualify-allocations f ] if + ] [ disqualify-allocations f ] if ] map ; : merge-allocations ( in-values out-values -- ) diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor new file mode 100644 index 0000000000..34ecc74813 --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -0,0 +1,130 @@ +IN: compiler.tree.escape-analysis.tests +USING: compiler.tree.escape-analysis +compiler.tree.escape-analysis.allocations compiler.tree.builder +compiler.tree.normalization compiler.tree.copy-equiv +compiler.tree.propagation compiler.tree.cleanup +compiler.tree.combinators compiler.tree sequences math +kernel tools.test accessors slots.private quotations.private +prettyprint ; + +\ escape-analysis must-infer + +: count-unboxed-allocations ( quot -- sizes ) + build-tree + normalize + compute-copy-equiv + propagate + cleanup + escape-analysis + 0 swap [ + dup #call? + [ + out-d>> dup empty? [ drop ] [ + first escaping-allocation? [ 1+ ] unless + ] if + ] [ drop ] if + ] each-node ; + +[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test + +[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test + +[ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test + +[ 2 ] [ + [ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations +] unit-test + +[ 3 ] [ + [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations +] unit-test + +[ 2 ] [ + [ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations +] unit-test + +TUPLE: cons { car read-only } { cdr read-only } ; + +[ 0 ] [ + [ + dup 0 = [ + 2 cons boa + ] [ + dup 1 = [ + 3 cons boa + ] when + ] if car>> + ] count-unboxed-allocations +] unit-test + +[ 3 ] [ + [ + dup 0 = [ + 2 cons boa + ] [ + dup 1 = [ + 3 cons boa + ] [ + 4 cons boa + ] if + ] if car>> + ] count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ + dup 0 = [ + dup 1 = [ + 3 cons boa + ] [ + 4 cons boa + ] if + ] unless car>> + ] count-unboxed-allocations +] unit-test + +[ 2 ] [ + [ + dup 0 = [ + 2 cons boa + ] [ + dup 1 = [ + 3 cons boa + ] [ + 4 cons boa + ] if car>> + ] if + ] count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ + dup 0 = [ + 2 cons boa + ] [ + dup 1 = [ + 3 cons boa dup . + ] [ + 4 cons boa + ] if + ] if drop + ] count-unboxed-allocations +] unit-test diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor index 490fff82ec..e8c02046f2 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor @@ -14,5 +14,6 @@ IN: compiler.tree.escape-analysis : escape-analysis ( node -- node ) H{ } clone slot-merging set H{ } clone allocations set + H{ } clone disqualified set work-list set dup (escape-analysis) ; diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor index cc6ac57a5e..93d0b28be3 100644 --- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor +++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor @@ -24,6 +24,9 @@ IN: compiler.tree.escape-analysis.simple [ in-d>> first ] tri over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ; +: add-escaping-values ( values -- ) + [ allocation [ disqualify ] each ] each ; + M: #call escape-analysis* dup word>> { { \ [ record-tuple-allocation ] } From 0929a5a9e8baaf5c37688dea36de70e4ca82b879 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 3 Aug 2008 01:12:45 -0500 Subject: [PATCH 09/26] Add cfdg.models.spirales --- extra/cfdg/models/spirales/spirales.factor | 41 ++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 extra/cfdg/models/spirales/spirales.factor diff --git a/extra/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor new file mode 100644 index 0000000000..5f01d6a48f --- /dev/null +++ b/extra/cfdg/models/spirales/spirales.factor @@ -0,0 +1,41 @@ + +USING: namespaces sequences math random-weighted cfdg ; + +IN: spirales + +DEFER: line + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: block ( -- ) + [ + [ circle ] do + [ 0.3 s 60 flip line ] do + ] + recursive ; + +: a1 ( -- ) + [ + [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do + [ block ] do + ] + recursive ; + +: line ( -- ) + -0.3 a + [ 0 rotate a1 ] do + [ 120 rotate a1 ] do + [ 240 rotate a1 ] do ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run ( -- ) + [ -1 b ] >background + { -20 40 -20 40 } viewport set + [ line ] >start-shape + 0.03 >threshold + cfdg-window ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: run \ No newline at end of file From d41bc716bfb26d79a579dfc669baed7026c06c70 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Aug 2008 05:01:05 -0500 Subject: [PATCH 10/26] More escape analysis work --- .../dataflow-analysis.factor | 6 +-- .../allocations/allocations.factor | 30 ++++++++++----- .../escape-analysis-tests.factor | 8 ++-- .../escape-analysis/escape-analysis.factor | 11 +++--- .../escape-analysis/graph/graph-tests.factor | 19 ++++++++++ .../tree/escape-analysis/graph/graph.factor | 38 +++++++++++++++++++ .../tree/escape-analysis/simple/simple.factor | 1 - .../work-list/work-list.factor | 9 ----- 8 files changed, 88 insertions(+), 34 deletions(-) create mode 100644 unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor create mode 100644 unfinished/compiler/tree/escape-analysis/graph/graph.factor delete mode 100644 unfinished/compiler/tree/escape-analysis/work-list/work-list.factor diff --git a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor index b6772650b6..c7d558f4bf 100644 --- a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor +++ b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor @@ -8,11 +8,9 @@ IN: compiler.tree.dataflow-analysis ! Dataflow analysis SYMBOL: work-list -: look-at-value ( values -- ) - work-list get push-front ; +: look-at-value ( values -- ) work-list get push-front ; -: look-at-values ( values -- ) - work-list get '[ , push-front ] each ; +: look-at-values ( values -- ) work-list get push-all-front ; : look-at-inputs ( node -- ) in-d>> look-at-values ; diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor index 59febb3801..09c20a93dc 100644 --- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces sequences kernel math combinators sets -stack-checker.state compiler.tree.copy-equiv ; +fry stack-checker.state compiler.tree.copy-equiv +compiler.tree.escape-analysis.graph ; IN: compiler.tree.escape-analysis.allocations SYMBOL: escaping @@ -25,24 +26,33 @@ SYMBOL: allocations : record-slot-access ( out slot# in -- ) over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ; -! A map from values to sequences of values -SYMBOL: slot-merging +! We track available values +SYMBOL: slot-graph : merge-slots ( values -- value ) dup [ ] contains? [ [ introduce-value ] - [ slot-merging get set-at ] + [ slot-graph get add-edges ] [ ] tri ] [ drop f ] if ; -! If an allocation's slot appears in this set, the allocation -! is disqualified from unboxing. -SYMBOL: disqualified +! A disqualified slot value is not available for unboxing. A +! tuple may be unboxed if none of its slots have been +! disqualified. : disqualify ( slot-value -- ) - [ disqualified get conjoin ] - [ slot-merging get at [ disqualify ] each ] bi ; + slot-graph get mark-vertex ; + +SYMBOL: escaping-allocations + +: compute-escaping-allocations ( -- ) + #! Any allocations involving unavailable slots are + #! potentially escaping, and cannot be unboxed. + allocations get + slot-graph get marked-components + '[ [ , key? ] contains? nip ] assoc-filter + escaping-allocations set ; : escaping-allocation? ( value -- ? ) - allocation [ [ disqualified get key? ] contains? ] [ t ] if* ; + escaping-allocations get key? ; diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor index 34ecc74813..83cdfd980b 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -5,7 +5,7 @@ compiler.tree.normalization compiler.tree.copy-equiv compiler.tree.propagation compiler.tree.cleanup compiler.tree.combinators compiler.tree sequences math kernel tools.test accessors slots.private quotations.private -prettyprint ; +prettyprint classes.tuple.private ; \ escape-analysis must-infer @@ -19,9 +19,9 @@ prettyprint ; 0 swap [ dup #call? [ - out-d>> dup empty? [ drop ] [ - first escaping-allocation? [ 1+ ] unless - ] if + dup word>> \ = [ + out-d>> first escaping-allocation? [ 1+ ] unless + ] [ drop ] if ] [ drop ] if ] each-node ; diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor index e8c02046f2..c41627005b 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor @@ -3,17 +3,16 @@ USING: kernel namespaces search-dequeues compiler.tree compiler.tree.def-use +compiler.tree.escape-analysis.graph compiler.tree.escape-analysis.allocations compiler.tree.escape-analysis.recursive compiler.tree.escape-analysis.branches compiler.tree.escape-analysis.nodes -compiler.tree.escape-analysis.simple -compiler.tree.escape-analysis.work-list ; +compiler.tree.escape-analysis.simple ; IN: compiler.tree.escape-analysis : escape-analysis ( node -- node ) - H{ } clone slot-merging set H{ } clone allocations set - H{ } clone disqualified set - work-list set - dup (escape-analysis) ; + slot-graph set + dup (escape-analysis) + compute-escaping-allocations ; diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor new file mode 100644 index 0000000000..3a7dee58a9 --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor @@ -0,0 +1,19 @@ +IN: compiler.tree.escape-analysis.graph.tests +USING: compiler.tree.escape-analysis.graph tools.test namespaces +accessors ; + + "graph" set + +[ ] [ { 2 3 4 } 1 "graph" get add-edges ] unit-test +[ ] [ { 5 6 } 2 "graph" get add-edges ] unit-test +[ ] [ { 7 8 } 9 "graph" get add-edges ] unit-test +[ ] [ { 6 10 } 4 "graph" get add-edges ] unit-test + +[ ] [ 3 "graph" get mark-vertex ] unit-test + +[ H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 5 } { 6 6 } { 10 10 } } ] +[ "graph" get marked>> ] unit-test + +[ ] [ { 1 11 } 12 "graph" get add-edges ] unit-test + +[ t ] [ 11 "graph" get marked-vertex? ] unit-test diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph.factor b/unfinished/compiler/tree/escape-analysis/graph/graph.factor new file mode 100644 index 0000000000..59ba51d99e --- /dev/null +++ b/unfinished/compiler/tree/escape-analysis/graph/graph.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs fry sequences sets +dequeues search-dequeues namespaces ; +IN: compiler.tree.escape-analysis.graph + +TUPLE: graph edges work-list ; + +: ( -- graph ) + H{ } clone graph boa ; + +: mark-vertex ( vertex graph -- ) work-list>> push-front ; + +: add-edge ( out in graph -- ) + [ edges>> push-at ] [ swapd edges>> push-at ] 3bi ; + +: add-edges ( out-seq in graph -- ) + '[ , , add-edge ] each ; + +> at ] [ work-list>> ] bi push-all-front ] + 2bi + ] if ; + +PRIVATE> + +: marked-components ( graph -- vertices ) + #! All vertices in connected components of marked vertices. + H{ } clone marked [ + [ work-list>> ] keep + '[ , (mark-vertex) ] slurp-dequeue + ] with-variable ; diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor index 93d0b28be3..8329a04a61 100644 --- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor +++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor @@ -6,7 +6,6 @@ combinators dequeues search-dequeues namespaces fry compiler.tree compiler.tree.propagation.info compiler.tree.escape-analysis.nodes -compiler.tree.escape-analysis.work-list compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.simple diff --git a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor deleted file mode 100644 index 8378ee43ae..0000000000 --- a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor +++ /dev/null @@ -1,9 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: dequeues namespaces sequences fry ; -IN: compiler.tree.escape-analysis.work-list - -SYMBOL: work-list - -: add-escaping-values ( values -- ) - work-list get '[ , push-front ] each ; From 64bed4e44e9f4eb495ed5196b4408bd4ca19714f Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sun, 3 Aug 2008 13:21:32 -0400 Subject: [PATCH 11/26] irc.ui: Userlists are now sorted --- extra/irc/ui/ui.factor | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index d899b75d8d..0c9fdee6e0 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -3,12 +3,13 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables colors + sorting qualified unicode.case math.order ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load qualified ; + irc.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -86,6 +87,12 @@ M: mode write-irc " to " blue write-color channel>> write ; +M: nick write-irc + "* " blue write-color + [ prefix>> parse-name write ] keep + " is now known as " blue write-color + trailing>> write ; + M: unhandled write-irc "UNHANDLED: " write line>> blue write-color ; @@ -118,15 +125,18 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( pack alist val color -- pack ) - '[ , = [