From 043578ca1de11634502ba77cc9038535a000ca8c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 18 Mar 2010 00:00:32 -0400 Subject: [PATCH 001/123] require-if loads vocabs conditionally, now or later --- core/vocabs/loader/loader-tests.factor | 18 ++++++++++++++++++ core/vocabs/loader/loader.factor | 16 +++++++++++++++- core/vocabs/loader/test/m/m.factor | 4 ++++ core/vocabs/loader/test/n/n.factor | 1 + core/vocabs/loader/test/o/o.factor | 1 + core/vocabs/vocabs.factor | 9 ++++++--- 6 files changed, 45 insertions(+), 4 deletions(-) create mode 100644 core/vocabs/loader/test/m/m.factor create mode 100644 core/vocabs/loader/test/n/n.factor create mode 100644 core/vocabs/loader/test/o/o.factor diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 09f28541e0..89afb50af7 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -170,3 +170,21 @@ forget-junk ] with-compilation-unit [ ] [ [ "vocabs.loader.test.j" require ] [ drop :1 ] recover ] unit-test + +[ ] [ "vocabs.loader.test.m" require ] unit-test +[ f ] [ "vocabs.loader.test.n" vocab ] unit-test +[ ] [ "vocabs.loader.test.o" require ] unit-test +[ t ] [ "vocabs.loader.test.n" vocab >boolean ] unit-test + +[ + "mno" [ "vocabs.loader.test." swap suffix forget-vocab ] each +] with-compilation-unit + +[ ] [ "vocabs.loader.test.o" require ] unit-test +[ f ] [ "vocabs.loader.test.n" vocab ] unit-test +[ ] [ "vocabs.loader.test.m" require ] unit-test +[ t ] [ "vocabs.loader.test.n" vocab >boolean ] unit-test + +[ + "mno" [ "vocabs.loader.test." swap suffix forget-vocab ] each +] with-compilation-unit diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index c8cf77b795..2acefe4cef 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -62,8 +62,15 @@ SYMBOL: check-vocab-hook check-vocab-hook [ [ drop ] ] initialize +DEFER: require + >source-loaded? ] dip [ % ] [ call( -- ) ] if-bootstrapping - +done+ >>source-loaded? drop + +done+ >>source-loaded? + vocab-name load-conditional-requires ] [ ] [ f >>source-loaded? ] cleanup ; : load-docs ( vocab -- ) @@ -88,6 +96,12 @@ PRIVATE> : require ( vocab -- ) load-vocab drop ; +: require-if ( if then -- ) + over vocab + [ nip require ] + [ swap conditional-requires get [ swap suffix ] change-at ] + if ; + : reload ( name -- ) dup vocab [ [ load-source ] [ load-docs ] bi ] diff --git a/core/vocabs/loader/test/m/m.factor b/core/vocabs/loader/test/m/m.factor new file mode 100644 index 0000000000..e5106d86b7 --- /dev/null +++ b/core/vocabs/loader/test/m/m.factor @@ -0,0 +1,4 @@ +USE: vocabs.loader +IN: vocabs.loader.test.m + +"vocabs.loader.test.o" "vocabs.loader.test.n" require-if diff --git a/core/vocabs/loader/test/n/n.factor b/core/vocabs/loader/test/n/n.factor new file mode 100644 index 0000000000..b3cedb3006 --- /dev/null +++ b/core/vocabs/loader/test/n/n.factor @@ -0,0 +1 @@ +IN: vocabs.loader.test.n diff --git a/core/vocabs/loader/test/o/o.factor b/core/vocabs/loader/test/o/o.factor new file mode 100644 index 0000000000..cc8051ab38 --- /dev/null +++ b/core/vocabs/loader/test/o/o.factor @@ -0,0 +1 @@ +IN: vocabs.loader.test.o diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 239b88a2e8..e48d6c3031 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs strings kernel sorting namespaces -sequences definitions ; +sequences definitions sets ; IN: vocabs SYMBOL: dictionary @@ -83,6 +83,9 @@ ERROR: bad-vocab-name name ; : check-vocab-name ( name -- name ) dup string? [ bad-vocab-name ] unless ; +SYMBOL: conditional-requires +conditional-requires [ H{ } clone ] initialize + : create-vocab ( name -- vocab ) check-vocab-name dictionary get [ ] cache @@ -118,8 +121,8 @@ M: vocab-spec >vocab-link ; M: string >vocab-link dup vocab [ ] [ ] ?if ; : forget-vocab ( vocab -- ) - dup words forget-all - vocab-name dictionary get delete-at + [ words forget-all ] + [ vocab-name dictionary get delete-at ] bi notify-vocab-observers ; M: vocab-spec forget* forget-vocab ; From 9e602d213f95f42914094db099d6e102d6d4092b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 18 Mar 2010 00:24:41 -0400 Subject: [PATCH 002/123] Renaming require-if to require-when --- core/vocabs/loader/loader.factor | 2 +- core/vocabs/loader/test/m/m.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 2acefe4cef..59fe06e6fd 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -96,7 +96,7 @@ PRIVATE> : require ( vocab -- ) load-vocab drop ; -: require-if ( if then -- ) +: require-when ( if then -- ) over vocab [ nip require ] [ swap conditional-requires get [ swap suffix ] change-at ] diff --git a/core/vocabs/loader/test/m/m.factor b/core/vocabs/loader/test/m/m.factor index e5106d86b7..d6d3bd8a7a 100644 --- a/core/vocabs/loader/test/m/m.factor +++ b/core/vocabs/loader/test/m/m.factor @@ -1,4 +1,4 @@ USE: vocabs.loader IN: vocabs.loader.test.m -"vocabs.loader.test.o" "vocabs.loader.test.n" require-if +"vocabs.loader.test.o" "vocabs.loader.test.n" require-when From eb060443dbfcf1dd3fc523cbdf1e306021464dbd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 18 Mar 2010 01:13:37 -0400 Subject: [PATCH 003/123] Updating code to use require-when rather than vocab [ require ] when --- basis/bootstrap/compiler/compiler.factor | 10 +++++----- basis/bootstrap/threads/threads.factor | 8 +++----- basis/classes/struct/struct.factor | 2 +- basis/http/client/client.factor | 2 +- basis/locals/locals.factor | 6 ++---- basis/math/rectangles/rectangles.factor | 4 ++-- basis/peg/peg.factor | 4 +--- basis/regexp/regexp.factor | 4 +--- basis/specialized-arrays/specialized-arrays.factor | 8 ++------ basis/typed/typed.factor | 2 +- basis/ui/gadgets/gadgets.factor | 4 ++-- basis/unix/unix.factor | 4 +--- basis/urls/urls.factor | 6 ++---- basis/windows/com/syntax/syntax.factor | 6 ++---- extra/game/loop/loop.factor | 2 +- extra/gpu/shaders/shaders.factor | 2 +- 16 files changed, 28 insertions(+), 46 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 0bdb2494f8..393e4eab27 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -20,11 +20,11 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"prettyprint" vocab [ - "stack-checker.errors.prettyprint" require - "alien.prettyprint" require - "alien.debugger" require -] when +{ + "stack-checker.errors.prettyprint" + "alien.prettyprint" + "alien.debugger" +} [ "prettyprint" swap require-when ] each "cpu." cpu name>> append require diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor index 24cbba6af8..3a8fe98cf4 100644 --- a/basis/bootstrap/threads/threads.factor +++ b/basis/bootstrap/threads/threads.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: vocabs vocabs.loader kernel io.thread threads +USING: vocabs.loader kernel io.thread threads compiler.utilities namespaces ; IN: bootstrap.threads -"debugger" vocab [ - "debugger.threads" require -] when +"debugger" "debugger.threads" require-when -[ yield ] yield-hook set-global \ No newline at end of file +[ yield ] yield-hook set-global diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 79dea73d8c..ffde233748 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -404,4 +404,4 @@ FUNCTOR-SYNTAX: STRUCT: USING: vocabs vocabs.loader ; -"prettyprint" vocab [ "classes.struct.prettyprint" require ] when +"prettyprint" "classes.struct.prettyprint" require-when diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 2ce0ec9dfc..1221ee39f3 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -196,4 +196,4 @@ ERROR: download-failed response ; USING: vocabs vocabs.loader ; -"debugger" vocab [ "http.client.debugger" require ] when +"debugger" "http.client.debugger" require-when diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 8e940bfdd8..7d67881c47 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -26,7 +26,5 @@ SYNTAX: MEMO:: (::) define-memoized ; "locals.fry" } [ require ] each -"prettyprint" vocab [ - "locals.definitions" require - "locals.prettyprint" require -] when +"prettyprint" "locals.definitions" require-when +"prettyprint" "locals.prettyprint" require-when diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index db3794cbb0..78ac5457bc 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -62,6 +62,6 @@ M: rect contains-point? [ [ dim>> ] dip (>>dim) ] 2bi ; inline -USING: vocabs vocabs.loader ; +USE: vocabs.loader -"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when +"prettyprint" "math.rectangles.prettyprint" require-when diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index cc480c30b2..ca7d28bb97 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -630,6 +630,4 @@ SYNTAX: PEG: USING: vocabs vocabs.loader ; -"debugger" vocab [ - "peg.debugger" require -] when +"debugger" "peg.debugger" require-when diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index e5ac1df151..eea0a26ea5 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -218,6 +218,4 @@ SYNTAX: R| CHAR: | parsing-regexp ; USING: vocabs vocabs.loader ; -"prettyprint" vocab [ - "regexp.prettyprint" require -] when +"prettyprint" "regexp.prettyprint" require-when diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 11b050d5fc..c82ebd78c8 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -173,10 +173,6 @@ SYNTAX: SPECIALIZED-ARRAYS: SYNTAX: SPECIALIZED-ARRAY: scan-c-type define-array-vocab use-vocab ; -"prettyprint" vocab [ - "specialized-arrays.prettyprint" require -] when +"prettyprint" "specialized-arrays.prettyprint" require-when -"mirrors" vocab [ - "specialized-arrays.mirrors" require -] when +"mirrors" "specialized-arrays.mirrors" require-when diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 6ab4e0334d..df46303b79 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -166,4 +166,4 @@ SYNTAX: TYPED:: USING: vocabs vocabs.loader ; -"prettyprint" vocab [ "typed.prettyprint" require ] when +"prettyprint" "typed.prettyprint" require-when diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 7e47bf627b..dca340cd3b 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -393,6 +393,6 @@ M: f request-focus-on 2drop ; : focus-path ( gadget -- seq ) [ focus>> ] follow ; -USING: vocabs vocabs.loader ; +USE: vocabs.loader -"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when +"prettyprint" "ui.gadgets.prettyprint" require-when diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 4e77a41713..e747e48433 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -74,8 +74,6 @@ M: unix open-file [ open ] unix-system-call ; << -"debugger" vocab [ - "unix.debugger" require -] when +"debugger" "unix.debugger" require-when >> diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index bf4a9bb76c..cd470a451a 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -183,8 +183,6 @@ PRIVATE> ! Literal syntax SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ; -USING: vocabs vocabs.loader ; +USE: vocabs.loader -"prettyprint" vocab [ - "urls.prettyprint" require -] when +"prettyprint" "urls.prettyprint" require-when diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 49c9272d9b..78a3c0e6d2 100644 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -94,8 +94,6 @@ SYNTAX: COM-INTERFACE: SYNTAX: GUID: scan string>guid suffix! ; -USING: vocabs vocabs.loader ; +USE: vocabs.loader -"prettyprint" vocab [ - "windows.com.prettyprint" require -] when +"prettyprint" "windows.com.prettyprint" require-when diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index 00fe14c3cd..ffe5acd879 100644 --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -114,4 +114,4 @@ M: game-loop dispose USING: vocabs vocabs.loader ; -"prettyprint" vocab [ "game.loop.prettyprint" require ] when +"prettyprint" "game.loop.prettyprint" require-when diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 025acba896..7c03e00851 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -575,4 +575,4 @@ M: program-instance dispose [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at reset-memos ; -"prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when +"prettyprint" "gpu.shaders.prettyprint" require-when From 4af88ff9ffb449cad5017f9e4a30148c54a9f7d8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 18 Mar 2010 01:39:30 -0400 Subject: [PATCH 004/123] Making more vocabs use require-when --- basis/bootstrap/handbook/handbook.factor | 2 +- basis/bootstrap/ui/tools/tools.factor | 4 +--- basis/math/vectors/simd/simd.factor | 4 +--- basis/mirrors/mirrors.factor | 4 ---- basis/x11/x11.factor | 2 +- 5 files changed, 4 insertions(+), 12 deletions(-) diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor index 51aa9eefaf..11f7349b79 100644 --- a/basis/bootstrap/handbook/handbook.factor +++ b/basis/bootstrap/handbook/handbook.factor @@ -1,4 +1,4 @@ USING: vocabs.loader vocabs kernel ; IN: bootstrap.handbook -"bootstrap.help" vocab [ "help.handbook" require ] when +"bootstrap.help" "help.handbook" require-when diff --git a/basis/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor index 5cf05aef91..7db69ce9c1 100644 --- a/basis/bootstrap/ui/tools/tools.factor +++ b/basis/bootstrap/ui/tools/tools.factor @@ -4,9 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ; [ "bootstrap." prepend vocab ] all? [ "ui.tools" require - "ui.backend.cocoa" vocab [ - "ui.backend.cocoa.tools" require - ] when + "ui.backend.cocoa" "ui.backend.cocoa.tools" require-when "ui.tools.walker" require ] when diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 8d804247d3..65d6e113bf 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -339,6 +339,4 @@ M: short-8 v*hs+ M: int-4 v*hs+ int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline -"mirrors" vocab [ - "math.vectors.simd.mirrors" require -] when +"mirrors" "math.vectors.simd.mirrors" require-when diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index 65978f0b46..f12d34e170 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -59,7 +59,3 @@ M: hashtable make-mirror ; M: integer make-mirror drop f ; M: enumerated-sequence make-mirror ; M: object make-mirror ; - -"specialized-arrays" vocab [ - "specialized-arrays.mirrors" require -] when diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor index 09328c6f6e..e91c6a6909 100644 --- a/basis/x11/x11.factor +++ b/basis/x11/x11.factor @@ -33,4 +33,4 @@ SYMBOL: root : with-x ( display-string quot -- ) [ init-x ] dip [ close-x ] [ ] cleanup ; inline -"io.backend.unix" vocab [ "x11.io.unix" require ] when \ No newline at end of file +"io.backend.unix" "x11.io.unix" require-when From b4bf7b1d9b5967536eb7421a5b0ff8ceca4531c1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 18 Mar 2010 02:07:47 -0400 Subject: [PATCH 005/123] Making xml literal inverse behavior only load if inverse is loaded --- basis/xml/syntax/inverse/inverse.factor | 75 +++++++++++++++++++++++++ basis/xml/syntax/syntax.factor | 74 +----------------------- 2 files changed, 78 insertions(+), 71 deletions(-) create mode 100644 basis/xml/syntax/inverse/inverse.factor diff --git a/basis/xml/syntax/inverse/inverse.factor b/basis/xml/syntax/inverse/inverse.factor new file mode 100644 index 0000000000..002f60aa23 --- /dev/null +++ b/basis/xml/syntax/inverse/inverse.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +combinators.short-circuit fry generalizations inverse kernel +namespaces sequences sorting strings unicode.categories +xml.data xml.syntax xml.syntax.private ; +IN: xml.syntax.inverse + +: remove-blanks ( seq -- newseq ) + [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; + +GENERIC: >xml ( xml -- tag ) +M: xml >xml body>> ; +M: tag >xml ; +M: xml-chunk >xml + remove-blanks + [ length 1 =/fail ] + [ first dup tag? [ fail ] unless ] bi ; +M: object >xml fail ; + +: 1chunk ( object -- xml-chunk ) + 1array ; + +GENERIC: >xml-chunk ( xml -- chunk ) +M: xml >xml-chunk body>> 1chunk ; +M: xml-chunk >xml-chunk ; +M: object >xml-chunk 1chunk ; + +GENERIC: [undo-xml] ( xml -- quot ) + +M: xml [undo-xml] + body>> [undo-xml] '[ >xml @ ] ; + +M: xml-chunk [undo-xml] + seq>> [undo-xml] '[ >xml-chunk @ ] ; + +: undo-attrs ( attrs -- quot: ( attrs -- ) ) + [ + [ main>> ] dip dup interpolated? + [ var>> '[ _ attr _ set ] ] + [ '[ _ attr _ =/fail ] ] if + ] { } assoc>map '[ _ cleave ] ; + +M: tag [undo-xml] ( tag -- quot: ( tag -- ) ) + { + [ name>> main>> '[ name>> main>> _ =/fail ] ] + [ attrs>> undo-attrs ] + [ children>> [undo-xml] '[ children>> @ ] ] + } cleave '[ _ _ _ tri ] ; + +: firstn-strong ( seq n -- ... ) + [ swap length =/fail ] + [ firstn ] 2bi ; inline + +M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) ) + remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi + '[ remove-blanks _ firstn-strong _ spread ] ; + +M: string [undo-xml] ( string -- quot: ( string -- ) ) + '[ _ =/fail ] ; + +M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) ) + '[ _ =/fail ] ; + +M: interpolated [undo-xml] + var>> '[ _ set ] ; + +: >enum ( assoc -- enum ) + ! Assumes keys are 0..n + >alist sort-keys values ; + +: undo-xml ( xml -- quot ) + [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ; + +\ interpolate-xml 1 [ undo-xml ] define-pop-inverse diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index c56dd23db7..a58526faa3 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -4,7 +4,7 @@ USING: words assocs kernel accessors parser vocabs.parser effects.parser sequences summary lexer splitting combinators locals memoize sequences.deep xml.data xml.state xml namespaces present arrays generalizations strings make math macros multiline -inverse combinators.short-circuit sorting fry unicode.categories +combinators.short-circuit sorting fry unicode.categories effects ; IN: xml.syntax @@ -175,74 +175,6 @@ SYNTAX: chunk ] parse-def ; -xml ( xml -- tag ) -M: xml >xml body>> ; -M: tag >xml ; -M: xml-chunk >xml - remove-blanks - [ length 1 =/fail ] - [ first dup tag? [ fail ] unless ] bi ; -M: object >xml fail ; - -: 1chunk ( object -- xml-chunk ) - 1array ; - -GENERIC: >xml-chunk ( xml -- chunk ) -M: xml >xml-chunk body>> 1chunk ; -M: xml-chunk >xml-chunk ; -M: object >xml-chunk 1chunk ; - -GENERIC: [undo-xml] ( xml -- quot ) - -M: xml [undo-xml] - body>> [undo-xml] '[ >xml @ ] ; - -M: xml-chunk [undo-xml] - seq>> [undo-xml] '[ >xml-chunk @ ] ; - -: undo-attrs ( attrs -- quot: ( attrs -- ) ) - [ - [ main>> ] dip dup interpolated? - [ var>> '[ _ attr _ set ] ] - [ '[ _ attr _ =/fail ] ] if - ] { } assoc>map '[ _ cleave ] ; - -M: tag [undo-xml] ( tag -- quot: ( tag -- ) ) - { - [ name>> main>> '[ name>> main>> _ =/fail ] ] - [ attrs>> undo-attrs ] - [ children>> [undo-xml] '[ children>> @ ] ] - } cleave '[ _ _ _ tri ] ; - -: firstn-strong ( seq n -- ... ) - [ swap length =/fail ] - [ firstn ] 2bi ; inline - -M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) ) - remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi - '[ remove-blanks _ firstn-strong _ spread ] ; - -M: string [undo-xml] ( string -- quot: ( string -- ) ) - '[ _ =/fail ] ; - -M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) ) - '[ _ =/fail ] ; - -M: interpolated [undo-xml] - var>> '[ _ set ] ; - -: >enum ( assoc -- enum ) - ! Assumes keys are 0..n - >alist sort-keys values ; - -: undo-xml ( xml -- quot ) - [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ; - -\ interpolate-xml 1 [ undo-xml ] define-pop-inverse - -PRIVATE> +"inverse" "xml.syntax.inverse" require-when From bcba3ab5ec0b576fd1f892f12c33a0060f0421dc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 19 Mar 2010 06:34:25 -0400 Subject: [PATCH 006/123] Untested tags for vocabs.loader.test.[mno] --- core/vocabs/loader/test/m/tags.txt | 1 + core/vocabs/loader/test/n/tags.txt | 1 + core/vocabs/loader/test/o/tags.txt | 1 + 3 files changed, 3 insertions(+) create mode 100644 core/vocabs/loader/test/m/tags.txt create mode 100644 core/vocabs/loader/test/n/tags.txt create mode 100644 core/vocabs/loader/test/o/tags.txt diff --git a/core/vocabs/loader/test/m/tags.txt b/core/vocabs/loader/test/m/tags.txt new file mode 100644 index 0000000000..5d77766703 --- /dev/null +++ b/core/vocabs/loader/test/m/tags.txt @@ -0,0 +1 @@ +untested diff --git a/core/vocabs/loader/test/n/tags.txt b/core/vocabs/loader/test/n/tags.txt new file mode 100644 index 0000000000..5d77766703 --- /dev/null +++ b/core/vocabs/loader/test/n/tags.txt @@ -0,0 +1 @@ +untested diff --git a/core/vocabs/loader/test/o/tags.txt b/core/vocabs/loader/test/o/tags.txt new file mode 100644 index 0000000000..5d77766703 --- /dev/null +++ b/core/vocabs/loader/test/o/tags.txt @@ -0,0 +1 @@ +untested From 7dd44bfccf4bc2e1eba0935cf0d4c952eb2a7cea Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 19 Mar 2010 06:45:55 -0400 Subject: [PATCH 007/123] Docs for require-when --- core/vocabs/loader/loader-docs.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 08ab729b6d..d5a6be5335 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -50,7 +50,9 @@ $nl { $subsections "vocabs.metadata" "vocabs.icons" } "Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:" { $subsections require } -"The above word will only ever load a vocabulary once in a given session. There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:" +"The above word will only ever load a vocabulary once in a given session. Sometimes, two vocabularies require special code to interact. The following word is used to load one vocabulary when another is present:" +{ $subsections require-when } +"There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:" { $subsections reload } "For interactive development in the listener, calling " { $link reload } " directly is usually not necessary, since a better facility exists for " { $link "vocabs.refresh" } "." $nl @@ -111,6 +113,12 @@ HELP: require { $description "Loads a vocabulary if it has not already been loaded." } { $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ; +HELP: require-when +{ $values { "if" "a vocabulary specifier" } { "then" "a vocabulary specifier" } } +{ $description "Loads the " { $snippet "then" } " vocabulary if it is not loaded and the " { $snippet "if" } " vocabulary is. If the " { $snippet "if" } " vocabulary is not loaded now, but it is later, then the " { $snippet "then" } " vocabulary will be loaded along with it at that time." } +{ $notes "This is used to express a joint dependency of vocabularies. If vocabularies " { $snippet "a" } " and " { $snippet "b" } " use code in vocabulary " { $snippet "c" } " to interact, then the following line can be placed in " { $snippet "a" } " in order express the dependency." +{ $code "\"b\" \"c\" require-when" } } ; + HELP: run { $values { "vocab" "a vocabulary specifier" } } { $description "Runs a vocabulary's main entry point. The main entry point is set with the " { $link POSTPONE: MAIN: } " parsing word." } ; From 88e88207ffa978bc9f9b18536c0255268cddc6e9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 23 Mar 2010 00:30:49 -0400 Subject: [PATCH 008/123] Fixing bug in regexp \P --- basis/regexp/parser/parser.factor | 2 +- basis/regexp/regexp-tests.factor | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 0025b89d56..a038351cb0 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -133,7 +133,7 @@ CharacterInBracket = !("}") Character QuotedCharacter = !("\\E") . Escape = "p{" CharacterInBracket*:s "}" => [[ s name>class ]] - | "P{" CharacterInBracket*:s "}" => [[ s name>class ]] + | "P{" CharacterInBracket*:s "}" => [[ s name>class ]] | "Q" QuotedCharacter*:s "\\E" => [[ s ]] | "u" Character:a Character:b Character:c Character:d => [[ { a b c d } hex> ensure-number ]] diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 1f72fa04ba..2488f568da 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -530,3 +530,8 @@ IN: regexp-tests [ f ] [ "π" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test [ t ] [ "A" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test [ f ] [ "3" R/ [\p{script=latin}--\p{lower}]/ matches? ] unit-test + +[ t ] [ " " R/ \P{alpha}/ matches? ] unit-test +[ f ] [ "" R/ \P{alpha}/ matches? ] unit-test +[ f ] [ "a " R/ \P{alpha}/ matches? ] unit-test +[ f ] [ "a" R/ \P{alpha}/ matches? ] unit-test From f6561f3c03036670cabfd92a827e9ba1faab903c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 22 Mar 2010 22:32:00 -0700 Subject: [PATCH 009/123] delegate: add BROADCAST: syntax, delegate generic with no outputs to an array of multiple delegates --- basis/delegate/delegate-docs.factor | 16 ++++++++++---- basis/delegate/delegate-tests.factor | 17 ++++++++++++++- basis/delegate/delegate.factor | 31 +++++++++++++++++++++++----- 3 files changed, 54 insertions(+), 10 deletions(-) diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index d4867714d3..451016cc6c 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -18,9 +18,16 @@ HELP: define-consult { $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ; HELP: CONSULT: -{ $syntax "CONSULT: group class getter... ;" } -{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } } -{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ; +{ $syntax """CONSULT: group class + code ;""" } +{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } } +{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to the object returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "CONSULT:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "CONSULT:" } " to override the delegation." } ; + +HELP: BROADCAST: +{ $syntax """BROADCAST: group class + code ;""" } +{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } } +{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to every object in the sequence returned by executing " { $snippet "code" } " with the original object as an input." { $snippet "BROADCAST:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "BROADCAST:" } " to override the delegation. Every generic word in " { $snippet "group" } " must return no outputs; otherwise, a " { $link broadcast-words-must-have-no-outputs } " error will be raised." } ; HELP: SLOT-PROTOCOL: { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" } @@ -28,7 +35,7 @@ HELP: SLOT-PROTOCOL: { define-protocol POSTPONE: PROTOCOL: } related-words -{ define-consult POSTPONE: CONSULT: } related-words +{ define-consult POSTPONE: BROADCAST: POSTPONE: CONSULT: } related-words HELP: group-words { $values { "group" "a group" } { "words" "an array of words" } } @@ -52,6 +59,7 @@ $nl { $subsections POSTPONE: SLOT-PROTOCOL: } "Defining consultation:" { $subsections + POSTPONE: BROADCAST: POSTPONE: CONSULT: define-consult } diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 17f81708c5..4a280ef584 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,7 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string accessors eval multiline generic.single delegate.protocols -delegate.private assocs see ; +delegate.private assocs see make ; IN: delegate.tests TUPLE: hello this that ; @@ -197,3 +197,18 @@ DEFER: seq-delegate sequence-protocol \ protocol-consult word-prop key? ] unit-test + +GENERIC: broadcastable ( x -- ) +GENERIC: nonbroadcastable ( x -- y ) + +TUPLE: broadcaster targets ; + +BROADCAST: broadcastable broadcaster targets>> ; + +M: integer broadcastable 1 + , ; + +[ "USING: accessors delegate ; IN: delegate.tests BROADCAST: nonbroadcastable broadcaster targets>> ;" eval( -- ) ] +[ error>> broadcast-words-must-have-no-outputs? ] must-fail-with + +[ { 2 3 4 } ] +[ { 1 2 3 } broadcaster boa [ broadcastable ] { } make ] unit-test diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index dc3024b55f..5c8703116d 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2007, 2008 Daniel Ehrenberg -! Portions copyright (C) 2009 Slava Pestov +! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.tuple definitions generic +USING: accessors arrays assocs classes.tuple definitions effects generic generic.standard hashtables kernel lexer math parser generic.parser sequences sets slots words words.symbol fry compiler.units ; IN: delegate +ERROR: broadcast-words-must-have-no-outputs group ; + > empty? ] all? + [ broadcast-words-must-have-no-outputs ] unless ; + ! Consultation TUPLE: consultation group class quot loc ; +TUPLE: broadcast < consultation ; : ( group class quot -- consultation ) f consultation boa ; +: ( group class quot -- consultation ) + [ check-broadcast-group ] 2dip f broadcast boa ; : create-consult-method ( word consultation -- method ) [ class>> swap first create-method dup fake-definition ] keep @@ -44,13 +53,21 @@ PREDICATE: consult-method < method "consultation" word-prop ; M: consult-method reset-word [ call-next-method ] [ f "consultation" set-word-prop ] bi ; -: consult-method-quot ( quot word -- object ) +GENERIC# (consult-method-quot) 2 ( consultation quot word -- object ) + +M: consultation (consult-method-quot) + '[ _ call _ execute ] nip ; +M: broadcast (consult-method-quot) + '[ _ call [ _ execute ] each ] nip ; + +: consult-method-quot ( consultation word -- object ) + [ dup quot>> ] dip [ second [ [ dip ] curry ] times ] [ first ] bi - '[ _ call _ execute ] ; + (consult-method-quot) ; : consult-method ( word consultation -- ) [ create-consult-method ] - [ quot>> swap consult-method-quot ] 2bi + [ swap consult-method-quot ] 2bi define ; : change-word-prop ( word prop quot -- ) @@ -89,6 +106,10 @@ SYNTAX: CONSULT: scan-word scan-word parse-definition [ save-location ] [ define-consult ] bi ; +SYNTAX: BROADCAST: + scan-word scan-word parse-definition + [ save-location ] [ define-consult ] bi ; + M: consultation where loc>> ; M: consultation set-where (>>loc) ; From bc174332d1c410ab1c2c104eb29e04d558e9539b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 23 Mar 2010 01:55:50 -0400 Subject: [PATCH 010/123] irc.gitbot: don't stop the alarm if running git throws an error --- extra/irc/gitbot/gitbot.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 0963765482..ccb96239ff 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry irc.client irc.client.chats kernel namespaces sequences threads io.launcher io splitting @@ -46,8 +46,10 @@ M: object handle-message drop ; '[ _ speak ] interleave ; : check-for-updates ( chat -- ) - [ git-id git-pull-cmd short-running-process git-id ] dip - report-updates ; + '[ + git-id git-pull-cmd short-running-process git-id + _ report-updates + ] try ; : bot ( -- ) start-bot From 3ffee52cadcf50dd919cd91d46897388939c193e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 23 Mar 2010 02:05:24 -0400 Subject: [PATCH 011/123] irc.gitbot: fix USING: --- extra/irc/gitbot/gitbot.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index ccb96239ff..2627e8d081 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -3,7 +3,7 @@ USING: fry irc.client irc.client.chats kernel namespaces sequences threads io.launcher io splitting make mason.common mason.updates calendar math alarms -io.encodings.8-bit.latin1 ; +io.encodings.8-bit.latin1 debugger ; IN: irc.gitbot : bot-profile ( -- obj ) From 76e1dc5c77413413d8ed1a9c2dd08ef4115bc7d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 23 Mar 2010 02:22:28 -0400 Subject: [PATCH 012/123] irc.gitbot: new nickname --- extra/irc/gitbot/gitbot.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 2627e8d081..950b34a8d7 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -7,7 +7,7 @@ io.encodings.8-bit.latin1 debugger ; IN: irc.gitbot : bot-profile ( -- obj ) - "irc.freenode.org" 6667 "jackass" f ; + "irc.freenode.org" 6667 "stackoid" f ; : bot-channel ( -- seq ) "#concatenative" ; From ffafafd951ada6137e3bd66ad7b0286fb2755cc7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 23 Mar 2010 04:04:08 -0400 Subject: [PATCH 013/123] vm/mach_signal.c: work around Mac OS X 10.6 API change (or bug?) --- vm/mach_signal.cpp | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index 3fa7dcbf07..5a96bdaf3f 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -82,11 +82,14 @@ static void call_fault_handler( MACH_THREAD_STATE_TYPE *thread_state, MACH_FLOAT_STATE_TYPE *float_state) { + /* Look up the VM instance involved */ THREADHANDLE thread_id = pthread_from_mach_thread_np(thread); assert(thread_id); std::map::const_iterator vm = thread_vms.find(thread_id); + + /* Handle the exception */ if (vm != thread_vms.end()) - vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state); + vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state); } /* Handle an exception by invoking the user's fault handler and/or forwarding @@ -100,15 +103,14 @@ catch_exception_raise (mach_port_t exception_port, exception_data_t code, mach_msg_type_number_t code_count) { - MACH_EXC_STATE_TYPE exc_state; - MACH_THREAD_STATE_TYPE thread_state; - MACH_FLOAT_STATE_TYPE float_state; - mach_msg_type_number_t exc_state_count, thread_state_count, float_state_count; + /* 10.6 likes to report exceptions from child processes too. Ignore those */ + if(task != mach_task_self()) return KERN_SUCCESS; /* Get fault information and the faulting thread's register contents.. See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */ - exc_state_count = MACH_EXC_STATE_COUNT; + MACH_EXC_STATE_TYPE exc_state; + mach_msg_type_number_t exc_state_count = MACH_EXC_STATE_COUNT; if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR, (natural_t *)&exc_state, &exc_state_count) != KERN_SUCCESS) @@ -118,7 +120,8 @@ catch_exception_raise (mach_port_t exception_port, return KERN_FAILURE; } - thread_state_count = MACH_THREAD_STATE_COUNT; + MACH_THREAD_STATE_TYPE thread_state; + mach_msg_type_number_t thread_state_count = MACH_THREAD_STATE_COUNT; if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR, (natural_t *)&thread_state, &thread_state_count) != KERN_SUCCESS) @@ -128,7 +131,8 @@ catch_exception_raise (mach_port_t exception_port, return KERN_FAILURE; } - float_state_count = MACH_FLOAT_STATE_COUNT; + MACH_FLOAT_STATE_TYPE float_state; + mach_msg_type_number_t float_state_count = MACH_FLOAT_STATE_COUNT; if (thread_get_state (thread, MACH_FLOAT_STATE_FLAVOR, (natural_t *)&float_state, &float_state_count) != KERN_SUCCESS) From 14d1da94bb5f04211190667852a964405b83b0f1 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 17 Mar 2010 10:50:45 +0100 Subject: [PATCH 014/123] Use sets --- extra/astar/astar.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/astar/astar.factor b/extra/astar/astar.factor index 45f8aaa86e..85b3108217 100644 --- a/extra/astar/astar.factor +++ b/extra/astar/astar.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs heaps kernel math sequences sets shuffle ; +USING: accessors assocs hash-sets heaps kernel math sequences sets shuffle ; IN: astar ! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A* @@ -24,10 +24,10 @@ TUPLE: (astar) astar goal origin in-open-set open-set ; (add-to-open-set) ; : ?add-to-open-set ( node astar -- ) - 2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ; + 2dup astar>> in-closed-set>> in? [ 2drop ] [ add-to-open-set ] if ; : move-to-closed-set ( node astar -- ) - [ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ; + [ astar>> in-closed-set>> adjoin ] [ in-open-set>> delete-at ] 2bi ; : get-first ( astar -- node ) [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ; @@ -58,7 +58,7 @@ TUPLE: (astar) astar goal origin in-open-set open-set ; : (init) ( from to astar -- ) swap >>goal H{ } clone over astar>> (>>g) - H{ } clone over astar>> (>>in-closed-set) + { } over astar>> (>>in-closed-set) H{ } clone >>origin H{ } clone >>in-open-set >>open-set @@ -78,4 +78,4 @@ PRIVATE> astar-simple new swap >>heuristic swap >>cost swap >>neighbours ; : considered ( astar -- considered ) - in-closed-set>> keys ; + in-closed-set>> members ; From 1e4e66d6a2b1154ebbab62bbeaf7b64dd91025fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 23 Mar 2010 04:17:39 -0400 Subject: [PATCH 015/123] vm: another fix --- vm/mach_signal.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index 5a96bdaf3f..6295381b1c 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -104,7 +104,7 @@ catch_exception_raise (mach_port_t exception_port, mach_msg_type_number_t code_count) { /* 10.6 likes to report exceptions from child processes too. Ignore those */ - if(task != mach_task_self()) return KERN_SUCCESS; + if(task != mach_task_self()) return KERN_FAILURE; /* Get fault information and the faulting thread's register contents.. From f62d414bd15c8d128ce9414e28046e91069ca1c2 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 23 Mar 2010 09:30:48 +0100 Subject: [PATCH 016/123] Add some documentation precisions for astar --- extra/astar/astar-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/astar/astar-docs.factor b/extra/astar/astar-docs.factor index d19166c1bf..7c474bdb57 100644 --- a/extra/astar/astar-docs.factor +++ b/extra/astar/astar-docs.factor @@ -62,8 +62,7 @@ HELP: find-path ", or f if no such path exists" } } { $description "Find a path between " { $snippet "start" } " and " { $snippet "target" } - " using the A* algorithm. The " { $snippet "astar" } " tuple must have been previously " - " built using " { $link } "." + " using the A* algorithm." } ; HELP: considered @@ -77,6 +76,7 @@ HELP: considered ARTICLE: "astar" "A* algorithm" "The " { $vocab-link "astar" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another." $nl +"The " { $link astar } " tuple may be derived from and its " { $link cost } ", " { $link heuristic } ", and " { $link neighbours } " methods overwritten, or the " { $link } " word can be used to build such an object from quotations." $nl "Make an A* object:" { $subsections } "Find a path between nodes:" From 522f28d5a584415d3583e456a0e877b3afbcfa3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 23 Mar 2010 05:07:44 -0400 Subject: [PATCH 017/123] webapps.planet: wrap feed updating within a with-logging form so that errors fetch-feed don't break everything. Previously if there was an error fetching a feed, the update task would just stop --- extra/webapps/planet/planet.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index eb51acbe1a..a003c8b618 100644 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces @@ -194,4 +194,7 @@ posting "POSTINGS" { planet "planet-common" } >>template ; : start-update-task ( db -- ) - '[ _ [ update-cached-postings ] with-db ] 10 minutes every drop ; + '[ + "webapps.planet" + [ _ [ update-cached-postings ] with-db ] with-logging + ] 10 minutes every drop ; From 63bb6c4e4268731d93e5325d47b5dd4446abcad7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 23 Mar 2010 02:11:57 -0700 Subject: [PATCH 018/123] gpu: add geometry shader support --- extra/gpu/demos/raytrace/deploy.factor | 1 + extra/gpu/render/render.factor | 8 +++ extra/gpu/shaders/shaders.factor | 75 +++++++++++++++++++++++--- 3 files changed, 76 insertions(+), 8 deletions(-) diff --git a/extra/gpu/demos/raytrace/deploy.factor b/extra/gpu/demos/raytrace/deploy.factor index b01a64ccbc..2fec4f861f 100644 --- a/extra/gpu/demos/raytrace/deploy.factor +++ b/extra/gpu/demos/raytrace/deploy.factor @@ -3,6 +3,7 @@ H{ { deploy-name "Raytrace" } { deploy-ui? t } { deploy-c-types? f } + { deploy-console? f } { deploy-unicode? f } { "stop-after-last-window?" t } { deploy-io 2 } diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 2b7d75a3ae..6e66832a2f 100755 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -104,9 +104,13 @@ VARIANT: primitive-mode points-mode lines-mode line-strip-mode + lines-with-adjacency-mode + line-strip-with-adjacency-mode line-loop-mode triangles-mode triangle-strip-mode + triangles-with-adjacency-mode + triangle-strip-with-adjacency-mode triangle-fan-mode ; TUPLE: uniform-tuple ; @@ -131,6 +135,10 @@ ERROR: invalid-uniform-type uniform ; { triangles-mode [ GL_TRIANGLES ] } { triangle-strip-mode [ GL_TRIANGLE_STRIP ] } { triangle-fan-mode [ GL_TRIANGLE_FAN ] } + { lines-with-adjacency-mode [ GL_LINES_ADJACENCY ] } + { line-strip-with-adjacency-mode [ GL_LINE_STRIP_ADJACENCY ] } + { triangles-with-adjacency-mode [ GL_TRIANGLES_ADJACENCY ] } + { triangle-strip-with-adjacency-mode [ GL_TRIANGLE_STRIP_ADJACENCY ] } } case ; inline GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- ) diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 025acba896..8609a914bf 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -15,7 +15,18 @@ SPECIALIZED-ARRAY: void* IN: gpu.shaders VARIANT: shader-kind - vertex-shader fragment-shader ; + vertex-shader fragment-shader geometry-shader ; + +VARIANT: geometry-shader-input + points-input + lines-input + lines-with-adjacency-input + triangles-input + triangles-with-adjacency-input ; +VARIANT: geometry-shader-output + points-output + line-strips-output + triangle-strips-output ; UNION: ?string string POSTPONE: f ; @@ -47,6 +58,7 @@ TUPLE: program { shaders array read-only } { vertex-formats array read-only } { feedback-format ?vertex-format read-only } + { geometry-shader-parameters array read-only } { instances hashtable read-only } ; TUPLE: shader-instance < gpu-object @@ -197,6 +209,31 @@ TR: hyphens>underscores "-" "_" ; vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave { drop verify-cleave cleave } >quotation ; +: gl-geometry-shader-input ( input -- input ) + { + { points-input [ GL_POINTS ] } + { lines-input [ GL_LINES ] } + { lines-with-adjacency-input [ GL_LINES_ADJACENCY ] } + { triangles-input [ GL_TRIANGLES ] } + { triangles-with-adjacency-input [ GL_TRIANGLES_ADJACENCY ] } + } case ; inline + +: gl-geometry-shader-output ( output -- output ) + { + { points-output [ GL_POINTS ] } + { line-strips-output [ GL_LINE_STRIP ] } + { triangle-strips-output [ GL_TRIANGLE_STRIP ] } + } case ; inline + +TUPLE: geometry-shader-vertices-out + { count integer read-only } ; + +UNION: geometry-shader-parameter + geometry-shader-input + geometry-shader-output + geometry-shader-vertices-out ; + + GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- ) GENERIC: link-feedback-format ( program-handle format -- ) @@ -208,6 +245,18 @@ M: f link-feedback-format [ vertex-format-attributes [ name>> ] map sift ] map concat swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ; +GENERIC: link-geometry-shader-parameter ( program-handle parameter -- ) + +M: geometry-shader-input link-geometry-shader-parameter + [ GL_GEOMETRY_INPUT_TYPE ] dip gl-geometry-shader-input glProgramParameteriARB ; +M: geometry-shader-output link-geometry-shader-parameter + [ GL_GEOMETRY_OUTPUT_TYPE ] dip gl-geometry-shader-output glProgramParameteriARB ; +M: geometry-shader-vertices-out link-geometry-shader-parameter + [ GL_GEOMETRY_VERTICES_OUT ] dip count>> glProgramParameteriARB ; + +: link-geometry-shader-parameters ( program-handle parameters -- ) + [ link-geometry-shader-parameter ] with each ; + GENERIC: (verify-feedback-format) ( program-instance format -- ) M: f (verify-feedback-format) @@ -293,7 +342,8 @@ padding-no [ 0 ] initialize { { vertex-shader [ GL_VERTEX_SHADER ] } { fragment-shader [ GL_FRAGMENT_SHADER ] } - } case ; + { geometry-shader [ GL_GEOMETRY_SHADER ] } + } case ; inline PRIVATE> @@ -433,8 +483,12 @@ DEFER: : (link-program) ( program shader-instances -- program-instance ) '[ _ [ handle>> ] map ] [ - [ vertex-formats>> ] [ feedback-format>> ] bi - '[ [ _ link-vertex-formats ] [ _ link-feedback-format ] bi ] + [ vertex-formats>> ] [ feedback-format>> ] [ geometry-shader-parameters>> ] tri + '[ + [ _ link-vertex-formats ] + [ _ link-feedback-format ] + [ _ link-geometry-shader-parameters ] tri + ] ] bi (gl-program) dup gl-program-ok? [ [ swap world get \ program-instance boa |dispose dup verify-feedback-format ] @@ -485,15 +539,20 @@ TUPLE: feedback-format : ?shader ( object -- shader/f ) dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ; -: shaders-and-formats ( words -- shaders vertex-formats feedback-format ) - [ [ ?shader ] map sift ] - [ [ vertex-format-attributes ] filter ] - [ [ feedback-format? ] filter validate-feedback-format ] tri ; +: shaders-and-formats ( words -- shaders vertex-formats feedback-format geom-parameters ) + { + [ [ ?shader ] map sift ] + [ [ vertex-format-attributes ] filter ] + [ [ feedback-format? ] filter validate-feedback-format ] + [ [ geometry-shader-parameter? ] filter ] + } cleave ; PRIVATE> SYNTAX: feedback-format: scan-object feedback-format boa suffix! ; +SYNTAX: geometry-shader-vertices-out: + scan-object geometry-shader-vertices-out boa suffix! ; TYPED:: refresh-program ( program: program -- ) program shaders>> [ refresh-shader-source ] each From 8e003bf239ddb15fd7ea52e5a17451aaf778c4b1 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 23 Mar 2010 09:52:51 +0100 Subject: [PATCH 019/123] Rename astar into path-finding --- extra/{astar => path-finding}/authors.txt | 0 .../path-finding-docs.factor} | 4 ++-- .../path-finding-tests.factor} | 6 +++--- .../astar.factor => path-finding/path-finding.factor} | 2 +- extra/{astar => path-finding}/summary.txt | 0 5 files changed, 6 insertions(+), 6 deletions(-) rename extra/{astar => path-finding}/authors.txt (100%) rename extra/{astar/astar-docs.factor => path-finding/path-finding-docs.factor} (94%) rename extra/{astar/astar-tests.factor => path-finding/path-finding-tests.factor} (94%) rename extra/{astar/astar.factor => path-finding/path-finding.factor} (99%) rename extra/{astar => path-finding}/summary.txt (100%) diff --git a/extra/astar/authors.txt b/extra/path-finding/authors.txt similarity index 100% rename from extra/astar/authors.txt rename to extra/path-finding/authors.txt diff --git a/extra/astar/astar-docs.factor b/extra/path-finding/path-finding-docs.factor similarity index 94% rename from extra/astar/astar-docs.factor rename to extra/path-finding/path-finding-docs.factor index 7c474bdb57..dd66e4f76a 100644 --- a/extra/astar/astar-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax ; -IN: astar +IN: path-finding HELP: astar { $description "This tuple must be subclassed and its method " { $link cost } ", " @@ -75,7 +75,7 @@ HELP: considered } ; ARTICLE: "astar" "A* algorithm" -"The " { $vocab-link "astar" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another." $nl +"The " { $vocab-link "path-finding" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another." $nl "The " { $link astar } " tuple may be derived from and its " { $link cost } ", " { $link heuristic } ", and " { $link neighbours } " methods overwritten, or the " { $link } " word can be used to build such an object from quotations." $nl "Make an A* object:" { $subsections } diff --git a/extra/astar/astar-tests.factor b/extra/path-finding/path-finding-tests.factor similarity index 94% rename from extra/astar/astar-tests.factor rename to extra/path-finding/path-finding-tests.factor index 6e2e2f4f1b..16614bb165 100644 --- a/extra/astar/astar-tests.factor +++ b/extra/path-finding/path-finding-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs astar combinators hashtables kernel literals math math.functions -math.vectors sequences sorting splitting strings tools.test ; -IN: astar.tests +USING: arrays assocs combinators hashtables kernel literals math math.functions +math.vectors path-finding sequences sorting splitting strings tools.test ; +IN: path-finding.tests ! Use a 10x9 maze (see below) to try to go from s to e, f or g. ! X means that a position is unreachable. diff --git a/extra/astar/astar.factor b/extra/path-finding/path-finding.factor similarity index 99% rename from extra/astar/astar.factor rename to extra/path-finding/path-finding.factor index 85b3108217..74e12e1e38 100644 --- a/extra/astar/astar.factor +++ b/extra/path-finding/path-finding.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs hash-sets heaps kernel math sequences sets shuffle ; -IN: astar +IN: path-finding ! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A* diff --git a/extra/astar/summary.txt b/extra/path-finding/summary.txt similarity index 100% rename from extra/astar/summary.txt rename to extra/path-finding/summary.txt From b742df468b54ceeb26b94fd20944fbf643680717 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 23 Mar 2010 10:24:01 +0100 Subject: [PATCH 020/123] Add BFS search algorithm --- extra/path-finding/path-finding-docs.factor | 22 +++++++++++++++----- extra/path-finding/path-finding-tests.factor | 12 +++++++++-- extra/path-finding/path-finding.factor | 8 +++++++ 3 files changed, 35 insertions(+), 7 deletions(-) diff --git a/extra/path-finding/path-finding-docs.factor b/extra/path-finding/path-finding-docs.factor index dd66e4f76a..46f1048ba7 100644 --- a/extra/path-finding/path-finding-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -3,6 +3,8 @@ USING: help.markup help.syntax ; IN: path-finding +{ } related-words + HELP: astar { $description "This tuple must be subclassed and its method " { $link cost } ", " { $link heuristic } ", and " { $link neighbours } " must be implemented. " @@ -53,6 +55,16 @@ HELP: "may not be as efficient as subclassing the " { $link astar } " tuple." } ; +HELP: +{ $values + { "neighbours" "an assoc" } + { "astar" "a astar tuple" } +} +{ $description "Build an astar object from the " { $snippet "neighbours" } " assoc. " + "When used with " { $link find-path } ", this astar tuple will use the breadth-first search (BFS) " + "path finding algorithm which is a particular case of the general A* algorithm." +} ; + HELP: find-path { $values { "start" "a node" } @@ -74,12 +86,12 @@ HELP: considered "which have been examined during the A* exploration." } ; -ARTICLE: "astar" "A* algorithm" -"The " { $vocab-link "path-finding" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another." $nl -"The " { $link astar } " tuple may be derived from and its " { $link cost } ", " { $link heuristic } ", and " { $link neighbours } " methods overwritten, or the " { $link } " word can be used to build such an object from quotations." $nl +ARTICLE: "path-finding" "Path finding using the A* algorithm" +"The " { $vocab-link "path-finding" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another using the A* algorithm." $nl +"The " { $link astar } " tuple may be derived from and its " { $link cost } ", " { $link heuristic } ", and " { $link neighbours } " methods overwritten, or the " { $link } " or " { $link } " words can be used to build a new tuple." $nl "Make an A* object:" -{ $subsections } +{ $subsections } "Find a path between nodes:" { $subsections find-path } ; -ABOUT: "astar" +ABOUT: "path-finding" diff --git a/extra/path-finding/path-finding-tests.factor b/extra/path-finding/path-finding-tests.factor index 16614bb165..11a047cb89 100644 --- a/extra/path-finding/path-finding-tests.factor +++ b/extra/path-finding/path-finding-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators hashtables kernel literals math math.functions -math.vectors path-finding sequences sorting splitting strings tools.test ; +math.vectors memoize path-finding sequences sorting splitting strings tools.test ; IN: path-finding.tests ! Use a 10x9 maze (see below) to try to go from s to e, f or g. @@ -97,8 +97,10 @@ M: maze cost ! In this version, we will use the quotations-aware version through . +MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] ; + : n ( pos -- neighbours ) - $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ; + routes at ; : c ( from to -- cost ) "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ; @@ -112,3 +114,9 @@ M: maze cost ! No path from D to B -- all nodes reachable from D must have been examined [ f "CDEF" ] [ "DB" test2 ] unit-test + +! Find a path using BFS. There are no path from F to A, and the path from D to +! C does not include any other node. + +[ f ] [ "FA" first2 routes find-path ] unit-test +[ "DC" ] [ "DC" first2 routes find-path >string ] unit-test diff --git a/extra/path-finding/path-finding.factor b/extra/path-finding/path-finding.factor index 74e12e1e38..3188013940 100644 --- a/extra/path-finding/path-finding.factor +++ b/extra/path-finding/path-finding.factor @@ -69,6 +69,11 @@ M: astar-simple cost cost>> call( n1 n2 -- c ) ; M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ; M: astar-simple neighbours neighbours>> call( n -- neighbours ) ; +TUPLE: bfs < astar neighbours ; +M: bfs cost 3drop 1 ; +M: bfs heuristic 3drop 0 ; +M: bfs neighbours neighbours>> at ; + PRIVATE> : find-path ( start target astar -- path/f ) @@ -79,3 +84,6 @@ PRIVATE> : considered ( astar -- considered ) in-closed-set>> members ; + +: ( neighbours -- astar ) + [ bfs new ] dip >>neighbours ; From 305ea844dece4d19313eadd99f04c44e3dfadcf6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 23 Mar 2010 15:32:16 -0700 Subject: [PATCH 021/123] tools.deploy.windows: got the "com" and "exe" backwards for deploy-console? flag --- basis/tools/deploy/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 5945d9915c..f592ff2d69 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -21,7 +21,7 @@ CONSTANT: app-icon-resource-id "APPICON" : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dll - deploy-console? get ".exe" ".com" ? copy-vm ; + deploy-console? get ".com" ".exe" ? copy-vm ; : open-in-explorer ( dir -- ) [ f "open" ] dip absolute-path normalize-separators From ab148a85e0bc30ec6f111f032cbe1cc7b3e2069c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 23 Mar 2010 17:54:47 -0700 Subject: [PATCH 022/123] proof of concept new "cursors" framework --- extra/cursors/authors.txt | 2 +- extra/cursors/cursors-tests.factor | 84 ++++-- extra/cursors/cursors.factor | 457 ++++++++++++++++++++++------- 3 files changed, 403 insertions(+), 140 deletions(-) diff --git a/extra/cursors/authors.txt b/extra/cursors/authors.txt index b4bd0e7b35..f13c9c1e77 100644 --- a/extra/cursors/authors.txt +++ b/extra/cursors/authors.txt @@ -1 +1 @@ -Doug Coleman \ No newline at end of file +Joe Groff diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor index 8821d4570c..158769ff14 100644 --- a/extra/cursors/cursors-tests.factor +++ b/extra/cursors/cursors-tests.factor @@ -1,44 +1,68 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: cursors math tools.test make ; +! (c)2010 Joe Groff bsd license +USING: accessors cursors make math sequences sorting tools.test ; +FROM: cursors => each map assoc-each assoc>map ; IN: cursors.tests -[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test -[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test -[ f f ] [ { 2 4 } [ odd? ] find ] unit-test +[ { 1 2 3 4 } ] [ + [ T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> , ] -each ] + { } make +] unit-test -[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test -[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test +[ { 1 3 } ] [ + [ T{ linear-cursor f 1 2 } T{ linear-cursor f 5 2 } [ value>> , ] -each ] + { } make +] unit-test -[ t ] [ { } [ odd? ] all? ] unit-test -[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test -[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test +[ B{ 1 2 3 4 5 } ] [ [ { 1 2 3 4 5 } [ , ] each ] B{ } make ] unit-test +[ B{ } ] [ [ { } [ , ] each ] B{ } make ] unit-test +[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } [ 2 * ] map ] unit-test -[ t ] [ { } [ odd? ] all? ] unit-test -[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test -[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test +[ { "roses: lutefisk" "tulips: lox" } ] +[ + [ + { { "roses" "lutefisk" } { "tulips" "lox" } } + [ ": " glue , ] assoc-each + ] { } make +] unit-test -[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test +[ { "roses: lutefisk" "tulips: lox" } ] +[ + { { "roses" "lutefisk" } { "tulips" "lox" } } + [ ": " glue ] { } assoc>map +] unit-test -[ { } ] -[ { 1 2 } { } [ + ] 2map ] unit-test +[ { "roses: lutefisk" "tulips: lox" } ] +[ + [ + H{ { "roses" "lutefisk" } { "tulips" "lox" } } + [ ": " glue , ] assoc-each + ] { } make natural-sort +] unit-test -[ { 11 } ] -[ { 1 2 } { 10 } [ + ] 2map ] unit-test +[ { "roses: lutefisk" "tulips: lox" } ] +[ + H{ { "roses" "lutefisk" } { "tulips" "lox" } } + [ ": " glue ] { } assoc>map natural-sort +] unit-test -[ { 11 22 } ] -[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test +: compile-test-each ( xs -- ) + [ , ] each ; -[ { } ] -[ { 1 2 } { } { } [ + + ] 3map ] unit-test +: compile-test-map ( xs -- ys ) + [ 2 * ] map ; -[ { 111 } ] -[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test +: compile-test-assoc-each ( xs -- ) + [ ": " glue , ] assoc-each ; -[ { 111 222 } ] -[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test +: compile-test-assoc>map ( xs -- ys ) + [ ": " glue ] { } assoc>map ; -: test-3map ( -- seq ) - { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ; +[ B{ 1 2 3 4 5 } ] [ [ { 1 2 3 4 5 } compile-test-each ] B{ } make ] unit-test +[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } compile-test-map ] unit-test + +[ { "roses: lutefisk" "tulips: lox" } ] +[ [ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ] { } make ] unit-test + +[ { "roses: lutefisk" "tulips: lox" } ] +[ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map ] unit-test -[ { 111 222 } ] [ test-3map ] unit-test diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 77defb081d..b93a7bb645 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -1,153 +1,392 @@ -! Copyright (C) 2009 Slava Pestov, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays generalizations kernel math sequences -sequences.private fry ; +! (c)2010 Joe Groff bsd license +USING: accessors assocs combinators.short-circuit fry hashtables +kernel locals math math.functions sequences sequences.private ; +FROM: hashtables.private => tombstone? ; IN: cursors -GENERIC: cursor-done? ( cursor -- ? ) -GENERIC: cursor-get-unsafe ( cursor -- obj ) -GENERIC: cursor-advance ( cursor -- ) +! +! basic cursor protocol +! + +MIXIN: cursor + +GENERIC: cursor-compatible? ( cursor cursor -- ? ) GENERIC: cursor-valid? ( cursor -- ? ) -GENERIC: cursor-write ( obj cursor -- ) +GENERIC: cursor= ( cursor cursor -- ? ) +GENERIC: cursor<= ( cursor cursor -- ? ) +GENERIC: cursor>= ( cursor cursor -- ? ) +GENERIC: cursor-distance-hint ( cursor cursor -- n ) -ERROR: cursor-ended cursor ; +M: cursor cursor<= cursor= ; inline +M: cursor cursor>= cursor= ; inline +M: cursor cursor-distance-hint 2drop 0 ; inline -: cursor-get ( cursor -- obj ) - dup cursor-done? - [ cursor-ended ] [ cursor-get-unsafe ] if ; inline +! +! cursor iteration +! -: find-done? ( cursor quot -- ? ) - over cursor-done? - [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline +MIXIN: forward-cursor +INSTANCE: forward-cursor cursor -: cursor-until ( cursor quot -- ) - [ find-done? not ] - [ drop cursor-advance ] bi-curry bi-curry while ; inline - -: cursor-each ( cursor quot -- ) - [ f ] compose cursor-until ; inline +GENERIC: inc-cursor ( cursor -- cursor' ) -: cursor-find ( cursor quot -- obj ? ) - [ cursor-until ] [ drop ] 2bi - dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline +MIXIN: bidirectional-cursor +INSTANCE: bidirectional-cursor forward-cursor -: cursor-any? ( cursor quot -- ? ) - cursor-find nip ; inline +GENERIC: dec-cursor ( cursor -- cursor' ) -: cursor-all? ( cursor quot -- ? ) - [ not ] compose cursor-any? not ; inline +MIXIN: random-access-cursor +INSTANCE: random-access-cursor bidirectional-cursor -: cursor-map-quot ( quot to -- quot' ) - [ [ call ] dip cursor-write ] 2curry ; inline +GENERIC# cursor+ 1 ( cursor n -- cursor' ) +GENERIC# cursor- 1 ( cursor n -- cursor' ) +GENERIC: cursor-distance ( cursor cursor -- n ) +GENERIC: cursor< ( cursor cursor -- ? ) +GENERIC: cursor> ( cursor cursor -- ? ) -: cursor-map ( from to quot -- ) - swap cursor-map-quot cursor-each ; inline +M: random-access-cursor inc-cursor 1 cursor+ ; inline +M: random-access-cursor dec-cursor -1 cursor+ ; inline +M: random-access-cursor cursor- neg cursor+ ; inline +M: random-access-cursor cursor<= { [ cursor= ] [ cursor< ] } 2|| ; inline +M: random-access-cursor cursor>= { [ cursor= ] [ cursor> ] } 2|| ; inline +M: random-access-cursor cursor-distance-hint cursor-distance ; inline -: cursor-write-if ( obj quot to -- ) - [ over [ call ] dip ] dip - [ cursor-write ] 2curry when ; inline +! +! input cursors +! -: cursor-filter-quot ( quot to -- quot' ) - [ cursor-write-if ] 2curry ; inline +ERROR: invalid-cursor cursor ; -: cursor-filter ( from to quot -- ) - swap cursor-filter-quot cursor-each ; inline +MIXIN: input-cursor -TUPLE: from-sequence { seq sequence } { n integer } ; +GENERIC: cursor-value ( cursor -- value ) + +M: input-cursor cursor-value-unsafe cursor-value ; inline +M: input-cursor cursor-value + dup cursor-valid? [ cursor-value-unsafe ] [ invalid-cursor ] if ; inline -: >from-sequence< ( from-sequence -- n seq ) - [ n>> ] [ seq>> ] bi ; inline +! +! output cursors +! -M: from-sequence cursor-done? ( cursor -- ? ) - >from-sequence< length >= ; +MIXIN: output-cursor -M: from-sequence cursor-valid? - >from-sequence< bounds-check? not ; +GENERIC: set-cursor-value ( value cursor -- ) + +M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline +M: output-cursor set-cursor-value + dup cursor-valid? [ set-cursor-value-unsafe ] [ invalid-cursor ] if ; inline -M: from-sequence cursor-get-unsafe - >from-sequence< nth-unsafe ; +! +! basic iterator +! -M: from-sequence cursor-advance - [ 1 + ] change-n drop ; +: -each ( ... begin end quot: ( ... cursor -- ... ) -- ... ) + [ '[ dup _ cursor>= ] ] + [ '[ _ keep inc-cursor ] ] bi* until drop ; inline -: >input ( seq -- cursor ) - 0 from-sequence boa ; inline +! +! numeric cursors +! -: iterate ( seq quot iterator -- ) - [ >input ] 2dip call ; inline +TUPLE: numeric-cursor + { value read-only } ; -: each ( seq quot -- ) [ cursor-each ] iterate ; inline -: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline -: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline -: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline +M: numeric-cursor cursor-valid? drop t ; inline -TUPLE: to-sequence { seq sequence } { exemplar sequence } ; +M: numeric-cursor cursor= [ value>> ] bi@ = ; inline -M: to-sequence cursor-write - seq>> push ; +M: numeric-cursor cursor<= [ value>> ] bi@ <= ; inline +M: numeric-cursor cursor< [ value>> ] bi@ < ; inline +M: numeric-cursor cursor> [ value>> ] bi@ > ; inline +M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline -: freeze ( cursor -- seq ) - [ seq>> ] [ exemplar>> ] bi like ; inline +INSTANCE: numeric-cursor input-cursor -: >output ( seq -- cursor ) - [ [ length ] keep new-resizable ] keep - to-sequence boa ; inline +M: numeric-cursor cursor-value value>> ; inline -: transform ( seq quot transformer -- newseq ) - [ [ >input ] [ >output ] bi ] 2dip - [ call ] - [ 2drop freeze ] 3bi ; inline +! +! linear cursor +! -: map ( seq quot -- ) [ cursor-map ] transform ; inline -: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline +TUPLE: linear-cursor < numeric-cursor + { delta read-only } ; +C: linear-cursor -: find-done2? ( cursor cursor quot -- ? ) - 2over [ cursor-done? ] either? - [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline +INSTANCE: linear-cursor random-access-cursor -: cursor-until2 ( cursor cursor quot -- ) - [ find-done2? not ] - [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline +M: linear-cursor cursor-compatible? + [ linear-cursor? ] both? ; inline -: cursor-each2 ( cursor cursor quot -- ) - [ f ] compose cursor-until2 ; inline +M: linear-cursor inc-cursor + [ value>> ] [ delta>> ] bi [ + ] keep ; inline +M: linear-cursor dec-cursor + [ value>> ] [ delta>> ] bi [ - ] keep ; inline +M: linear-cursor cursor+ + [ [ value>> ] [ delta>> ] bi ] dip [ * + ] keep ; inline +M: linear-cursor cursor- + [ [ value>> ] [ delta>> ] bi ] dip [ * - ] keep ; inline -: cursor-map2 ( from to quot -- ) - swap cursor-map-quot cursor-each2 ; inline +GENERIC: up/i ( distance delta -- distance' ) +M: integer up/i [ 1 - + ] keep /i ; inline +M: real up/i / ceiling >integer ; inline -: iterate2 ( seq1 seq2 quot iterator -- ) - [ [ >input ] bi@ ] 2dip call ; inline +M: linear-cursor cursor-distance + [ [ value>> ] bi@ - ] [ nip delta>> ] 2bi up/i ; inline -: transform2 ( seq1 seq2 quot transformer -- newseq ) - [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip - [ call ] - [ 2drop nip freeze ] 4 nbi ; inline +! +! quadratic cursor +! -: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline -: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline +TUPLE: quadratic-cursor < numeric-cursor + { delta read-only } + { delta2 read-only } ; -: find-done3? ( cursor1 cursor2 cursor3 quot -- ? ) - [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ] - [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline +C: quadratic-cursor -: cursor-until3 ( cursor cursor quot -- ) - [ find-done3? not ] - [ drop [ cursor-advance ] tri@ ] - bi-curry bi-curry bi-curry bi-curry while ; inline +INSTANCE: quadratic-cursor bidirectional-cursor -: cursor-each3 ( cursor cursor quot -- ) - [ f ] compose cursor-until3 ; inline +M: quadratic-cursor cursor-compatible? + [ linear-cursor? ] both? ; inline -: cursor-map3 ( from to quot -- ) - swap cursor-map-quot cursor-each3 ; inline +M: quadratic-cursor inc-cursor + [ value>> ] [ delta>> [ + ] keep ] [ delta2>> [ + ] keep ] tri ; inline -: iterate3 ( seq1 seq2 seq3 quot iterator -- ) - [ [ >input ] tri@ ] 2dip call ; inline +M: quadratic-cursor dec-cursor + [ value>> ] [ delta>> ] [ delta2>> ] tri [ - [ - ] keep ] keep ; inline -: transform3 ( seq1 seq2 seq3 quot transformer -- newseq ) - [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip - [ call ] - [ 2drop 2nip freeze ] 5 nbi ; inline +! +! collections +! -: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline -: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline +MIXIN: collection + +GENERIC: begin-cursor ( collection -- cursor ) +GENERIC: end-cursor ( collection -- cursor ) + +: all- ( collection quot -- begin end quot ) + [ [ begin-cursor ] [ end-cursor ] bi ] dip ; inline + +! +! containers +! + +MIXIN: container +INSTANCE: container collection + +: -container- ( quot -- quot' ) + '[ cursor-value-unsafe @ ] ; inline + +: container- ( container quot -- begin end quot' ) + all- -container- ; inline + +: each ( ... container quot: ( ... x -- ... ) -- ... ) container- -each ; inline + +! +! sequence cursor +! + +TUPLE: sequence-cursor + { seq read-only } + { n fixnum read-only } ; +C: sequence-cursor + +INSTANCE: sequence container + +M: sequence begin-cursor 0 ; inline +M: sequence end-cursor dup length ; inline + +INSTANCE: sequence-cursor random-access-cursor + +M: sequence-cursor cursor-compatible? + { + [ [ sequence-cursor? ] both? ] + [ [ seq>> ] bi@ eq? ] + } 2&& ; inline + +M: sequence-cursor cursor-valid? + [ n>> ] [ seq>> ] bi bounds-check? ; inline + +M: sequence-cursor cursor= [ n>> ] bi@ = ; inline +M: sequence-cursor cursor<= [ n>> ] bi@ <= ; inline +M: sequence-cursor cursor>= [ n>> ] bi@ >= ; inline +M: sequence-cursor cursor< [ n>> ] bi@ < ; inline +M: sequence-cursor cursor> [ n>> ] bi@ > ; inline +M: sequence-cursor inc-cursor [ seq>> ] [ n>> ] bi 1 + ; inline +M: sequence-cursor dec-cursor [ seq>> ] [ n>> ] bi 1 - ; inline +M: sequence-cursor cursor+ [ [ seq>> ] [ n>> ] bi ] dip + ; inline +M: sequence-cursor cursor- [ [ seq>> ] [ n>> ] bi ] dip - ; inline +M: sequence-cursor cursor-distance ( cursor cursor -- n ) + [ n>> ] bi@ - ; inline + +INSTANCE: sequence-cursor input-cursor + +M: sequence-cursor cursor-value-unsafe [ n>> ] [ seq>> ] bi nth-unsafe ; inline +M: sequence-cursor cursor-value [ n>> ] [ seq>> ] bi nth ; inline + +INSTANCE: sequence-cursor output-cursor + +M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; inline +M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline + +! +! pipe cursor +! + +TUPLE: pipe-cursor + { from read-only } + { to read-only } ; +C: pipe-cursor + +INSTANCE: pipe-cursor forward-cursor + +M: pipe-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline +M: pipe-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline +M: pipe-cursor cursor= [ from>> ] bi@ cursor= ; inline +M: pipe-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi ; inline + +INSTANCE: pipe-cursor output-cursor + +M: pipe-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline +M: pipe-cursor set-cursor-value to>> set-cursor-value ; inline + +: -pipe- ( begin end quot to -- begin' end' quot' ) + swap [ '[ _ ] bi@ ] dip '[ from>> @ ] ; inline + +! +! pusher cursor +! + +TUPLE: pusher-cursor + { growable read-only } ; +C: pusher-cursor + +INSTANCE: pusher-cursor forward-cursor + +! XXX define a protocol for stream cursors that don't actually move +M: pusher-cursor cursor-compatible? 2drop f ; inline +M: pusher-cursor cursor-valid? drop t ; inline +M: pusher-cursor cursor= 2drop f ; inline +M: pusher-cursor inc-cursor ; inline + +INSTANCE: pusher-cursor output-cursor + +M: pusher-cursor set-cursor-value growable>> push ; inline + +! +! Create cursors into new sequences +! + +: new-growable-cursor ( begin end exemplar -- cursor result ) + [ swap cursor-distance-hint ] dip new-resizable [ ] keep ; inline + +GENERIC# new-sequence-cursor 1 ( begin end exemplar -- cursor result ) + +M: random-access-cursor new-sequence-cursor + [ swap cursor-distance ] dip new-sequence [ begin-cursor ] keep ; inline +M: forward-cursor new-sequence-cursor + new-growable-cursor ; inline + +: -into-sequence- ( begin end quot exemplar -- begin' end' quot' result ) + swap [ [ 2dup ] dip new-sequence-cursor ] dip swap [ swap -pipe- ] dip ; inline + +: -into-growable- ( begin end quot exemplar -- begin' end' quot' result ) + swap [ [ 2dup ] dip new-growable-cursor ] dip swap [ swap -pipe- ] dip ; inline + +! +! map +! + +: -map- ( quot -- quot' ) + '[ _ keep set-cursor-value-unsafe ] ; inline + +: -map ( ... begin end quot: ( ... cursor -- ... value ) -- ... ) + -map- -each ; inline + +! XXX generalize exemplar +: -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq ) + [ -into-sequence- [ -map ] dip ] keep like ; inline + +: map! ( ... container quot: ( ... x -- ... newx ) -- ... container ) + [ container- -map ] keep ; inline +: map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq ) + [ container- ] dip -map-as ; inline +: map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer ) + over map-as ; inline + +! +! assoc cursors +! + +MIXIN: assoc-cursor + +GENERIC: cursor-key-value ( cursor -- key value ) + +: -assoc- ( quot -- quot' ) + '[ cursor-key-value @ ] ; inline + +: assoc- ( assoc quot -- begin end quot' ) + all- -assoc- ; inline + +: assoc-each ( ... assoc quot: ( ... k v -- ... ) -- ... ) + assoc- -each ; inline +: assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer ) + [ assoc- ] dip -map-as ; inline + +INSTANCE: input-cursor assoc-cursor + +M: input-cursor cursor-key-value + cursor-value first2 ; inline + +! +! hashtable cursor +! + +TUPLE: hashtable-cursor + { hashtable hashtable read-only } + { n fixnum read-only } ; + hashtable-cursor +PRIVATE> + +INSTANCE: hashtable-cursor forward-cursor + +M: hashtable-cursor cursor-compatible? + { + [ [ hashtable-cursor? ] both? ] + [ [ hashtable>> ] bi@ eq? ] + } 2&& ; inline + +M: hashtable-cursor cursor-valid? ( cursor -- ? ) + [ n>> ] [ hashtable>> array>> ] bi bounds-check? ; inline + +M: hashtable-cursor cursor= ( cursor cursor -- ? ) + [ n>> ] bi@ = ; inline +M: hashtable-cursor cursor-distance-hint ( cursor cursor -- n ) + nip hashtable>> assoc-size ; inline + + + +M: hashtable-cursor inc-cursor ( cursor -- cursor' ) + [ hashtable>> dup array>> ] [ n>> 2 + ] bi + (inc-hashtable-cursor) ; inline + +INSTANCE: hashtable-cursor assoc-cursor + +M: hashtable-cursor cursor-key-value + [ n>> ] [ hashtable>> array>> ] bi + [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline + +INSTANCE: hashtable collection + +M: hashtable begin-cursor + dup array>> 0 (inc-hashtable-cursor) ; inline +M: hashtable end-cursor + dup array>> length ; inline From cd3bffee345a515712f8b2e9dd6726547f8f6340 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 13:04:14 -0700 Subject: [PATCH 023/123] cursors: set up some "stream cursor" mixin and change pusher-cursor to use them --- extra/cursors/cursors.factor | 60 ++++++++++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 12 deletions(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index b93a7bb645..a706f043ce 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -1,6 +1,7 @@ ! (c)2010 Joe Groff bsd license -USING: accessors assocs combinators.short-circuit fry hashtables -kernel locals math math.functions sequences sequences.private ; +USING: accessors arrays assocs combinators.short-circuit fry +hashtables kernel locals math math.functions sequences ; +FROM: sequences.private => nth-unsafe set-nth-unsafe ; FROM: hashtables.private => tombstone? ; IN: cursors @@ -81,6 +82,40 @@ M: output-cursor set-cursor-value-unsafe set-cursor-value ; inline M: output-cursor set-cursor-value dup cursor-valid? [ set-cursor-value-unsafe ] [ invalid-cursor ] if ; inline +! +! stream cursors +! + +MIXIN: stream-cursor +INSTANCE: stream-cursor forward-cursor + +M: stream-cursor cursor-compatible? 2drop f ; inline +M: stream-cursor cursor-valid? drop t ; inline +M: stream-cursor cursor= 2drop f ; inline + +MIXIN: infinite-stream-cursor +INSTANCE: infinite-stream-cursor stream-cursor + +M: infinite-stream-cursor inc-cursor ; inline + +MIXIN: finite-stream-cursor +INSTANCE: finite-stream-cursor stream-cursor + +SINGLETON: end-of-stream + +GENERIC: cursor-stream-ended? ( cursor -- ? ) + +M: finite-stream-cursor inc-cursor + dup cursor-stream-ended? [ drop end-of-stream ] when ; inline + +INSTANCE: end-of-stream finite-stream-cursor + +M: end-of-stream cursor-compatible? drop finite-stream-cursor? ; inline +M: end-of-stream cursor-valid? drop f ; inline +M: end-of-stream cursor= eq? ; inline +M: end-of-stream inc-cursor ; inline +M: end-of-stream cursor-stream-ended? drop t ; inline + ! ! basic iterator ! @@ -168,8 +203,11 @@ MIXIN: collection GENERIC: begin-cursor ( collection -- cursor ) GENERIC: end-cursor ( collection -- cursor ) +: all ( collection -- begin end ) + [ begin-cursor ] [ end-cursor ] bi ; inline + : all- ( collection quot -- begin end quot ) - [ [ begin-cursor ] [ end-cursor ] bi ] dip ; inline + [ all ] dip ; inline ! ! containers @@ -265,14 +303,7 @@ TUPLE: pusher-cursor { growable read-only } ; C: pusher-cursor -INSTANCE: pusher-cursor forward-cursor - -! XXX define a protocol for stream cursors that don't actually move -M: pusher-cursor cursor-compatible? 2drop f ; inline -M: pusher-cursor cursor-valid? drop t ; inline -M: pusher-cursor cursor= 2drop f ; inline -M: pusher-cursor inc-cursor ; inline - +INSTANCE: pusher-cursor infinite-stream-cursor INSTANCE: pusher-cursor output-cursor M: pusher-cursor set-cursor-value growable>> push ; inline @@ -384,7 +415,12 @@ M: hashtable-cursor cursor-key-value [ n>> ] [ hashtable>> array>> ] bi [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline -INSTANCE: hashtable collection +INSTANCE: hashtable-cursor input-cursor + +M: hashtable-cursor cursor-value + cursor-key-value 2array ; inline + +INSTANCE: hashtable container M: hashtable begin-cursor dup array>> 0 (inc-hashtable-cursor) ; inline From 7fe4a2b01fee1f184808280777784e4d1f1614e0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 14:35:51 -0700 Subject: [PATCH 024/123] cursors: finite-stream-cursors can act as containers over [self, end-of-stream) --- extra/cursors/cursors.factor | 60 ++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index a706f043ce..03855bc536 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -116,6 +116,11 @@ M: end-of-stream cursor= eq? ; inline M: end-of-stream inc-cursor ; inline M: end-of-stream cursor-stream-ended? drop t ; inline +INSTANCE: finite-stream-cursor container + +M: finite-stream-cursor begin-cursor ; inline +M: finite-stream-cursor end-cursor drop end-of-stream ; inline + ! ! basic iterator ! @@ -426,3 +431,58 @@ M: hashtable begin-cursor dup array>> 0 (inc-hashtable-cursor) ; inline M: hashtable end-cursor dup array>> length ; inline + +! +! zip cursor +! + +TUPLE: zip-cursor + { keys read-only } + { values read-only } ; +C: zip-cursor + +INSTANCE: zip-cursor forward-cursor + +M: zip-cursor cursor-compatible? ( cursor cursor -- ? ) + { + [ [ zip-cursor? ] both? ] + [ [ keys>> ] bi@ cursor-compatible? ] + [ [ values>> ] bi@ cursor-compatible? ] + } 2&& ; inline + +M: zip-cursor cursor-valid? ( cursor -- ? ) + [ keys>> ] [ values>> ] bi [ cursor-valid? ] both? ; inline +M: zip-cursor cursor= ( cursor cursor -- ? ) + { + [ [ keys>> ] bi@ cursor= ] + [ [ values>> ] bi@ cursor= ] + } 2|| ; inline + +M: zip-cursor cursor-distance-hint ( cursor cursor -- n ) + [ [ keys>> ] bi@ cursor-distance-hint ] + [ [ values>> ] bi@ cursor-distance-hint ] 2bi max ; inline + +M: zip-cursor inc-cursor ( cursor -- cursor' ) + [ keys>> inc-cursor ] [ values>> inc-cursor ] bi ; inline + +INSTANCE: zip-cursor assoc-cursor + +M: zip-cursor cursor-key-value + [ keys>> cursor-value ] [ values>> cursor-value ] bi ; inline + +: zip-cursors ( a-begin a-end b-begin b-end -- begin end ) + [ ] bi-curry@ bi* ; inline + +: 2all ( a b -- begin end ) + [ all ] bi@ zip-cursors ; inline + +: 2all- ( a b quot -- begin end quot ) + [ 2all ] dip ; inline + +ALIAS: -2container- assoc ; inline + +: 2container- ( a b quot -- begin end quot' ) + 2all- -2container- ; inline + + + From 98d81e71d79bcf37cc000a232949d9bbff5fdc86 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 14:37:01 -0700 Subject: [PATCH 025/123] cursors: fix load errors w/o auto-use --- extra/cursors/cursors.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 03855bc536..84b3d0ef78 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -1,6 +1,6 @@ ! (c)2010 Joe Groff bsd license USING: accessors arrays assocs combinators.short-circuit fry -hashtables kernel locals math math.functions sequences ; +hashtables kernel locals math math.functions math.order sequences ; FROM: sequences.private => nth-unsafe set-nth-unsafe ; FROM: hashtables.private => tombstone? ; IN: cursors @@ -116,11 +116,6 @@ M: end-of-stream cursor= eq? ; inline M: end-of-stream inc-cursor ; inline M: end-of-stream cursor-stream-ended? drop t ; inline -INSTANCE: finite-stream-cursor container - -M: finite-stream-cursor begin-cursor ; inline -M: finite-stream-cursor end-cursor drop end-of-stream ; inline - ! ! basic iterator ! @@ -229,6 +224,11 @@ INSTANCE: container collection : each ( ... container quot: ( ... x -- ... ) -- ... ) container- -each ; inline +INSTANCE: finite-stream-cursor container + +M: finite-stream-cursor begin-cursor ; inline +M: finite-stream-cursor end-cursor drop end-of-stream ; inline + ! ! sequence cursor ! @@ -479,7 +479,7 @@ M: zip-cursor cursor-key-value : 2all- ( a b quot -- begin end quot ) [ 2all ] dip ; inline -ALIAS: -2container- assoc ; inline +ALIAS: -2container- -assoc- : 2container- ( a b quot -- begin end quot' ) 2all- -2container- ; inline From 56c89c0510a16a9f52688aef4bbc2e3b7ca70e05 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 15:26:50 -0700 Subject: [PATCH 026/123] cursors: 2each, 2map-as, 2map, using zip-cursors --- extra/cursors/cursors.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 84b3d0ef78..1d02311c2f 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -484,5 +484,11 @@ ALIAS: -2container- -assoc- : 2container- ( a b quot -- begin end quot' ) 2all- -2container- ; inline +: 2each ( ... a b quot: ( ... x y -- ... ) -- ... ) + 2container- -each ; inline +: 2map-as ( ... a b quot: ( ... x y -- ... z ) exemplar -- ... c ) + [ 2container- ] dip -map-as ; inline +: 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c ) + pick 2map-as ; inline From c17eb80b90fe97ae4b5a8471918e3645a92488e8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 16:41:52 -0700 Subject: [PATCH 027/123] cursors: generalized -ncontainer- --- extra/cursors/cursors.factor | 33 +++++++++++++++++++++++++++++---- 1 file changed, 29 insertions(+), 4 deletions(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 1d02311c2f..94e83398bd 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -1,6 +1,7 @@ ! (c)2010 Joe Groff bsd license USING: accessors arrays assocs combinators.short-circuit fry -hashtables kernel locals math math.functions math.order sequences ; +hashtables kernel locals macros math math.functions math.order +generalizations sequences ; FROM: sequences.private => nth-unsafe set-nth-unsafe ; FROM: hashtables.private => tombstone? ; IN: cursors @@ -376,7 +377,7 @@ GENERIC: cursor-key-value ( cursor -- key value ) INSTANCE: input-cursor assoc-cursor M: input-cursor cursor-key-value - cursor-value first2 ; inline + cursor-value-unsafe first2 ; inline ! ! hashtable cursor @@ -422,7 +423,7 @@ M: hashtable-cursor cursor-key-value INSTANCE: hashtable-cursor input-cursor -M: hashtable-cursor cursor-value +M: hashtable-cursor cursor-value-unsafe cursor-key-value 2array ; inline INSTANCE: hashtable container @@ -468,7 +469,7 @@ M: zip-cursor inc-cursor ( cursor -- cursor' ) INSTANCE: zip-cursor assoc-cursor M: zip-cursor cursor-key-value - [ keys>> cursor-value ] [ values>> cursor-value ] bi ; inline + [ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline : zip-cursors ( a-begin a-end b-begin b-end -- begin end ) [ ] bi-curry@ bi* ; inline @@ -492,3 +493,27 @@ ALIAS: -2container- -assoc- : 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c ) pick 2map-as ; inline + +! +! generalized zips +! + +: -unzip- ( quot -- quot' ) + '[ [ keys>> cursor-value-unsafe ] [ values>> ] bi @ ] ; inline + +MACRO: nzip-cursors ( n -- ) 1 - [ zip-cursors ] n*quot ; + +: nall ( seqs... n -- begin end ) [ [ all ] swap napply ] [ nzip-cursors ] bi ; inline + +: nall- ( seqs... quot n -- begin end quot ) swap [ nall ] dip ; inline + +MACRO: -ncontainer- ( n -- ) + 1 - [ -unzip- ] n*quot [ -container- ] prepend ; + +: ncontainer- ( seqs... quot n -- begin end quot ) [ nall- ] [ -ncontainer- ] bi ; inline + +: neach ( seqs... quot n -- ) ncontainer- -each ; inline +: nmap-as ( seqs... quot exemplar n -- newseq ) + swap [ ncontainer- ] dip -map-as ; inline +: nmap ( seqs... quot n -- newseq ) + dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline From c70090bb8378538a94e844571e3499b2531bd095 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 17:02:10 -0700 Subject: [PATCH 028/123] cursors: -with- filter (e.g. foo H{ ... } [ ... ] assoc- -with- -each) --- extra/cursors/cursors.factor | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 94e83398bd..750540844a 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -517,3 +517,17 @@ MACRO: -ncontainer- ( n -- ) swap [ ncontainer- ] dip -map-as ; inline : nmap ( seqs... quot n -- newseq ) dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline + +! +! utilities +! + +: -with- ( invariant begin end quot -- begin end quot' ) + [ rot ] dip '[ [ _ ] dip @ ] ; inline + +: -2with- ( invariant invariant begin end quot -- begin end quot' ) + -with- -with- ; inline + +MACRO: -nwith- ( n -- ) + [ -with- ] n*quot ; + From e0358219ad96c2880836ac8d8caa21557048f838 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 18:05:41 -0700 Subject: [PATCH 029/123] cursors: some refactoring: - rename -container- to -in- - rename current -map- to -out- - rename "pipe-cursor" to "map-cursor" - have -map- and -map take the "to" cursor --- extra/cursors/cursors.factor | 89 +++++++++++++++++++----------------- 1 file changed, 46 insertions(+), 43 deletions(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 750540844a..a82f0e28a0 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -118,13 +118,22 @@ M: end-of-stream inc-cursor ; inline M: end-of-stream cursor-stream-ended? drop t ; inline ! -! basic iterator +! basic iterators ! : -each ( ... begin end quot: ( ... cursor -- ... ) -- ... ) [ '[ dup _ cursor>= ] ] [ '[ _ keep inc-cursor ] ] bi* until drop ; inline +: -in- ( quot -- quot' ) + '[ cursor-value-unsafe @ ] ; inline + +: -out- ( quot -- quot' ) + '[ _ keep set-cursor-value-unsafe ] ; inline + +: -out ( ... begin end quot: ( ... cursor -- ... value ) -- ... ) + -out- -each ; inline + ! ! numeric cursors ! @@ -217,13 +226,10 @@ GENERIC: end-cursor ( collection -- cursor ) MIXIN: container INSTANCE: container collection -: -container- ( quot -- quot' ) - '[ cursor-value-unsafe @ ] ; inline +: in- ( container quot -- begin end quot' ) + all- -in- ; inline -: container- ( container quot -- begin end quot' ) - all- -container- ; inline - -: each ( ... container quot: ( ... x -- ... ) -- ... ) container- -each ; inline +: each ( ... container quot: ( ... x -- ... ) -- ... ) in- -each ; inline INSTANCE: finite-stream-cursor container @@ -278,28 +284,31 @@ M: sequence-cursor set-cursor-value-unsafe [ n>> ] [ seq>> ] bi set-nth-unsafe ; M: sequence-cursor set-cursor-value [ n>> ] [ seq>> ] bi set-nth ; inline ! -! pipe cursor +! map cursor ! -TUPLE: pipe-cursor +TUPLE: map-cursor { from read-only } { to read-only } ; -C: pipe-cursor +C: map-cursor -INSTANCE: pipe-cursor forward-cursor +INSTANCE: map-cursor forward-cursor -M: pipe-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline -M: pipe-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline -M: pipe-cursor cursor= [ from>> ] bi@ cursor= ; inline -M: pipe-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi ; inline +M: map-cursor cursor-compatible? [ from>> ] bi@ cursor-compatible? ; inline +M: map-cursor cursor-valid? [ from>> ] [ to>> ] bi [ cursor-valid? ] both? ; inline +M: map-cursor cursor= [ from>> ] bi@ cursor= ; inline +M: map-cursor inc-cursor [ from>> inc-cursor ] [ to>> inc-cursor ] bi ; inline -INSTANCE: pipe-cursor output-cursor +INSTANCE: map-cursor output-cursor -M: pipe-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline -M: pipe-cursor set-cursor-value to>> set-cursor-value ; inline +M: map-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline +M: map-cursor set-cursor-value to>> set-cursor-value ; inline -: -pipe- ( begin end quot to -- begin' end' quot' ) - swap [ '[ _ ] bi@ ] dip '[ from>> @ ] ; inline +: -map- ( begin end quot to -- begin' end' quot' ) + swap [ '[ _ ] bi@ ] dip '[ from>> @ ] ; inline + +: -map ( begin end quot to -- begin' end' quot' ) + -map- -out ; inline ! ! pusher cursor @@ -328,30 +337,24 @@ M: random-access-cursor new-sequence-cursor M: forward-cursor new-sequence-cursor new-growable-cursor ; inline -: -into-sequence- ( begin end quot exemplar -- begin' end' quot' result ) - swap [ [ 2dup ] dip new-sequence-cursor ] dip swap [ swap -pipe- ] dip ; inline +: -into-sequence- ( begin end quot exemplar -- begin' end' quot' cursor result ) + [ 2over ] dip new-sequence-cursor ; inline -: -into-growable- ( begin end quot exemplar -- begin' end' quot' result ) - swap [ [ 2dup ] dip new-growable-cursor ] dip swap [ swap -pipe- ] dip ; inline +: -into-growable- ( begin end quot exemplar -- begin' end' quot' cursor result ) + [ 2over ] dip new-sequence-cursor ; inline ! -! map +! map combinators ! -: -map- ( quot -- quot' ) - '[ _ keep set-cursor-value-unsafe ] ; inline - -: -map ( ... begin end quot: ( ... cursor -- ... value ) -- ... ) - -map- -each ; inline - ! XXX generalize exemplar : -map-as ( ... begin end quot: ( ... cursor -- ... value ) exemplar -- ... newseq ) [ -into-sequence- [ -map ] dip ] keep like ; inline : map! ( ... container quot: ( ... x -- ... newx ) -- ... container ) - [ container- -map ] keep ; inline + [ in- -out ] keep ; inline : map-as ( ... container quot: ( ... x -- ... newx ) exemplar -- ... newseq ) - [ container- ] dip -map-as ; inline + [ in- ] dip -map-as ; inline : map ( ... container quot: ( ... x -- ... newx ) -- ... newcontainer ) over map-as ; inline @@ -480,16 +483,16 @@ M: zip-cursor cursor-key-value : 2all- ( a b quot -- begin end quot ) [ 2all ] dip ; inline -ALIAS: -2container- -assoc- +ALIAS: -2in- -assoc- -: 2container- ( a b quot -- begin end quot' ) - 2all- -2container- ; inline +: 2in- ( a b quot -- begin end quot' ) + 2all- -2in- ; inline : 2each ( ... a b quot: ( ... x y -- ... ) -- ... ) - 2container- -each ; inline + 2in- -each ; inline : 2map-as ( ... a b quot: ( ... x y -- ... z ) exemplar -- ... c ) - [ 2container- ] dip -map-as ; inline + [ 2in- ] dip -map-as ; inline : 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c ) pick 2map-as ; inline @@ -507,14 +510,14 @@ MACRO: nzip-cursors ( n -- ) 1 - [ zip-cursors ] n*quot ; : nall- ( seqs... quot n -- begin end quot ) swap [ nall ] dip ; inline -MACRO: -ncontainer- ( n -- ) - 1 - [ -unzip- ] n*quot [ -container- ] prepend ; +MACRO: -nin- ( n -- ) + 1 - [ -unzip- ] n*quot [ -in- ] prepend ; -: ncontainer- ( seqs... quot n -- begin end quot ) [ nall- ] [ -ncontainer- ] bi ; inline +: nin- ( seqs... quot n -- begin end quot ) [ nall- ] [ -nin- ] bi ; inline -: neach ( seqs... quot n -- ) ncontainer- -each ; inline +: neach ( seqs... quot n -- ) nin- -each ; inline : nmap-as ( seqs... quot exemplar n -- newseq ) - swap [ ncontainer- ] dip -map-as ; inline + swap [ nin- ] dip -map-as ; inline : nmap ( seqs... quot n -- newseq ) dup [ npick ] curry [ dip swap ] curry dip nmap-as ; inline From 96d2b44f3e806f27f1a2e06a2eeb8413200aca00 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 18:16:22 -0700 Subject: [PATCH 030/123] cursors: push the -out- part from -map into -map- --- extra/cursors/cursors.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index a82f0e28a0..5a3e7475c6 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -305,10 +305,10 @@ M: map-cursor set-cursor-value-unsafe to>> set-cursor-value-unsafe ; inline M: map-cursor set-cursor-value to>> set-cursor-value ; inline : -map- ( begin end quot to -- begin' end' quot' ) - swap [ '[ _ ] bi@ ] dip '[ from>> @ ] ; inline + swap [ '[ _ ] bi@ ] dip '[ from>> @ ] -out- ; inline : -map ( begin end quot to -- begin' end' quot' ) - -map- -out ; inline + -map- -each ; inline ! ! pusher cursor From e0435f6261d04d38563f288b8ca7e801bd3610df Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 24 Mar 2010 19:02:27 -0700 Subject: [PATCH 031/123] cursors: typo in -into-growable- --- extra/cursors/cursors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 5a3e7475c6..030e9ab72f 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -341,7 +341,7 @@ M: forward-cursor new-sequence-cursor [ 2over ] dip new-sequence-cursor ; inline : -into-growable- ( begin end quot exemplar -- begin' end' quot' cursor result ) - [ 2over ] dip new-sequence-cursor ; inline + [ 2over ] dip new-growable-cursor ; inline ! ! map combinators From 63c7513e2d7db2113d3145dbba388a526b6a3625 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 25 Mar 2010 09:21:49 -0400 Subject: [PATCH 032/123] websites.concatenative: fix stylesheet --- extra/websites/concatenative/page.css | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/websites/concatenative/page.css b/extra/websites/concatenative/page.css index 8115627742..dc0c57b7d5 100644 --- a/extra/websites/concatenative/page.css +++ b/extra/websites/concatenative/page.css @@ -9,7 +9,7 @@ body, button { border: none; } -a, .link { +a:link, a:visited, .link { color: #222; border-bottom:1px dotted #666; text-decoration:none; From a566d8cc6b2daa14289c6fce71b02b95354f118c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 26 Mar 2010 03:42:07 -0400 Subject: [PATCH 033/123] lexer: each-token and map-tokens did not handle EOF properly --- core/lexer/lexer.factor | 15 +- core/parser/parser-tests.factor | 514 ++++++++++++++++---------------- core/syntax/syntax.factor | 4 +- 3 files changed, 268 insertions(+), 265 deletions(-) diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 7f6324c251..f9554fa9bb 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -86,8 +86,7 @@ M: lexer skip-word ( lexer -- ) : scan ( -- str/f ) lexer get parse-token ; -PREDICATE: unexpected-eof < unexpected - got>> not ; +PREDICATE: unexpected-eof < unexpected got>> not ; : unexpected-eof ( word -- * ) f unexpected ; @@ -97,14 +96,15 @@ PREDICATE: unexpected-eof < unexpected [ unexpected-eof ] if* ; -: (each-token) ( end quot -- pred quot ) - [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline - : each-token ( ... end quot: ( ... token -- ... ) -- ... ) - (each-token) while drop ; inline + [ scan ] 2dip { + { [ 2over = ] [ 3drop ] } + { [ pick not ] [ drop unexpected-eof ] } + [ [ nip call ] [ each-token ] 2bi ] + } cond ; inline recursive : map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq ) - (each-token) produce nip ; inline + collector [ each-token ] dip ; inline : parse-tokens ( end -- seq ) [ ] map-tokens ; @@ -112,6 +112,7 @@ PREDICATE: unexpected-eof < unexpected TUPLE: lexer-error line column line-text parsing-words error ; M: lexer-error error-file error>> error-file ; + M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; : ( msg -- error ) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 266a65b957..ac2310d3f9 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -7,332 +7,334 @@ vocabs.parser words.symbol multiline source-files.errors tools.crossref grouping ; IN: parser.tests +[ 1 [ 2 [ 3 ] 4 ] 5 ] +[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] +unit-test + +[ t t f f ] +[ "t t f f" eval( -- ? ? ? ? ) ] +unit-test + +[ "hello world" ] +[ "\"hello world\"" eval( -- string ) ] +unit-test + +[ "\n\r\t\\" ] +[ "\"\\n\\r\\t\\\\\"" eval( -- string ) ] +unit-test + +[ "hello world" ] [ - [ 1 [ 2 [ 3 ] 4 ] 5 ] - [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] - unit-test + "IN: parser.tests : hello ( -- str ) \"hello world\" ;" + eval( -- ) "USE: parser.tests hello" eval( -- string ) +] unit-test - [ t t f f ] - [ "t t f f" eval( -- ? ? ? ? ) ] - unit-test +[ ] +[ "! This is a comment, people." eval( -- ) ] +unit-test - [ "hello world" ] - [ "\"hello world\"" eval( -- string ) ] - unit-test +! Test escapes - [ "\n\r\t\\" ] - [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ] - unit-test +[ " " ] +[ "\"\\u000020\"" eval( -- string ) ] +unit-test - [ "hello world" ] - [ - "IN: parser.tests : hello ( -- str ) \"hello world\" ;" - eval( -- ) "USE: parser.tests hello" eval( -- string ) - ] unit-test +[ "'" ] +[ "\"\\u000027\"" eval( -- string ) ] +unit-test - [ ] - [ "! This is a comment, people." eval( -- ) ] - unit-test +! Test EOL comments in multiline strings. +[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test - ! Test escapes +[ word ] [ \ f class ] unit-test - [ " " ] - [ "\"\\u000020\"" eval( -- string ) ] - unit-test +! Test stack effect parsing - [ "'" ] - [ "\"\\u000027\"" eval( -- string ) ] - unit-test +: effect-parsing-test ( a b -- c ) + ; - ! Test EOL comments in multiline strings. - [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test +[ t ] [ + "effect-parsing-test" "parser.tests" lookup + \ effect-parsing-test eq? +] unit-test - [ word ] [ \ f class ] unit-test +[ T{ effect f { "a" "b" } { "c" } f } ] +[ \ effect-parsing-test "declared-effect" word-prop ] unit-test - ! Test stack effect parsing +: baz ( a b -- * ) 2array throw ; - : effect-parsing-test ( a b -- c ) + ; +[ t ] +[ \ baz "declared-effect" word-prop terminated?>> ] +unit-test - [ t ] [ - "effect-parsing-test" "parser.tests" lookup - \ effect-parsing-test eq? - ] unit-test +[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test - [ T{ effect f { "a" "b" } { "c" } f } ] - [ \ effect-parsing-test "declared-effect" word-prop ] unit-test +[ t ] [ + "effect-parsing-test" "parser.tests" lookup + \ effect-parsing-test eq? +] unit-test - : baz ( a b -- * ) 2array throw ; +[ T{ effect f { "a" "b" } { "d" } f } ] +[ \ effect-parsing-test "declared-effect" word-prop ] unit-test - [ t ] - [ \ baz "declared-effect" word-prop terminated?>> ] - unit-test +[ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail - [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test +! Funny bug +[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test - [ t ] [ - "effect-parsing-test" "parser.tests" lookup - \ effect-parsing-test eq? - ] unit-test +! These should throw errors +[ "HEX: zzz" eval( -- obj ) ] must-fail +[ "OCT: 999" eval( -- obj ) ] must-fail +[ "BIN: --0" eval( -- obj ) ] must-fail - [ T{ effect f { "a" "b" } { "d" } f } ] - [ \ effect-parsing-test "declared-effect" word-prop ] unit-test +DEFER: foo - ! Funny bug - [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test +"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- ) - [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail +[ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test - ! These should throw errors - [ "HEX: zzz" eval( -- obj ) ] must-fail - [ "OCT: 999" eval( -- obj ) ] must-fail - [ "BIN: --0" eval( -- obj ) ] must-fail +"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- ) - DEFER: foo +[ t ] [ + "USE: parser.tests \\ foo" eval( -- word ) + "foo" "parser.tests" lookup eq? +] unit-test - "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- ) +! parse-tokens should do the right thing on EOF +[ "USING: kernel" eval( -- ) ] +[ error>> T{ unexpected { want ";" } } = ] must-fail-with - [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test +! Test smudging - "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- ) +[ 1 ] [ + "IN: parser.tests : smudge-me ( -- ) ;" "foo" + parse-stream drop - [ t ] [ - "USE: parser.tests \\ foo" eval( -- word ) - "foo" "parser.tests" lookup eq? - ] unit-test + "foo" source-file definitions>> first assoc-size +] unit-test - ! Test smudging +[ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test - [ 1 ] [ - "IN: parser.tests : smudge-me ( -- ) ;" "foo" - parse-stream drop +[ ] [ + "IN: parser.tests : smudge-me-more ( -- ) ;" "foo" + parse-stream drop +] unit-test - "foo" source-file definitions>> first assoc-size - ] unit-test +[ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test +[ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test - [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test +[ 3 ] [ + "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" "foo" + parse-stream drop - [ ] [ - "IN: parser.tests : smudge-me-more ( -- ) ;" "foo" - parse-stream drop - ] unit-test + "foo" source-file definitions>> first assoc-size +] unit-test - [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test - [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test +[ 1 ] [ + "IN: parser.tests USING: arrays ; M: array smudge-me ;" "bar" + parse-stream drop - [ 3 ] [ - "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" "foo" - parse-stream drop + "bar" source-file definitions>> first assoc-size +] unit-test - "foo" source-file definitions>> first assoc-size - ] unit-test +[ 2 ] [ + "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" "foo" + parse-stream drop - [ 1 ] [ - "IN: parser.tests USING: arrays ; M: array smudge-me ;" "bar" - parse-stream drop + "foo" source-file definitions>> first assoc-size +] unit-test - "bar" source-file definitions>> first assoc-size - ] unit-test +[ t ] [ + array "smudge-me" "parser.tests" lookup order member-eq? +] unit-test - [ 2 ] [ - "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" "foo" - parse-stream drop +[ t ] [ + integer "smudge-me" "parser.tests" lookup order member-eq? +] unit-test - "foo" source-file definitions>> first assoc-size - ] unit-test - - [ t ] [ - array "smudge-me" "parser.tests" lookup order member-eq? - ] unit-test - - [ t ] [ - integer "smudge-me" "parser.tests" lookup order member-eq? - ] unit-test - - [ f ] [ - string "smudge-me" "parser.tests" lookup order member-eq? - ] unit-test +[ f ] [ + string "smudge-me" "parser.tests" lookup order member-eq? +] unit-test - [ ] [ - "IN: parser.tests USE: math 2 2 +" "a" - parse-stream drop - ] unit-test - - [ t ] [ - "a" \ + usage member? - ] unit-test +[ ] [ + "IN: parser.tests USE: math 2 2 +" "a" + parse-stream drop +] unit-test - [ ] [ - "IN: parser.tests USE: math 2 2 -" "a" - parse-stream drop - ] unit-test - - [ f ] [ - "a" \ + usage member? - ] unit-test - - [ ] [ - "a" source-files get delete-at - 2 [ - "IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;" - "a" parse-stream drop - ] times - ] unit-test - +[ t ] [ + "a" \ + usage member? +] unit-test + +[ ] [ + "IN: parser.tests USE: math 2 2 -" "a" + parse-stream drop +] unit-test + +[ f ] [ + "a" \ + usage member? +] unit-test + +[ ] [ "a" source-files get delete-at - - [ - "IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error" - "a" parse-stream - ] [ source-file-error? ] must-fail-with - - [ t ] [ - "y" "parser.tests" lookup >boolean - ] unit-test - - [ f ] [ - "IN: parser.tests : x ( -- ) ;" + 2 [ + "IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;" "a" parse-stream drop - - "y" "parser.tests" lookup - ] unit-test + ] times +] unit-test - ! Test new forward definition logic - [ ] [ - "IN: axx : axx ( -- ) ;" - "axx" parse-stream drop - ] unit-test +"a" source-files get delete-at - [ ] [ - "USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;" - "bxx" parse-stream drop - ] unit-test +[ + "IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error" + "a" parse-stream +] [ source-file-error? ] must-fail-with - ! So we move the bxx word to axx... - [ ] [ - "IN: axx : axx ( -- ) ; : bxx ( -- ) ;" - "axx" parse-stream drop - ] unit-test +[ t ] [ + "y" "parser.tests" lookup >boolean +] unit-test - [ t ] [ "bxx" "axx" lookup >boolean ] unit-test - - ! And reload the file that uses it... - [ ] [ - "USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;" - "bxx" parse-stream drop - ] unit-test +[ f ] [ + "IN: parser.tests : x ( -- ) ;" + "a" parse-stream drop - ! And hope not to get a forward-error! + "y" "parser.tests" lookup +] unit-test - ! Turning a generic into a non-generic could cause all - ! kinds of funnyness - [ ] [ - "IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;" - "ayy" parse-stream drop - ] unit-test +! Test new forward definition logic +[ ] [ + "IN: axx : axx ( -- ) ;" + "axx" parse-stream drop +] unit-test - [ ] [ - "IN: ayy USE: kernel : ayy ( -- ) ;" - "ayy" parse-stream drop - ] unit-test +[ ] [ + "USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;" + "bxx" parse-stream drop +] unit-test - [ ] [ - "IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )" - "azz" parse-stream drop - ] unit-test +! So we move the bxx word to axx... +[ ] [ + "IN: axx : axx ( -- ) ; : bxx ( -- ) ;" + "axx" parse-stream drop +] unit-test - [ ] [ - "USE: azz M: my-class a-generic ;" - "azz-2" parse-stream drop - ] unit-test +[ t ] [ "bxx" "axx" lookup >boolean ] unit-test - [ ] [ - "IN: azz GENERIC: a-generic ( a -- b )" - "azz" parse-stream drop - ] unit-test +! And reload the file that uses it... +[ ] [ + "USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;" + "bxx" parse-stream drop +] unit-test - [ ] [ - "USE: azz USE: math M: integer a-generic ;" - "azz-2" parse-stream drop - ] unit-test +! And hope not to get a forward-error! - [ ] [ - "IN: parser.tests : ( -- ) ; : bogus ( -- error ) ;" - "bogus-error" parse-stream drop - ] unit-test +! Turning a generic into a non-generic could cause all +! kinds of funnyness +[ ] [ + "IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;" + "ayy" parse-stream drop +] unit-test - [ ] [ - "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- error ) ;" - "bogus-error" parse-stream drop - ] unit-test +[ ] [ + "IN: ayy USE: kernel : ayy ( -- ) ;" + "ayy" parse-stream drop +] unit-test - ! Problems with class predicates -vs- ordinary words - [ ] [ - "IN: parser.tests TUPLE: killer ;" - "removing-the-predicate" parse-stream drop - ] unit-test +[ ] [ + "IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )" + "azz" parse-stream drop +] unit-test - [ ] [ - "IN: parser.tests GENERIC: killer? ( a -- b )" - "removing-the-predicate" parse-stream drop - ] unit-test - - [ t ] [ - "killer?" "parser.tests" lookup >boolean - ] unit-test +[ ] [ + "USE: azz M: my-class a-generic ;" + "azz-2" parse-stream drop +] unit-test - [ - "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )" - "removing-the-predicate" parse-stream - ] [ error>> error>> error>> redefine-error? ] must-fail-with +[ ] [ + "IN: azz GENERIC: a-generic ( a -- b )" + "azz" parse-stream drop +] unit-test - [ - "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" - "redefining-a-class-1" parse-stream - ] [ error>> error>> error>> redefine-error? ] must-fail-with +[ ] [ + "USE: azz USE: math M: integer a-generic ;" + "azz-2" parse-stream drop +] unit-test - [ ] [ - "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" - "redefining-a-class-2" parse-stream drop - ] unit-test +[ ] [ + "IN: parser.tests : ( -- ) ; : bogus ( -- error ) ;" + "bogus-error" parse-stream drop +] unit-test - [ - "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;" - "redefining-a-class-3" parse-stream drop - ] [ error>> error>> error>> redefine-error? ] must-fail-with +[ ] [ + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- error ) ;" + "bogus-error" parse-stream drop +] unit-test - [ ] [ - "IN: parser.tests TUPLE: class-fwd-test ;" - "redefining-a-class-3" parse-stream drop - ] unit-test +! Problems with class predicates -vs- ordinary words +[ ] [ + "IN: parser.tests TUPLE: killer ;" + "removing-the-predicate" parse-stream drop +] unit-test - [ - "IN: parser.tests \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] [ error>> error>> error>> no-word-error? ] must-fail-with +[ ] [ + "IN: parser.tests GENERIC: killer? ( a -- b )" + "removing-the-predicate" parse-stream drop +] unit-test - [ ] [ - "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] unit-test +[ t ] [ + "killer?" "parser.tests" lookup >boolean +] unit-test - [ - "IN: parser.tests \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] [ error>> error>> error>> no-word-error? ] must-fail-with +[ + "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )" + "removing-the-predicate" parse-stream +] [ error>> error>> error>> redefine-error? ] must-fail-with - [ - "IN: parser.tests : foo ( -- ) ; TUPLE: foo ;" - "redefining-a-class-4" parse-stream drop - ] [ error>> error>> error>> redefine-error? ] must-fail-with +[ + "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "redefining-a-class-1" parse-stream +] [ error>> error>> error>> redefine-error? ] must-fail-with - [ ] [ - "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- ) - ] unit-test +[ ] [ + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" + "redefining-a-class-2" parse-stream drop +] unit-test - [ - "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- ) - ] must-fail -] with-file-vocabs +[ + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;" + "redefining-a-class-3" parse-stream drop +] [ error>> error>> error>> redefine-error? ] must-fail-with + +[ ] [ + "IN: parser.tests TUPLE: class-fwd-test ;" + "redefining-a-class-3" parse-stream drop +] unit-test + +[ + "IN: parser.tests \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop +] [ error>> error>> error>> no-word-error? ] must-fail-with + +[ ] [ + "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" + "redefining-a-class-3" parse-stream drop +] unit-test + +[ + "IN: parser.tests \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop +] [ error>> error>> error>> no-word-error? ] must-fail-with + +[ + "IN: parser.tests : foo ( -- ) ; TUPLE: foo ;" + "redefining-a-class-4" parse-stream drop +] [ error>> error>> error>> redefine-error? ] must-fail-with + +[ ] [ + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- ) +] unit-test + +[ + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- ) +] must-fail [ ] [ "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- ) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 84a753fb1b..bd70b0be62 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays byte-arrays byte-vectors definitions generic hashtables kernel math namespaces parser lexer sequences strings @@ -125,7 +125,7 @@ IN: bootstrap.syntax ] define-core-syntax "SYMBOLS:" [ - ";" [ create-in dup reset-generic define-symbol ] each-token + ";" [ create-in [ reset-generic ] [ define-symbol ] bi ] each-token ] define-core-syntax "SINGLETONS:" [ From dde21c3cc40cfd6b29296e5b10020c2c76b0c22f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 26 Mar 2010 16:31:48 -0400 Subject: [PATCH 034/123] lexer: fix output type of map-tokens --- core/lexer/lexer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index f9554fa9bb..7939a49d7a 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -104,7 +104,7 @@ PREDICATE: unexpected-eof < unexpected got>> not ; } cond ; inline recursive : map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq ) - collector [ each-token ] dip ; inline + collector [ each-token ] dip { } like ; inline : parse-tokens ( end -- seq ) [ ] map-tokens ; From 560c119cd2482ce3f96644be564294ed5afd1f22 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 26 Mar 2010 22:44:43 -0400 Subject: [PATCH 035/123] vm: actually use context callstacks when running code --- basis/bootstrap/image/image.factor | 4 +- basis/command-line/command-line-docs.factor | 4 +- basis/compiler/alien/alien.factor | 6 +- basis/compiler/codegen/codegen.factor | 5 +- basis/compiler/constants/constants.factor | 2 + basis/compiler/tests/alien.factor | 17 +- basis/cpu/architecture/architecture.factor | 8 +- basis/cpu/ppc/bootstrap.factor | 10 +- basis/cpu/ppc/ppc.factor | 10 +- basis/cpu/x86/32/32.factor | 22 +- basis/cpu/x86/32/bootstrap.factor | 46 ++- basis/cpu/x86/64/64.factor | 34 +- basis/cpu/x86/64/bootstrap.factor | 56 ++-- basis/cpu/x86/bootstrap.factor | 54 ++-- basis/cpu/x86/x86.factor | 3 - .../known-words/known-words.factor | 39 ++- basis/vm/vm.factor | 8 +- core/alien/alien.factor | 23 +- core/bootstrap/primitives.factor | 5 + vm/callbacks.cpp | 3 +- vm/callstack.cpp | 2 +- vm/callstack.hpp | 2 +- vm/code_block_visitor.hpp | 2 +- vm/contexts.cpp | 155 +++++++--- vm/contexts.hpp | 36 ++- vm/cpu-ppc.hpp | 2 + vm/cpu-x86.hpp | 2 + vm/data_heap.cpp | 2 +- vm/debug.cpp | 8 +- vm/errors.cpp | 8 +- vm/factor.cpp | 21 +- vm/image.hpp | 2 +- vm/primitives.hpp | 290 +++++++++--------- vm/slot_visitor.hpp | 14 +- vm/vm.cpp | 6 + vm/vm.hpp | 52 ++-- 36 files changed, 557 insertions(+), 406 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 3552f0bd92..141a77d2b2 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -129,8 +129,8 @@ SYMBOL: jit-literals : jit-vm ( offset rc -- ) [ jit-parameter ] dip rt-vm jit-rel ; -: jit-dlsym ( name library rc -- ) - rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ; +: jit-dlsym ( name rc -- ) + rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ; :: jit-conditional ( test-quot false-quot -- ) [ 0 test-quot call ] B{ } make length :> len diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 9a69614766..b17f8250dd 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } + { { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" } { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } } { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } + { { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" } { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } } -"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ; +"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ; ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap" "A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:" diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index 6a63b719df..7426d7e940 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -1,17 +1,17 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces make math sequences layouts alien.c-types cpu.architecture ; IN: compiler.alien -: large-struct? ( ctype -- ? ) +: large-struct? ( type -- ? ) dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ; : alien-parameters ( params -- seq ) dup parameters>> swap return>> large-struct? [ void* prefix ] when ; -: alien-return ( params -- ctype ) +: alien-return ( params -- type ) return>> dup large-struct? [ drop void ] when ; : c-type-stack-align ( type -- align ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 73cfd6b86e..430bd9550d 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -458,7 +458,7 @@ M: ##alien-indirect generate-insn ! Generate code for boxing input parameters in a callback. [ dup \ %save-param-reg move-parameters - %nest-stacks + %begin-callback box-parameters ] with-param-regs ; @@ -482,5 +482,4 @@ M: ##alien-callback generate-insn params>> [ registers>objects ] [ wrap-callback-quot %alien-callback ] - [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ] - tri ; + [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 73e77cca4d..9769b72801 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -28,10 +28,12 @@ CONSTANT: deck-bits 18 : callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline : callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline : vm-context-offset ( -- n ) 0 bootstrap-cells ; inline +: vm-spare-context-offset ( -- n ) 1 bootstrap-cells ; inline : context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline : context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline : context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline : context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline +: context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index ad8dac3ef9..692dbee4c5 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -4,7 +4,7 @@ compiler continuations effects io io.backend io.pathnames io.streams.string kernel math memory namespaces namespaces.private parser quotations sequences specialized-arrays stack-checker stack-checker.errors -system threads tools.test words alien.complex ; +system threads tools.test words alien.complex concurrency.promises ; FROM: alien.c-types => float short ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: char @@ -579,6 +579,21 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; ] unless +! Test interaction between threads and callbacks +: thread-callback-1 ( -- callback ) + int { } "cdecl" [ yield 100 ] alien-callback ; + +: thread-callback-2 ( -- callback ) + int { } "cdecl" [ yield 200 ] alien-callback ; + +: thread-callback-invoker ( callback -- n ) + int { } "cdecl" alien-indirect ; + + "p" set +[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread +[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test +[ 100 ] [ "p" get ?promise ] unit-test + ! Regression: calling an undefined function would raise a protection fault FUNCTION: void this_does_not_exist ( ) ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 4d99b5a0ed..b617746a06 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -582,13 +582,13 @@ HOOK: %prepare-alien-indirect cpu ( -- ) HOOK: %alien-indirect cpu ( -- ) +HOOK: %begin-callback cpu ( -- ) + HOOK: %alien-callback cpu ( quot -- ) -HOOK: %callback-value cpu ( ctype -- ) +HOOK: %end-callback cpu ( -- ) -HOOK: %nest-stacks cpu ( -- ) - -HOOK: %unnest-stacks cpu ( -- ) +HOOK: %end-callback-value cpu ( c-type -- ) HOOK: callback-return-rewind cpu ( params -- n ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index b2ae9c4e73..58c0a4ef7b 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -267,7 +267,7 @@ CONSTANT: ctx-reg 16 jit-save-context 3 6 MR 4 vm-reg MR - 0 5 LOAD32 "inline_cache_miss" f rc-absolute-ppc-2/2 jit-dlsym + 0 5 LOAD32 "inline_cache_miss" rc-absolute-ppc-2/2 jit-dlsym 5 MTLR BLRL jit-restore-context ; @@ -392,7 +392,7 @@ CONSTANT: ctx-reg 16 1 3 MR ! Call memcpy; arguments are now in the correct registers 1 1 -64 STWU - 0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym + 0 2 LOAD32 "factor_memcpy" rc-absolute-ppc-2/2 jit-dlsym 2 MTLR BLRL 1 1 0 LWZ @@ -405,7 +405,7 @@ CONSTANT: ctx-reg 16 [ jit-save-context 4 vm-reg MR - 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym + 0 2 LOAD32 "lazy_jit_compile" rc-absolute-ppc-2/2 jit-dlsym 2 MTLR BLRL 5 3 quot-entry-point-offset LWZ @@ -665,7 +665,7 @@ CONSTANT: ctx-reg 16 [ BNO ] [ 5 vm-reg MR - 0 6 LOAD32 func f rc-absolute-ppc-2/2 jit-dlsym + 0 6 LOAD32 func rc-absolute-ppc-2/2 jit-dlsym 6 MTLR BLRL ] @@ -689,7 +689,7 @@ CONSTANT: ctx-reg 16 [ 4 4 tag-bits get SRAWI 5 vm-reg MR - 0 6 LOAD32 "overflow_fixnum_multiply" f rc-absolute-ppc-2/2 jit-dlsym + 0 6 LOAD32 "overflow_fixnum_multiply" rc-absolute-ppc-2/2 jit-dlsym 6 MTLR BLRL ] diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 6d84aad8d5..36beb86792 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -716,7 +716,7 @@ M: ppc %callback-value ( ctype -- ) 3 1 0 local@ STW 3 %load-vm-addr ! Restore data/call/retain stacks - "unnest_stacks" f %alien-invoke + "unnest_context" f %alien-invoke ! Restore top of data stack 3 1 0 local@ LWZ ! Unbox former top of data stack to return registers @@ -757,13 +757,13 @@ M: ppc %box-small-struct ( c-type -- ) 4 3 4 LWZ 3 3 0 LWZ ; -M: ppc %nest-stacks ( -- ) +M: ppc %nest-context ( -- ) 3 %load-vm-addr - "nest_stacks" f %alien-invoke ; + "nest_context" f %alien-invoke ; -M: ppc %unnest-stacks ( -- ) +M: ppc %unnest-context ( -- ) 3 %load-vm-addr - "unnest_stacks" f %alien-invoke ; + "unnest_context" f %alien-invoke ; M: ppc %unbox-small-struct ( size -- ) heap-size cell align cell /i { diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b8b621ee11..09f1ecb32b 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -228,14 +228,6 @@ M:: x86.32 %unbox-large-struct ( n c-type -- ) 0 stack@ EAX MOV "to_value_struct" f %alien-invoke ; -M: x86.32 %nest-stacks ( -- ) - 0 save-vm-ptr - "nest_stacks" f %alien-invoke ; - -M: x86.32 %unnest-stacks ( -- ) - 0 save-vm-ptr - "unnest_stacks" f %alien-invoke ; - M: x86.32 %prepare-alien-indirect ( -- ) EAX ds-reg [] MOV ds-reg 4 SUB @@ -247,18 +239,24 @@ M: x86.32 %prepare-alien-indirect ( -- ) M: x86.32 %alien-indirect ( -- ) EBP CALL ; +M: x86.32 %begin-callback ( -- ) + 0 save-vm-ptr + "begin_callback" f %alien-invoke ; + M: x86.32 %alien-callback ( quot -- ) EAX EDX %restore-context EAX swap %load-reference EAX quot-entry-point-offset [+] CALL EAX EDX %save-context ; -M: x86.32 %callback-value ( ctype -- ) +M: x86.32 %end-callback ( -- ) + 0 save-vm-ptr + "end_callback" f %alien-invoke ; + +M: x86.32 %end-callback-value ( ctype -- ) %pop-context-stack 4 stack@ EAX MOV - 0 save-vm-ptr - ! Restore data/call/retain stacks - "unnest_stacks" f %alien-invoke + %end-callback ! Place former top of data stack back in EAX EAX 4 stack@ MOV ! Unbox EAX diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index cf2d09501c..c7457d2732 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -16,17 +16,20 @@ IN: bootstrap.x86 : temp1 ( -- reg ) EDX ; : temp2 ( -- reg ) ECX ; : temp3 ( -- reg ) EBX ; -: safe-reg ( -- reg ) EAX ; : stack-reg ( -- reg ) ESP ; : frame-reg ( -- reg ) EBP ; : vm-reg ( -- reg ) ECX ; : ctx-reg ( -- reg ) EBP ; : nv-regs ( -- seq ) { ESI EDI EBX } ; +: nv-reg ( -- reg ) nv-regs first ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; : fixnum>slot@ ( -- ) temp0 2 SAR ; : rex-length ( -- n ) 0 ; +: jit-call ( name -- ) + 0 CALL rc-relative jit-dlsym ; + [ ! save stack frame size stack-frame-size PUSH @@ -49,7 +52,7 @@ IN: bootstrap.x86 ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) - EDX RSP -4 [+] LEA + EDX ESP -4 [+] LEA ctx-reg context-callstack-top-offset [+] EDX MOV ctx-reg context-datastack-offset [+] ds-reg MOV ctx-reg context-retainstack-offset [+] rs-reg MOV ; @@ -70,18 +73,37 @@ IN: bootstrap.x86 ] jit-primitive jit-define [ - ! Load quotation + jit-load-vm + ESP [] vm-reg MOV + "begin_callback" jit-call + + ! load quotation - EBP is ctx-reg so it will get clobbered + ! later on EAX EBP 8 [+] MOV - ! save ctx->callstack_bottom, load ds, rs registers + jit-load-vm jit-load-context jit-restore-context - EDX stack-reg stack-frame-size 4 - [+] LEA - ctx-reg context-callstack-bottom-offset [+] EDX MOV + + ! save C callstack pointer + ctx-reg context-callstack-save-offset [+] ESP MOV + + ! load Factor callstack pointer + ESP ctx-reg context-callstack-bottom-offset [+] MOV + ESP 4 ADD + ! call the quotation EAX quot-entry-point-offset [+] CALL - ! save ds, rs registers + + jit-load-vm + jit-load-context jit-save-context + + ! load C callstack pointer + ESP ctx-reg context-callstack-save-offset [+] MOV + + ESP [] vm-reg MOV + "end_callback" jit-call ] \ c-to-factor define-sub-primitive [ @@ -137,7 +159,7 @@ IN: bootstrap.x86 EDX PUSH EBP PUSH EAX PUSH - 0 CALL "factor_memcpy" f rc-relative jit-dlsym + "factor_memcpy" jit-call ESP 12 ADD ! Return with new callstack 0 RET @@ -153,7 +175,7 @@ IN: bootstrap.x86 ESP 4 [+] vm-reg MOV ! Call VM - 0 CALL "lazy_jit_compile" f rc-relative jit-dlsym + "lazy_jit_compile" jit-call ] [ EAX quot-entry-point-offset [+] CALL ] [ EAX quot-entry-point-offset [+] JMP ] @@ -171,7 +193,7 @@ IN: bootstrap.x86 jit-save-context ESP 4 [+] vm-reg MOV ESP [] EBX MOV - 0 CALL "inline_cache_miss" f rc-relative jit-dlsym + "inline_cache_miss" jit-call jit-restore-context ; [ jit-load-return-address jit-inline-cache-miss ] @@ -200,7 +222,7 @@ IN: bootstrap.x86 ESP [] EAX MOV ESP 4 [+] EDX MOV ESP 8 [+] vm-reg MOV - [ 0 CALL ] dip f rc-relative jit-dlsym + jit-call ] jit-conditional ; @@ -225,7 +247,7 @@ IN: bootstrap.x86 ESP [] EBX MOV ESP 4 [+] EBP MOV ESP 8 [+] vm-reg MOV - 0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym + "overflow_fixnum_multiply" jit-call ] jit-conditional ] \ fixnum* define-sub-primitive diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 856127aedf..04f64f96b6 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -38,6 +38,7 @@ M: x86.64 machine-registers } ; : vm-reg ( -- reg ) R13 ; inline +: nv-reg ( -- reg ) RBX ; inline M: x86.64 %mov-vm-ptr ( reg -- ) vm-reg MOV ; @@ -215,23 +216,19 @@ M: x86.64 %alien-invoke rc-absolute-cell rel-dlsym R11 CALL ; -M: x86.64 %nest-stacks ( -- ) - param-reg-0 %mov-vm-ptr - "nest_stacks" f %alien-invoke ; - -M: x86.64 %unnest-stacks ( -- ) - param-reg-0 %mov-vm-ptr - "unnest_stacks" f %alien-invoke ; - M: x86.64 %prepare-alien-indirect ( -- ) param-reg-0 ds-reg [] MOV ds-reg 8 SUB param-reg-1 %mov-vm-ptr "pinned_alien_offset" f %alien-invoke - RBP RAX MOV ; + nv-reg RAX MOV ; M: x86.64 %alien-indirect ( -- ) - RBP CALL ; + nv-reg CALL ; + +M: x86.64 %begin-callback ( -- ) + param-reg-0 %mov-vm-ptr + "begin_callback" f %alien-invoke ; M: x86.64 %alien-callback ( quot -- ) param-reg-0 param-reg-1 %restore-context @@ -239,16 +236,15 @@ M: x86.64 %alien-callback ( quot -- ) param-reg-0 quot-entry-point-offset [+] CALL param-reg-0 param-reg-1 %save-context ; -M: x86.64 %callback-value ( ctype -- ) - %pop-context-stack - RSP 8 SUB - param-reg-0 PUSH +M: x86.64 %end-callback ( -- ) param-reg-0 %mov-vm-ptr - ! Restore data/call/retain stacks - "unnest_stacks" f %alien-invoke - ! Put former top of data stack in param-reg-0 - param-reg-0 POP - RSP 8 ADD + "end_callback" f %alien-invoke ; + +M: x86.64 %end-callback-value ( ctype -- ) + %pop-context-stack + nv-reg param-reg-0 MOV + %end-callback + param-reg-0 nv-reg MOV ! Unbox former top of data stack to return registers unbox-return ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index bc560580fa..2da9f7564e 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -16,7 +16,7 @@ IN: bootstrap.x86 : temp2 ( -- reg ) RDX ; : temp3 ( -- reg ) RBX ; : return-reg ( -- reg ) RAX ; -: safe-reg ( -- reg ) RAX ; +: nv-reg ( -- reg ) nv-regs first ; : stack-reg ( -- reg ) RSP ; : frame-reg ( -- reg ) RBP ; : ctx-reg ( -- reg ) R12 ; @@ -26,13 +26,17 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 1 ; +: jit-call ( name -- ) + RAX 0 MOV rc-absolute-cell jit-dlsym + RAX CALL ; + [ ! load entry point - safe-reg 0 MOV rc-absolute-cell rt-this jit-rel + RAX 0 MOV rc-absolute-cell rt-this jit-rel ! save stack frame size stack-frame-size PUSH ! push entry point - safe-reg PUSH + RAX PUSH ! alignment RSP stack-frame-size 3 bootstrap-cells - SUB ] jit-prolog jit-define @@ -47,8 +51,8 @@ IN: bootstrap.x86 : jit-save-context ( -- ) jit-load-context - safe-reg RSP -8 [+] LEA - ctx-reg context-callstack-top-offset [+] safe-reg MOV + RAX RSP -8 [+] LEA + ctx-reg context-callstack-top-offset [+] RAX MOV ctx-reg context-datastack-offset [+] ds-reg MOV ctx-reg context-retainstack-offset [+] rs-reg MOV ; @@ -67,13 +71,31 @@ IN: bootstrap.x86 ] jit-primitive jit-define [ + nv-reg arg1 MOV + + arg1 vm-reg MOV + "begin_callback" jit-call + jit-restore-context - ! save ctx->callstack_bottom - safe-reg stack-reg stack-frame-size 8 - [+] LEA - ctx-reg context-callstack-bottom-offset [+] safe-reg MOV + + ! save C callstack pointer + ctx-reg context-callstack-save-offset [+] stack-reg MOV + + ! load Factor callstack pointer + stack-reg ctx-reg context-callstack-bottom-offset [+] MOV + stack-reg 8 ADD + ! call the quotation + arg1 nv-reg MOV arg1 quot-entry-point-offset [+] CALL + jit-save-context + + ! load C callstack pointer + stack-reg ctx-reg context-callstack-save-offset [+] MOV + + arg1 vm-reg MOV + "end_callback" jit-call ] \ c-to-factor define-sub-primitive [ @@ -124,8 +146,7 @@ IN: bootstrap.x86 ! Call memcpy; arguments are now in the correct registers ! Create register shadow area for Win64 RSP 32 SUB - safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym - safe-reg CALL + "factor_memcpy" jit-call ! Tear down register shadow area RSP 32 ADD ! Return with new callstack @@ -135,8 +156,7 @@ IN: bootstrap.x86 [ jit-save-context arg2 vm-reg MOV - safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym - safe-reg CALL + "lazy_jit_compile" jit-call ] [ return-reg quot-entry-point-offset [+] CALL ] [ return-reg quot-entry-point-offset [+] JMP ] @@ -152,8 +172,7 @@ IN: bootstrap.x86 jit-save-context arg1 RBX MOV arg2 vm-reg MOV - RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym - RAX CALL + "inline_cache_miss" jit-call jit-restore-context ; [ jit-load-return-address jit-inline-cache-miss ] @@ -176,11 +195,7 @@ IN: bootstrap.x86 [ [ arg3 arg2 ] dip call ] dip ds-reg [] arg3 MOV [ JNO ] - [ - arg3 vm-reg MOV - RAX 0 MOV f rc-absolute-cell jit-dlsym - RAX CALL - ] + [ arg3 vm-reg MOV jit-call ] jit-conditional ; inline [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive @@ -202,8 +217,7 @@ IN: bootstrap.x86 arg1 tag-bits get SAR arg2 RBX MOV arg3 vm-reg MOV - RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym - RAX CALL + "overflow_fixnum_multiply" jit-call ] jit-conditional ] \ fixnum* define-sub-primitive diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 8f1a4d7f49..1c4a6b7796 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -13,35 +13,45 @@ big-endian off ! Optimizing compiler's side of callback accesses ! arguments that are on the stack via the frame pointer. ! On x86-64, some arguments are passed in registers, and - ! so the only register that is safe for use here is safe-reg. + ! so the only register that is safe for use here is nv-reg. frame-reg PUSH frame-reg stack-reg MOV ! Save all non-volatile registers nv-regs [ PUSH ] each - ! Save old stack pointer and align - safe-reg stack-reg MOV - stack-reg bootstrap-cell SUB - stack-reg -16 AND - stack-reg [] safe-reg MOV + ! Load VM into vm-reg + vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel - ! Register shadow area - only required on Win64, but doesn't - ! hurt on other platforms - stack-reg 32 SUB + ! Save old context + nv-reg vm-reg vm-context-offset [+] MOV + nv-reg PUSH + + ! Switch over to the spare context + nv-reg vm-reg vm-spare-context-offset [+] MOV + vm-reg vm-context-offset [+] nv-reg MOV + + ! Save C callstack pointer + nv-reg context-callstack-save-offset [+] stack-reg MOV + + ! Load Factor callstack pointer + stack-reg nv-reg context-callstack-bottom-offset [+] MOV + stack-reg bootstrap-cell ADD + + ! Call into Factor code + nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel + nv-reg CALL ! Load VM into vm-reg vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel - ! Call into Factor code - safe-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel - safe-reg CALL + ! Load C callstack pointer + nv-reg vm-reg vm-context-offset [+] MOV + stack-reg nv-reg context-callstack-save-offset [+] MOV - ! Tear down register shadow area - stack-reg 32 ADD - - ! Undo stack alignment - stack-reg stack-reg [] MOV + ! Load old context + nv-reg POP + vm-reg vm-context-offset [+] nv-reg MOV ! Restore non-volatile registers nv-regs [ POP ] each @@ -56,15 +66,15 @@ big-endian off [ ! Load word - safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel + temp0 0 MOV rc-absolute-cell rt-literal jit-rel ! Bump profiling counter - safe-reg profile-count-offset [+] 1 tag-fixnum ADD + temp0 profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code - safe-reg safe-reg word-code-offset [+] MOV + temp0 temp0 word-code-offset [+] MOV ! Compute word entry point - safe-reg compiled-header-size ADD + temp0 compiled-header-size ADD ! Jump to entry point - safe-reg JMP + temp0 JMP ] jit-profiling jit-define [ diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index e54e307f79..dbb112bf4b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1403,10 +1403,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ; M:: x86 %restore-context ( temp1 temp2 -- ) #! Load Factor stack pointers on entry from C to Factor. - #! Also save callstack bottom! temp1 "ctx" %vm-field - temp2 stack-reg stack-frame get total-size>> cell - [+] LEA - temp1 "callstack-bottom" context-field-offset [+] temp2 MOV ds-reg temp1 "datastack" context-field-offset [+] MOV rs-reg temp1 "retainstack" context-field-offset [+] MOV ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index d0cbb05919..289afcf28c 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,19 +1,20 @@ ! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors alien alien.accessors arrays byte-arrays -classes continuations.private effects generic hashtables -hashtables.private io io.backend io.files io.files.private -io.streams.c kernel kernel.private math math.private -math.parser.private memory memory.private namespaces -namespaces.private parser quotations quotations.private sbufs -sbufs.private sequences sequences.private slots.private strings -strings.private system threads.private classes.tuple -classes.tuple.private vectors vectors.private words -words.private definitions assocs summary compiler.units -system.private combinators combinators.short-circuit locals -locals.backend locals.types combinators.private -stack-checker.values generic.single generic.single.private -alien.libraries tools.dispatch.private tools.profiler.private +USING: fry accessors alien alien.accessors alien.private arrays +byte-arrays classes continuations.private effects generic +hashtables hashtables.private io io.backend io.files +io.files.private io.streams.c kernel kernel.private math +math.private math.parser.private memory memory.private +namespaces namespaces.private parser quotations +quotations.private sbufs sbufs.private sequences +sequences.private slots.private strings strings.private system +threads.private classes.tuple classes.tuple.private vectors +vectors.private words words.private definitions assocs summary +compiler.units system.private combinators +combinators.short-circuit locals locals.backend locals.types +combinators.private stack-checker.values generic.single +generic.single.private alien.libraries tools.dispatch.private +tools.profiler.private stack-checker.alien stack-checker.state stack-checker.errors @@ -504,6 +505,16 @@ M: bad-executable summary \ word-code { word } { integer integer } define-primitive \ word-code make-flushable +\ current-callback { } { fixnum } define-primitive +\ current-callback make-flushable + +\ current-context { } { c-ptr } define-primitive +\ current-context make-flushable + +\ delete-context { c-ptr } { } define-primitive + +\ start-context { quotation } { } define-primitive + \ special-object { fixnum } { object } define-primitive \ special-object make-flushable diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index cc4a291a8b..b0f2c945f7 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -10,12 +10,11 @@ STRUCT: context { callstack-bottom void* } { datastack cell } { retainstack cell } -{ magic-frame void* } +{ callstack-save cell } +{ context-objects cell[10] } { datastack-region void* } { retainstack-region void* } -{ catchstack-save cell } -{ current-callback-save cell } -{ next context* } ; +{ callstack-region void* } ; : context-field-offset ( field -- offset ) context offset-of ; inline @@ -27,6 +26,7 @@ STRUCT: zone STRUCT: vm { ctx context* } +{ spare-ctx context* } { nursery zone } { cards-offset cell } { decks-offset cell } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 191886393a..a44d703fbc 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -94,26 +94,21 @@ SYMBOL: callbacks [ H{ } clone callbacks set-global ] "alien" add-startup-hook -! Every context object in the VM is identified from the Factor -! side by a unique identifier -TUPLE: context-id < identity-tuple ; - -C: context-id - -: context-id ( -- id ) 2 context-object ; - -: set-context-id ( id -- ) 2 set-context-object ; - -: wait-to-return ( yield-quot id -- ) - dup context-id eq? +! Every callback invocation has a unique identifier in the VM. +! We make sure that the current callback is the right one before +! returning from it, to avoid a bad interaction between threads +! and callbacks. See basis/compiler/tests/alien.factor for a +! test case. +: wait-to-return ( yield-quot callback-id -- ) + dup current-callback eq? [ 2drop ] [ over call( -- ) wait-to-return ] if ; ! Used by compiler.codegen to wrap callback bodies : do-callback ( callback-quot yield-quot -- ) init-namespaces init-catchstack - - [ set-context-id drop call ] [ wait-to-return drop ] 3bi ; inline + current-callback + [ 2drop call ] [ wait-to-return drop ] 3bi ; inline ! A utility for defining global variables that are recompiled in ! every session diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 19a179a6b1..9bf7be31a2 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -63,6 +63,7 @@ call( -- ) "alien" "alien.accessors" "alien.libraries" + "alien.private" "arrays" "byte-arrays" "classes.private" @@ -415,6 +416,7 @@ tuple { "(dlsym)" "alien.libraries" "primitive_dlsym" (( name dll -- alien )) } { "dlclose" "alien.libraries" "primitive_dlclose" (( dll -- )) } { "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) } + { "current-callback" "alien.private" "primitive_current_callback" (( -- n )) } { "" "arrays" "primitive_array" (( n elt -- array )) } { "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) } { "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) } @@ -532,6 +534,9 @@ tuple { "nano-count" "system" "primitive_nano_count" (( -- ns )) } { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } + { "current-context" "threads.private" "primitive_current_context" (( -- c-ptr )) } + { "delete-context" "threads.private" "primitive_delete_context" (( c-ptr -- )) } + { "start-context" "threads.private" "primitive_start_context" (( quot -- )) } { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) } { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) } { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) } diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp index 416c1395d4..6c8165f5c4 100644 --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -64,11 +64,12 @@ code_block *callback_heap::add(cell owner, cell return_rewind) /* Store VM pointer */ store_callback_operand(stub,0,(cell)parent); + store_callback_operand(stub,2,(cell)parent); /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ #if defined(FACTOR_X86) || defined(FACTOR_AMD64) - store_callback_operand(stub,2,return_rewind); + store_callback_operand(stub,3,return_rewind); #endif update(stub); diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 195b212d8b..8389ff8d90 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -13,7 +13,7 @@ void factor_vm::check_frame(stack_frame *frame) callstack *factor_vm::allot_callstack(cell size) { - callstack *stack = allot(callstack_size(size)); + callstack *stack = allot(callstack_object_size(size)); stack->length = tag_fixnum(size); return stack; } diff --git a/vm/callstack.hpp b/vm/callstack.hpp index 9f8867447c..9f0693eb76 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -1,7 +1,7 @@ namespace factor { -inline static cell callstack_size(cell size) +inline static cell callstack_object_size(cell size) { return sizeof(callstack) + size; } diff --git a/vm/code_block_visitor.hpp b/vm/code_block_visitor.hpp index ac5d140783..deaa41e4b8 100644 --- a/vm/code_block_visitor.hpp +++ b/vm/code_block_visitor.hpp @@ -114,7 +114,7 @@ template void code_block_visitor::visit_context_code_blocks() { call_frame_code_block_visitor call_frame_visitor(parent,visitor); - parent->iterate_active_frames(call_frame_visitor); + parent->iterate_active_callstacks(call_frame_visitor); } template diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 1079c572d2..b5ca348d14 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -3,28 +3,32 @@ namespace factor { -context::context(cell ds_size, cell rs_size) : +context::context(cell datastack_size, cell retainstack_size, cell callstack_size) : callstack_top(NULL), callstack_bottom(NULL), datastack(0), retainstack(0), - datastack_region(new segment(ds_size,false)), - retainstack_region(new segment(rs_size,false)), - next(NULL) + callstack_save(0), + datastack_seg(new segment(datastack_size,false)), + retainstack_seg(new segment(retainstack_size,false)), + callstack_seg(new segment(callstack_size,false)) { - reset_datastack(); - reset_retainstack(); - reset_context_objects(); + reset(); } void context::reset_datastack() { - datastack = datastack_region->start - sizeof(cell); + datastack = datastack_seg->start - sizeof(cell); } void context::reset_retainstack() { - retainstack = retainstack_region->start - sizeof(cell); + retainstack = retainstack_seg->start - sizeof(cell); +} + +void context::reset_callstack() +{ + callstack_top = callstack_bottom = CALLSTACK_BOTTOM(this); } void context::reset_context_objects() @@ -32,68 +36,99 @@ void context::reset_context_objects() memset_cell(context_objects,false_object,context_object_count * sizeof(cell)); } -context *factor_vm::alloc_context() +void context::reset() +{ + reset_datastack(); + reset_retainstack(); + reset_callstack(); + reset_context_objects(); +} + +context::~context() +{ + delete datastack_seg; + delete retainstack_seg; + delete callstack_seg; +} + +/* called on startup */ +void factor_vm::init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_) +{ + datastack_size = datastack_size_; + retainstack_size = retainstack_size_; + callstack_size = callstack_size_; + + ctx = NULL; + spare_ctx = new_context(); +} + +void factor_vm::delete_contexts() +{ + assert(!ctx); + std::vector::const_iterator iter = unused_contexts.begin(); + std::vector::const_iterator end = unused_contexts.end(); + while(iter != end) + { + delete *iter; + iter++; + } +} + +context *factor_vm::new_context() { context *new_context; - if(unused_contexts) + if(unused_contexts.empty()) { - new_context = unused_contexts; - unused_contexts = unused_contexts->next; + new_context = new context(datastack_size, + retainstack_size, + callstack_size); } else - new_context = new context(ds_size,rs_size); + { + new_context = unused_contexts.back(); + unused_contexts.pop_back(); + } + + new_context->reset(); + + active_contexts.insert(new_context); return new_context; } -void factor_vm::dealloc_context(context *old_context) +void factor_vm::delete_context(context *old_context) { - old_context->next = unused_contexts; - unused_contexts = old_context; + unused_contexts.push_back(old_context); + active_contexts.erase(old_context); } -/* called on entry into a compiled callback */ -void factor_vm::nest_stacks() +void factor_vm::begin_callback() { - context *new_ctx = alloc_context(); - - new_ctx->callstack_bottom = (stack_frame *)-1; - new_ctx->callstack_top = (stack_frame *)-1; - - new_ctx->reset_datastack(); - new_ctx->reset_retainstack(); - new_ctx->reset_context_objects(); - - new_ctx->next = ctx; - ctx = new_ctx; + ctx->reset(); + spare_ctx = new_context(); + callback_ids.push_back(callback_id++); } -void nest_stacks(factor_vm *parent) +void begin_callback(factor_vm *parent) { - return parent->nest_stacks(); + parent->begin_callback(); } -/* called when leaving a compiled callback */ -void factor_vm::unnest_stacks() +void factor_vm::end_callback() { - context *old_ctx = ctx; - ctx = old_ctx->next; - dealloc_context(old_ctx); + callback_ids.pop_back(); + delete_context(ctx); } -void unnest_stacks(factor_vm *parent) +void end_callback(factor_vm *parent) { - return parent->unnest_stacks(); + parent->end_callback(); } -/* called on startup */ -void factor_vm::init_stacks(cell ds_size_, cell rs_size_) +void factor_vm::primitive_current_callback() { - ds_size = ds_size_; - rs_size = rs_size_; - ctx = NULL; - unused_contexts = NULL; + ctx->push(tag_fixnum(callback_ids.back())); } void factor_vm::primitive_context_object() @@ -126,13 +161,13 @@ bool factor_vm::stack_to_array(cell bottom, cell top) void factor_vm::primitive_datastack() { - if(!stack_to_array(ctx->datastack_region->start,ctx->datastack)) + if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack)) general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL); } void factor_vm::primitive_retainstack() { - if(!stack_to_array(ctx->retainstack_region->start,ctx->retainstack)) + if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack)) general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL); } @@ -146,12 +181,12 @@ cell factor_vm::array_to_stack(array *array, cell bottom) void factor_vm::primitive_set_datastack() { - ctx->datastack = array_to_stack(untag_check(ctx->pop()),ctx->datastack_region->start); + ctx->datastack = array_to_stack(untag_check(ctx->pop()),ctx->datastack_seg->start); } void factor_vm::primitive_set_retainstack() { - ctx->retainstack = array_to_stack(untag_check(ctx->pop()),ctx->retainstack_region->start); + ctx->retainstack = array_to_stack(untag_check(ctx->pop()),ctx->retainstack_seg->start); } /* Used to implement call( */ @@ -162,12 +197,12 @@ void factor_vm::primitive_check_datastack() fixnum height = out - in; array *saved_datastack = untag_check(ctx->pop()); fixnum saved_height = array_capacity(saved_datastack); - fixnum current_height = (ctx->datastack - ctx->datastack_region->start + sizeof(cell)) / sizeof(cell); + fixnum current_height = (ctx->datastack - ctx->datastack_seg->start + sizeof(cell)) / sizeof(cell); if(current_height - height != saved_height) ctx->push(false_object); else { - cell *ds_bot = (cell *)ctx->datastack_region->start; + cell *ds_bot = (cell *)ctx->datastack_seg->start; for(fixnum i = 0; i < saved_height - in; i++) { if(ds_bot[i] != array_nth(saved_datastack,i)) @@ -190,4 +225,22 @@ void factor_vm::primitive_load_locals() ctx->retainstack += sizeof(cell) * count; } +void factor_vm::primitive_current_context() +{ + ctx->push(allot_alien(ctx)); +} + +void factor_vm::primitive_start_context() +{ + cell quot = ctx->pop(); + ctx = new_context(); + unwind_native_frames(quot,ctx->callstack_bottom); +} + +void factor_vm::primitive_delete_context() +{ + context *old_context = (context *)pinned_alien_offset(ctx->pop()); + delete_context(old_context); +} + } diff --git a/vm/contexts.hpp b/vm/contexts.hpp index e555bd4a92..e746e53ffa 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -6,12 +6,13 @@ static const cell context_object_count = 10; enum context_object { OBJ_NAMESTACK, OBJ_CATCHSTACK, - OBJ_CONTEXT_ID, }; -/* Assembly code makes assumptions about the layout of this struct */ struct context { - /* C stack pointer on entry */ + + // First 4 fields accessed directly by compiler. See basis/vm/vm.factor + + /* Factor callstack pointers */ stack_frame *callstack_top; stack_frame *callstack_bottom; @@ -21,22 +22,25 @@ struct context { /* current retain stack top pointer */ cell retainstack; - /* memory region holding current datastack */ - segment *datastack_region; - - /* memory region holding current retain stack */ - segment *retainstack_region; + /* C callstack pointer */ + cell callstack_save; /* context-specific special objects, accessed by context-object and set-context-object primitives */ cell context_objects[context_object_count]; - context *next; + segment *datastack_seg; + segment *retainstack_seg; + segment *callstack_seg; + + context(cell datastack_size, cell retainstack_size, cell callstack_size); + ~context(); - context(cell ds_size, cell rs_size); void reset_datastack(); void reset_retainstack(); + void reset_callstack(); void reset_context_objects(); + void reset(); cell peek() { @@ -65,17 +69,17 @@ struct context { void fix_stacks() { - if(datastack + sizeof(cell) < datastack_region->start - || datastack + stack_reserved >= datastack_region->end) + if(datastack + sizeof(cell) < datastack_seg->start + || datastack + stack_reserved >= datastack_seg->end) reset_datastack(); - if(retainstack + sizeof(cell) < retainstack_region->start - || retainstack + stack_reserved >= retainstack_region->end) + if(retainstack + sizeof(cell) < retainstack_seg->start + || retainstack + stack_reserved >= retainstack_seg->end) reset_retainstack(); } }; -VM_C_API void nest_stacks(factor_vm *vm); -VM_C_API void unnest_stacks(factor_vm *vm); +VM_C_API void begin_callback(factor_vm *vm); +VM_C_API void end_callback(factor_vm *vm); } diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index d09fc173ea..6e76164308 100644 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -3,6 +3,8 @@ namespace factor #define FACTOR_CPU_STRING "ppc" +#define CALLSTACK_BOTTOM(ctx) (stack_frame *)ctx->callstack_seg->end + /* In the instruction sequence: LOAD32 r3,... diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index ac8ac51ade..bfdcd8afb2 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -5,6 +5,8 @@ namespace factor #define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1) +#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell)) + inline static void flush_icache(cell start, cell len) {} /* In the instruction sequence: diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index 22ef39e868..9b28215bb8 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -159,7 +159,7 @@ cell object::size() const case WRAPPER_TYPE: return align(sizeof(wrapper),data_alignment); case CALLSTACK_TYPE: - return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment); + return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment); default: critical_error("Invalid header",(cell)this); return 0; /* can't happen */ diff --git a/vm/debug.cpp b/vm/debug.cpp index e82394951a..85335d49ae 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -145,13 +145,13 @@ void factor_vm::print_objects(cell *start, cell *end) void factor_vm::print_datastack() { std::cout << "==== DATA STACK:\n"; - print_objects((cell *)ctx->datastack_region->start,(cell *)ctx->datastack); + print_objects((cell *)ctx->datastack_seg->start,(cell *)ctx->datastack); } void factor_vm::print_retainstack() { std::cout << "==== RETAIN STACK:\n"; - print_objects((cell *)ctx->retainstack_region->start,(cell *)ctx->retainstack); + print_objects((cell *)ctx->retainstack_seg->start,(cell *)ctx->retainstack); } struct stack_frame_printer { @@ -421,9 +421,9 @@ void factor_vm::factorbug() else if(strcmp(cmd,"t") == 0) full_output = !full_output; else if(strcmp(cmd,"s") == 0) - dump_memory(ctx->datastack_region->start,ctx->datastack); + dump_memory(ctx->datastack_seg->start,ctx->datastack); else if(strcmp(cmd,"r") == 0) - dump_memory(ctx->retainstack_region->start,ctx->retainstack); + dump_memory(ctx->retainstack_seg->start,ctx->retainstack); else if(strcmp(cmd,".s") == 0) print_datastack(); else if(strcmp(cmd,".r") == 0) diff --git a/vm/errors.cpp b/vm/errors.cpp index ae560012aa..8efcb3346f 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -99,13 +99,13 @@ bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset) void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack) { - if(in_page(addr, ctx->datastack_region->start, 0, -1)) + if(in_page(addr, ctx->datastack_seg->start, 0, -1)) general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, ctx->datastack_region->start, ds_size, 0)) + else if(in_page(addr, ctx->datastack_seg->start, datastack_size, 0)) general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, ctx->retainstack_region->start, 0, -1)) + else if(in_page(addr, ctx->retainstack_seg->start, 0, -1)) general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, ctx->retainstack_region->start, rs_size, 0)) + else if(in_page(addr, ctx->retainstack_seg->start, retainstack_size, 0)) general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack); else if(in_page(addr, nursery.end, 0, 0)) critical_error("allot_object() missed GC check",0); diff --git a/vm/factor.cpp b/vm/factor.cpp index 4433095173..c38e38a5d0 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -14,8 +14,9 @@ void factor_vm::default_parameters(vm_parameters *p) { p->image_path = NULL; - p->ds_size = 32 * sizeof(cell); - p->rs_size = 32 * sizeof(cell); + p->datastack_size = 32 * sizeof(cell); + p->retainstack_size = 32 * sizeof(cell); + p->callstack_size = 128 * sizeof(cell); p->code_size = 8 * sizeof(cell); p->young_size = sizeof(cell) / 4; @@ -59,8 +60,9 @@ void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char ** { vm_char *arg = argv[i]; if(STRCMP(arg,STRING_LITERAL("--")) == 0) break; - else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->ds_size)); - else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->rs_size)); + else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->datastack_size)); + else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->retainstack_size)); + else if(factor_arg(arg,STRING_LITERAL("-callstack=%d"),&p->callstack_size)); else if(factor_arg(arg,STRING_LITERAL("-young=%d"),&p->young_size)); else if(factor_arg(arg,STRING_LITERAL("-aging=%d"),&p->aging_size)); else if(factor_arg(arg,STRING_LITERAL("-tenured=%d"),&p->tenured_size)); @@ -91,8 +93,9 @@ void factor_vm::prepare_boot_image() void factor_vm::init_factor(vm_parameters *p) { /* Kilobytes */ - p->ds_size = align_page(p->ds_size << 10); - p->rs_size = align_page(p->rs_size << 10); + p->datastack_size = align_page(p->datastack_size << 10); + p->retainstack_size = align_page(p->retainstack_size << 10); + p->callstack_size = align_page(p->retainstack_size << 10); p->callback_size = align_page(p->callback_size << 10); /* Megabytes */ @@ -117,7 +120,7 @@ void factor_vm::init_factor(vm_parameters *p) srand((unsigned int)system_micros()); init_ffi(); - init_stacks(p->ds_size,p->rs_size); + init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size); init_callbacks(p->callback_size); load_image(p); init_c_io(); @@ -161,16 +164,12 @@ void factor_vm::start_factor(vm_parameters *p) { if(p->fep) factorbug(); - nest_stacks(); c_to_factor_toplevel(special_objects[OBJ_STARTUP_QUOT]); - unnest_stacks(); } void factor_vm::stop_factor() { - nest_stacks(); c_to_factor_toplevel(special_objects[OBJ_SHUTDOWN_QUOT]); - unnest_stacks(); } char *factor_vm::factor_eval_string(char *string) diff --git a/vm/image.hpp b/vm/image.hpp index 101482b1da..40ffa28d11 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -30,7 +30,7 @@ struct image_header { struct vm_parameters { const vm_char *image_path; const vm_char *executable_path; - cell ds_size, rs_size; + cell datastack_size, retainstack_size, callstack_size; cell young_size, aging_size, tenured_size; cell code_size; bool fep; diff --git a/vm/primitives.hpp b/vm/primitives.hpp index df36ed84b2..cbbadd2596 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -2,157 +2,159 @@ namespace factor { /* Generated with PRIMITIVE in primitives.cpp */ -#define EACH_PRIMITIVE(_) \ - _(alien_address) \ - _(all_instances) \ - _(array) \ - _(array_to_quotation) \ - _(become) \ - _(bignum_add) \ - _(bignum_and) \ - _(bignum_bitp) \ - _(bignum_divint) \ - _(bignum_divmod) \ - _(bignum_eq) \ - _(bignum_greater) \ - _(bignum_greatereq) \ - _(bignum_less) \ - _(bignum_lesseq) \ - _(bignum_log2) \ - _(bignum_mod) \ - _(bignum_multiply) \ - _(bignum_not) \ - _(bignum_or) \ - _(bignum_shift) \ - _(bignum_subtract) \ - _(bignum_to_fixnum) \ - _(bignum_to_float) \ - _(bignum_xor) \ - _(bits_double) \ - _(bits_float) \ - _(byte_array) \ - _(byte_array_to_bignum) \ - _(call_clear) \ - _(callback) \ - _(callstack) \ - _(callstack_to_array) \ - _(check_datastack) \ - _(clone) \ - _(code_blocks) \ - _(code_room) \ - _(compact_gc) \ - _(compute_identity_hashcode) \ - _(context_object) \ - _(data_room) \ - _(datastack) \ - _(die) \ - _(disable_gc_events) \ - _(dispatch_stats) \ - _(displaced_alien) \ - _(dlclose) \ - _(dll_validp) \ - _(dlopen) \ - _(dlsym) \ - _(double_bits) \ - _(enable_gc_events) \ - _(existsp) \ - _(exit) \ - _(fclose) \ - _(fflush) \ - _(fgetc) \ - _(fixnum_divint) \ - _(fixnum_divmod) \ - _(fixnum_shift) \ - _(fixnum_to_bignum) \ - _(fixnum_to_float) \ - _(float_add) \ - _(float_bits) \ - _(float_divfloat) \ - _(float_eq) \ - _(float_greater) \ - _(float_greatereq) \ - _(float_less) \ - _(float_lesseq) \ - _(float_mod) \ - _(float_multiply) \ - _(float_subtract) \ - _(float_to_bignum) \ - _(float_to_fixnum) \ - _(float_to_str) \ - _(fopen) \ - _(fputc) \ - _(fread) \ - _(fseek) \ - _(ftell) \ - _(full_gc) \ - _(fwrite) \ - _(identity_hashcode) \ - _(innermost_stack_frame_executing) \ - _(innermost_stack_frame_scan) \ - _(jit_compile) \ - _(load_locals) \ - _(lookup_method) \ - _(mega_cache_miss) \ - _(minor_gc) \ - _(modify_code_heap) \ - _(nano_count) \ - _(optimized_p) \ - _(profiling) \ - _(quot_compiled_p) \ - _(quotation_code) \ - _(reset_dispatch_stats) \ - _(resize_array) \ - _(resize_byte_array) \ - _(resize_string) \ - _(retainstack) \ - _(save_image) \ - _(save_image_and_exit) \ - _(set_context_object) \ - _(set_datastack) \ - _(set_innermost_stack_frame_quot) \ - _(set_retainstack) \ - _(set_slot) \ - _(set_special_object) \ - _(set_string_nth_fast) \ - _(set_string_nth_slow) \ - _(size) \ - _(sleep) \ - _(special_object) \ - _(string) \ - _(string_nth) \ - _(strip_stack_traces) \ - _(system_micros) \ - _(tuple) \ - _(tuple_boa) \ - _(unimplemented) \ - _(uninitialized_byte_array) \ - _(word) \ - _(word_code) \ - _(wrapper) -/* These are generated with macros in alien.cpp, and not with PRIMIIVE in -primitives.cpp */ +#define EACH_PRIMITIVE(_) \ + _(alien_address) \ + _(all_instances) \ + _(array) \ + _(array_to_quotation) \ + _(become) \ + _(bignum_add) \ + _(bignum_and) \ + _(bignum_bitp) \ + _(bignum_divint) \ + _(bignum_divmod) \ + _(bignum_eq) \ + _(bignum_greater) \ + _(bignum_greatereq) \ + _(bignum_less) \ + _(bignum_lesseq) \ + _(bignum_log2) \ + _(bignum_mod) \ + _(bignum_multiply) \ + _(bignum_not) \ + _(bignum_or) \ + _(bignum_shift) \ + _(bignum_subtract) \ + _(bignum_to_fixnum) \ + _(bignum_to_float) \ + _(bignum_xor) \ + _(bits_double) \ + _(bits_float) \ + _(byte_array) \ + _(byte_array_to_bignum) \ + _(call_clear) \ + _(callback) \ + _(callstack) \ + _(callstack_to_array) \ + _(check_datastack) \ + _(clone) \ + _(code_blocks) \ + _(code_room) \ + _(compact_gc) \ + _(compute_identity_hashcode) \ + _(context_object) \ + _(current_callback) \ + _(current_context) \ + _(data_room) \ + _(datastack) \ + _(delete_context) \ + _(die) \ + _(disable_gc_events) \ + _(dispatch_stats) \ + _(displaced_alien) \ + _(dlclose) \ + _(dll_validp) \ + _(dlopen) \ + _(dlsym) \ + _(double_bits) \ + _(enable_gc_events) \ + _(existsp) \ + _(exit) \ + _(fclose) \ + _(fflush) \ + _(fgetc) \ + _(fixnum_divint) \ + _(fixnum_divmod) \ + _(fixnum_shift) \ + _(fixnum_to_bignum) \ + _(fixnum_to_float) \ + _(float_add) \ + _(float_bits) \ + _(float_divfloat) \ + _(float_eq) \ + _(float_greater) \ + _(float_greatereq) \ + _(float_less) \ + _(float_lesseq) \ + _(float_mod) \ + _(float_multiply) \ + _(float_subtract) \ + _(float_to_bignum) \ + _(float_to_fixnum) \ + _(float_to_str) \ + _(fopen) \ + _(fputc) \ + _(fread) \ + _(fseek) \ + _(ftell) \ + _(full_gc) \ + _(fwrite) \ + _(identity_hashcode) \ + _(innermost_stack_frame_executing) \ + _(innermost_stack_frame_scan) \ + _(jit_compile) \ + _(load_locals) \ + _(lookup_method) \ + _(mega_cache_miss) \ + _(minor_gc) \ + _(modify_code_heap) \ + _(nano_count) \ + _(optimized_p) \ + _(profiling) \ + _(quot_compiled_p) \ + _(quotation_code) \ + _(reset_dispatch_stats) \ + _(resize_array) \ + _(resize_byte_array) \ + _(resize_string) \ + _(retainstack) \ + _(save_image) \ + _(save_image_and_exit) \ + _(set_context_object) \ + _(set_datastack) \ + _(set_innermost_stack_frame_quot) \ + _(set_retainstack) \ + _(set_slot) \ + _(set_special_object) \ + _(set_string_nth_fast) \ + _(set_string_nth_slow) \ + _(size) \ + _(sleep) \ + _(special_object) \ + _(start_context) \ + _(string) \ + _(string_nth) \ + _(strip_stack_traces) \ + _(system_micros) \ + _(tuple) \ + _(tuple_boa) \ + _(unimplemented) \ + _(uninitialized_byte_array) \ + _(word) \ + _(word_code) \ + _(wrapper) #define EACH_ALIEN_PRIMITIVE(_) \ - _(signed_cell,fixnum,from_signed_cell,to_fixnum) \ - _(unsigned_cell,cell,from_unsigned_cell,to_cell) \ - _(signed_8,s64,from_signed_8,to_signed_8) \ - _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \ - _(signed_4,s32,from_signed_4,to_fixnum) \ - _(unsigned_4,u32,from_unsigned_4,to_cell) \ - _(signed_2,s16,from_signed_2,to_fixnum) \ - _(unsigned_2,u16,from_unsigned_2,to_cell) \ - _(signed_1,s8,from_signed_1,to_fixnum) \ - _(unsigned_1,u8,from_unsigned_1,to_cell) \ - _(float,float,from_float,to_float) \ - _(double,double,from_double,to_double) \ - _(cell,void *,allot_alien,pinned_alien_offset) + _(signed_cell,fixnum,from_signed_cell,to_fixnum) \ + _(unsigned_cell,cell,from_unsigned_cell,to_cell) \ + _(signed_8,s64,from_signed_8,to_signed_8) \ + _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \ + _(signed_4,s32,from_signed_4,to_fixnum) \ + _(unsigned_4,u32,from_unsigned_4,to_cell) \ + _(signed_2,s16,from_signed_2,to_fixnum) \ + _(unsigned_2,u16,from_unsigned_2,to_cell) \ + _(signed_1,s8,from_signed_1,to_fixnum) \ + _(unsigned_1,u8,from_unsigned_1,to_cell) \ + _(float,float,from_float,to_float) \ + _(double,double,from_double,to_double) \ + _(cell,void *,allot_alien,pinned_alien_offset) #define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent); #define DECLARE_ALIEN_PRIMITIVE(name, type, from, to) \ - DECLARE_PRIMITIVE(alien_##name) \ - DECLARE_PRIMITIVE(set_alien_##name) + DECLARE_PRIMITIVE(alien_##name) \ + DECLARE_PRIMITIVE(set_alien_##name) EACH_PRIMITIVE(DECLARE_PRIMITIVE) EACH_ALIEN_PRIMITIVE(DECLARE_ALIEN_PRIMITIVE) diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp index e8ff7e30d2..d4dd44bed1 100644 --- a/vm/slot_visitor.hpp +++ b/vm/slot_visitor.hpp @@ -170,15 +170,17 @@ void slot_visitor::visit_roots() template void slot_visitor::visit_contexts() { - context *ctx = parent->ctx; - - while(ctx) + std::set::const_iterator begin = parent->active_contexts.begin(); + std::set::const_iterator end = parent->active_contexts.end(); + while(begin != end) { - visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack); - visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack); + context *ctx = *begin; + + visit_stack_elements(ctx->datastack_seg,(cell *)ctx->datastack); + visit_stack_elements(ctx->retainstack_seg,(cell *)ctx->retainstack); visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count); - ctx = ctx->next; + begin++; } } diff --git a/vm/vm.cpp b/vm/vm.cpp index be43371087..87bf47f290 100755 --- a/vm/vm.cpp +++ b/vm/vm.cpp @@ -5,6 +5,7 @@ namespace factor factor_vm::factor_vm() : nursery(0,0), + callback_id(0), c_to_factor_func(NULL), profiling_p(false), gc_off(false), @@ -17,4 +18,9 @@ factor_vm::factor_vm() : primitive_reset_dispatch_stats(); } +factor_vm::~factor_vm() +{ + delete_contexts(); +} + } diff --git a/vm/vm.hpp b/vm/vm.hpp index f20145b43f..f2f2d9a769 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -6,11 +6,14 @@ struct code_root; struct factor_vm { - // First five fields accessed directly by assembler. See vm.factor + // First 5 fields accessed directly by compiler. See basis/vm/vm.factor - /* Current stacks */ + /* Current context */ context *ctx; - + + /* Spare context -- for callbacks */ + context *spare_ctx; + /* New objects are allocated here */ nursery_space nursery; @@ -23,10 +26,19 @@ struct factor_vm cell special_objects[special_object_count]; /* Data stack and retain stack sizes */ - cell ds_size, rs_size; + cell datastack_size, retainstack_size, callstack_size; - /* Pooling unused contexts to make callbacks cheaper */ - context *unused_contexts; + /* Stack of callback IDs */ + std::vector callback_ids; + + /* Next callback ID */ + int callback_id; + + /* Pooling unused contexts to make context allocation cheaper */ + std::vector unused_contexts; + + /* Active contexts, for tracing by the GC */ + std::set active_contexts; /* Canonical truth value. In Factor, 't' */ cell true_object; @@ -96,11 +108,13 @@ struct factor_vm u64 last_nano_count; // contexts - context *alloc_context(); - void dealloc_context(context *old_context); - void nest_stacks(); - void unnest_stacks(); - void init_stacks(cell ds_size_, cell rs_size_); + context *new_context(); + void delete_context(context *old_context); + void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_); + void delete_contexts(); + void begin_callback(); + void end_callback(); + void primitive_current_callback(); void primitive_context_object(); void primitive_set_context_object(); bool stack_to_array(cell bottom, cell top); @@ -111,16 +125,15 @@ struct factor_vm void primitive_set_retainstack(); void primitive_check_datastack(); void primitive_load_locals(); + void primitive_current_context(); + void primitive_start_context(); + void primitive_delete_context(); - template void iterate_active_frames(Iterator &iter) + template void iterate_active_callstacks(Iterator &iter) { - context *ctx = this->ctx; - - while(ctx) - { - iterate_callstack(ctx,iter); - ctx = ctx->next; - } + std::set::const_iterator begin = active_contexts.begin(); + std::set::const_iterator end = active_contexts.end(); + while(begin != end) iterate_callstack(*begin++,iter); } // run @@ -694,6 +707,7 @@ struct factor_vm #endif factor_vm(); + ~factor_vm(); }; From e6a15c0b336df2c522a92bc00531ea29cf6b4a82 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 26 Mar 2010 22:44:56 -0400 Subject: [PATCH 036/123] compiler.tree.propagation: don't constant-fold boa constructors of identity-tuple subclasses --- .../tree/propagation/propagation-tests.factor | 6 ++++++ .../tree/propagation/slots/slots.factor | 17 +++++++++-------- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 444a424766..ad8a75ecdd 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -467,6 +467,12 @@ TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ; [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ] unit-test +TUPLE: don't-fold-boa-test-tuple < identity-tuple ; + +[ V{ f } ] +[ [ don't-fold-boa-test-tuple boa ] final-literals ] +unit-test + TUPLE: immutable-prop-test-tuple { x sequence read-only } ; [ V{ T{ immutable-prop-test-tuple f "hey" } } ] [ diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 2602d6d59a..14546f0237 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -34,17 +34,18 @@ IN: compiler.tree.propagation.slots [ read-only>> [ value-info ] [ drop f ] if ] 2map f prefix ; -: (propagate-tuple-constructor) ( values class -- info ) - [ read-only-slots ] keep - over rest-slice [ dup [ literal?>> ] when ] all? [ - [ rest-slice ] dip fold- - ] [ - - ] if ; +: fold-? ( values class -- ? ) + [ rest-slice [ dup [ literal?>> ] when ] all? ] + [ identity-tuple class<= not ] + bi* and ; + +: (propagate-) ( values class -- info ) + [ read-only-slots ] keep 2dup fold-? + [ [ rest-slice ] dip fold- ] [ ] if ; : propagate- ( #call -- infos ) in-d>> unclip-last - value-info literal>> first (propagate-tuple-constructor) 1array ; + value-info literal>> first (propagate-) 1array ; : read-only-slot? ( n class -- ? ) all-slots [ offset>> = ] with find nip From dbebe044c9a01d0efd66cd6fcad6966b821621da Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Mar 2010 20:08:29 -0700 Subject: [PATCH 037/123] cursors: -find iterator --- extra/cursors/cursors-tests.factor | 4 ++++ extra/cursors/cursors.factor | 3 +++ 2 files changed, 7 insertions(+) diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor index 158769ff14..d71999ab87 100644 --- a/extra/cursors/cursors-tests.factor +++ b/extra/cursors/cursors-tests.factor @@ -8,6 +8,10 @@ IN: cursors.tests { } make ] unit-test +[ T{ linear-cursor f 3 1 } ] [ + T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> 3 mod zero? ] -find +] unit-test + [ { 1 3 } ] [ [ T{ linear-cursor f 1 2 } T{ linear-cursor f 5 2 } [ value>> , ] -each ] { } make diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 030e9ab72f..d7fe5fb893 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -125,6 +125,9 @@ M: end-of-stream cursor-stream-ended? drop t ; inline [ '[ dup _ cursor>= ] ] [ '[ _ keep inc-cursor ] ] bi* until drop ; inline +: -find ( ... begin end quot: ( ... cursor -- ... ? ) -- ... cursor ) + '[ dup _ cursor>= [ t ] [ dup @ ] if ] [ inc-cursor ] until ; inline + : -in- ( quot -- quot' ) '[ cursor-value-unsafe @ ] ; inline From d98e752199b687b4c62e920242454c5391b4fb1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 26 Mar 2010 23:11:05 -0400 Subject: [PATCH 038/123] compiler: add intrinsic for context-object primitive --- .../cfg/instructions/instructions.factor | 4 ++++ .../compiler/cfg/intrinsics/intrinsics.factor | 1 + .../compiler/cfg/intrinsics/misc/misc.factor | 20 +++++++++++++++---- basis/compiler/codegen/codegen.factor | 1 + 4 files changed, 22 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 68a8b8ce59..678ce76860 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -664,6 +664,10 @@ INSN: ##vm-field-ptr def: dst/int-rep literal: field-name ; +INSN: ##vm-field +def: dst/int-rep +literal: field-name ; + ! FFI INSN: ##alien-invoke literal: params stack-frame ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index d753a4c1b4..4ebc818b83 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -30,6 +30,7 @@ IN: compiler.cfg.intrinsics { { kernel.private:tag [ drop emit-tag ] } + { kernel.private:context-object [ emit-context-object ] } { kernel.private:special-object [ emit-special-object ] } { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index fed5492220..9731d2f6f5 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -3,17 +3,29 @@ USING: namespaces layouts sequences kernel math accessors compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.builder.blocks compiler.cfg.utilities ; +FROM: vm => context-field-offset ; IN: compiler.cfg.intrinsics.misc : emit-tag ( -- ) ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; : emit-special-object ( node -- ) - "special-objects" ^^vm-field-ptr - swap node-input-infos first literal>> - [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if* - ds-push ; + dup node-input-infos first literal>> [ + "special-objects" ^^vm-field-ptr + ds-drop swap 0 ^^slot-imm + ds-push + ] [ emit-primitive ] ?if ; + +: context-object-offset ( -- n ) + "context-objects" context-field-offset cell /i ; + +: emit-context-object ( node -- ) + dup node-input-infos first literal>> [ + "ctx" ^^vm-field + ds-drop swap context-object-offset + 0 ^^slot-imm ds-push + ] [ emit-primitive ] ?if ; : emit-identity-hashcode ( -- ) ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 430bd9550d..d82ced8a1d 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -211,6 +211,7 @@ CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##save-context %save-context CODEGEN: ##vm-field-ptr %vm-field-ptr +CODEGEN: ##vm-field %vm-field CODEGEN: _fixnum-add %fixnum-add CODEGEN: _fixnum-sub %fixnum-sub From 1717b8d0f7f928aff230fb160e7f339ed38a38c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 02:55:49 -0400 Subject: [PATCH 039/123] Implement start-context and set-context primitives --- basis/cpu/x86/32/bootstrap.factor | 64 ++++++++++++++++--- basis/cpu/x86/64/bootstrap.factor | 60 +++++++++++++++-- basis/cpu/x86/bootstrap.factor | 3 +- .../known-words/known-words.factor | 4 +- basis/threads/threads.factor | 10 +++ core/bootstrap/primitives.factor | 5 +- vm/contexts.cpp | 14 ++-- vm/contexts.hpp | 5 +- vm/primitives.hpp | 3 +- vm/vm.hpp | 3 +- 10 files changed, 141 insertions(+), 30 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index c7457d2732..6fab8769d5 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -3,7 +3,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser compiler.constants sequences math math.private -generic.single.private ; +generic.single.private threads.private ; IN: bootstrap.x86 4 \ cell set @@ -21,7 +21,7 @@ IN: bootstrap.x86 : vm-reg ( -- reg ) ECX ; : ctx-reg ( -- reg ) EBP ; : nv-regs ( -- seq ) { ESI EDI EBX } ; -: nv-reg ( -- reg ) nv-regs first ; +: nv-reg ( -- reg ) EBX ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; : fixnum>slot@ ( -- ) temp0 2 SAR ; @@ -52,6 +52,7 @@ IN: bootstrap.x86 ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) + jit-load-context EDX ESP -4 [+] LEA ctx-reg context-callstack-top-offset [+] EDX MOV ctx-reg context-datastack-offset [+] ds-reg MOV @@ -63,7 +64,6 @@ IN: bootstrap.x86 [ jit-load-vm - jit-load-context jit-save-context ! call the primitive ESP [] vm-reg MOV @@ -96,7 +96,6 @@ IN: bootstrap.x86 EAX quot-entry-point-offset [+] CALL jit-load-vm - jit-load-context jit-save-context ! load C callstack pointer @@ -167,7 +166,6 @@ IN: bootstrap.x86 [ jit-load-vm - jit-load-context jit-save-context ! Store arguments @@ -189,7 +187,6 @@ IN: bootstrap.x86 ! frame, and the stack. The frame setup takes this into account. : jit-inline-cache-miss ( -- ) jit-load-vm - jit-load-context jit-save-context ESP 4 [+] vm-reg MOV ESP [] EBX MOV @@ -210,7 +207,6 @@ IN: bootstrap.x86 : jit-overflow ( insn func -- ) ds-reg 4 SUB jit-load-vm - jit-load-context jit-save-context EAX ds-reg [] MOV EDX ds-reg 4 [+] MOV @@ -233,7 +229,6 @@ IN: bootstrap.x86 [ ds-reg 4 SUB jit-load-vm - jit-load-context jit-save-context EBX ds-reg [] MOV EAX EBX MOV @@ -252,5 +247,58 @@ IN: bootstrap.x86 jit-conditional ] \ fixnum* define-sub-primitive +! Threads +: jit-set-context ( reg -- ) + ! Save ds, rs registers + jit-load-vm + jit-save-context + + ! Make the new context the current one + ctx-reg swap MOV + vm-reg vm-context-offset [+] ctx-reg MOV + + ! Load new stack pointer + ESP ctx-reg context-callstack-top-offset [+] MOV + + ! Load new ds, rs registers + jit-restore-context ; + +[ + ! Create the new context in return-reg + jit-load-vm + ESP [] vm-reg MOV + "new_context" jit-call + + ! Save pointer to quotation and parameter, pop them off the + ! datastack + EBX ds-reg MOV + ds-reg 8 SUB + + ! Make the new context the active context + EAX jit-set-context + + ! Push parameter + EAX EBX -4 [+] MOV + ds-reg 4 ADD + ds-reg [] EAX MOV + + ! Jump to initial quotation + EAX EBX [] MOV + EAX quot-entry-point-offset [+] JMP +] \ (start-context) define-sub-primitive + +[ + ! Load context from datastack + EAX ds-reg [] MOV + EAX EAX alien-offset [+] MOV + ds-reg 4 SUB + + ! Make it the active context + EAX jit-set-context + + ! Twiddle stack for return + ESP 4 ADD +] \ (set-context) define-sub-primitive + << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 2da9f7564e..e8fa026a49 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -3,7 +3,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system layouts vocabs parser compiler.constants math math.private cpu.x86.assembler cpu.x86.assembler.operands -sequences generic.single.private ; +sequences generic.single.private threads.private ; IN: bootstrap.x86 8 \ cell set @@ -16,7 +16,7 @@ IN: bootstrap.x86 : temp2 ( -- reg ) RDX ; : temp3 ( -- reg ) RBX ; : return-reg ( -- reg ) RAX ; -: nv-reg ( -- reg ) nv-regs first ; +: nv-reg ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : frame-reg ( -- reg ) RBP ; : ctx-reg ( -- reg ) R12 ; @@ -51,8 +51,8 @@ IN: bootstrap.x86 : jit-save-context ( -- ) jit-load-context - RAX RSP -8 [+] LEA - ctx-reg context-callstack-top-offset [+] RAX MOV + R11 RSP -8 [+] LEA + ctx-reg context-callstack-top-offset [+] R11 MOV ctx-reg context-datastack-offset [+] ds-reg MOV ctx-reg context-retainstack-offset [+] rs-reg MOV ; @@ -222,5 +222,57 @@ IN: bootstrap.x86 jit-conditional ] \ fixnum* define-sub-primitive +! Threads +: jit-set-context ( reg -- ) + ! Save ds, rs registers + jit-save-context + + ! Make the new context the current one + ctx-reg swap MOV + vm-reg vm-context-offset [+] ctx-reg MOV + + ! Load new stack pointer + RSP ctx-reg context-callstack-top-offset [+] MOV + + ! Load new ds, rs registers + jit-restore-context ; + +[ + ! Create the new context in return-reg + arg1 vm-reg MOV + "new_context" jit-call + + ! Load quotation from datastack + arg1 ds-reg [] MOV + + ! Load parameter from datastack + arg2 ds-reg -8 [+] MOV + + ds-reg 16 SUB + + ! Make the new context the active context + return-reg jit-set-context + + ! Push parameter + ds-reg 8 ADD + ds-reg [] arg2 MOV + + ! Jump to initial quotation + arg1 quot-entry-point-offset [+] JMP +] \ (start-context) define-sub-primitive + +[ + ! Load context from datastack + temp0 ds-reg [] MOV + temp0 temp0 alien-offset [+] MOV + ds-reg 8 SUB + + ! Make it the active context + temp0 jit-set-context + + ! Twiddle stack for return + RSP 8 ADD +] \ (set-context) define-sub-primitive + << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 1c4a6b7796..d75d80faf2 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,7 +42,8 @@ big-endian off nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel nv-reg CALL - ! Load VM into vm-reg + ! Load VM into vm-reg; only needed on x86-32, but doesn't + ! hurt on x86-64 vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel ! Load C callstack pointer diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 289afcf28c..656c159a9b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -513,7 +513,9 @@ M: bad-executable summary \ delete-context { c-ptr } { } define-primitive -\ start-context { quotation } { } define-primitive +\ (start-context) { object quotation } { } define-primitive + +\ (set-context) { alien } { } define-primitive \ special-object { fixnum } { object } define-primitive \ special-object make-flushable diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 952652d801..9282dda46f 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -7,6 +7,16 @@ dlists assocs system combinators combinators.private init boxes accessors math.order deques strings quotations fry ; IN: threads + + SYMBOL: initial-thread TUPLE: thread diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 9bf7be31a2..9971c00e1d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -369,6 +369,8 @@ tuple { "fixnum<=" "math.private" (( x y -- z )) } { "fixnum>" "math.private" (( x y -- ? )) } { "fixnum>=" "math.private" (( x y -- ? )) } + { "(set-context)" "threads.private" (( context -- )) } + { "(start-context)" "threads.private" (( obj quot -- )) } } [ first3 make-sub-primitive ] each ! Primitive words @@ -534,9 +536,8 @@ tuple { "nano-count" "system" "primitive_nano_count" (( -- ns )) } { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } - { "current-context" "threads.private" "primitive_current_context" (( -- c-ptr )) } + { "context" "threads.private" "primitive_context" (( -- c-ptr )) } { "delete-context" "threads.private" "primitive_delete_context" (( c-ptr -- )) } - { "start-context" "threads.private" "primitive_start_context" (( quot -- )) } { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) } { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) } { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) } diff --git a/vm/contexts.cpp b/vm/contexts.cpp index b5ca348d14..f21d9c948d 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -97,6 +97,11 @@ context *factor_vm::new_context() return new_context; } +context *new_context(factor_vm *parent) +{ + return parent->new_context(); +} + void factor_vm::delete_context(context *old_context) { unused_contexts.push_back(old_context); @@ -225,18 +230,11 @@ void factor_vm::primitive_load_locals() ctx->retainstack += sizeof(cell) * count; } -void factor_vm::primitive_current_context() +void factor_vm::primitive_context() { ctx->push(allot_alien(ctx)); } -void factor_vm::primitive_start_context() -{ - cell quot = ctx->pop(); - ctx = new_context(); - unwind_native_frames(quot,ctx->callstack_bottom); -} - void factor_vm::primitive_delete_context() { context *old_context = (context *)pinned_alien_offset(ctx->pop()); diff --git a/vm/contexts.hpp b/vm/contexts.hpp index e746e53ffa..3adabd9e5d 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -79,7 +79,8 @@ struct context { } }; -VM_C_API void begin_callback(factor_vm *vm); -VM_C_API void end_callback(factor_vm *vm); +VM_C_API context *new_context(factor_vm *parent); +VM_C_API void begin_callback(factor_vm *parent); +VM_C_API void end_callback(factor_vm *parent); } diff --git a/vm/primitives.hpp b/vm/primitives.hpp index cbbadd2596..4d72cf1abb 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -43,9 +43,9 @@ namespace factor _(code_room) \ _(compact_gc) \ _(compute_identity_hashcode) \ + _(context) \ _(context_object) \ _(current_callback) \ - _(current_context) \ _(data_room) \ _(datastack) \ _(delete_context) \ @@ -122,7 +122,6 @@ namespace factor _(size) \ _(sleep) \ _(special_object) \ - _(start_context) \ _(string) \ _(string_nth) \ _(strip_stack_traces) \ diff --git a/vm/vm.hpp b/vm/vm.hpp index f2f2d9a769..defe4f24eb 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -125,8 +125,7 @@ struct factor_vm void primitive_set_retainstack(); void primitive_check_datastack(); void primitive_load_locals(); - void primitive_current_context(); - void primitive_start_context(); + void primitive_context(); void primitive_delete_context(); template void iterate_active_callstacks(Iterator &iter) From e6b9e54454ff244222d012523e844b4e180bdce3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 03:35:01 -0400 Subject: [PATCH 040/123] stack-checker.known-words: fix load error --- basis/stack-checker/known-words/known-words.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 656c159a9b..a625eedb3a 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -508,8 +508,8 @@ M: bad-executable summary \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable -\ current-context { } { c-ptr } define-primitive -\ current-context make-flushable +\ context { } { c-ptr } define-primitive +\ context make-flushable \ delete-context { c-ptr } { } define-primitive From fa08afdde8608bcad93406caba0dc3f7ec7de787 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 03:35:10 -0400 Subject: [PATCH 041/123] vm: fix ridiculous default callstack size --- vm/factor.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/factor.cpp b/vm/factor.cpp index c38e38a5d0..c33db440a0 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -95,7 +95,7 @@ void factor_vm::init_factor(vm_parameters *p) /* Kilobytes */ p->datastack_size = align_page(p->datastack_size << 10); p->retainstack_size = align_page(p->retainstack_size << 10); - p->callstack_size = align_page(p->retainstack_size << 10); + p->callstack_size = align_page(p->callstack_size << 10); p->callback_size = align_page(p->callback_size << 10); /* Megabytes */ From 69bb81dab864277caf4971782a0f144d8ca33c5b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 03:44:40 -0400 Subject: [PATCH 042/123] vm: clean up TLS usage --- vm/code_blocks.cpp | 2 +- vm/errors.cpp | 10 +++++----- vm/os-linux-arm.cpp | 2 +- vm/os-unix.cpp | 16 ++++++++-------- vm/os-unix.hpp | 2 +- vm/os-windows-nt.cpp | 6 +++--- vm/os-windows-nt.hpp | 2 +- 7 files changed, 20 insertions(+), 20 deletions(-) diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index e002b26afc..4741a68c54 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -149,7 +149,7 @@ void factor_vm::undefined_symbol() void undefined_symbol() { - return tls_vm()->undefined_symbol(); + return current_vm()->undefined_symbol(); } /* Look up an external library symbol referenced by a compiled code block */ diff --git a/vm/errors.cpp b/vm/errors.cpp index 8efcb3346f..37a9452744 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -17,13 +17,13 @@ void critical_error(const char *msg, cell tagged) std::cout << "critical_error: " << msg; std::cout << ": " << std::hex << tagged << std::dec; std::cout << std::endl; - tls_vm()->factorbug(); + current_vm()->factorbug(); } void out_of_memory() { std::cout << "Out of memory\n\n"; - tls_vm()->dump_generations(); + current_vm()->dump_generations(); exit(1); } @@ -146,7 +146,7 @@ void factor_vm::memory_signal_handler_impl() void memory_signal_handler_impl() { - tls_vm()->memory_signal_handler_impl(); + current_vm()->memory_signal_handler_impl(); } void factor_vm::misc_signal_handler_impl() @@ -156,7 +156,7 @@ void factor_vm::misc_signal_handler_impl() void misc_signal_handler_impl() { - tls_vm()->misc_signal_handler_impl(); + current_vm()->misc_signal_handler_impl(); } void factor_vm::fp_signal_handler_impl() @@ -166,7 +166,7 @@ void factor_vm::fp_signal_handler_impl() void fp_signal_handler_impl() { - tls_vm()->fp_signal_handler_impl(); + current_vm()->fp_signal_handler_impl(); } } diff --git a/vm/os-linux-arm.cpp b/vm/os-linux-arm.cpp index 07eda12186..8e131b9011 100644 --- a/vm/os-linux-arm.cpp +++ b/vm/os-linux-arm.cpp @@ -25,7 +25,7 @@ void flush_icache(cell start, cell len) : "r0","r1","r2"); if(result < 0) - tls_vm()critical_error("flush_icache() failed",result); + critical_error("flush_icache() failed",result); } } diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 15f8132a63..f63b509cb5 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -17,23 +17,23 @@ THREADHANDLE start_thread(void *(*start_routine)(void *),void *args) return thread; } -pthread_key_t tlsKey = 0; +pthread_key_t current_vm_tls_key = 0; void init_platform_globals() { - if (pthread_key_create(&tlsKey, NULL) != 0) + if (pthread_key_create(¤t_vm_tls_key, NULL) != 0) fatal_error("pthread_key_create() failed",0); } void register_vm_with_thread(factor_vm *vm) { - pthread_setspecific(tlsKey,vm); + pthread_setspecific(current_vm_tls_key,vm); } -factor_vm *tls_vm() +factor_vm *current_vm() { - factor_vm *vm = (factor_vm*)pthread_getspecific(tlsKey); + factor_vm *vm = (factor_vm*)pthread_getspecific(current_vm_tls_key); assert(vm != NULL); return vm; } @@ -156,21 +156,21 @@ void factor_vm::dispatch_signal(void *uap, void (handler)()) void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - factor_vm *vm = tls_vm(); + factor_vm *vm = current_vm(); vm->signal_fault_addr = (cell)siginfo->si_addr; vm->dispatch_signal(uap,factor::memory_signal_handler_impl); } void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - factor_vm *vm = tls_vm(); + factor_vm *vm = current_vm(); vm->signal_number = signal; vm->dispatch_signal(uap,factor::misc_signal_handler_impl); } void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - factor_vm *vm = tls_vm(); + factor_vm *vm = current_vm(); vm->signal_number = signal; vm->signal_fpu_status = fpu_status(uap_fpu_status(uap)); uap_clear_fpu_status(uap); diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 29378bb523..de60bbe15f 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -50,7 +50,7 @@ void sleep_nanos(u64 nsec); void init_platform_globals(); void register_vm_with_thread(factor_vm *vm); -factor_vm *tls_vm(); +factor_vm *current_vm(); void open_console(); void move_file(const vm_char *path1, const vm_char *path2); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 07d428fb49..d33a935f7f 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -22,9 +22,9 @@ void register_vm_with_thread(factor_vm *vm) fatal_error("TlsSetValue failed",0); } -factor_vm *tls_vm() +factor_vm *current_vm() { - factor_vm *vm = (factor_vm*)TlsGetValue(dwTlsIndex); + factor_vm *vm = (factor_vm *)TlsGetValue(dwTlsIndex); assert(vm != NULL); return vm; } @@ -122,7 +122,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe) { - return tls_vm()->exception_handler(pe); + return current_vm()->exception_handler(pe); } void factor_vm::c_to_factor_toplevel(cell quot) diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 8ad34ed147..d425a2c281 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -47,6 +47,6 @@ inline static THREADHANDLE thread_id() { return GetCurrentThread(); } void init_platform_globals(); void register_vm_with_thread(factor_vm *vm); -factor_vm *tls_vm(); +factor_vm *current_vm(); } From 88d07939467580a25b6f9bf161559e8bb4cf774d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 06:25:47 -0400 Subject: [PATCH 043/123] spelling: John Benediktsson's port of Peter Norvig's spelling corrector --- extra/spelling/authors.txt | 1 + extra/spelling/spelling-tests.factor | 14 ++ extra/spelling/spelling.factor | 78 +++++++++ extra/spelling/summary.txt | 1 + extra/spelling/tags.txt | 1 + extra/spelling/test.txt | 246 +++++++++++++++++++++++++++ 6 files changed, 341 insertions(+) create mode 100644 extra/spelling/authors.txt create mode 100644 extra/spelling/spelling-tests.factor create mode 100644 extra/spelling/spelling.factor create mode 100644 extra/spelling/summary.txt create mode 100644 extra/spelling/tags.txt create mode 100644 extra/spelling/test.txt diff --git a/extra/spelling/authors.txt b/extra/spelling/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/spelling/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/spelling/spelling-tests.factor b/extra/spelling/spelling-tests.factor new file mode 100644 index 0000000000..f32363854b --- /dev/null +++ b/extra/spelling/spelling-tests.factor @@ -0,0 +1,14 @@ +USING: spelling tools.test memoize ; +IN: spelling.tests + +MEMO: test-dictionary ( -- assoc ) + "vocab:spelling/test.txt" load-dictionary ; + +: test-correct ( word -- word/f ) + test-dictionary (correct) ; + +[ "government" ] [ "goverment" test-correct ] unit-test +[ "government" ] [ "govxernment" test-correct ] unit-test +[ "government" ] [ "govermnent" test-correct ] unit-test +[ "government" ] [ "govxermnent" test-correct ] unit-test +[ "government" ] [ "govyrmnent" test-correct ] unit-test diff --git a/extra/spelling/spelling.factor b/extra/spelling/spelling.factor new file mode 100644 index 0000000000..b8a90bd2da --- /dev/null +++ b/extra/spelling/spelling.factor @@ -0,0 +1,78 @@ +USING: arrays ascii assocs combinators combinators.smart fry +http.client io.encodings.ascii io.files io.files.temp kernel +locals math math.statistics memoize sequences sorting splitting +strings urls ; +IN: spelling + +! http://norvig.com/spell-correct.html + +CONSTANT: ALPHABET "abcdefghijklmnopqrstuvwxyz" + +: splits ( word -- sequence ) + dup length iota [ cut 2array ] with map ; + +: deletes ( sequence -- sequence' ) + [ second length 0 > ] filter [ first2 rest append ] map ; + +: transposes ( sequence -- sequence' ) + [ second length 1 > ] filter [ + [ + { + [ first ] + [ second second 1string ] + [ second first 1string ] + [ second 2 tail ] + } cleave + ] "" append-outputs-as + ] map ; + +: replaces ( sequence -- sequence' ) + [ second length 0 > ] filter [ + [ ALPHABET ] dip first2 + '[ 1string _ _ rest surround ] { } map-as + ] map concat ; + +: inserts ( sequence -- sequence' ) + [ + ALPHABET + [ [ first2 ] dip 1string glue ] with { } map-as + ] map concat ; + +: edits1 ( word -- edits ) + [ + splits { + [ deletes ] + [ transposes ] + [ replaces ] + [ inserts ] + } cleave + ] append-outputs ; + +: edits2 ( word -- edits ) + edits1 [ edits1 ] map concat ; + +: filter-known ( words dictionary -- words' ) + '[ _ key? ] filter ; + +:: corrections ( word dictionary -- words ) + word 1array dictionary filter-known + [ word edits1 dictionary filter-known ] when-empty + [ word edits2 dictionary filter-known ] when-empty + [ dictionary at 1 or ] sort-with ; + +: words ( string -- words ) + >lower [ letter? not ] split-when harvest ; + +: load-dictionary ( file -- assoc ) + ascii file-contents words histogram ; + +MEMO: default-dictionary ( -- counts ) + "big.txt" temp-file dup exists? + [ URL" http://norvig.com/big.txt" over download-to ] unless + load-dictionary ; + +: (correct) ( word dictionary -- word/f ) + corrections [ f ] [ first ] if-empty ; + +: correct ( word -- word/f ) + default-dictionary (correct) ; diff --git a/extra/spelling/summary.txt b/extra/spelling/summary.txt new file mode 100644 index 0000000000..7fa90685bc --- /dev/null +++ b/extra/spelling/summary.txt @@ -0,0 +1 @@ +Peter Norvig's spelling corrector diff --git a/extra/spelling/tags.txt b/extra/spelling/tags.txt new file mode 100644 index 0000000000..1e107f52e4 --- /dev/null +++ b/extra/spelling/tags.txt @@ -0,0 +1 @@ +examples diff --git a/extra/spelling/test.txt b/extra/spelling/test.txt new file mode 100644 index 0000000000..5b9de09b8f --- /dev/null +++ b/extra/spelling/test.txt @@ -0,0 +1,246 @@ +AMERICAN FOREIGN RELATIONS (1865-98) + +=French Intrigues in Mexico Blocked.=--Between the war for the union and +the war with Spain, the Department of State had many an occasion to +present the rights of America among the powers of the world. Only a +little while after the civil conflict came to a close, it was called +upon to deal with a dangerous situation created in Mexico by the +ambitions of Napoleon III. During the administration of Buchanan, Mexico +had fallen into disorder through the strife of the Liberal and the +Clerical parties; the President asked for authority to use American +troops to bring to a peaceful haven "a wreck upon the ocean, drifting +about as she is impelled by different factions." Our own domestic crisis +then intervened. + +Observing the United States heavily involved in its own problems, the +great powers, England, France, and Spain, decided in the autumn of 1861 +to take a hand themselves in restoring order in Mexico. They entered +into an agreement to enforce the claims of their citizens against Mexico +and to protect their subjects residing in that republic. They invited +the United States to join them, and, on meeting a polite refusal, they +prepared for a combined military and naval demonstration on their own +account. In the midst of this action England and Spain, discovering the +sinister purposes of Napoleon, withdrew their troops and left the field +to him. + +The French Emperor, it was well known, looked with jealousy upon the +growth of the United States and dreamed of establishing in the Western +hemisphere an imperial power to offset the American republic. +Intervention to collect debts was only a cloak for his deeper designs. +Throwing off that guise in due time, he made the Archduke Maximilian, a +brother of the ruler of Austria, emperor in Mexico, and surrounded his +throne by French soldiers, in spite of all protests. + +This insolent attack upon the Mexican republic, deeply resented in the +United States, was allowed to drift in its course until 1865. At that +juncture General Sheridan was dispatched to the Mexican border with a +large armed force; General Grant urged the use of the American army to +expel the French from this continent. The Secretary of State, Seward, +counseled negotiation first, and, applying the Monroe Doctrine, was able +to prevail upon Napoleon III to withdraw his troops. Without the support +of French arms, the sham empire in Mexico collapsed like a house of +cards and the unhappy Maximilian, the victim of French ambition and +intrigue, met his death at the hands of a Mexican firing squad. + +=Alaska Purchased.=--The Mexican affair had not been brought to a close +before the Department of State was busy with negotiations which resulted +in the purchase of Alaska from Russia. The treaty of cession, signed on +March 30, 1867, added to the United States a domain of nearly six +hundred thousand square miles, a territory larger than Texas and nearly +three-fourths the size of the Louisiana purchase. Though it was a +distant colony separated from our continental domain by a thousand miles +of water, no question of "imperialism" or "colonization foreign to +American doctrines" seems to have been raised at the time. The treaty +was ratified promptly by the Senate. The purchase price, $7,200,000, was +voted by the House of Representatives after the display of some +resentment against a system that compelled it to appropriate money to +fulfill an obligation which it had no part in making. Seward, who +formulated the treaty, rejoiced, as he afterwards said, that he had kept +Alaska out of the hands of England. + +=American Interest in the Caribbean.=--Having achieved this diplomatic +triumph, Seward turned to the increase of American power in another +direction. He negotiated, with Denmark, a treaty providing for the +purchase of the islands of St. John and St. Thomas in the West Indies, +strategic points in the Caribbean for sea power. This project, long +afterward brought to fruition by other men, was defeated on this +occasion by the refusal of the Senate to ratify the treaty. Evidently it +was not yet prepared to exercise colonial dominion over other races. + +Undaunted by the misadventure in Caribbean policies, President Grant +warmly advocated the acquisition of Santo Domingo. This little republic +had long been in a state of general disorder. In 1869 a treaty of +annexation was concluded with its president. The document Grant +transmitted to the Senate with his cordial approval, only to have it +rejected. Not at all changed in his opinion by the outcome of his +effort, he continued to urge the subject of annexation. Even in his last +message to Congress he referred to it, saying that time had only proved +the wisdom of his early course. The addition of Santo Domingo to the +American sphere of protection was the work of a later generation. The +State Department, temporarily checked, had to bide its time. + +=The _Alabama_ Claims Arbitrated.=--Indeed, it had in hand a far more +serious matter, a vexing issue that grew out of Civil War diplomacy. The +British government, as already pointed out in other connections, had +permitted Confederate cruisers, including the famous _Alabama_, built in +British ports, to escape and prey upon the commerce of the Northern +states. This action, denounced at the time by our government as a grave +breach of neutrality as well as a grievous injury to American citizens, +led first to remonstrances and finally to repeated claims for damages +done to American ships and goods. For a long time Great Britain was +firm. Her foreign secretary denied all obligations in the premises, +adding somewhat curtly that "he wished to say once for all that Her +Majesty's government disclaimed any responsibility for the losses and +hoped that they had made their position perfectly clear." Still +President Grant was not persuaded that the door of diplomacy, though +closed, was barred. Hamilton Fish, his Secretary of State, renewed the +demand. Finally he secured from the British government in 1871 the +treaty of Washington providing for the arbitration not merely of the +_Alabama_ and other claims but also all points of serious controversy +between the two countries. + +The tribunal of arbitration thus authorized sat at Geneva in +Switzerland, and after a long and careful review of the arguments on +both sides awarded to the United States the lump sum of $15,500,000 to +be distributed among the American claimants. The damages thus allowed +were large, unquestionably larger than strict justice required and it is +not surprising that the decision excited much adverse comment in +England. Nevertheless, the prompt payment by the British government +swept away at once a great cloud of ill-feeling in America. Moreover, +the spectacle of two powerful nations choosing the way of peaceful +arbitration to settle an angry dispute seemed a happy, if illusory, omen +of a modern method for avoiding the arbitrament of war. + +=Samoa.=--If the Senate had its doubts at first about the wisdom of +acquiring strategic points for naval power in distant seas, the same +could not be said of the State Department or naval officers. In 1872 +Commander Meade, of the United States navy, alive to the importance of +coaling stations even in mid-ocean, made a commercial agreement with the +chief of Tutuila, one of the Samoan Islands, far below the equator, in +the southern Pacific, nearer to Australia than to California. This +agreement, providing among other things for our use of the harbor of +Pago Pago as a naval base, was six years later changed into a formal +treaty ratified by the Senate. + +Such enterprise could not escape the vigilant eyes of England and +Germany, both mindful of the course of the sea power in history. The +German emperor, seizing as a pretext a quarrel between his consul in the +islands and a native king, laid claim to an interest in the Samoan +group. England, aware of the dangers arising from German outposts in the +southern seas so near to Australia, was not content to stand aside. So +it happened that all three countries sent battleships to the Samoan +waters, threatening a crisis that was fortunately averted by friendly +settlement. If, as is alleged, Germany entertained a notion of +challenging American sea power then and there, the presence of British +ships must have dispelled that dream. + +The result of the affair was a tripartite agreement by which the three +powers in 1889 undertook a protectorate over the islands. But joint +control proved unsatisfactory. There was constant friction between the +Germans and the English. The spheres of authority being vague and open +to dispute, the plan had to be abandoned at the end of ten years. +England withdrew altogether, leaving to Germany all the islands except +Tutuila, which was ceded outright to the United States. Thus one of the +finest harbors in the Pacific, to the intense delight of the American +navy, passed permanently under American dominion. Another triumph in +diplomacy was set down to the credit of the State Department. + +=Cleveland and the Venezuela Affair.=--In the relations with South +America, as well as in those with the distant Pacific, the diplomacy of +the government at Washington was put to the test. For some time it had +been watching a dispute between England and Venezuela over the western +boundary of British Guiana and, on an appeal from Venezuela, it had +taken a lively interest in the contest. In 1895 President Cleveland saw +that Great Britain would yield none of her claims. After hearing the +arguments of Venezuela, his Secretary of State, Richard T. Olney, in a +note none too conciliatory, asked the British government whether it was +willing to arbitrate the points in controversy. This inquiry he +accompanied by a warning to the effect that the United States could not +permit any European power to contest its mastery in this hemisphere. +"The United States," said the Secretary, "is practically sovereign on +this continent and its fiat is law upon the subjects to which it +confines its interposition.... Its infinite resources, combined with its +isolated position, render it master of the situation and practically +invulnerable against any or all other powers." + +The reply evoked from the British government by this strong statement +was firm and clear. The Monroe Doctrine, it said, even if not so widely +stretched by interpretation, was not binding in international law; the +dispute with Venezuela was a matter of interest merely to the parties +involved; and arbitration of the question was impossible. This response +called forth President Cleveland's startling message of 1895. He asked +Congress to create a commission authorized to ascertain by researches +the true boundary between Venezuela and British Guiana. He added that it +would be the duty of this country "to resist by every means in its +power, as a willful aggression upon its rights and interests, the +appropriation by Great Britain of any lands or the exercise of +governmental jurisdiction over any territory which, after investigation, +we have determined of right belongs to Venezuela." The serious character +of this statement he thoroughly understood. He declared that he was +conscious of his responsibilities, intimating that war, much as it was +to be deplored, was not comparable to "a supine submission to wrong and +injustice and the consequent loss of national self-respect and honor." + +[Illustration: GROVER CLEVELAND] + +The note of defiance which ran through this message, greeted by shrill +cries of enthusiasm in many circles, was viewed in other quarters as a +portent of war. Responsible newspapers in both countries spoke of an +armed settlement of the dispute as inevitable. Congress created the +commission and appropriated money for the investigation; a body of +learned men was appointed to determine the merits of the conflicting +boundary claims. The British government, deaf to the clamor of the +bellicose section of the London press, deplored the incident, +courteously replied in the affirmative to a request for assistance in +the search for evidence, and finally agreed to the proposition that the +issue be submitted to arbitration. The outcome of this somewhat perilous +dispute contributed not a little to Cleveland's reputation as "a +sterling representative of the true American spirit." This was not +diminished when the tribunal of arbitration found that Great Britain was +on the whole right in her territorial claims against Venezuela. + +=The Annexation of Hawaii.=--While engaged in the dangerous Venezuela +controversy, President Cleveland was compelled by a strange turn in +events to consider the annexation of the Hawaiian Islands in the +mid-Pacific. For more than half a century American missionaries had been +active in converting the natives to the Christian faith and enterprising +American business men had been developing the fertile sugar plantations. +Both the Department of State and the Navy Department were fully +conscious of the strategic relation of the islands to the growth of sea +power and watched with anxiety any developments likely to bring them +under some other Dominion. + +The country at large was indifferent, however, until 1893, when a +revolution, headed by Americans, broke out, ending in the overthrow of +the native government, the abolition of the primitive monarchy, and the +retirement of Queen Liliuokalani to private life. This crisis, a +repetition of the Texas affair in a small theater, was immediately +followed by a demand from the new Hawaiian government for annexation to +the United States. President Harrison looked with favor on the proposal, +negotiated the treaty of annexation, and laid it before the Senate for +approval. There it still rested when his term of office was brought to a +close. + +Harrison's successor, Cleveland, it was well known, had doubts about the +propriety of American action in Hawaii. For the purpose of making an +inquiry into the matter, he sent a special commissioner to the islands. +On the basis of the report of his agent, Cleveland came to the +conclusion that "the revolution in the island kingdom had been +accomplished by the improper use of the armed forces of the United +States and that the wrong should be righted by a restoration of the +queen to her throne." Such being his matured conviction, though the +facts upon which he rested it were warmly controverted, he could do +nothing but withdraw the treaty from the Senate and close the incident. + +To the Republicans this sharp and cavalier disposal of their plans, +carried out in a way that impugned the motives of a Republican +President, was nothing less than "a betrayal of American interests." In +their platform of 1896 they made clear their position: "Our foreign +policy should be at all times firm, vigorous, and dignified and all our +interests in the Western hemisphere carefully watched and guarded. The +Hawaiian Islands should be controlled by the United States and no +foreign power should be permitted to interfere with them." There was no +mistaking this view of the issue. As the vote in the election gave +popular sanction to Republican policies, Congress by a joint resolution, +passed on July 6, 1898, annexed the islands to the United States and +later conferred upon them the ordinary territorial form of government. From 11ddbc03a4d56763d8eec123ddce61083db1a661 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 07:33:28 -0400 Subject: [PATCH 044/123] vm: signal handling cleanup --- vm/alien.cpp | 2 +- vm/callstack.cpp | 12 +++++-- vm/code_blocks.cpp | 2 +- vm/contexts.cpp | 15 ++++++-- vm/contexts.hpp | 16 ++------- vm/errors.cpp | 76 +++++++++++++++++------------------------ vm/errors.hpp | 8 ++--- vm/io.cpp | 2 +- vm/mach_signal.cpp | 14 ++------ vm/math.cpp | 2 +- vm/os-genunix.hpp | 5 --- vm/os-macosx-ppc.hpp | 5 --- vm/os-macosx-x86.32.hpp | 5 --- vm/os-macosx-x86.64.hpp | 5 --- vm/os-unix.cpp | 15 ++------ vm/os-windows-nt.cpp | 2 ++ vm/os-windows.cpp | 2 +- vm/segments.hpp | 10 ++++++ vm/vm.hpp | 16 ++++----- 19 files changed, 90 insertions(+), 124 deletions(-) diff --git a/vm/alien.cpp b/vm/alien.cpp index 44365859e2..da70fa134e 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -13,7 +13,7 @@ char *factor_vm::pinned_alien_offset(cell obj) { alien *ptr = untag(obj); if(to_boolean(ptr->expired)) - general_error(ERROR_EXPIRED,obj,false_object,NULL); + general_error(ERROR_EXPIRED,obj,false_object); if(to_boolean(ptr->base)) type_error(ALIEN_TYPE,obj); else diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 8389ff8d90..7268d6ab91 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -18,11 +18,17 @@ callstack *factor_vm::allot_callstack(cell size) return stack; } -stack_frame *factor_vm::fix_callstack_top(stack_frame *top, stack_frame *bottom) +/* If 'stack' points into the middle of the frame, find the nearest valid stack +pointer where we can resume execution and hope to capture the call trace without +crashing. Also, make sure we have at least 'stack_reserved' bytes available so +that we don't run out of callstack space while handling the error. */ +stack_frame *factor_vm::fix_callstack_top(stack_frame *stack) { - stack_frame *frame = bottom - 1; + stack_frame *frame = ctx->callstack_bottom - 1; - while(frame >= top) + while(frame >= stack + && frame >= ctx->callstack_top + && (cell)frame >= ctx->callstack_seg->start + stack_reserved) frame = frame_successor(frame); return frame + 1; diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 4741a68c54..894e49846d 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -144,7 +144,7 @@ void factor_vm::update_word_references(code_block *compiled, bool reset_inline_c image load */ void factor_vm::undefined_symbol() { - general_error(ERROR_UNDEFINED_SYMBOL,false_object,false_object,NULL); + general_error(ERROR_UNDEFINED_SYMBOL,false_object,false_object); } void undefined_symbol() diff --git a/vm/contexts.cpp b/vm/contexts.cpp index f21d9c948d..8734ff8486 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -44,6 +44,17 @@ void context::reset() reset_context_objects(); } +void context::fix_stacks() +{ + if(datastack + sizeof(cell) < datastack_seg->start + || datastack + stack_reserved >= datastack_seg->end) + reset_datastack(); + + if(retainstack + sizeof(cell) < retainstack_seg->start + || retainstack + stack_reserved >= retainstack_seg->end) + reset_retainstack(); +} + context::~context() { delete datastack_seg; @@ -167,13 +178,13 @@ bool factor_vm::stack_to_array(cell bottom, cell top) void factor_vm::primitive_datastack() { if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack)) - general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL); + general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); } void factor_vm::primitive_retainstack() { if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack)) - general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL); + general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object); } /* returns pointer to top of stack */ diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 3adabd9e5d..441b5916c8 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -8,6 +8,8 @@ enum context_object { OBJ_CATCHSTACK, }; +static const cell stack_reserved = 1024; + struct context { // First 4 fields accessed directly by compiler. See basis/vm/vm.factor @@ -41,6 +43,7 @@ struct context { void reset_callstack(); void reset_context_objects(); void reset(); + void fix_stacks(); cell peek() { @@ -64,19 +67,6 @@ struct context { datastack += sizeof(cell); replace(tagged); } - - static const cell stack_reserved = (64 * sizeof(cell)); - - void fix_stacks() - { - if(datastack + sizeof(cell) < datastack_seg->start - || datastack + stack_reserved >= datastack_seg->end) - reset_datastack(); - - if(retainstack + sizeof(cell) < retainstack_seg->start - || retainstack + stack_reserved >= retainstack_seg->end) - reset_retainstack(); - } }; VM_C_API context *new_context(factor_vm *parent); diff --git a/vm/errors.cpp b/vm/errors.cpp index 37a9452744..d0c72989a3 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -27,8 +27,10 @@ void out_of_memory() exit(1); } -void factor_vm::throw_error(cell error, stack_frame *callstack_top) +void factor_vm::throw_error(cell error, stack_frame *stack) { + assert(stack); + /* If the error handler is set, we rewind any C stack frames and pass the error to user-space. */ if(!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT])) @@ -41,22 +43,13 @@ void factor_vm::throw_error(cell error, stack_frame *callstack_top) bignum_roots.clear(); code_roots.clear(); - /* If we had an underflow or overflow, stack pointers might be - out of bounds */ + /* If we had an underflow or overflow, data or retain stack + pointers might be out of bounds */ ctx->fix_stacks(); ctx->push(error); - /* Errors thrown from C code pass NULL for this parameter. - Errors thrown from Factor code, or signal handlers, pass the - actual stack pointer at the time, since the saved pointer is - not necessarily up to date at that point. */ - if(callstack_top) - callstack_top = fix_callstack_top(callstack_top,ctx->callstack_bottom); - else - callstack_top = ctx->callstack_top; - - unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],callstack_top); + unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],stack); } /* Error was thrown in early startup before error handler is set, just crash. */ @@ -70,62 +63,55 @@ void factor_vm::throw_error(cell error, stack_frame *callstack_top) } } -void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top) +void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack) { throw_error(allot_array_4(special_objects[OBJ_ERROR], - tag_fixnum(error),arg1,arg2),callstack_top); + tag_fixnum(error),arg1,arg2),stack); +} + +void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2) +{ + throw_error(allot_array_4(special_objects[OBJ_ERROR], + tag_fixnum(error),arg1,arg2),ctx->callstack_top); } void factor_vm::type_error(cell type, cell tagged) { - general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); + general_error(ERROR_TYPE,tag_fixnum(type),tagged); } void factor_vm::not_implemented_error() { - general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object,NULL); + general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object); } -/* Test if 'fault' is in the guard page at the top or bottom (depending on -offset being 0 or -1) of area+area_size */ -bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset) +void factor_vm::memory_protection_error(cell addr, stack_frame *stack) { - int pagesize = getpagesize(); - area += area_size; - area += offset * pagesize; - - return fault >= area && fault <= area + pagesize; -} - -void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack) -{ - if(in_page(addr, ctx->datastack_seg->start, 0, -1)) - general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, ctx->datastack_seg->start, datastack_size, 0)) - general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, ctx->retainstack_seg->start, 0, -1)) - general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, ctx->retainstack_seg->start, retainstack_size, 0)) - general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack); - else if(in_page(addr, nursery.end, 0, 0)) - critical_error("allot_object() missed GC check",0); + if(ctx->datastack_seg->underflow_p(addr)) + general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object,stack); + else if(ctx->datastack_seg->overflow_p(addr)) + general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object,stack); + else if(ctx->retainstack_seg->underflow_p(addr)) + general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object,stack); + else if(ctx->retainstack_seg->overflow_p(addr)) + general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object,stack); else - general_error(ERROR_MEMORY,allot_cell(addr),false_object,native_stack); + general_error(ERROR_MEMORY,allot_cell(addr),false_object,stack); } -void factor_vm::signal_error(cell signal, stack_frame *native_stack) +void factor_vm::signal_error(cell signal, stack_frame *stack) { - general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack); + general_error(ERROR_SIGNAL,allot_cell(signal),false_object,stack); } void factor_vm::divide_by_zero_error() { - general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object,NULL); + general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object); } -void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top) +void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *stack) { - general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,signal_callstack_top); + general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,stack); } void factor_vm::primitive_call_clear() diff --git a/vm/errors.hpp b/vm/errors.hpp index 4b237e03a0..0ce5957aef 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -14,10 +14,10 @@ enum vm_error_type ERROR_C_STRING, ERROR_FFI, ERROR_UNDEFINED_SYMBOL, - ERROR_DS_UNDERFLOW, - ERROR_DS_OVERFLOW, - ERROR_RS_UNDERFLOW, - ERROR_RS_OVERFLOW, + ERROR_DATASTACK_UNDERFLOW, + ERROR_DATASTACK_OVERFLOW, + ERROR_RETAINSTACK_UNDERFLOW, + ERROR_RETAINSTACK_OVERFLOW, ERROR_MEMORY, ERROR_FP_TRAP, }; diff --git a/vm/io.cpp b/vm/io.cpp index fdd872457e..8ce7ff5256 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -28,7 +28,7 @@ void factor_vm::io_error() return; #endif - general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL); + general_error(ERROR_IO,tag_fixnum(errno),false_object); } FILE *factor_vm::safe_fopen(char *filename, char *mode) diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index 6295381b1c..af14c3a49a 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -35,19 +35,9 @@ void factor_vm::call_fault_handler( MACH_THREAD_STATE_TYPE *thread_state, MACH_FLOAT_STATE_TYPE *float_state) { - /* There is a race condition here, but in practice an exception - delivered during stack frame setup/teardown or while transitioning - from Factor to C is a sign of things seriously gone wrong, not just - a divide by zero or stack underflow in the listener */ + MACH_STACK_POINTER(thread_state) = (cell)fix_callstack_top((stack_frame *)MACH_STACK_POINTER(thread_state)); - /* Are we in compiled Factor code? Then use the current stack pointer */ - if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state))) - signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state); - /* Are we in C? Then use the saved callstack top */ - else - signal_callstack_top = NULL; - - MACH_STACK_POINTER(thread_state) = align_stack_pointer(MACH_STACK_POINTER(thread_state)); + signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state); /* Now we point the program counter at the right handler function. */ if(exception == EXC_BAD_ACCESS) diff --git a/vm/math.cpp b/vm/math.cpp index bb5d9c13c4..a462232344 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -246,7 +246,7 @@ cell factor_vm::unbox_array_size_slow() } } - general_error(ERROR_ARRAY_SIZE,ctx->pop(),tag_fixnum(array_size_max),NULL); + general_error(ERROR_ARRAY_SIZE,ctx->pop(),tag_fixnum(array_size_max)); return 0; /* can't happen */ } diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index ff5d29ecd7..1972a728e6 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -10,9 +10,4 @@ void early_init(); const char *vm_executable_path(); const char *default_image_path(); -template Type align_stack_pointer(Type sp) -{ - return sp; -} - } diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 30fd4b2081..90da9a26f3 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -62,11 +62,6 @@ inline static unsigned int uap_fpu_status(void *uap) return mach_fpu_status(UAP_FS(uap)); } -template Type align_stack_pointer(Type sp) -{ - return sp; -} - inline static void mach_clear_fpu_status(ppc_float_state_t *float_state) { FPSCR(float_state) &= 0x0007f8ff; diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index a6fe8e2703..3d754ae9e4 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -64,11 +64,6 @@ inline static unsigned int uap_fpu_status(void *uap) return mach_fpu_status(UAP_FS(uap)); } -template Type align_stack_pointer(Type sp) -{ - return (Type)((((cell)sp + 4) & ~15) - 4); -} - inline static void mach_clear_fpu_status(i386_float_state_t *float_state) { MXCSR(float_state) &= 0xffffffc0; diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index cb1980ddbf..7cef436327 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -62,11 +62,6 @@ inline static unsigned int uap_fpu_status(void *uap) return mach_fpu_status(UAP_FS(uap)); } -template Type align_stack_pointer(Type sp) -{ - return (Type)((((cell)sp + 8) & ~15) - 8); -} - inline static void mach_clear_fpu_status(x86_float_state64_t *float_state) { MXCSR(float_state) &= 0xffffffc0; diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index f63b509cb5..94d2a31839 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -85,7 +85,7 @@ void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol) void factor_vm::ffi_dlclose(dll *dll) { if(dlclose(dll->handle)) - general_error(ERROR_FFI,false_object,false_object,NULL); + general_error(ERROR_FFI,false_object,false_object); dll->handle = NULL; } @@ -103,7 +103,7 @@ void factor_vm::move_file(const vm_char *path1, const vm_char *path2) ret = rename((path1),(path2)); } while(ret < 0 && errno == EINTR); if(ret < 0) - general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL); + general_error(ERROR_IO,tag_fixnum(errno),false_object); } segment::segment(cell size_, bool executable_p) @@ -141,16 +141,7 @@ segment::~segment() void factor_vm::dispatch_signal(void *uap, void (handler)()) { - if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap))) - { - stack_frame *ptr = (stack_frame *)UAP_STACK_POINTER(uap); - assert(ptr); - signal_callstack_top = ptr; - } - else - signal_callstack_top = NULL; - - UAP_STACK_POINTER(uap) = align_stack_pointer(UAP_STACK_POINTER(uap)); + UAP_STACK_POINTER(uap) = fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap)); UAP_PROGRAM_COUNTER(uap) = (cell)handler; } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index d33a935f7f..e063fe3db3 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -74,6 +74,8 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; + c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); + if(in_code_heap_p(c->EIP)) signal_callstack_top = (stack_frame *)c->ESP; else diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 08f5932172..d69966567a 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -140,7 +140,7 @@ long getpagesize() void factor_vm::move_file(const vm_char *path1, const vm_char *path2) { if(MoveFileEx((path1),(path2),MOVEFILE_REPLACE_EXISTING) == false) - general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object,NULL); + general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object); } } diff --git a/vm/segments.hpp b/vm/segments.hpp index 5cedada578..7f86c35485 100644 --- a/vm/segments.hpp +++ b/vm/segments.hpp @@ -15,6 +15,16 @@ struct segment { explicit segment(cell size, bool executable_p); ~segment(); + + bool underflow_p(cell addr) + { + return (addr >= start - getpagesize() && addr < start); + } + + bool overflow_p(cell addr) + { + return (addr >= end && addr < end + getpagesize()); + } }; } diff --git a/vm/vm.hpp b/vm/vm.hpp index defe4f24eb..7a0b0fcd33 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -160,20 +160,20 @@ struct factor_vm void primitive_profiling(); // errors - void throw_error(cell error, stack_frame *callstack_top); + void throw_error(cell error, stack_frame *stack); + void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack); + void general_error(vm_error_type error, cell arg1, cell arg2); + void type_error(cell type, cell tagged); void not_implemented_error(); - bool in_page(cell fault, cell area, cell area_size, int offset); - void memory_protection_error(cell addr, stack_frame *native_stack); - void signal_error(cell signal, stack_frame *native_stack); + void memory_protection_error(cell addr, stack_frame *stack); + void signal_error(cell signal, stack_frame *stack); void divide_by_zero_error(); - void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top); + void fp_trap_error(unsigned int fpu_status, stack_frame *stack); void primitive_call_clear(); void primitive_unimplemented(); void memory_signal_handler_impl(); void misc_signal_handler_impl(); void fp_signal_handler_impl(); - void type_error(cell type, cell tagged); - void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack); // bignum int bignum_equal_p(bignum * x, bignum * y); @@ -582,7 +582,7 @@ struct factor_vm template void iterate_callstack_object(callstack *stack_, Iterator &iterator); void check_frame(stack_frame *frame); callstack *allot_callstack(cell size); - stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom); + stack_frame *fix_callstack_top(stack_frame *top); stack_frame *second_from_top_stack_frame(); void primitive_callstack(); code_block *frame_code(stack_frame *frame); From b5f7e91bdcc43e8ff51f91b236a2ee89ad8379dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 07:45:11 -0400 Subject: [PATCH 045/123] vm: report callstack overflow --- basis/debugger/debugger.factor | 8 ++++++-- core/kernel/kernel-tests.factor | 4 ++++ vm/errors.cpp | 6 ++++++ vm/errors.hpp | 2 ++ 4 files changed, 18 insertions(+), 2 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index c34a50190f..d10fd4f73a 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -120,6 +120,8 @@ HOOK: signal-error. os ( obj -- ) : datastack-overflow. ( obj -- ) "Data" stack-overflow. ; : retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ; : retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ; +: callstack-underflow. ( obj -- ) "Call" stack-underflow. ; +: callstack-overflow. ( obj -- ) "Call" stack-overflow. ; : memory-error. ( error -- ) "Memory protection fault at address " write third .h ; @@ -153,8 +155,10 @@ PREDICATE: vm-error < array { 11 [ datastack-overflow. ] } { 12 [ retainstack-underflow. ] } { 13 [ retainstack-overflow. ] } - { 14 [ memory-error. ] } - { 15 [ fp-trap-error. ] } + { 13 [ callstack-underflow. ] } + { 14 [ callstack-overflow. ] } + { 15 [ memory-error. ] } + { 16 [ fp-trap-error. ] } } ; inline M: vm-error summary drop "VM error" ; diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index ca8aa8286b..bf16d9439f 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -46,6 +46,10 @@ IN: kernel.tests [ ] [ :c ] unit-test +: overflow-c ( -- ) overflow-c overflow-c ; + +[ overflow-c ] [ { "kernel-error" 14 f f } = ] must-fail-with + [ -7 ] must-fail [ 3 ] [ t 3 and ] unit-test diff --git a/vm/errors.cpp b/vm/errors.cpp index d0c72989a3..21dff5a475 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -87,6 +87,8 @@ void factor_vm::not_implemented_error() void factor_vm::memory_protection_error(cell addr, stack_frame *stack) { + /* Retain and call stack underflows are not supposed to happen */ + if(ctx->datastack_seg->underflow_p(addr)) general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object,stack); else if(ctx->datastack_seg->overflow_p(addr)) @@ -95,6 +97,10 @@ void factor_vm::memory_protection_error(cell addr, stack_frame *stack) general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object,stack); else if(ctx->retainstack_seg->overflow_p(addr)) general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object,stack); + else if(ctx->callstack_seg->underflow_p(addr)) + general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack); + else if(ctx->callstack_seg->overflow_p(addr)) + general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object,stack); else general_error(ERROR_MEMORY,allot_cell(addr),false_object,stack); } diff --git a/vm/errors.hpp b/vm/errors.hpp index 0ce5957aef..34a23bd46d 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -18,6 +18,8 @@ enum vm_error_type ERROR_DATASTACK_OVERFLOW, ERROR_RETAINSTACK_UNDERFLOW, ERROR_RETAINSTACK_OVERFLOW, + ERROR_CALLSTACK_UNDERFLOW, + ERROR_CALLSTACK_OVERFLOW, ERROR_MEMORY, ERROR_FP_TRAP, }; From b6dfdcb9095e3087e7aa657377f82d0a5a2b5218 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 08:13:57 -0400 Subject: [PATCH 046/123] set-context and start-context primitives can now pass parameters around --- basis/cpu/x86/32/bootstrap.factor | 16 ++++++++++------ basis/cpu/x86/64/bootstrap.factor | 18 ++++++++++-------- .../known-words/known-words.factor | 4 ++-- core/bootstrap/primitives.factor | 4 ++-- 4 files changed, 24 insertions(+), 18 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 6fab8769d5..dde800760e 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -269,12 +269,11 @@ IN: bootstrap.x86 ESP [] vm-reg MOV "new_context" jit-call - ! Save pointer to quotation and parameter, pop them off the - ! datastack + ! Save pointer to quotation and parameter EBX ds-reg MOV ds-reg 8 SUB - ! Make the new context the active context + ! Make the new context active EAX jit-set-context ! Push parameter @@ -288,16 +287,21 @@ IN: bootstrap.x86 ] \ (start-context) define-sub-primitive [ - ! Load context from datastack + ! Load context and parameter from datastack EAX ds-reg [] MOV EAX EAX alien-offset [+] MOV - ds-reg 4 SUB + EBX ds-reg -4 [+] MOV + ds-reg 8 SUB - ! Make it the active context + ! Make the new context active EAX jit-set-context ! Twiddle stack for return ESP 4 ADD + + ! Store parameter to datastack + ds-reg 4 ADD + ds-reg [] EBX MOV ] \ (set-context) define-sub-primitive << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index e8fa026a49..9eb59e2c86 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -242,15 +242,12 @@ IN: bootstrap.x86 arg1 vm-reg MOV "new_context" jit-call - ! Load quotation from datastack + ! Load quotation and parameter from datastack arg1 ds-reg [] MOV - - ! Load parameter from datastack arg2 ds-reg -8 [+] MOV - ds-reg 16 SUB - ! Make the new context the active context + ! Make the new context active return-reg jit-set-context ! Push parameter @@ -262,16 +259,21 @@ IN: bootstrap.x86 ] \ (start-context) define-sub-primitive [ - ! Load context from datastack + ! Load context and parameter from datastack temp0 ds-reg [] MOV temp0 temp0 alien-offset [+] MOV - ds-reg 8 SUB + temp1 ds-reg -8 [+] MOV + ds-reg 16 SUB - ! Make it the active context + ! Make the new context active temp0 jit-set-context ! Twiddle stack for return RSP 8 ADD + + ! Store parameter to datastack + ds-reg 8 ADD + ds-reg [] temp1 MOV ] \ (set-context) define-sub-primitive << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a625eedb3a..a95456cdc6 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -513,9 +513,9 @@ M: bad-executable summary \ delete-context { c-ptr } { } define-primitive -\ (start-context) { object quotation } { } define-primitive +\ (start-context) { object quotation } { object } define-primitive -\ (set-context) { alien } { } define-primitive +\ (set-context) { object alien } { object } define-primitive \ special-object { fixnum } { object } define-primitive \ special-object make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 9971c00e1d..38e1a380ee 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -369,8 +369,8 @@ tuple { "fixnum<=" "math.private" (( x y -- z )) } { "fixnum>" "math.private" (( x y -- ? )) } { "fixnum>=" "math.private" (( x y -- ? )) } - { "(set-context)" "threads.private" (( context -- )) } - { "(start-context)" "threads.private" (( obj quot -- )) } + { "(set-context)" "threads.private" (( obj context -- obj' )) } + { "(start-context)" "threads.private" (( obj quot -- obj' )) } } [ first3 make-sub-primitive ] each ! Primitive words From 19aef06741d3998bf4fe83807b097031a45ebb40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 09:44:20 -0400 Subject: [PATCH 047/123] vm: fix compilation on various Unices --- vm/os-freebsd.hpp | 2 ++ vm/os-linux.hpp | 2 ++ vm/os-macosx.hpp | 2 ++ vm/os-netbsd.hpp | 7 ++----- vm/os-openbsd.hpp | 1 + vm/os-unix.cpp | 2 +- vm/platform.hpp | 3 ++- 7 files changed, 12 insertions(+), 7 deletions(-) create mode 100644 vm/os-openbsd.hpp diff --git a/vm/os-freebsd.hpp b/vm/os-freebsd.hpp index 7797a7199b..177a920d87 100644 --- a/vm/os-freebsd.hpp +++ b/vm/os-freebsd.hpp @@ -6,3 +6,5 @@ extern "C" int getosreldate(); #ifndef KERN_PROC_PATHNAME #define KERN_PROC_PATHNAME 12 #endif + +#define UAP_STACK_POINTER_TYPE __register_t diff --git a/vm/os-linux.hpp b/vm/os-linux.hpp index de13896b9a..6c490de260 100644 --- a/vm/os-linux.hpp +++ b/vm/os-linux.hpp @@ -7,4 +7,6 @@ VM_C_API int inotify_init(); VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask); VM_C_API int inotify_rm_watch(int fd, u32 wd); +#define UAP_STACK_POINTER_TYPE greg_t + } diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 0d230f48e3..93f6574367 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -15,4 +15,6 @@ void c_to_factor_toplevel(cell quot); #define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp) +#define UAP_STACK_POINTER_TYPE void* + } diff --git a/vm/os-netbsd.hpp b/vm/os-netbsd.hpp index d45b2ac163..e79d1bf375 100644 --- a/vm/os-netbsd.hpp +++ b/vm/os-netbsd.hpp @@ -1,8 +1,5 @@ #include -namespace factor -{ +#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) -#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) - -} +#define UAP_STACK_POINTER_TYPE __greg_t diff --git a/vm/os-openbsd.hpp b/vm/os-openbsd.hpp new file mode 100644 index 0000000000..6a81a26be2 --- /dev/null +++ b/vm/os-openbsd.hpp @@ -0,0 +1 @@ +#define UAP_STACK_POINTER_TYPE __greg_t diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 94d2a31839..01740a1712 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -141,7 +141,7 @@ segment::~segment() void factor_vm::dispatch_signal(void *uap, void (handler)()) { - UAP_STACK_POINTER(uap) = fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap)); + UAP_STACK_POINTER(uap) = (UAP_STACK_POINTER_TYPE)fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap)); UAP_PROGRAM_COUNTER(uap) = (cell)handler; } diff --git a/vm/platform.hpp b/vm/platform.hpp index 2a38c91171..a71aae1e89 100755 --- a/vm/platform.hpp +++ b/vm/platform.hpp @@ -48,6 +48,7 @@ #endif #elif defined(__OpenBSD__) #define FACTOR_OS_STRING "openbsd" + #include "os-openbsd.hpp" #if defined(FACTOR_X86) #include "os-openbsd-x86.32.hpp" @@ -58,6 +59,7 @@ #endif #elif defined(__NetBSD__) #define FACTOR_OS_STRING "netbsd" + #include "os-netbsd.hpp" #if defined(FACTOR_X86) #include "os-netbsd-x86.32.hpp" @@ -67,7 +69,6 @@ #error "Unsupported NetBSD flavor" #endif - #include "os-netbsd.hpp" #elif defined(linux) #define FACTOR_OS_STRING "linux" #include "os-linux.hpp" From 532c2aa5ad5a4c73c9583a536061ddb53c123189 Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Sat, 27 Mar 2010 14:21:28 -0700 Subject: [PATCH 048/123] FFI structs for manipulating ELF objects. --- extra/elf/authors.txt | 1 + extra/elf/elf.factor | 458 ++++++++++++++++++++++++++++++++++++++++++ extra/elf/summary.txt | 1 + 3 files changed, 460 insertions(+) create mode 100644 extra/elf/authors.txt create mode 100644 extra/elf/elf.factor create mode 100644 extra/elf/summary.txt diff --git a/extra/elf/authors.txt b/extra/elf/authors.txt new file mode 100644 index 0000000000..6f03a12101 --- /dev/null +++ b/extra/elf/authors.txt @@ -0,0 +1 @@ +Erik Charlebois diff --git a/extra/elf/elf.factor b/extra/elf/elf.factor new file mode 100644 index 0000000000..2ad82bc23c --- /dev/null +++ b/extra/elf/elf.factor @@ -0,0 +1,458 @@ +! Copyright (C) 2010 Erik Charlebois. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types alien.syntax classes.struct ; +IN: elf + +CONSTANT: EI_NIDENT 16 +CONSTANT: EI_MAG0 0 +CONSTANT: EI_MAG1 1 +CONSTANT: EI_MAG2 2 +CONSTANT: EI_MAG3 3 +CONSTANT: EI_CLASS 4 +CONSTANT: EI_DATA 5 +CONSTANT: EI_VERSION 6 +CONSTANT: EI_OSABI 7 +CONSTANT: EI_ABIVERSION 8 +CONSTANT: EI_PAD 9 + +CONSTANT: ELFMAG0 HEX: 7f +CONSTANT: ELFMAG1 HEX: 45 +CONSTANT: ELFMAG2 HEX: 4c +CONSTANT: ELFMAG3 HEX: 46 + +CONSTANT: ELFCLASS32 1 +CONSTANT: ELFCLASS64 2 + +CONSTANT: ELFDATA2LSB 1 +CONSTANT: ELFDATA2MSB 2 + +CONSTANT: ELFOSABI_SYSV 0 +CONSTANT: ELFOSABI_HPUX 1 +CONSTANT: ELFOSABI_NETBSD 2 +CONSTANT: ELFOSABI_LINUX 3 +CONSTANT: ELFOSABI_SOLARIS 6 +CONSTANT: ELFOSABI_AIX 7 +CONSTANT: ELFOSABI_IRIX 8 +CONSTANT: ELFOSABI_FREEBSD 9 +CONSTANT: ELFOSABI_TRU64 10 +CONSTANT: ELFOSABI_MODESTO 11 +CONSTANT: ELFOSABI_OPENBSD 12 +CONSTANT: ELFOSABI_OPENVMS 13 +CONSTANT: ELFOSABI_NSK 14 +CONSTANT: ELFOSABI_AROS 15 +CONSTANT: ELFOSABI_ARM_AEABI 64 +CONSTANT: ELFOSABI_ARM 97 +CONSTANT: ELFOSABI_STANDALONE 255 + +CONSTANT: ET_NONE 0 +CONSTANT: ET_REL 1 +CONSTANT: ET_EXEC 2 +CONSTANT: ET_DYN 3 +CONSTANT: ET_CORE 4 +CONSTANT: ET_LOOS HEX: FE00 +CONSTANT: ET_HIOS HEX: FEFF +CONSTANT: ET_LOPROC HEX: FF00 +CONSTANT: ET_HIPROC HEX: FFFF + +CONSTANT: EM_NONE 0 +CONSTANT: EM_M32 1 +CONSTANT: EM_SPARC 2 +CONSTANT: EM_386 3 +CONSTANT: EM_68K 4 +CONSTANT: EM_88K 5 +CONSTANT: EM_486 6 +CONSTANT: EM_860 7 +CONSTANT: EM_MIPS 8 +CONSTANT: EM_S370 9 +CONSTANT: EM_MIPS_RS3_LE 10 +CONSTANT: EM_SPARC64 11 +CONSTANT: EM_PARISC 15 +CONSTANT: EM_VPP500 17 +CONSTANT: EM_SPARC32PLUS 18 +CONSTANT: EM_960 19 +CONSTANT: EM_PPC 20 +CONSTANT: EM_PPC64 21 +CONSTANT: EM_S390 22 +CONSTANT: EM_SPU 23 +CONSTANT: EM_V800 36 +CONSTANT: EM_FR20 37 +CONSTANT: EM_RH32 38 +CONSTANT: EM_RCE 39 +CONSTANT: EM_ARM 40 +CONSTANT: EM_ALPHA 41 +CONSTANT: EM_SH 42 +CONSTANT: EM_SPARCV9 43 +CONSTANT: EM_TRICORE 44 +CONSTANT: EM_ARC 45 +CONSTANT: EM_H8_300 46 +CONSTANT: EM_H8_300H 47 +CONSTANT: EM_H8S 48 +CONSTANT: EM_H8_500 49 +CONSTANT: EM_IA_64 50 +CONSTANT: EM_MIPS_X 51 +CONSTANT: EM_COLDFIRE 52 +CONSTANT: EM_68HC12 53 +CONSTANT: EM_MMA 54 +CONSTANT: EM_PCP 55 +CONSTANT: EM_NCPU 56 +CONSTANT: EM_NDR1 57 +CONSTANT: EM_STARCORE 58 +CONSTANT: EM_ME16 59 +CONSTANT: EM_ST100 60 +CONSTANT: EM_TINYJ 61 +CONSTANT: EM_X86_64 62 +CONSTANT: EM_PDSP 63 +CONSTANT: EM_FX66 66 +CONSTANT: EM_ST9PLUS 67 +CONSTANT: EM_ST7 68 +CONSTANT: EM_68HC16 69 +CONSTANT: EM_68HC11 70 +CONSTANT: EM_68HC08 71 +CONSTANT: EM_68HC05 72 +CONSTANT: EM_SVX 73 +CONSTANT: EM_ST19 74 +CONSTANT: EM_VAX 75 +CONSTANT: EM_CRIS 76 +CONSTANT: EM_JAVELIN 77 +CONSTANT: EM_FIREPATH 78 +CONSTANT: EM_ZSP 79 +CONSTANT: EM_MMIX 80 +CONSTANT: EM_HUANY 81 +CONSTANT: EM_PRISM 82 +CONSTANT: EM_AVR 83 +CONSTANT: EM_FR30 84 +CONSTANT: EM_D10V 85 +CONSTANT: EM_D30V 86 +CONSTANT: EM_V850 87 +CONSTANT: EM_M32R 88 +CONSTANT: EM_MN10300 89 +CONSTANT: EM_MN10200 90 +CONSTANT: EM_PJ 91 +CONSTANT: EM_OPENRISC 92 +CONSTANT: EM_ARC_A5 93 +CONSTANT: EM_XTENSA 94 +CONSTANT: EM_VIDEOCORE 95 +CONSTANT: EM_TMM_GPP 96 +CONSTANT: EM_NS32K 97 +CONSTANT: EM_TPC 98 +CONSTANT: EM_SNP1K 99 +CONSTANT: EM_ST200 100 +CONSTANT: EM_IP2K 101 +CONSTANT: EM_MAX 102 +CONSTANT: EM_CR 103 +CONSTANT: EM_F2MC16 104 +CONSTANT: EM_MSP430 105 +CONSTANT: EM_BLACKFIN 106 +CONSTANT: EM_SE_C33 107 +CONSTANT: EM_SEP 108 +CONSTANT: EM_ARCA 109 +CONSTANT: EM_UNICORE 110 + +CONSTANT: EV_NONE 0 +CONSTANT: EV_CURRENT 1 + +CONSTANT: EF_ARM_EABIMASK HEX: ff000000 +CONSTANT: EF_ARM_BE8 HEX: 00800000 + +CONSTANT: SHN_UNDEF HEX: 0000 +CONSTANT: SHN_LOPROC HEX: FF00 +CONSTANT: SHN_HIPROC HEX: FF1F +CONSTANT: SHN_LOOS HEX: FF20 +CONSTANT: SHN_HIOS HEX: FF3F +CONSTANT: SHN_ABS HEX: FFF1 +CONSTANT: SHN_COMMON HEX: FFF2 + +CONSTANT: SHT_NULL 0 +CONSTANT: SHT_PROGBITS 1 +CONSTANT: SHT_SYMTAB 2 +CONSTANT: SHT_STRTAB 3 +CONSTANT: SHT_RELA 4 +CONSTANT: SHT_HASH 5 +CONSTANT: SHT_DYNAMIC 6 +CONSTANT: SHT_NOTE 7 +CONSTANT: SHT_NOBITS 8 +CONSTANT: SHT_REL 9 +CONSTANT: SHT_SHLIB 10 +CONSTANT: SHT_DYNSYM 11 +CONSTANT: SHT_LOOS HEX: 60000000 +CONSTANT: SHT_GNU_LIBLIST HEX: 6ffffff7 +CONSTANT: SHT_CHECKSUM HEX: 6ffffff8 +CONSTANT: SHT_LOSUNW HEX: 6ffffffa +CONSTANT: SHT_SUNW_move HEX: 6ffffffa +CONSTANT: SHT_SUNW_COMDAT HEX: 6ffffffb +CONSTANT: SHT_SUNW_syminfo HEX: 6ffffffc +CONSTANT: SHT_GNU_verdef HEX: 6ffffffd +CONSTANT: SHT_GNU_verneed HEX: 6ffffffe +CONSTANT: SHT_GNU_versym HEX: 6fffffff +CONSTANT: SHT_HISUNW HEX: 6fffffff +CONSTANT: SHT_HIOS HEX: 6fffffff +CONSTANT: SHT_LOPROC HEX: 70000000 +CONSTANT: SHT_ARM_EXIDX HEX: 70000001 +CONSTANT: SHT_ARM_PREEMPTMAP HEX: 70000002 +CONSTANT: SHT_ARM_ATTRIBUTES HEX: 70000003 +CONSTANT: SHT_ARM_DEBUGOVERLAY HEX: 70000004 +CONSTANT: SHT_ARM_OVERLAYSECTION HEX: 70000005 +CONSTANT: SHT_HIPROC HEX: 7fffffff +CONSTANT: SHT_LOUSER HEX: 80000000 +CONSTANT: SHT_HIUSER HEX: 8fffffff + +CONSTANT: SHF_WRITE 1 +CONSTANT: SHF_ALLOC 2 +CONSTANT: SHF_EXECINSTR 4 +CONSTANT: SHF_MERGE 16 +CONSTANT: SHF_STRINGS 32 +CONSTANT: SHF_INFO_LINK 64 +CONSTANT: SHF_LINK_ORDER 128 +CONSTANT: SHF_OS_NONCONFORMING 256 +CONSTANT: SHF_GROUP 512 +CONSTANT: SHF_TLS 1024 +CONSTANT: SHF_MASKOS HEX: 0f000000 +CONSTANT: SHF_MASKPROC HEX: f0000000 + +CONSTANT: STB_LOCAL 0 +CONSTANT: STB_GLOBAL 1 +CONSTANT: STB_WEAK 2 +CONSTANT: STB_LOOS 10 +CONSTANT: STB_HIOS 12 +CONSTANT: STB_LOPROC 13 +CONSTANT: STB_HIPROC 15 + +CONSTANT: STT_NOTYPE 0 +CONSTANT: STT_OBJECT 1 +CONSTANT: STT_FUNC 2 +CONSTANT: STT_SECTION 3 +CONSTANT: STT_FILE 4 +CONSTANT: STT_COMMON 5 +CONSTANT: STT_TLS 6 +CONSTANT: STT_LOOS 10 +CONSTANT: STT_HIOS 12 +CONSTANT: STT_LOPROC 13 +CONSTANT: STT_HIPROC 15 + +CONSTANT: STN_UNDEF 0 + +CONSTANT: STV_DEFAULT 0 +CONSTANT: STV_INTERNAL 1 +CONSTANT: STV_HIDDEN 2 +CONSTANT: STV_PROTECTED 3 + +CONSTANT: PT_NULL 0 +CONSTANT: PT_LOAD 1 +CONSTANT: PT_DYNAMIC 2 +CONSTANT: PT_INTERP 3 +CONSTANT: PT_NOTE 4 +CONSTANT: PT_SHLIB 5 +CONSTANT: PT_PHDR 6 +CONSTANT: PT_TLS 7 +CONSTANT: PT_LOOS HEX: 60000000 +CONSTANT: PT_HIOS HEX: 6fffffff +CONSTANT: PT_LOPROC HEX: 70000000 +CONSTANT: PT_ARM_ARCHEXT HEX: 70000000 +CONSTANT: PT_ARM_EXIDX HEX: 70000001 +CONSTANT: PT_ARM_UNWIND HEX: 70000001 +CONSTANT: PT_HIPROC HEX: 7fffffff + +CONSTANT: PT_ARM_ARCHEXT_FMTMSK HEX: ff000000 +CONSTANT: PT_ARM_ARCHEXT_PROFMSK HEX: 00ff0000 +CONSTANT: PT_ARM_ARCHEXT_ARCHMSK HEX: 000000ff +CONSTANT: PT_ARM_ARCHEXT_FMT_OS HEX: 00000000 +CONSTANT: PT_ARM_ARCHEXT_FMT_ABI HEX: 01000000 +CONSTANT: PT_ARM_ARCHEXT_PROF_NONE HEX: 00000000 +CONSTANT: PT_ARM_ARCHEXT_PROF_ARM HEX: 00410000 +CONSTANT: PT_ARM_ARCHEXT_PROF_RT HEX: 00520000 +CONSTANT: PT_ARM_ARCHEXT_PROF_MC HEX: 004d0000 +CONSTANT: PT_ARM_ARCHEXT_PROF_CLASSIC HEX: 00530000 + +CONSTANT: PT_ARM_ARCHEXT_ARCH_UNKN HEX: 00 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv4 HEX: 01 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv4T HEX: 02 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv5T HEX: 03 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv5TE HEX: 04 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv5TEJ HEX: 05 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6 HEX: 06 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6KZ HEX: 07 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6T2 HEX: 08 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6K HEX: 09 +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv7 HEX: 0A +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6M HEX: 0B +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv6SM HEX: 0C +CONSTANT: PT_ARM_ARCHEXT_ARCH_ARCHv7EM HEX: 0D + +CONSTANT: PF_X 1 +CONSTANT: PF_W 2 +CONSTANT: PF_R 4 +CONSTANT: PF_MASKOS HEX: 00ff0000 +CONSTANT: PF_MASKPROC HEX: ff000000 + +CONSTANT: DT_NULL 0 +CONSTANT: DT_NEEDED 1 +CONSTANT: DT_PLTRELSZ 2 +CONSTANT: DT_PLTGOT 3 +CONSTANT: DT_HASH 4 +CONSTANT: DT_STRTAB 5 +CONSTANT: DT_SYMTAB 6 +CONSTANT: DT_RELA 7 +CONSTANT: DT_RELASZ 8 +CONSTANT: DT_RELAENT 9 +CONSTANT: DT_STRSZ 10 +CONSTANT: DT_SYMENT 11 +CONSTANT: DT_INIT 12 +CONSTANT: DT_FINI 13 +CONSTANT: DT_SONAME 14 +CONSTANT: DT_RPATH 15 +CONSTANT: DT_SYMBOLIC 16 +CONSTANT: DT_REL 17 +CONSTANT: DT_RELSZ 18 +CONSTANT: DT_RELENT 19 +CONSTANT: DT_PLTREL 20 +CONSTANT: DT_DEBUG 21 +CONSTANT: DT_TEXTREL 22 +CONSTANT: DT_JMPREL 23 +CONSTANT: DT_BIND_NOW 24 +CONSTANT: DT_INIT_ARRAY 25 +CONSTANT: DT_FINI_ARRAY 26 +CONSTANT: DT_INIT_ARRAYSZ 27 +CONSTANT: DT_FINI_ARRAYSZ 28 +CONSTANT: DT_RUNPATH 29 +CONSTANT: DT_FLAGS 30 +CONSTANT: DT_ENCODING 32 +CONSTANT: DT_PREINIT_ARRAY 32 +CONSTANT: DT_PREINIT_ARRAYSZ 33 +CONSTANT: DT_LOOS HEX: 60000000 +CONSTANT: DT_HIOS HEX: 6fffffff +CONSTANT: DT_LOPROC HEX: 70000000 +CONSTANT: DT_ARM_RESERVED1 HEX: 70000000 +CONSTANT: DT_ARM_SYMTABSZ HEX: 70000001 +CONSTANT: DT_ARM_PREEMPTYMAP HEX: 70000002 +CONSTANT: DT_ARM_RESERVED2 HEX: 70000003 +CONSTANT: DT_HIPROC HEX: 7fffffff + +TYPEDEF: ushort Elf32_Half +TYPEDEF: uint Elf32_Word +TYPEDEF: int Elf32_Sword +TYPEDEF: uint Elf32_Off +TYPEDEF: uint Elf32_Addr +TYPEDEF: ushort Elf64_Half +TYPEDEF: uint Elf64_Word +TYPEDEF: ulonglong Elf64_Xword +TYPEDEF: longlong Elf64_Sxword +TYPEDEF: ulonglong Elf64_Off +TYPEDEF: ulonglong Elf64_Addr + +STRUCT: Elf32_Ehdr + { e_ident uchar[16] } + { e_type Elf32_Half } + { e_machine Elf32_Half } + { e_version Elf32_Word } + { e_entry Elf32_Addr } + { e_phoff Elf32_Off } + { e_shoff Elf32_Off } + { e_flags Elf32_Word } + { e_ehsize Elf32_Half } + { e_phentsize Elf32_Half } + { e_phnum Elf32_Half } + { e_shentsize Elf32_Half } + { e_shnum Elf32_Half } + { e_shstrndx Elf32_Half } ; + +STRUCT: Elf64_Ehdr + { e_ident uchar[16] } + { e_type Elf64_Half } + { e_machine Elf64_Half } + { e_version Elf64_Word } + { e_entry Elf64_Addr } + { e_phoff Elf64_Off } + { e_shoff Elf64_Off } + { e_flags Elf64_Word } + { e_ehsize Elf64_Half } + { e_phentsize Elf64_Half } + { e_phnum Elf64_Half } + { e_shentsize Elf64_Half } + { e_shnum Elf64_Half } + { e_shstrndx Elf64_Half } ; + +STRUCT: Elf32_Shdr + { sh_name Elf32_Word } + { sh_type Elf32_Word } + { sh_flags Elf32_Word } + { sh_addr Elf32_Addr } + { sh_offset Elf32_Off } + { sh_size Elf32_Word } + { sh_link Elf32_Word } + { sh_info Elf32_Word } + { sh_addralign Elf32_Word } + { sh_entsize Elf32_Word } ; + +STRUCT: Elf64_Shdr + { sh_name Elf64_Word } + { sh_type Elf64_Word } + { sh_flags Elf64_Xword } + { sh_addr Elf64_Addr } + { sh_offset Elf64_Off } + { sh_size Elf64_Xword } + { sh_link Elf64_Word } + { sh_info Elf64_Word } + { sh_addralign Elf64_Xword } + { sh_entsize Elf64_Xword } ; + +STRUCT: Elf32_Sym + { st_name Elf32_Word } + { st_value Elf32_Addr } + { st_size Elf32_Word } + { st_info uchar } + { st_other uchar } + { st_shndx Elf32_Half } ; + +STRUCT: Elf64_Sym + { st_name Elf64_Word } + { st_info uchar } + { st_other uchar } + { st_shndx Elf64_Half } + { st_value Elf64_Addr } + { st_size Elf64_Xword } ; + +STRUCT: Elf32_Rel + { r_offset Elf32_Addr } + { r_info Elf32_Word } ; + +STRUCT: Elf32_Rela + { r_offset Elf32_Addr } + { r_info Elf32_Word } + { r_addend Elf32_Sword } ; + +STRUCT: Elf64_Rel + { r_offset Elf64_Addr } + { r_info Elf64_Xword } ; + +STRUCT: Elf64_Rela + { r_offset Elf64_Addr } + { r_info Elf64_Xword } + { r_addend Elf64_Sxword } ; + +STRUCT: Elf32_Phdr + { p_type Elf32_Word } + { p_offset Elf32_Off } + { p_vaddr Elf32_Addr } + { p_paddr Elf32_Addr } + { p_filesz Elf32_Word } + { p_memsz Elf32_Word } + { p_flags Elf32_Word } + { p_align Elf32_Word } ; + +STRUCT: Elf64_Phdr + { p_type Elf64_Word } + { p_flags Elf64_Word } + { p_offset Elf64_Off } + { p_vaddr Elf64_Addr } + { p_paddr Elf64_Addr } + { p_filesz Elf64_Xword } + { p_memsz Elf64_Xword } + { p_align Elf64_Xword } ; + +STRUCT: Elf32_Dyn + { d_tag Elf32_Sword } + { d_val Elf32_Word } ; + +STRUCT: Elf64_Dyn + { d_tag Elf64_Sxword } + { d_val Elf64_Xword } ; diff --git a/extra/elf/summary.txt b/extra/elf/summary.txt new file mode 100644 index 0000000000..5cb6b843c3 --- /dev/null +++ b/extra/elf/summary.txt @@ -0,0 +1 @@ +Constants and structs related to the ELF object format. From fcec127d2d93c9413e3f6a5317550ebc0d06663f Mon Sep 17 00:00:00 2001 From: Erik Charlebois Date: Sat, 27 Mar 2010 14:31:24 -0700 Subject: [PATCH 049/123] Debug rendering vocabulary --- extra/game/debug/authors.txt | 1 + extra/game/debug/debug.factor | 212 ++++++++++++++++++++++++++++ extra/game/debug/summary.txt | 1 + extra/game/debug/tags.txt | 1 + extra/game/debug/tests/tests.factor | 68 +++++++++ 5 files changed, 283 insertions(+) create mode 100644 extra/game/debug/authors.txt create mode 100644 extra/game/debug/debug.factor create mode 100644 extra/game/debug/summary.txt create mode 100644 extra/game/debug/tags.txt create mode 100644 extra/game/debug/tests/tests.factor diff --git a/extra/game/debug/authors.txt b/extra/game/debug/authors.txt new file mode 100644 index 0000000000..6f03a12101 --- /dev/null +++ b/extra/game/debug/authors.txt @@ -0,0 +1 @@ +Erik Charlebois diff --git a/extra/game/debug/debug.factor b/extra/game/debug/debug.factor new file mode 100644 index 0000000000..a4f4895812 --- /dev/null +++ b/extra/game/debug/debug.factor @@ -0,0 +1,212 @@ +! Copyright (C) 2010 Erik Charlebois +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types arrays circular colors colors.constants +columns destructors fonts gpu.buffers gpu.render gpu.shaders gpu.state +gpu.textures images kernel literals locals make math math.constants +math.functions math.vectors sequences specialized-arrays typed ui.text fry ; +FROM: alien.c-types => float ; +SPECIALIZED-ARRAYS: float uint ; +IN: game.debug + +image ( string color -- image ) + debug-text-font clone swap >>foreground swap string>image drop ; + +:: image>texture ( image -- texture ) + image [ component-order>> ] [ component-type>> ] bi + debug-text-texture-parameters &dispose + [ 0 image allocate-texture-image ] keep ; + +:: screen-quad ( image pt dim -- float-array ) + pt dim v/ 2.0 v*n 1.0 v-n + dup image dim>> dim v/ 2.0 v*n v+ + [ first2 ] bi@ :> ( x0 y0 x1 y1 ) + image upside-down?>> + [ { x0 y0 0 0 x1 y0 1 0 x1 y1 1 1 x0 y1 0 1 } ] + [ { x0 y0 0 1 x1 y0 1 1 x1 y1 1 0 x0 y1 0 0 } ] + if >float-array ; + +: debug-text-uniform-variables ( string color -- image uniforms ) + text>image dup image>texture + float-array{ 0.0 0.0 0.0 } + debug-text-uniforms boa swap ; + +: debug-text-vertex-array ( image pt dim -- vertex-array ) + screen-quad stream-upload draw-usage vertex-buffer byte-array>buffer &dispose + debug-text-program &dispose ; + +: debug-text-index-buffer ( -- index-buffer ) + uint-array{ 0 1 2 2 3 0 } stream-upload draw-usage index-buffer + byte-array>buffer &dispose 0 6 uint-indexes ; + +: debug-text-render ( uniforms vertex-array index-buffer -- ) + [ + { + { "primitive-mode" [ 3drop triangles-mode ] } + { "uniforms" [ 2drop ] } + { "vertex-array" [ drop nip ] } + { "indexes" [ 2nip ] } + } 3 render + ] with-destructors ; + +: debug-shapes-vertex-array ( sequence -- vertex-array ) + stream-upload draw-usage vertex-buffer byte-array>buffer &dispose + debug-shapes-program &dispose &dispose ; + +: draw-debug-primitives ( mode primitives mvp-matrix -- ) + f origin-upper-left 1.0 set-gpu-state + { + { "primitive-mode" [ 2drop ] } + { "uniforms" [ 2nip debug-shapes-uniforms boa ] } + { "vertex-array" [ drop nip debug-shapes-vertex-array ] } + { "indexes" [ drop nip length 0 swap ] } + } 3 render ; + +CONSTANT: box-vertices + { { { 1 1 1 } { 1 1 -1 } } + { { 1 1 1 } { 1 -1 1 } } + { { 1 1 1 } { -1 1 1 } } + { { -1 -1 -1 } { -1 -1 1 } } + { { -1 -1 -1 } { -1 1 -1 } } + { { -1 -1 -1 } { 1 -1 -1 } } + { { -1 -1 1 } { -1 1 1 } } + { { -1 -1 1 } { 1 -1 1 } } + { { -1 1 -1 } { -1 1 1 } } + { { -1 1 -1 } { 1 1 -1 } } + { { 1 -1 -1 } { 1 -1 1 } } + { { 1 -1 -1 } { 1 1 -1 } } } + +CONSTANT: cylinder-vertices + $[ 12 iota [ 2pi 12 / * [ cos ] [ drop 0.0 ] [ sin ] tri 3array ] map ] + +:: scale-cylinder-vertices ( radius half-height verts -- bot-verts top-verts ) + verts + [ [ radius v*n { 0 half-height 0 } v- ] map ] + [ [ radius v*n { 0 half-height 0 } v+ ] map ] bi ; +PRIVATE> + +: debug-point ( pt color -- ) + [ first3 [ , ] tri@ ] + [ [ red>> , ] [ green>> , ] [ blue>> , ] tri ] + bi* ; inline + +: debug-line ( from to color -- ) + dup swapd [ debug-point ] 2bi@ ; inline + +: debug-axes ( pt mat -- ) + [ 0 normalize over v+ COLOR: red debug-line ] + [ 1 normalize over v+ COLOR: green debug-line ] + [ 2 normalize over v+ COLOR: blue debug-line ] + 2tri ; inline + +:: debug-box ( pt half-widths color -- ) + box-vertices [ + first2 [ half-widths v* pt v+ ] bi@ color debug-line + ] each ; inline + +:: debug-circle ( points color -- ) + points dup [ 1 swap change-circular-start ] keep + [ color debug-line ] 2each ; inline + +:: debug-cylinder ( pt half-height radius color -- ) + radius half-height cylinder-vertices scale-cylinder-vertices + [ [ color debug-circle ] bi@ ] + [ color '[ _ debug-line ] 2each ] 2bi ; inline + +TYPED: draw-debug-lines ( lines: float-array mvp-matrix -- ) + [ lines-mode -rot draw-debug-primitives ] with-destructors ; inline + +TYPED: draw-debug-points ( points: float-array mvp-matrix -- ) + [ points-mode -rot draw-debug-primitives ] with-destructors ; inline + +TYPED: draw-text ( string color: rgba pt dim -- ) + [ + [ debug-text-uniform-variables ] 2dip + debug-text-vertex-array + debug-text-index-buffer + debug-text-render + ] with-destructors ; inline diff --git a/extra/game/debug/summary.txt b/extra/game/debug/summary.txt new file mode 100644 index 0000000000..1f772ef24b --- /dev/null +++ b/extra/game/debug/summary.txt @@ -0,0 +1 @@ +Simple shape rendering for visual debugging. diff --git a/extra/game/debug/tags.txt b/extra/game/debug/tags.txt new file mode 100644 index 0000000000..84d4140a70 --- /dev/null +++ b/extra/game/debug/tags.txt @@ -0,0 +1 @@ +games diff --git a/extra/game/debug/tests/tests.factor b/extra/game/debug/tests/tests.factor new file mode 100644 index 0000000000..049aa2b492 --- /dev/null +++ b/extra/game/debug/tests/tests.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2010 Erik Charlebois +! See http://factorcode.org/license.txt for BSD license. +USING: accessors colors.constants game.loop game.worlds gpu +gpu.framebuffers gpu.util.wasd game.debug kernel literals locals +make math math.constants math.matrices math.parser sequences +alien.c-types specialized-arrays ui.gadgets.worlds ui.pixel-formats ; +FROM: alien.c-types => float ; +SPECIALIZED-ARRAY: float +IN: game.debug.tests + +:: clear-screen ( color -- ) + system-framebuffer { + { default-attachment color } + } clear-framebuffer ; + +: deg>rad ( d -- r ) + 180 / pi * ; + +:: draw-debug-tests ( world -- ) + world [ wasd-p-matrix ] [ wasd-mv-matrix ] bi m. :> mvp-matrix + { 0 0 0 } clear-screen + + [ + { 0 0 0 } { 1 0 0 } COLOR: red debug-line + { 0 0 0 } { 0 1 0 } COLOR: green debug-line + { 0 0 0 } { 0 0 1 } COLOR: blue debug-line + { -1.2 0 0 } { 0 1 0 } 0 deg>rad rotation-matrix3 debug-axes + { 3 5 -2 } { 3 2 1 } COLOR: white debug-box + { 0 9 0 } 8 2 COLOR: blue debug-cylinder + ] float-array{ } make + mvp-matrix draw-debug-lines + + [ + { 0 4.0 0 } COLOR: red debug-point + { 0 4.1 0 } COLOR: green debug-point + { 0 4.2 0 } COLOR: blue debug-point + ] float-array{ } make + mvp-matrix draw-debug-points + + "Frame: " world frame-number>> number>string append + COLOR: purple { 5 5 } world dim>> draw-text + world [ 1 + ] change-frame-number drop ; + +TUPLE: tests-world < wasd-world frame-number ; +M: tests-world draw-world* draw-debug-tests ; +M: tests-world wasd-movement-speed drop 1/16. ; +M: tests-world wasd-near-plane drop 1/32. ; +M: tests-world wasd-far-plane drop 1024.0 ; +M: tests-world begin-game-world + init-gpu + 0 >>frame-number + { 0.0 0.0 2.0 } 0 0 set-wasd-view drop ; + +GAME: run-tests { + { world-class tests-world } + { title "game.debug.tests" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 24 } } + } } + { grab-input? t } + { use-game-input? t } + { pref-dim { 1024 768 } } + { tick-interval-micros $[ 60 fps ] } + } ; + +MAIN: run-tests From 031ea6c39cc26217c68448bc205dcd8d9eaf8731 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 08:29:10 -0400 Subject: [PATCH 050/123] vm: fix factor_vm::dispatch_signal() --- vm/os-unix.cpp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 01740a1712..8aa100aa01 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -67,7 +67,7 @@ void sleep_nanos(u64 nsec) void factor_vm::init_ffi() { - /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */ + /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic Unix */ null_dll = dlopen(NULL_DLL,RTLD_LAZY); } @@ -143,6 +143,8 @@ void factor_vm::dispatch_signal(void *uap, void (handler)()) { UAP_STACK_POINTER(uap) = (UAP_STACK_POINTER_TYPE)fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap)); UAP_PROGRAM_COUNTER(uap) = (cell)handler; + + signal_callstack_top = (stack_frame *)UAP_STACK_POINTER(uap); } void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) From f1e19aabdbf96fcfc8b84abf2e6b3bd7f9649533 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 27 Mar 2010 12:03:06 -0400 Subject: [PATCH 051/123] threads: simplify 'suspend' combinator --- basis/alarms/alarms-tests.factor | 5 +-- basis/channels/channels.factor | 10 ++--- .../concurrency/conditions/conditions.factor | 9 ++-- .../concurrency/exchangers/exchangers.factor | 5 ++- basis/deques/deques.factor | 10 ++--- basis/io/backend/unix/unix.factor | 11 +++-- basis/io/backend/windows/nt/nt.factor | 4 +- basis/io/launcher/launcher.factor | 8 +--- basis/threads/threads-docs.factor | 6 +-- basis/threads/threads-tests.factor | 6 +-- basis/threads/threads.factor | 44 ++++++++++--------- .../tools/continuations/continuations.factor | 14 +++--- 12 files changed, 64 insertions(+), 68 deletions(-) diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index 2379e3e80d..8f7868324d 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -11,7 +11,6 @@ IN: alarms.tests ] unit-test [ ] [ - [ - [ resume ] curry instant later drop - ] "test" suspend drop + self [ resume ] curry instant later drop + "test" suspend drop ] unit-test diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 0eb7881f95..870085f77a 100644 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -17,7 +17,7 @@ GENERIC: from ( channel -- value ) > push ] curry + [ self ] dip senders>> push "channel send" suspend drop ; : (to) ( value receivers -- ) @@ -36,7 +36,7 @@ M: channel to ( value channel -- ) [ dup wait to ] [ nip (to) ] if-empty ; M: channel from ( channel -- value ) - [ - notify senders>> - [ (from) ] unless-empty - ] curry "channel receive" suspend ; + [ self ] dip + notify senders>> + [ (from) ] unless-empty + "channel receive" suspend ; diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index ad00bbdfa9..4a1c7d3370 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: deques threads kernel arrays sequences alarms fry ; IN: concurrency.conditions @@ -22,10 +22,13 @@ IN: concurrency.conditions ERROR: wait-timeout ; +: queue ( queue -- ) + [ self ] dip push-front ; + : wait ( queue timeout status -- ) over [ - [ queue-timeout [ drop ] ] dip suspend + [ queue-timeout ] dip suspend [ wait-timeout ] [ cancel-alarm ] if ] [ - [ drop '[ _ push-front ] ] dip suspend drop + [ drop queue ] dip suspend drop ] if ; diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor index 97b3c14fe4..7cfe016085 100644 --- a/basis/concurrency/exchangers/exchangers.factor +++ b/basis/concurrency/exchangers/exchangers.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel threads boxes accessors fry ; IN: concurrency.exchangers @@ -17,5 +17,6 @@ TUPLE: exchanger thread object ; [ thread>> box> resume-with ] dip ] [ [ object>> >box ] keep - '[ _ thread>> >box ] "exchange" suspend + [ self ] dip thread>> >box + "exchange" suspend ] if ; diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index 1e1be404a7..7483c0f56b 100644 --- a/basis/deques/deques.factor +++ b/basis/deques/deques.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math fry ; IN: deques @@ -16,22 +16,22 @@ GENERIC: node-value ( node -- value ) GENERIC: deque-empty? ( deque -- ? ) : push-front ( obj deque -- ) - push-front* drop ; + push-front* drop ; inline : push-all-front ( seq deque -- ) [ push-front ] curry each ; : push-back ( obj deque -- ) - push-back* drop ; + push-back* drop ; inline : push-all-back ( seq deque -- ) [ push-back ] curry each ; : pop-front ( deque -- obj ) - [ peek-front ] [ pop-front* ] bi ; + [ peek-front ] [ pop-front* ] bi ; inline : pop-back ( deque -- obj ) - [ peek-back ] [ pop-back* ] bi ; + [ peek-back ] [ pop-back* ] bi ; inline : slurp-deque ( deque quot -- ) [ drop '[ _ deque-empty? not ] ] diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 39f0a5fec3..0e84f1b65e 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -67,12 +67,11 @@ M: io-timeout summary drop "I/O operation timed out" ; : wait-for-fd ( handle event -- ) dup +retry+ eq? [ 2drop ] [ - '[ - swap handle-fd mx get-global _ { - { +input+ [ add-input-callback ] } - { +output+ [ add-output-callback ] } - } case - ] "I/O" suspend nip [ io-timeout ] when + [ [ self ] dip handle-fd mx get-global ] dip { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + "I/O" suspend [ io-timeout ] when ] if ; : wait-for-port ( port event -- ) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index de29f33ee6..5cbe7b3ad9 100644 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -40,8 +40,8 @@ M: winnt add-completion ( win32-handle -- ) : twiddle-thumbs ( overlapped port -- bytes-transferred ) [ drop - [ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend - { + [ self ] dip >c-ptr pending-overlapped get-global set-at + "I/O" suspend { { [ dup integer? ] [ ] } { [ dup array? ] [ first dup eof? diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 3999a026c0..dfbbd33d2e 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -129,12 +129,8 @@ M: process-was-killed error. : (wait-for-process) ( process -- status ) dup handle>> - [ - dup [ processes get at push ] curry - "process" suspend drop - ] when - dup killed>> - [ process-was-killed ] [ status>> ] if ; + [ self over processes get at push "process" suspend drop ] when + dup killed>> [ process-was-killed ] [ status>> ] if ; : wait-for-process ( process -- status ) [ (wait-for-process) ] with-timeout ; diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index 995fc867e7..335fbb3902 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -142,10 +142,8 @@ HELP: interrupt { $description "Interrupts a sleeping thread." } ; HELP: suspend -{ $values { "quot" { $quotation "( thread -- )" } } { "state" string } { "obj" object } } -{ $description "Suspends the current thread and passes it to the quotation." -$nl -"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." +{ $values { "state" string } { "obj" object } } +{ $description "Suspends the current thread. Control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the caller of this word must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." $nl "The status string is for debugging purposes; see " { $link "tools.threads" } "." } ; diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 4568b7c491..6e573ccd88 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -13,9 +13,7 @@ yield [ ] [ 0.3 sleep ] unit-test [ "hey" sleep ] must-fail -[ 3 ] [ - [ 3 swap resume-with ] "Test suspend" suspend -] unit-test +[ 3 ] [ 3 self resume-with "Test suspend" suspend ] unit-test [ f ] [ f get-global ] unit-test @@ -29,8 +27,6 @@ yield ] parallel-map ] unit-test -[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with - :: spawn-namespace-test ( -- ? ) :> p gensym :> g [ diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 9282dda46f..09869924f4 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables heaps kernel kernel.private math @@ -12,8 +12,8 @@ IN: threads ! (set-context) and (start-context) are sub-primitives, but ! we don't want them inlined into callers since their behavior ! depends on what frames are on the callstack -: start-context ( obj quot: ( obj -- * ) -- ) (start-context) ; -: set-context ( context -- ) (set-context) ; +: set-context ( obj context -- obj' ) (set-context) ; +: start-context ( obj quot: ( obj -- * ) -- obj' ) (start-context) ; PRIVATE> @@ -24,14 +24,15 @@ TUPLE: thread { quot callable initial: [ ] } { exit-handler callable initial: [ ] } { id integer } -continuation +{ continuation box } state runnable mailbox -variables +{ variables hashtable } sleep-entry ; -: self ( -- thread ) 63 special-object ; inline +: self ( -- thread ) + 63 special-object { thread } declare ; inline ! Thread-local storage : tnamespace ( -- assoc ) @@ -46,9 +47,11 @@ sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads ( -- assoc ) 64 special-object ; +: threads ( -- assoc ) + 64 special-object { hashtable } declare ; inline -: thread ( id -- thread ) threads at ; +: thread ( id -- thread ) + threads at ; : thread-registered? ( thread -- ? ) id>> threads key? ; @@ -85,9 +88,11 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue ( -- dlist ) 65 special-object ; +: run-queue ( -- dlist ) + 65 special-object { dlist } declare ; inline -: sleep-queue ( -- heap ) 66 special-object ; +: sleep-queue ( -- heap ) + 66 special-object { dlist } declare ; inline : resume ( thread -- ) f >>state @@ -175,25 +180,22 @@ DEFER: next PRIVATE> -: stop ( -- ) +: stop ( -- * ) self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ; -: suspend ( quot state -- obj ) - [ - [ [ self swap call ] dip self (>>state) ] dip - self continuation>> >box - next - ] callcc1 2nip ; inline +: suspend ( state -- obj ) + self (>>state) + [ self continuation>> >box next ] callcc1 ; inline -: yield ( -- ) [ resume ] f suspend drop ; +: yield ( -- ) self resume f suspend drop ; GENERIC: sleep-until ( n/f -- ) M: integer sleep-until - '[ _ schedule-sleep ] "sleep" suspend drop ; + [ self ] dip schedule-sleep "sleep" suspend drop ; M: f sleep-until - drop [ drop ] "interrupt" suspend drop ; + drop "interrupt" suspend drop ; GENERIC: sleep ( dt -- ) @@ -218,7 +220,7 @@ M: real sleep : in-thread ( quot -- ) [ datastack ] dip - '[ _ set-datastack _ call ] + '[ _ set-datastack @ ] "Thread" spawn drop ; GENERIC: error-in-thread ( error thread -- ) diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 15fdb9f9b5..6f748cdb31 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: threads kernel namespaces continuations combinators -sequences math namespaces.private continuations.private -concurrency.messaging quotations kernel.private words -sequences.private assocs models models.arrow arrays accessors -generic generic.single definitions make sbufs tools.crossref fry ; +USING: threads threads.private kernel namespaces continuations +combinators sequences math namespaces.private +continuations.private concurrency.messaging quotations +kernel.private words sequences.private assocs models +models.arrow arrays accessors generic generic.single definitions +make sbufs tools.crossref fry ; IN: tools.continuations >n ndrop >c c> continue continue-with stop suspend (spawn) + set-context start-context } [ don't-step-into ] each \ break [ break ] "step-into" set-word-prop From e859a3209628b44b8e3382e5c1ac9894c1917505 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 07:30:58 -0400 Subject: [PATCH 052/123] cpu.x86.bootstrap: fix jit-profiling regression --- basis/cpu/x86/bootstrap.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index d75d80faf2..961f0c9977 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -67,15 +67,15 @@ big-endian off [ ! Load word - temp0 0 MOV rc-absolute-cell rt-literal jit-rel + nv-reg 0 MOV rc-absolute-cell rt-literal jit-rel ! Bump profiling counter - temp0 profile-count-offset [+] 1 tag-fixnum ADD + nv-reg profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code - temp0 temp0 word-code-offset [+] MOV + nv-reg nv-reg word-code-offset [+] MOV ! Compute word entry point - temp0 compiled-header-size ADD + nv-reg compiled-header-size ADD ! Jump to entry point - temp0 JMP + nv-reg JMP ] jit-profiling jit-define [ From 9ffe0a69d158dca004e33f6859421bb609f01ac5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 11:37:28 -0400 Subject: [PATCH 053/123] vm: use sigaltstack to handle callstack overflow properly --- vm/os-genunix.cpp | 2 +- vm/os-genunix.hpp | 2 -- vm/os-macosx.hpp | 3 --- vm/os-macosx.mm | 8 +++----- vm/os-unix.cpp | 23 ++++++++++++++++------- vm/os-unix.hpp | 1 - vm/os-windows.cpp | 2 ++ vm/os-windows.hpp | 1 - vm/vm.cpp | 8 +++++++- vm/vm.hpp | 45 +++++++++++++++++++++++++-------------------- 10 files changed, 54 insertions(+), 41 deletions(-) diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 301b68fb52..c7449e867b 100644 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -9,7 +9,7 @@ void factor_vm::c_to_factor_toplevel(cell quot) c_to_factor(quot); } -void init_signals() +void factor_vm::init_signals() { unix_init_signals(); } diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index 1972a728e6..c6123eca56 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -4,8 +4,6 @@ namespace factor #define VM_C_API extern "C" #define NULL_DLL NULL -void c_to_factor_toplevel(cell quot); -void init_signals(); void early_init(); const char *vm_executable_path(); const char *default_image_path(); diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 93f6574367..8428f56998 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -5,14 +5,11 @@ namespace factor #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" -void init_signals(); void early_init(); const char *vm_executable_path(); const char *default_image_path(); -void c_to_factor_toplevel(cell quot); - #define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp) #define UAP_STACK_POINTER_TYPE void* diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index 92694a4599..4a6a3cb2b4 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -70,7 +70,7 @@ const char *default_image_path(void) return [returnVal UTF8String]; } -void init_signals(void) +void factor_vm::init_signals(void) { unix_init_signals(); mach_initialize(); @@ -87,11 +87,9 @@ Protocol *objc_getProtocol(char *name) u64 nano_count() { - u64 t; + u64 t = mach_absolute_time(); mach_timebase_info_data_t info; - kern_return_t ret; - t = mach_absolute_time(); - ret = mach_timebase_info(&info); + kern_return_t ret = mach_timebase_info(&info); if(ret != 0) fatal_error("mach_timebase_info failed",ret); return t * (info.numer/info.denom); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 8aa100aa01..7e88cedb0e 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -13,7 +13,7 @@ THREADHANDLE start_thread(void *(*start_routine)(void *),void *args) fatal_error("pthread_attr_setdetachstate() failed",0); if (pthread_create (&thread, &attr, start_routine, args) != 0) fatal_error("pthread_create() failed",0); - pthread_attr_destroy (&attr); + pthread_attr_destroy(&attr); return thread; } @@ -21,9 +21,8 @@ pthread_key_t current_vm_tls_key = 0; void init_platform_globals() { - if (pthread_key_create(¤t_vm_tls_key, NULL) != 0) + if(pthread_key_create(¤t_vm_tls_key, NULL) != 0) fatal_error("pthread_key_create() failed",0); - } void register_vm_with_thread(factor_vm *vm) @@ -187,8 +186,18 @@ static void sigaction_safe(int signum, const struct sigaction *act, struct sigac fatal_error("sigaction failed", 0); } -void unix_init_signals() +void factor_vm::unix_init_signals() { + signal_callstack_seg = new segment(callstack_size,false); + + stack_t signal_callstack; + signal_callstack.ss_sp = (void *)signal_callstack_seg->start; + signal_callstack.ss_size = signal_callstack_seg->size; + signal_callstack.ss_flags = 0; + + if(sigaltstack(&signal_callstack,(stack_t *)NULL) < 0) + fatal_error("sigaltstack() failed",0); + struct sigaction memory_sigaction; struct sigaction misc_sigaction; struct sigaction fpe_sigaction; @@ -197,7 +206,7 @@ void unix_init_signals() memset(&memory_sigaction,0,sizeof(struct sigaction)); sigemptyset(&memory_sigaction.sa_mask); memory_sigaction.sa_sigaction = memory_signal_handler; - memory_sigaction.sa_flags = SA_SIGINFO; + memory_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK; sigaction_safe(SIGBUS,&memory_sigaction,NULL); sigaction_safe(SIGSEGV,&memory_sigaction,NULL); @@ -205,14 +214,14 @@ void unix_init_signals() memset(&fpe_sigaction,0,sizeof(struct sigaction)); sigemptyset(&fpe_sigaction.sa_mask); fpe_sigaction.sa_sigaction = fpe_signal_handler; - fpe_sigaction.sa_flags = SA_SIGINFO; + fpe_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK; sigaction_safe(SIGFPE,&fpe_sigaction,NULL); memset(&misc_sigaction,0,sizeof(struct sigaction)); sigemptyset(&misc_sigaction.sa_mask); misc_sigaction.sa_sigaction = misc_signal_handler; - misc_sigaction.sa_flags = SA_SIGINFO; + misc_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK; sigaction_safe(SIGQUIT,&misc_sigaction,NULL); sigaction_safe(SIGILL,&misc_sigaction,NULL); diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index de60bbe15f..df6e0b4b3e 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -39,7 +39,6 @@ typedef pthread_t THREADHANDLE; THREADHANDLE start_thread(void *(*start_routine)(void *),void *args); inline static THREADHANDLE thread_id() { return pthread_self(); } -void unix_init_signals(); void signal_handler(int signal, siginfo_t* siginfo, void* uap); void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index d69966567a..1ff1b174b5 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -143,4 +143,6 @@ void factor_vm::move_file(const vm_char *path1, const vm_char *path2) general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object); } +void factor_vm::init_signals() {} + } diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 92a3c73a99..020a506038 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -43,7 +43,6 @@ typedef wchar_t vm_char; /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ #define EPOCH_OFFSET 0x019db1ded53e8000LL -inline static void init_signals() {} inline static void early_init() {} u64 system_micros(); diff --git a/vm/vm.cpp b/vm/vm.cpp index 87bf47f290..e9ade19cc6 100755 --- a/vm/vm.cpp +++ b/vm/vm.cpp @@ -13,7 +13,8 @@ factor_vm::factor_vm() : gc_events(NULL), fep_disabled(false), full_output(false), - last_nano_count(0) + last_nano_count(0), + signal_callstack_seg(NULL) { primitive_reset_dispatch_stats(); } @@ -21,6 +22,11 @@ factor_vm::factor_vm() : factor_vm::~factor_vm() { delete_contexts(); + if(signal_callstack_seg) + { + delete signal_callstack_seg; + signal_callstack_seg = NULL; + } } } diff --git a/vm/vm.hpp b/vm/vm.hpp index 7a0b0fcd33..4402b64f41 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -107,6 +107,9 @@ struct factor_vm decrease */ u64 last_nano_count; + /* Stack for signal handlers, only used on Unix */ + segment *signal_callstack_seg; + // contexts context *new_context(); void delete_context(context *old_context); @@ -339,7 +342,7 @@ struct factor_vm template bool reallot_array_in_place_p(Array *array, cell capacity); template Array *reallot_array(Array *array_, cell capacity); - //debug + // debug void print_chars(string* str); void print_word(word* word, cell nesting); void print_factor_string(string* str); @@ -362,7 +365,7 @@ struct factor_vm void factorbug(); void primitive_die(); - //arrays + // arrays inline void set_array_nth(array *array, cell slot, cell value); array *allot_array(cell capacity, cell fill_); void primitive_array(); @@ -372,7 +375,7 @@ struct factor_vm void primitive_resize_array(); cell std_vector_to_array(std::vector &elements); - //strings + // strings cell string_nth(const string *str, cell index); void set_string_nth_fast(string *str, cell index, cell ch); void set_string_nth_slow(string *str_, cell index, cell ch); @@ -388,13 +391,13 @@ struct factor_vm void primitive_set_string_nth_fast(); void primitive_set_string_nth_slow(); - //booleans + // booleans cell tag_boolean(cell untagged) { return (untagged ? true_object : false_object); } - //byte arrays + // byte arrays byte_array *allot_byte_array(cell size); void primitive_byte_array(); void primitive_uninitialized_byte_array(); @@ -402,11 +405,11 @@ struct factor_vm template byte_array *byte_array_from_value(Type *value); - //tuples + // tuples void primitive_tuple(); void primitive_tuple_boa(); - //words + // words word *allot_word(cell name_, cell vocab_, cell hashcode_); void primitive_word(); void primitive_word_code(); @@ -417,7 +420,7 @@ struct factor_vm cell find_all_words(); void compile_all_words(); - //math + // math void primitive_bignum_to_fixnum(); void primitive_float_to_fixnum(); void primitive_fixnum_divint(); @@ -503,7 +506,7 @@ struct factor_vm // tagged template Type *untag_check(cell value); - //io + // io void init_c_io(); void io_error(); FILE* safe_fopen(char *filename, char *mode); @@ -526,7 +529,7 @@ struct factor_vm void primitive_fflush(); void primitive_fclose(); - //code_block + // code_block cell compute_entry_point_address(cell obj); cell compute_entry_point_pic_address(word *w, cell tagged_quot); cell compute_entry_point_pic_address(cell w_); @@ -563,11 +566,11 @@ struct factor_vm cell code_blocks(); void primitive_code_blocks(); - //callbacks + // callbacks void init_callbacks(cell size); void primitive_callback(); - //image + // image void init_objects(image_header *h); void load_data_heap(FILE *file, image_header *h, vm_parameters *p); void load_code_heap(FILE *file, image_header *h, vm_parameters *p); @@ -578,7 +581,7 @@ struct factor_vm void fixup_code(cell data_offset, cell code_offset); void load_image(vm_parameters *p); - //callstack + // callstack template void iterate_callstack_object(callstack *stack_, Iterator &iterator); void check_frame(stack_frame *frame); callstack *allot_callstack(cell size); @@ -598,7 +601,7 @@ struct factor_vm void primitive_set_innermost_stack_frame_quot(); template void iterate_callstack(context *ctx, Iterator &iterator); - //alien + // alien char *pinned_alien_offset(cell obj); cell allot_alien(cell delegate_, cell displacement); cell allot_alien(void *address); @@ -615,7 +618,7 @@ struct factor_vm cell from_small_struct(cell x, cell y, cell size); cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size); - //quotations + // quotations void primitive_jit_compile(); code_block *lazy_jit_compile_block(); void primitive_array_to_quotation(); @@ -630,7 +633,7 @@ struct factor_vm cell find_all_quotations(); void initialize_all_quotations(); - //dispatch + // dispatch cell search_lookup_alist(cell table, cell klass); cell search_lookup_hash(cell table, cell klass, cell hashcode); cell nth_superclass(tuple_layout *layout, fixnum echelon); @@ -645,7 +648,7 @@ struct factor_vm void primitive_reset_dispatch_stats(); void primitive_dispatch_stats(); - //inline cache + // inline cache void init_inline_caching(int max_size); void deallocate_inline_cache(cell return_address); cell determine_inline_cache_type(array *cache_entries); @@ -657,11 +660,11 @@ struct factor_vm void update_pic_transitions(cell pic_size); void *inline_cache_miss(cell return_address); - //entry points + // entry points void c_to_factor(cell quot); void unwind_native_frames(cell quot, stack_frame *to); - //factor + // factor void default_parameters(vm_parameters *p); bool factor_arg(const vm_char *str, const vm_char *arg, cell *value); void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv); @@ -685,6 +688,7 @@ struct factor_vm void *ffi_dlsym(dll *dll, symbol_char *symbol); void ffi_dlclose(dll *dll); void c_to_factor_toplevel(cell quot); + void init_signals(); // os-windows #if defined(WINDOWS) @@ -697,8 +701,10 @@ struct factor_vm void open_console(); LONG exception_handler(PEXCEPTION_POINTERS pe); #endif + #else // UNIX void dispatch_signal(void *uap, void (handler)()); + void unix_init_signals(); #endif #ifdef __APPLE__ @@ -707,7 +713,6 @@ struct factor_vm factor_vm(); ~factor_vm(); - }; extern std::map thread_vms; From 51c7e1e1e64b123acebc4a70c8b8537d6acdf13d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 12:33:41 -0400 Subject: [PATCH 054/123] threads: fix thread-local variables --- basis/threads/threads-tests.factor | 16 ++++++++++++++++ basis/threads/threads.factor | 7 ++++--- 2 files changed, 20 insertions(+), 3 deletions(-) diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 6e573ccd88..742ecaa1f7 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -40,3 +40,19 @@ yield [ "a" [ 1 1 + ] spawn 100 sleep ] must-fail [ ] [ 0.1 seconds sleep ] unit-test + +! Test thread-local variables + "p" set + +5 "x" tset + +[ 5 ] [ "x" tget ] unit-test + +[ ] [ "x" [ 1 + ] tchange ] unit-test + +[ 6 ] [ "x" tget ] unit-test + +! Are they truly thread-local? +[ "x" tget "p" get fulfill ] in-thread + +[ f ] [ "p" get ?promise ] unit-test diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 09869924f4..89a90f87fd 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -36,10 +36,10 @@ sleep-entry ; ! Thread-local storage : tnamespace ( -- assoc ) - self variables>> [ H{ } clone dup self (>>variables) ] unless* ; + self variables>> ; inline : tget ( key -- value ) - self variables>> at ; + tnamespace at ; : tset ( value key -- ) tnamespace set-at ; @@ -83,7 +83,8 @@ PRIVATE> swap >>name swap >>quot \ thread counter >>id - >>continuation ; inline + >>continuation + H{ } clone >>variables ; inline : ( quot name -- thread ) \ thread new-thread ; From 84c01e1ab3b94c96af10606500ace00ebef499f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 12:52:16 -0400 Subject: [PATCH 055/123] vm: fix compilation on FreeBSD --- vm/os-unix.cpp | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 7e88cedb0e..78a487d9b6 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -98,9 +98,12 @@ void factor_vm::primitive_existsp() void factor_vm::move_file(const vm_char *path1, const vm_char *path2) { int ret = 0; - do { + do + { ret = rename((path1),(path2)); - } while(ret < 0 && errno == EINTR); + } + while(ret < 0 && errno == EINTR); + if(ret < 0) general_error(ERROR_IO,tag_fixnum(errno),false_object); } @@ -191,7 +194,7 @@ void factor_vm::unix_init_signals() signal_callstack_seg = new segment(callstack_size,false); stack_t signal_callstack; - signal_callstack.ss_sp = (void *)signal_callstack_seg->start; + signal_callstack.ss_sp = (char *)signal_callstack_seg->start; signal_callstack.ss_size = signal_callstack_seg->size; signal_callstack.ss_flags = 0; From bddbcd24cd67c3a2276e1ea4e3443a95c25dd21d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 12:53:01 -0400 Subject: [PATCH 056/123] vm: fix OpenBSD compilation --- vm/os-openbsd.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-openbsd.hpp b/vm/os-openbsd.hpp index 6a81a26be2..b3b47c08b3 100644 --- a/vm/os-openbsd.hpp +++ b/vm/os-openbsd.hpp @@ -1 +1 @@ -#define UAP_STACK_POINTER_TYPE __greg_t +#define UAP_STACK_POINTER_TYPE __register_t From 46ec4ff093f176d51af7dbb0723a2ae5ef28a6ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 17:57:47 -0500 Subject: [PATCH 057/123] vm: fix SEH on Windows --- vm/os-windows-nt.cpp | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index e063fe3db3..54ee78f977 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -75,11 +75,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) CONTEXT *c = (CONTEXT*)pe->ContextRecord; c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); - - if(in_code_heap_p(c->EIP)) - signal_callstack_top = (stack_frame *)c->ESP; - else - signal_callstack_top = NULL; + signal_callstack_top = (stack_frame *)c->ESP; switch (e->ExceptionCode) { From 43ac59a9f44978e4f6913793af3d6bbded34b508 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 28 Mar 2010 17:58:05 -0500 Subject: [PATCH 058/123] kernel: don't test callstack overflow on OpenBSD or Windows --- core/kernel/kernel-tests.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index bf16d9439f..152e1bac14 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,8 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private accessors locals.backend grouping words ; +sequences.private accessors locals.backend grouping words +system ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -48,7 +49,9 @@ IN: kernel.tests : overflow-c ( -- ) overflow-c overflow-c ; -[ overflow-c ] [ { "kernel-error" 14 f f } = ] must-fail-with +os [ windows? ] [ openbsd? ] bi or [ + [ overflow-c ] [ { "kernel-error" 14 f f } = ] must-fail-with +] unless [ -7 ] must-fail From b40382f412e36cb5b94eddd2b6f0c774d481652d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 28 Mar 2010 18:26:39 -0500 Subject: [PATCH 059/123] vm: don't use sigaltstack() on OpenBSD because OpenBSD sucks --- vm/os-unix.cpp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 78a487d9b6..a724007b1a 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -191,6 +191,10 @@ static void sigaction_safe(int signum, const struct sigaction *act, struct sigac void factor_vm::unix_init_signals() { + /* OpenBSD doesn't support sigaltstack() if we link against + libpthread. See http://redmine.ruby-lang.org/issues/show/1239 */ + +#ifndef __OpenBSD__ signal_callstack_seg = new segment(callstack_size,false); stack_t signal_callstack; @@ -200,6 +204,7 @@ void factor_vm::unix_init_signals() if(sigaltstack(&signal_callstack,(stack_t *)NULL) < 0) fatal_error("sigaltstack() failed",0); +#endif struct sigaction memory_sigaction; struct sigaction misc_sigaction; From 676d4e4c832e1e6860dfcef079b1bdba0e61e6e7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Mar 2010 18:31:11 -0700 Subject: [PATCH 060/123] someone screwed up the kernel-error codes in debugger --- basis/debugger/debugger.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index d10fd4f73a..8f448ff237 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -155,10 +155,10 @@ PREDICATE: vm-error < array { 11 [ datastack-overflow. ] } { 12 [ retainstack-underflow. ] } { 13 [ retainstack-overflow. ] } - { 13 [ callstack-underflow. ] } - { 14 [ callstack-overflow. ] } - { 15 [ memory-error. ] } - { 16 [ fp-trap-error. ] } + { 14 [ callstack-underflow. ] } + { 15 [ callstack-overflow. ] } + { 16 [ memory-error. ] } + { 17 [ fp-trap-error. ] } } ; inline M: vm-error summary drop "VM error" ; From f60bdb4cb1536c279b5a98dead8459be27f97c48 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Mar 2010 19:26:24 -0700 Subject: [PATCH 061/123] remove old, unused 'vars' vocab --- extra/vars/authors.txt | 1 - extra/vars/summary.txt | 1 - extra/vars/tags.txt | 1 - extra/vars/vars.factor | 31 ------------------------------- 4 files changed, 34 deletions(-) delete mode 100644 extra/vars/authors.txt delete mode 100644 extra/vars/summary.txt delete mode 100644 extra/vars/tags.txt delete mode 100644 extra/vars/vars.factor diff --git a/extra/vars/authors.txt b/extra/vars/authors.txt deleted file mode 100644 index 6cfd5da273..0000000000 --- a/extra/vars/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/vars/summary.txt b/extra/vars/summary.txt deleted file mode 100644 index 9f5f717b99..0000000000 --- a/extra/vars/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Shorthand notation for variables diff --git a/extra/vars/tags.txt b/extra/vars/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/vars/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor deleted file mode 100644 index 990b0307d0..0000000000 --- a/extra/vars/vars.factor +++ /dev/null @@ -1,31 +0,0 @@ -! Copyright (C) 2005, 2006 Eduardo Cavazos - -! Thanks to Mackenzie Straight for the idea - -USING: accessors kernel parser lexer words words.symbol -namespaces sequences quotations ; - -IN: vars - -: define-var-getter ( word -- ) - [ name>> ">" append create-in ] [ [ get ] curry ] bi - (( -- value )) define-declared ; - -: define-var-setter ( word -- ) - [ name>> ">" prepend create-in ] [ [ set ] curry ] bi - (( value -- )) define-declared ; - -: define-var ( str -- ) - create-in - [ define-symbol ] - [ define-var-getter ] - [ define-var-setter ] tri ; - -SYNTAX: VAR: ! var - scan define-var ; - -: define-vars ( seq -- ) - [ define-var ] each ; - -SYNTAX: VARS: ! vars ... - ";" [ define-var ] each-token ; From 5f31860f18f8ac9e8054ff00e6083f2a6b5506b6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Mar 2010 19:27:34 -0700 Subject: [PATCH 062/123] "variables" vocab with uniform-access global, dynamic, and local vars --- extra/variables/variables.factor | 60 ++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 extra/variables/variables.factor diff --git a/extra/variables/variables.factor b/extra/variables/variables.factor new file mode 100644 index 0000000000..5b7186e155 --- /dev/null +++ b/extra/variables/variables.factor @@ -0,0 +1,60 @@ +! (c)2010 Joe Groff bsd license +USING: accessors definitions fry kernel locals.types namespaces parser +see sequences words ; +FROM: help.markup.private => link-effect? ; +IN: variables + +PREDICATE: variable < word + "variable-setter" word-prop ; + +GENERIC: variable-setter ( word -- word' ) + +M: variable variable-setter "variable-setter" word-prop ; +M: local-reader variable-setter "local-writer" word-prop ; + +SYNTAX: set: + scan-object variable-setter suffix! ; + +: [variable-getter] ( variable -- quot ) + '[ _ get ] ; +: [variable-setter] ( variable -- quot ) + '[ _ set ] ; + +: (define-variable) ( word getter setter -- ) + [ (( -- value )) define-inline ] + [ + [ + [ name>> "set: " prepend ] + [ over "variable-setter" set-word-prop ] bi + ] dip (( value -- )) define-inline + ] bi-curry* bi ; + +: define-variable ( word -- ) + dup [ [variable-getter] ] [ [variable-setter] ] bi (define-variable) ; + +SYNTAX: VAR: + CREATE-WORD define-variable ; + +M: variable definer drop \ VAR: f ; +M: variable definition drop f ; +M: variable link-effect? drop f ; +M: variable print-stack-effect? drop f ; + +TUPLE: global-box value ; + +PREDICATE: global-variable < variable + "variable-setter" word-prop def>> first global-box? ; + +: [global-getter] ( box -- quot ) + '[ _ value>> ] ; +: [global-setter] ( box -- quot ) + '[ _ (>>value) ] ; + +: define-global ( word -- ) + global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ; + +SYNTAX: GLOBAL: + CREATE-WORD define-global ; + +M: global-variable definer drop \ GLOBAL: f ; + From 0a9d1b03a16b5284a5439034cadde48b2aef2ed4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 28 Mar 2010 21:25:49 -0700 Subject: [PATCH 063/123] variables: typed vars, globals --- extra/variables/variables.factor | 44 +++++++++++++++++++++++++++++--- 1 file changed, 41 insertions(+), 3 deletions(-) diff --git a/extra/variables/variables.factor b/extra/variables/variables.factor index 5b7186e155..705e1f1945 100644 --- a/extra/variables/variables.factor +++ b/extra/variables/variables.factor @@ -1,6 +1,8 @@ ! (c)2010 Joe Groff bsd license -USING: accessors definitions fry kernel locals.types namespaces parser -see sequences words ; +USING: accessors arrays combinators definitions fry kernel +locals.types namespaces parser quotations see sequences slots +words ; +FROM: kernel.private => declare ; FROM: help.markup.private => link-effect? ; IN: variables @@ -40,10 +42,32 @@ M: variable definition drop f ; M: variable link-effect? drop f ; M: variable print-stack-effect? drop f ; +PREDICATE: typed-variable < variable + "variable-type" word-prop ; + +: [typed-getter] ( quot type -- quot ) + 1array '[ @ _ declare ] ; +: [typed-setter] ( quot type -- quot ) + instance-check-quot prepose ; + +: define-typed-variable ( word type -- ) + dupd { + [ [ [variable-getter] ] dip [typed-getter] ] + [ [ [variable-setter] ] dip [typed-setter] ] + [ "variable-type" set-word-prop ] + [ initial-value swap set-global ] + } 2cleave (define-variable) ; + +SYNTAX: TYPED-VAR: + CREATE-WORD scan-object define-typed-variable ; + +M: typed-variable definer drop \ TYPED-VAR: f ; +M: typed-variable definition "variable-type" word-prop 1quotation ; + TUPLE: global-box value ; PREDICATE: global-variable < variable - "variable-setter" word-prop def>> first global-box? ; + def>> first global-box? ; : [global-getter] ( box -- quot ) '[ _ value>> ] ; @@ -58,3 +82,17 @@ SYNTAX: GLOBAL: M: global-variable definer drop \ GLOBAL: f ; +INTERSECTION: typed-global-variable + global-variable typed-variable ; + +: define-typed-global ( word type -- ) + 2dup "variable-type" set-word-prop + dup initial-value global-box boa swap + [ [ [global-getter] ] dip [typed-getter] ] + [ [ [global-setter] ] dip [typed-setter] ] 2bi (define-variable) ; + +SYNTAX: TYPED-GLOBAL: + CREATE-WORD scan-object define-typed-global ; + +M: typed-global-variable definer drop \ TYPED-GLOBAL: f ; + From 8ab0d12e8defc2b1c80db0e2481b2ca2acf71f17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Mar 2010 01:53:20 -0400 Subject: [PATCH 064/123] vm: callstack errors were flipped --- core/kernel/kernel-tests.factor | 5 ++++- vm/errors.cpp | 4 ++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 152e1bac14..7d5f7b538b 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -49,8 +49,11 @@ IN: kernel.tests : overflow-c ( -- ) overflow-c overflow-c ; +! The VM cannot recover from callstack overflow on Windows or +! OpenBSD, because no facility exists to run memory protection +! fault handlers on an alternate callstack. os [ windows? ] [ openbsd? ] bi or [ - [ overflow-c ] [ { "kernel-error" 14 f f } = ] must-fail-with + [ overflow-c ] [ { "kernel-error" 15 f f } = ] must-fail-with ] unless [ -7 ] must-fail diff --git a/vm/errors.cpp b/vm/errors.cpp index 21dff5a475..f6ceee9966 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -98,9 +98,9 @@ void factor_vm::memory_protection_error(cell addr, stack_frame *stack) else if(ctx->retainstack_seg->overflow_p(addr)) general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object,stack); else if(ctx->callstack_seg->underflow_p(addr)) - general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack); - else if(ctx->callstack_seg->overflow_p(addr)) general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object,stack); + else if(ctx->callstack_seg->overflow_p(addr)) + general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack); else general_error(ERROR_MEMORY,allot_cell(addr),false_object,stack); } From 43b2e02534f4e4d28e2ccc34dba1a7a4c5324b8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Mar 2010 02:23:21 -0400 Subject: [PATCH 065/123] vm: split up TLS code and add a dummy implementation for a dummy OS known as NetBSD --- GNUmakefile | 1 + Nmakefile | 2 ++ vm/Config.freebsd | 2 +- vm/Config.linux | 2 +- vm/Config.macosx | 2 +- vm/Config.netbsd | 2 +- vm/Config.openbsd | 2 +- vm/Config.windows.nt | 2 +- vm/factor.cpp | 27 +-------------------------- vm/factor.hpp | 2 +- vm/master.hpp | 1 + vm/mvm-none.cpp | 28 ++++++++++++++++++++++++++++ vm/mvm-unix.cpp | 26 ++++++++++++++++++++++++++ vm/mvm-windows-nt.cpp | 27 +++++++++++++++++++++++++++ vm/mvm.cpp | 29 +++++++++++++++++++++++++++++ vm/mvm.hpp | 12 ++++++++++++ vm/os-unix.cpp | 20 -------------------- vm/os-unix.hpp | 5 ----- vm/os-windows-nt.cpp | 21 --------------------- vm/os-windows-nt.hpp | 4 ---- vm/vm.hpp | 2 -- 21 files changed, 134 insertions(+), 85 deletions(-) create mode 100644 vm/mvm-none.cpp create mode 100644 vm/mvm-unix.cpp create mode 100644 vm/mvm-windows-nt.cpp create mode 100644 vm/mvm.cpp create mode 100644 vm/mvm.hpp diff --git a/GNUmakefile b/GNUmakefile index eac1c696df..12ca388f87 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -52,6 +52,7 @@ ifdef CONFIG vm/io.o \ vm/jit.o \ vm/math.o \ + vm/mvm.o \ vm/nursery_collector.o \ vm/object_start_map.o \ vm/objects.o \ diff --git a/Nmakefile b/Nmakefile index 7349deae23..a73a59d0f5 100755 --- a/Nmakefile +++ b/Nmakefile @@ -38,6 +38,8 @@ DLL_OBJS = vm\os-windows-nt.obj \ vm\io.obj \ vm\jit.obj \ vm\math.obj \ + vm\mvm.obj \ + vm\mvm-windows-nt.obj \ vm\nursery_collector.obj \ vm\object_start_map.obj \ vm\objects.obj \ diff --git a/vm/Config.freebsd b/vm/Config.freebsd index a0dbe228e5..4dc56cfaed 100644 --- a/vm/Config.freebsd +++ b/vm/Config.freebsd @@ -1,4 +1,4 @@ include vm/Config.unix -PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-freebsd.o vm/mvm-unix.o CFLAGS += -export-dynamic LIBS = -L/usr/local/lib/ -lm -lrt $(X11_UI_LIBS) diff --git a/vm/Config.linux b/vm/Config.linux index 4a859b1216..00ff73522a 100644 --- a/vm/Config.linux +++ b/vm/Config.linux @@ -1,4 +1,4 @@ include vm/Config.unix -PLAF_DLL_OBJS += vm/os-genunix.o vm/os-linux.o +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-linux.o vm/mvm-unix.o CFLAGS += -export-dynamic LIBS = -ldl -lm -lrt -lpthread $(X11_UI_LIBS) diff --git a/vm/Config.macosx b/vm/Config.macosx index 89fe239668..5b9de7f5cf 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -1,7 +1,7 @@ include vm/Config.unix CFLAGS += -fPIC -PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o +PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o vm/mvm-unix.o DLL_EXTENSION = .dylib SHARED_DLL_EXTENSION = .dylib diff --git a/vm/Config.netbsd b/vm/Config.netbsd index 72a4056c90..2838f9d4c5 100644 --- a/vm/Config.netbsd +++ b/vm/Config.netbsd @@ -1,5 +1,5 @@ include vm/Config.unix -PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o vm/mvm-none.o CFLAGS += -export-dynamic LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib LIBS = -lm -lrt -lssl -lcrypto $(X11_UI_LIBS) diff --git a/vm/Config.openbsd b/vm/Config.openbsd index c7d2672e6b..6983223b74 100644 --- a/vm/Config.openbsd +++ b/vm/Config.openbsd @@ -1,5 +1,5 @@ include vm/Config.unix -PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o vm/mvm-unix.o CC = egcc CPP = eg++ CFLAGS += -export-dynamic -fno-inline-functions diff --git a/vm/Config.windows.nt b/vm/Config.windows.nt index ffaa899fe1..322649dc06 100644 --- a/vm/Config.windows.nt +++ b/vm/Config.windows.nt @@ -1,7 +1,7 @@ LIBS = -lm EXE_SUFFIX= DLL_SUFFIX= -PLAF_DLL_OBJS += vm/os-windows-nt.o +PLAF_DLL_OBJS += vm/os-windows-nt.o vm/mvm-windows-nt.o PLAF_EXE_OBJS += vm/resources.o PLAF_EXE_OBJS += vm/main-windows-nt.o CFLAGS += -mwindows diff --git a/vm/factor.cpp b/vm/factor.cpp index c33db440a0..e726ebf6da 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -3,11 +3,9 @@ namespace factor { -std::map thread_vms; - void init_globals() { - init_platform_globals(); + init_mvm(); } void factor_vm::default_parameters(vm_parameters *p) @@ -205,11 +203,6 @@ void factor_vm::start_standalone_factor(int argc, vm_char **argv) start_factor(&p); } -struct startargs { - int argc; - vm_char **argv; -}; - factor_vm *new_factor_vm() { factor_vm *newvm = new factor_vm(); @@ -219,28 +212,10 @@ factor_vm *new_factor_vm() return newvm; } -// arg must be new'ed because we're going to delete it! -void *start_standalone_factor_thread(void *arg) -{ - factor_vm *newvm = new_factor_vm(); - startargs *args = (startargs*) arg; - int argc = args->argc; vm_char **argv = args->argv; - delete args; - newvm->start_standalone_factor(argc, argv); - return 0; -} - VM_C_API void start_standalone_factor(int argc, vm_char **argv) { factor_vm *newvm = new_factor_vm(); return newvm->start_standalone_factor(argc,argv); } -VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv) -{ - startargs *args = new startargs; - args->argc = argc; args->argv = argv; - return start_thread(start_standalone_factor_thread,args); -} - } diff --git a/vm/factor.hpp b/vm/factor.hpp index cec59bcc5c..f2dd6af0bf 100755 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -2,7 +2,7 @@ namespace factor { VM_C_API void init_globals(); +factor_vm *new_factor_vm(); VM_C_API void start_standalone_factor(int argc, vm_char **argv); -VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv); } diff --git a/vm/master.hpp b/vm/master.hpp index dca3d7473c..9879fa607a 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -132,6 +132,7 @@ namespace factor #include "jit.hpp" #include "quotations.hpp" #include "inline_cache.hpp" +#include "mvm.hpp" #include "factor.hpp" #include "utilities.hpp" diff --git a/vm/mvm-none.cpp b/vm/mvm-none.cpp new file mode 100644 index 0000000000..ab1b53a4b5 --- /dev/null +++ b/vm/mvm-none.cpp @@ -0,0 +1,28 @@ +#include "master.hpp" + +/* Multi-VM threading is not supported on NetBSD due to +http://gnats.netbsd.org/25563 */ + +namespace factor +{ + +factor_vm *global_vm; + +void init_mvm() +{ + global_vm = NULL; +} + +void register_vm_with_thread(factor_vm *vm) +{ + assert(!global_vm); + global_vm = vm; +} + +factor_vm *current_vm() +{ + assert(global_vm != NULL); + return global_vm; +} + +} diff --git a/vm/mvm-unix.cpp b/vm/mvm-unix.cpp new file mode 100644 index 0000000000..110e73f8af --- /dev/null +++ b/vm/mvm-unix.cpp @@ -0,0 +1,26 @@ +#include "master.hpp" + +namespace factor +{ + +pthread_key_t current_vm_tls_key = 0; + +void init_mvm() +{ + if(pthread_key_create(¤t_vm_tls_key, NULL) != 0) + fatal_error("pthread_key_create() failed",0); +} + +void register_vm_with_thread(factor_vm *vm) +{ + pthread_setspecific(current_vm_tls_key,vm); +} + +factor_vm *current_vm() +{ + factor_vm *vm = (factor_vm*)pthread_getspecific(current_vm_tls_key); + assert(vm != NULL); + return vm; +} + +} diff --git a/vm/mvm-windows-nt.cpp b/vm/mvm-windows-nt.cpp new file mode 100644 index 0000000000..7cb6b826a8 --- /dev/null +++ b/vm/mvm-windows-nt.cpp @@ -0,0 +1,27 @@ +#include "master.hpp" + +namespace factor +{ + +DWORD current_vm_tls_key; + +void init_mvm() +{ + if ((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) + fatal_error("TlsAlloc() failed",0); +} + +void register_vm_with_thread(factor_vm *vm) +{ + if (!TlsSetValue(current_vm_tls_key, vm)) + fatal_error("TlsSetValue() failed",0); +} + +factor_vm *current_vm() +{ + factor_vm *vm = (factor_vm *)TlsGetValue(current_vm_tls_key); + assert(vm != NULL); + return vm; +} + +} diff --git a/vm/mvm.cpp b/vm/mvm.cpp new file mode 100644 index 0000000000..dda2d66255 --- /dev/null +++ b/vm/mvm.cpp @@ -0,0 +1,29 @@ +#include "master.cpp" + +namespace factor +{ + +struct startargs { + int argc; + vm_char **argv; +}; + +// arg must be new'ed because we're going to delete it! +void *start_standalone_factor_thread(void *arg) +{ + factor_vm *newvm = new_factor_vm(); + startargs *args = (startargs*) arg; + int argc = args->argc; vm_char **argv = args->argv; + delete args; + newvm->start_standalone_factor(argc, argv); + return 0; +} + +VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv) +{ + startargs *args = new startargs; + args->argc = argc; args->argv = argv; + return start_thread(start_standalone_factor_thread,args); +} + +} diff --git a/vm/mvm.hpp b/vm/mvm.hpp new file mode 100644 index 0000000000..52430b7c01 --- /dev/null +++ b/vm/mvm.hpp @@ -0,0 +1,12 @@ +namespace factor +{ + +void init_mvm(); +void register_vm_with_thread(factor_vm *vm); +factor_vm *current_vm(); + +VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv); + +extern std::map thread_vms; + +} diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index a724007b1a..a8898eccab 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -17,26 +17,6 @@ THREADHANDLE start_thread(void *(*start_routine)(void *),void *args) return thread; } -pthread_key_t current_vm_tls_key = 0; - -void init_platform_globals() -{ - if(pthread_key_create(¤t_vm_tls_key, NULL) != 0) - fatal_error("pthread_key_create() failed",0); -} - -void register_vm_with_thread(factor_vm *vm) -{ - pthread_setspecific(current_vm_tls_key,vm); -} - -factor_vm *current_vm() -{ - factor_vm *vm = (factor_vm*)pthread_getspecific(current_vm_tls_key); - assert(vm != NULL); - return vm; -} - static void *null_dll; u64 system_micros() diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index df6e0b4b3e..3673c4e121 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -45,11 +45,6 @@ void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); u64 system_micros(); u64 nano_count(); void sleep_nanos(u64 nsec); - -void init_platform_globals(); - -void register_vm_with_thread(factor_vm *vm); -factor_vm *current_vm(); void open_console(); void move_file(const vm_char *path1, const vm_char *path2); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 54ee78f977..2d5881252a 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -8,27 +8,6 @@ THREADHANDLE start_thread(void *(*start_routine)(void *), void *args) return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0); } -DWORD dwTlsIndex; - -void init_platform_globals() -{ - if ((dwTlsIndex = TlsAlloc()) == TLS_OUT_OF_INDEXES) - fatal_error("TlsAlloc failed - out of indexes",0); -} - -void register_vm_with_thread(factor_vm *vm) -{ - if (! TlsSetValue(dwTlsIndex, vm)) - fatal_error("TlsSetValue failed",0); -} - -factor_vm *current_vm() -{ - factor_vm *vm = (factor_vm *)TlsGetValue(dwTlsIndex); - assert(vm != NULL); - return vm; -} - u64 system_micros() { FILETIME t; diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index d425a2c281..c5e721c56d 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -45,8 +45,4 @@ typedef HANDLE THREADHANDLE; THREADHANDLE start_thread(void *(*start_routine)(void *),void *args); inline static THREADHANDLE thread_id() { return GetCurrentThread(); } -void init_platform_globals(); -void register_vm_with_thread(factor_vm *vm); -factor_vm *current_vm(); - } diff --git a/vm/vm.hpp b/vm/vm.hpp index 4402b64f41..d304543879 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -715,6 +715,4 @@ struct factor_vm ~factor_vm(); }; -extern std::map thread_vms; - } From 946b7415e055fc802310f734d8c876dc2e881874 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Mar 2010 02:27:45 -0400 Subject: [PATCH 066/123] vm: fix typos --- vm/mvm-unix.cpp | 2 +- vm/mvm-windows-nt.cpp | 4 ++-- vm/mvm.cpp | 4 +++- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/vm/mvm-unix.cpp b/vm/mvm-unix.cpp index 110e73f8af..adba52b122 100644 --- a/vm/mvm-unix.cpp +++ b/vm/mvm-unix.cpp @@ -3,7 +3,7 @@ namespace factor { -pthread_key_t current_vm_tls_key = 0; +pthread_key_t current_vm_tls_key; void init_mvm() { diff --git a/vm/mvm-windows-nt.cpp b/vm/mvm-windows-nt.cpp index 7cb6b826a8..92c20672aa 100644 --- a/vm/mvm-windows-nt.cpp +++ b/vm/mvm-windows-nt.cpp @@ -7,13 +7,13 @@ DWORD current_vm_tls_key; void init_mvm() { - if ((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) + if((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) fatal_error("TlsAlloc() failed",0); } void register_vm_with_thread(factor_vm *vm) { - if (!TlsSetValue(current_vm_tls_key, vm)) + if(!TlsSetValue(current_vm_tls_key, vm)) fatal_error("TlsSetValue() failed",0); } diff --git a/vm/mvm.cpp b/vm/mvm.cpp index dda2d66255..df5d85ef30 100644 --- a/vm/mvm.cpp +++ b/vm/mvm.cpp @@ -1,8 +1,10 @@ -#include "master.cpp" +#include "master.hpp" namespace factor { +std::map thread_vms; + struct startargs { int argc; vm_char **argv; From 99771eb689c28a0afe306131145fe693c2357c9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Mar 2010 13:14:26 -0400 Subject: [PATCH 067/123] bootstrap.compiler: fix joint dependencies declared here --- basis/bootstrap/compiler/compiler.factor | 7 ++----- basis/stack-checker/errors/errors.factor | 4 +++- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 393e4eab27..0237ed99ee 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -20,11 +20,8 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -{ - "stack-checker.errors.prettyprint" - "alien.prettyprint" - "alien.debugger" -} [ "prettyprint" swap require-when ] each +"prettyprint" "alien.prettyprint" require-when +"debugger" "alien.debugger" require-when "cpu." cpu name>> append require diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 58ce20035c..5eca37ffbe 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,5 +1,6 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: vocabs.loader ; IN: stack-checker.errors TUPLE: inference-error ; @@ -34,3 +35,4 @@ ERROR: bad-declaration-error < inference-error declaration ; ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ; +"debugger" "stack-checker.errors.prettyprint" require-when From d130f242480ac8913bf137d25015251e17313e50 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Mar 2010 15:08:15 -0400 Subject: [PATCH 068/123] ui.gadgets.buttons: fix incorrect parameter order in --- basis/ui/gadgets/buttons/buttons.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index d0d25a0630..4a68b47f15 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -220,8 +220,8 @@ TUPLE: radio-control < button value ; M: radio-control model-changed 2dup [ value>> ] bi@ = >>selected? relayout-1 drop ; -:: ( parent model assoc quot: ( value model label -- gadget ) -- parent ) - assoc model [ parent swap quot call add-gadget ] assoc-each ; inline +:: ( model assoc parent quot: ( value model label -- gadget ) -- parent ) + parent assoc [ model swap quot call add-gadget ] assoc-each ; inline PRIVATE> From c7142e428110f29d6d02daae40397af35104c051 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 29 Mar 2010 20:40:17 -0400 Subject: [PATCH 069/123] threads: use context-switching primitives --- basis/boxes/boxes.factor | 8 +- .../known-words/known-words.factor | 637 +++++------------- basis/threads/threads-docs.factor | 14 +- basis/threads/threads.factor | 153 +++-- basis/tools/threads/threads.factor | 6 +- basis/ui/tools/listener/listener.factor | 4 +- basis/ui/tools/operations/operations.factor | 5 +- core/bootstrap/primitives.factor | 21 +- core/kernel/kernel-docs.factor | 29 +- vm/callstack.cpp | 19 +- vm/contexts.cpp | 67 +- vm/errors.cpp | 5 - vm/objects.hpp | 5 +- vm/primitives.hpp | 5 +- vm/vm.hpp | 16 +- 15 files changed, 406 insertions(+), 588 deletions(-) diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 39f8eb44cc..811c5addb0 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors ; IN: boxes @@ -15,9 +15,11 @@ ERROR: box-full box ; ERROR: box-empty box ; +: check-box ( box -- box ) + dup occupied>> [ box-empty ] unless ; inline + : box> ( box -- value ) - dup occupied>> - [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ; + check-box [ f ] change-value f >>occupied drop ; : ?box ( box -- value/f ? ) dup occupied>> [ box> t ] [ drop f f ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a95456cdc6..b0a751b172 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -247,7 +247,6 @@ M: bad-executable summary unwind-native-frames lazy-jit-compile c-to-factor - call-clear } [ dup '[ _ do-not-compile ] "special" set-word-prop ] each : infer-special ( word -- ) @@ -299,466 +298,184 @@ M: bad-executable summary 3tri ; ! Stack effects for all primitives -\ fixnum< { fixnum fixnum } { object } define-primitive -\ fixnum< make-foldable - -\ fixnum<= { fixnum fixnum } { object } define-primitive -\ fixnum<= make-foldable - -\ fixnum> { fixnum fixnum } { object } define-primitive -\ fixnum> make-foldable - -\ fixnum>= { fixnum fixnum } { object } define-primitive -\ fixnum>= make-foldable - -\ eq? { object object } { object } define-primitive -\ eq? make-foldable - -\ bignum>fixnum { bignum } { fixnum } define-primitive -\ bignum>fixnum make-foldable - -\ float>fixnum { float } { fixnum } define-primitive -\ bignum>fixnum make-foldable - -\ fixnum>bignum { fixnum } { bignum } define-primitive -\ fixnum>bignum make-foldable - -\ float>bignum { float } { bignum } define-primitive -\ float>bignum make-foldable - -\ fixnum>float { fixnum } { float } define-primitive -\ fixnum>float make-foldable - -\ bignum>float { bignum } { float } define-primitive -\ bignum>float make-foldable - -\ (float>string) { float } { byte-array } define-primitive -\ (float>string) make-foldable - -\ float>bits { real } { integer } define-primitive -\ float>bits make-foldable - -\ double>bits { real } { integer } define-primitive -\ double>bits make-foldable - -\ bits>float { integer } { float } define-primitive -\ bits>float make-foldable - -\ bits>double { integer } { float } define-primitive -\ bits>double make-foldable - -\ both-fixnums? { object object } { object } define-primitive - -\ fixnum+ { fixnum fixnum } { integer } define-primitive -\ fixnum+ make-foldable - -\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive -\ fixnum+fast make-foldable - -\ fixnum- { fixnum fixnum } { integer } define-primitive -\ fixnum- make-foldable - -\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive -\ fixnum-fast make-foldable - -\ fixnum* { fixnum fixnum } { integer } define-primitive -\ fixnum* make-foldable - -\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive -\ fixnum*fast make-foldable - -\ fixnum/i { fixnum fixnum } { integer } define-primitive -\ fixnum/i make-foldable - -\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive -\ fixnum/i-fast make-foldable - -\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive -\ fixnum-mod make-foldable - -\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive -\ fixnum/mod make-foldable - -\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive -\ fixnum/mod-fast make-foldable - -\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive -\ fixnum-bitand make-foldable - -\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive -\ fixnum-bitor make-foldable - -\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive -\ fixnum-bitxor make-foldable - -\ fixnum-bitnot { fixnum } { fixnum } define-primitive -\ fixnum-bitnot make-foldable - -\ fixnum-shift { fixnum fixnum } { integer } define-primitive -\ fixnum-shift make-foldable - -\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive -\ fixnum-shift-fast make-foldable - -\ bignum= { bignum bignum } { object } define-primitive -\ bignum= make-foldable - -\ bignum+ { bignum bignum } { bignum } define-primitive -\ bignum+ make-foldable - -\ bignum- { bignum bignum } { bignum } define-primitive -\ bignum- make-foldable - -\ bignum* { bignum bignum } { bignum } define-primitive -\ bignum* make-foldable - -\ bignum/i { bignum bignum } { bignum } define-primitive -\ bignum/i make-foldable - -\ bignum-mod { bignum bignum } { bignum } define-primitive -\ bignum-mod make-foldable - -\ bignum/mod { bignum bignum } { bignum bignum } define-primitive -\ bignum/mod make-foldable - -\ bignum-bitand { bignum bignum } { bignum } define-primitive -\ bignum-bitand make-foldable - -\ bignum-bitor { bignum bignum } { bignum } define-primitive -\ bignum-bitor make-foldable - -\ bignum-bitxor { bignum bignum } { bignum } define-primitive -\ bignum-bitxor make-foldable - -\ bignum-bitnot { bignum } { bignum } define-primitive -\ bignum-bitnot make-foldable - -\ bignum-shift { bignum fixnum } { bignum } define-primitive -\ bignum-shift make-foldable - -\ bignum< { bignum bignum } { object } define-primitive -\ bignum< make-foldable - -\ bignum<= { bignum bignum } { object } define-primitive -\ bignum<= make-foldable - -\ bignum> { bignum bignum } { object } define-primitive -\ bignum> make-foldable - -\ bignum>= { bignum bignum } { object } define-primitive -\ bignum>= make-foldable - -\ bignum-bit? { bignum integer } { object } define-primitive -\ bignum-bit? make-foldable - -\ bignum-log2 { bignum } { bignum } define-primitive -\ bignum-log2 make-foldable - -\ byte-array>bignum { byte-array } { bignum } define-primitive -\ byte-array>bignum make-foldable - -\ float= { float float } { object } define-primitive -\ float= make-foldable - -\ float+ { float float } { float } define-primitive -\ float+ make-foldable - -\ float- { float float } { float } define-primitive -\ float- make-foldable - -\ float* { float float } { float } define-primitive -\ float* make-foldable - -\ float/f { float float } { float } define-primitive -\ float/f make-foldable - -\ float-mod { float float } { float } define-primitive -\ float-mod make-foldable - -\ float< { float float } { object } define-primitive -\ float< make-foldable - -\ float<= { float float } { object } define-primitive -\ float<= make-foldable - -\ float> { float float } { object } define-primitive -\ float> make-foldable - -\ float>= { float float } { object } define-primitive -\ float>= make-foldable - -\ float-u< { float float } { object } define-primitive -\ float-u< make-foldable - -\ float-u<= { float float } { object } define-primitive -\ float-u<= make-foldable - -\ float-u> { float float } { object } define-primitive -\ float-u> make-foldable - -\ float-u>= { float float } { object } define-primitive -\ float-u>= make-foldable - -\ (word) { object object object } { word } define-primitive -\ (word) make-flushable - -\ word-code { word } { integer integer } define-primitive -\ word-code make-flushable - -\ current-callback { } { fixnum } define-primitive -\ current-callback make-flushable - -\ context { } { c-ptr } define-primitive -\ context make-flushable - -\ delete-context { c-ptr } { } define-primitive - -\ (start-context) { object quotation } { object } define-primitive - -\ (set-context) { object alien } { object } define-primitive - -\ special-object { fixnum } { object } define-primitive -\ special-object make-flushable - -\ set-special-object { object fixnum } { } define-primitive - -\ context-object { fixnum } { object } define-primitive -\ context-object make-flushable - -\ set-context-object { object fixnum } { } define-primitive - -\ (exists?) { string } { object } define-primitive - -\ minor-gc { } { } define-primitive - -\ gc { } { } define-primitive - -\ compact-gc { } { } define-primitive - -\ (save-image) { byte-array byte-array } { } define-primitive - -\ (save-image-and-exit) { byte-array byte-array } { } define-primitive - -\ data-room { } { byte-array } define-primitive -\ data-room make-flushable - -\ (code-blocks) { } { array } define-primitive -\ (code-blocks) make-flushable - -\ code-room { } { byte-array } define-primitive -\ code-room make-flushable - -\ system-micros { } { integer } define-primitive -\ system-micros make-flushable - -\ nano-count { } { integer } define-primitive -\ nano-count make-flushable - -\ tag { object } { fixnum } define-primitive -\ tag make-foldable - +\ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable +\ (clone) { object } { object } define-primitive \ (clone) make-flushable +\ (code-blocks) { } { array } define-primitive \ (code-blocks) make-flushable \ (dlopen) { byte-array } { dll } define-primitive - \ (dlsym) { byte-array object } { c-ptr } define-primitive - -\ dlclose { dll } { } define-primitive - -\ { integer } { byte-array } define-primitive -\ make-flushable - -\ (byte-array) { integer } { byte-array } define-primitive -\ (byte-array) make-flushable - -\ { integer c-ptr } { c-ptr } define-primitive -\ make-flushable - -\ alien-signed-cell { c-ptr integer } { integer } define-primitive -\ alien-signed-cell make-flushable - -\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive - -\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive -\ alien-unsigned-cell make-flushable - -\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive - -\ alien-signed-8 { c-ptr integer } { integer } define-primitive -\ alien-signed-8 make-flushable - -\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive - -\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive -\ alien-unsigned-8 make-flushable - -\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive - -\ alien-signed-4 { c-ptr integer } { integer } define-primitive -\ alien-signed-4 make-flushable - -\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive - -\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive -\ alien-unsigned-4 make-flushable - -\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive - -\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive -\ alien-signed-2 make-flushable - -\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive - -\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive -\ alien-unsigned-2 make-flushable - -\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive - -\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive -\ alien-signed-1 make-flushable - -\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive - -\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive -\ alien-unsigned-1 make-flushable - -\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive - -\ alien-float { c-ptr integer } { float } define-primitive -\ alien-float make-flushable - -\ set-alien-float { float c-ptr integer } { } define-primitive - -\ alien-double { c-ptr integer } { float } define-primitive -\ alien-double make-flushable - -\ set-alien-double { float c-ptr integer } { } define-primitive - -\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive -\ alien-cell make-flushable - -\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive - -\ alien-address { alien } { integer } define-primitive -\ alien-address make-flushable - -\ slot { object fixnum } { object } define-primitive -\ slot make-flushable - -\ set-slot { object object fixnum } { } define-primitive - -\ string-nth { fixnum string } { fixnum } define-primitive -\ string-nth make-flushable - -\ set-string-nth-slow { fixnum fixnum string } { } define-primitive -\ set-string-nth-fast { fixnum fixnum string } { } define-primitive - -\ resize-array { integer array } { array } define-primitive -\ resize-array make-flushable - -\ resize-byte-array { integer byte-array } { byte-array } define-primitive -\ resize-byte-array make-flushable - -\ resize-string { integer string } { string } define-primitive -\ resize-string make-flushable - -\ { integer object } { array } define-primitive -\ make-flushable - -\ all-instances { } { array } define-primitive - -\ size { object } { fixnum } define-primitive -\ size make-flushable - -\ die { } { } define-primitive - -\ (fopen) { byte-array byte-array } { alien } define-primitive - -\ fgetc { alien } { object } define-primitive - -\ fwrite { c-ptr integer alien } { } define-primitive - -\ fputc { object alien } { } define-primitive - -\ fread { integer alien } { object } define-primitive - -\ fflush { alien } { } define-primitive - -\ fseek { integer integer alien } { } define-primitive - -\ ftell { alien } { integer } define-primitive - -\ fclose { alien } { } define-primitive - -\ { object } { wrapper } define-primitive -\ make-foldable - -\ (clone) { object } { object } define-primitive -\ (clone) make-flushable - -\ { integer integer } { string } define-primitive -\ make-flushable - -\ array>quotation { array } { quotation } define-primitive -\ array>quotation make-flushable - -\ quotation-code { quotation } { integer integer } define-primitive -\ quotation-code make-flushable - -\ { tuple-layout } { tuple } define-primitive -\ make-flushable - -\ datastack { } { array } define-primitive -\ datastack make-flushable - -\ check-datastack { array integer integer } { object } define-primitive -\ check-datastack make-flushable - -\ retainstack { } { array } define-primitive -\ retainstack make-flushable - -\ callstack { } { callstack } define-primitive -\ callstack make-flushable - -\ callstack>array { callstack } { array } define-primitive -\ callstack>array make-flushable - -\ (sleep) { integer } { } define-primitive - -\ become { array array } { } define-primitive - -\ innermost-frame-executing { callstack } { object } define-primitive - -\ innermost-frame-scan { callstack } { fixnum } define-primitive - -\ set-innermost-frame-quot { quotation callstack } { } define-primitive - -\ dll-valid? { object } { object } define-primitive - -\ modify-code-heap { array object object } { } define-primitive - -\ unimplemented { } { } define-primitive - -\ jit-compile { quotation } { } define-primitive - -\ lookup-method { object array } { word } define-primitive - -\ reset-dispatch-stats { } { } define-primitive -\ dispatch-stats { } { byte-array } define-primitive - -\ optimized? { word } { object } define-primitive - -\ strip-stack-traces { } { } define-primitive - -\ { integer word } { alien } define-primitive - -\ enable-gc-events { } { } define-primitive -\ disable-gc-events { } { object } define-primitive - -\ profiling { object } { } define-primitive - -\ (identity-hashcode) { object } { fixnum } define-primitive - -\ compute-identity-hashcode { object } { } define-primitive - +\ (exists?) { string } { object } define-primitive \ (exit) { integer } { } define-primitive - +\ (float>string) { float } { byte-array } define-primitive \ (float>string) make-foldable +\ (fopen) { byte-array byte-array } { alien } define-primitive +\ (identity-hashcode) { object } { fixnum } define-primitive +\ (save-image) { byte-array byte-array } { } define-primitive +\ (save-image-and-exit) { byte-array byte-array } { } define-primitive +\ (set-context) { object alien } { object } define-primitive +\ (sleep) { integer } { } define-primitive +\ (start-context) { object quotation } { object } define-primitive +\ (word) { object object object } { word } define-primitive \ (word) make-flushable +\ { integer object } { array } define-primitive \ make-flushable +\ { integer } { byte-array } define-primitive \ make-flushable +\ { integer word } { alien } define-primitive +\ { integer c-ptr } { c-ptr } define-primitive \ make-flushable +\ { integer integer } { string } define-primitive \ make-flushable +\ { tuple-layout } { tuple } define-primitive \ make-flushable +\ { object } { wrapper } define-primitive \ make-foldable +\ alien-address { alien } { integer } define-primitive \ alien-address make-flushable +\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive \ alien-cell make-flushable +\ alien-double { c-ptr integer } { float } define-primitive \ alien-double make-flushable +\ alien-float { c-ptr integer } { float } define-primitive \ alien-float make-flushable +\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive \ alien-signed-1 make-flushable +\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive \ alien-signed-2 make-flushable +\ alien-signed-4 { c-ptr integer } { integer } define-primitive \ alien-signed-4 make-flushable +\ alien-signed-8 { c-ptr integer } { integer } define-primitive \ alien-signed-8 make-flushable +\ alien-signed-cell { c-ptr integer } { integer } define-primitive \ alien-signed-cell make-flushable +\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive \ alien-unsigned-1 make-flushable +\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive \ alien-unsigned-2 make-flushable +\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive \ alien-unsigned-4 make-flushable +\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive \ alien-unsigned-8 make-flushable +\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive \ alien-unsigned-cell make-flushable +\ all-instances { } { array } define-primitive +\ array>quotation { array } { quotation } define-primitive \ array>quotation make-foldable +\ become { array array } { } define-primitive +\ bignum* { bignum bignum } { bignum } define-primitive \ bignum* make-foldable +\ bignum+ { bignum bignum } { bignum } define-primitive \ bignum+ make-foldable +\ bignum- { bignum bignum } { bignum } define-primitive \ bignum- make-foldable +\ bignum-bit? { bignum integer } { object } define-primitive \ bignum-bit? make-foldable +\ bignum-bitand { bignum bignum } { bignum } define-primitive \ bignum-bitand make-foldable +\ bignum-bitnot { bignum } { bignum } define-primitive \ bignum-bitnot make-foldable +\ bignum-bitor { bignum bignum } { bignum } define-primitive \ bignum-bitor make-foldable +\ bignum-bitxor { bignum bignum } { bignum } define-primitive \ bignum-bitxor make-foldable +\ bignum-log2 { bignum } { bignum } define-primitive \ bignum-log2 make-foldable +\ bignum-mod { bignum bignum } { bignum } define-primitive \ bignum-mod make-foldable +\ bignum-shift { bignum fixnum } { bignum } define-primitive \ bignum-shift make-foldable +\ bignum/i { bignum bignum } { bignum } define-primitive \ bignum/i make-foldable +\ bignum/mod { bignum bignum } { bignum bignum } define-primitive \ bignum/mod make-foldable +\ bignum< { bignum bignum } { object } define-primitive \ bignum< make-foldable +\ bignum<= { bignum bignum } { object } define-primitive \ bignum<= make-foldable +\ bignum= { bignum bignum } { object } define-primitive \ bignum= make-foldable +\ bignum> { bignum bignum } { object } define-primitive \ bignum> make-foldable +\ bignum>= { bignum bignum } { object } define-primitive \ bignum>= make-foldable +\ bignum>fixnum { bignum } { fixnum } define-primitive \ bignum>fixnum make-foldable +\ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable +\ bits>double { integer } { float } define-primitive \ bits>double make-foldable +\ bits>float { integer } { float } define-primitive \ bits>float make-foldable +\ both-fixnums? { object object } { object } define-primitive +\ byte-array>bignum { byte-array } { bignum } define-primitive \ byte-array>bignum make-foldable +\ callstack { } { callstack } define-primitive \ callstack make-flushable +\ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable +\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable +\ check-datastack { array integer integer } { object } define-primitive \ check-datastack make-flushable +\ code-room { } { byte-array } define-primitive \ code-room make-flushable +\ compact-gc { } { } define-primitive +\ compute-identity-hashcode { object } { } define-primitive +\ context { } { c-ptr } define-primitive \ context make-flushable +\ context-object { fixnum } { object } define-primitive \ context-object make-flushable +\ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable +\ current-callback { } { fixnum } define-primitive \ current-callback make-flushable +\ data-room { } { byte-array } define-primitive \ data-room make-flushable +\ datastack { } { array } define-primitive \ datastack make-flushable +\ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable +\ delete-context { c-ptr } { } define-primitive +\ die { } { } define-primitive +\ disable-gc-events { } { object } define-primitive +\ dispatch-stats { } { byte-array } define-primitive +\ dlclose { dll } { } define-primitive +\ dll-valid? { object } { object } define-primitive +\ double>bits { real } { integer } define-primitive \ double>bits make-foldable +\ enable-gc-events { } { } define-primitive +\ eq? { object object } { object } define-primitive \ eq? make-foldable +\ fclose { alien } { } define-primitive +\ fflush { alien } { } define-primitive +\ fgetc { alien } { object } define-primitive +\ fixnum* { fixnum fixnum } { integer } define-primitive \ fixnum* make-foldable +\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive \ fixnum*fast make-foldable +\ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable +\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive \ fixnum+fast make-foldable +\ fixnum- { fixnum fixnum } { integer } define-primitive \ fixnum- make-foldable +\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand make-foldable +\ fixnum-bitnot { fixnum } { fixnum } define-primitive \ fixnum-bitnot make-foldable +\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitor make-foldable +\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitxor make-foldable +\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-fast make-foldable +\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod make-foldable +\ fixnum-shift { fixnum fixnum } { integer } define-primitive \ fixnum-shift make-foldable +\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum-shift-fast make-foldable +\ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i make-foldable +\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive \ fixnum/i-fast make-foldable +\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod make-foldable +\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive \ fixnum/mod-fast make-foldable +\ fixnum< { fixnum fixnum } { object } define-primitive \ fixnum< make-foldable +\ fixnum<= { fixnum fixnum } { object } define-primitive \ fixnum<= make-foldable +\ fixnum> { fixnum fixnum } { object } define-primitive \ fixnum> make-foldable +\ fixnum>= { fixnum fixnum } { object } define-primitive \ fixnum>= make-foldable +\ fixnum>bignum { fixnum } { bignum } define-primitive \ fixnum>bignum make-foldable +\ fixnum>float { fixnum } { float } define-primitive \ fixnum>float make-foldable +\ float* { float float } { float } define-primitive \ float* make-foldable +\ float+ { float float } { float } define-primitive \ float+ make-foldable +\ float- { float float } { float } define-primitive \ float- make-foldable +\ float-mod { float float } { float } define-primitive \ float-mod make-foldable +\ float-u< { float float } { object } define-primitive \ float-u< make-foldable +\ float-u<= { float float } { object } define-primitive \ float-u<= make-foldable +\ float-u> { float float } { object } define-primitive \ float-u> make-foldable +\ float-u>= { float float } { object } define-primitive \ float-u>= make-foldable +\ float/f { float float } { float } define-primitive \ float/f make-foldable +\ float< { float float } { object } define-primitive \ float< make-foldable +\ float<= { float float } { object } define-primitive \ float<= make-foldable +\ float= { float float } { object } define-primitive \ float= make-foldable +\ float> { float float } { object } define-primitive \ float> make-foldable +\ float>= { float float } { object } define-primitive \ float>= make-foldable +\ float>bignum { float } { bignum } define-primitive \ float>bignum make-foldable +\ float>bits { real } { integer } define-primitive \ float>bits make-foldable +\ float>fixnum { float } { fixnum } define-primitive \ bignum>fixnum make-foldable +\ fputc { object alien } { } define-primitive +\ fread { integer alien } { object } define-primitive +\ fseek { integer integer alien } { } define-primitive +\ ftell { alien } { integer } define-primitive +\ fwrite { c-ptr integer alien } { } define-primitive +\ gc { } { } define-primitive +\ innermost-frame-executing { callstack } { object } define-primitive +\ innermost-frame-scan { callstack } { fixnum } define-primitive +\ jit-compile { quotation } { } define-primitive +\ lookup-method { object array } { word } define-primitive +\ minor-gc { } { } define-primitive +\ modify-code-heap { array object object } { } define-primitive +\ nano-count { } { integer } define-primitive \ nano-count make-flushable +\ optimized? { word } { object } define-primitive +\ profiling { object } { } define-primitive \ quot-compiled? { quotation } { object } define-primitive +\ quotation-code { quotation } { integer integer } define-primitive \ quotation-code make-flushable +\ reset-dispatch-stats { } { } define-primitive +\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable +\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable +\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable +\ retainstack { } { array } define-primitive \ retainstack make-flushable +\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable +\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive +\ set-alien-double { float c-ptr integer } { } define-primitive +\ set-alien-float { float c-ptr integer } { } define-primitive +\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive +\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive +\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive +\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive +\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive +\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive +\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive +\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive +\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive +\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive +\ set-context-object { object fixnum } { } define-primitive +\ set-innermost-frame-quot { quotation callstack } { } define-primitive +\ set-slot { object object fixnum } { } define-primitive +\ set-special-object { object fixnum } { } define-primitive +\ set-string-nth-fast { fixnum fixnum string } { } define-primitive +\ set-string-nth-slow { fixnum fixnum string } { } define-primitive +\ size { object } { fixnum } define-primitive \ size make-flushable +\ slot { object fixnum } { object } define-primitive \ slot make-flushable +\ special-object { fixnum } { object } define-primitive \ special-object make-flushable +\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable +\ strip-stack-traces { } { } define-primitive +\ system-micros { } { integer } define-primitive \ system-micros make-flushable +\ tag { object } { fixnum } define-primitive \ tag make-foldable +\ unimplemented { } { } define-primitive +\ word-code { word } { integer integer } define-primitive \ word-code make-flushable diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index 335fbb3902..3e63a81d9a 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations init quotations strings -assocs heaps boxes namespaces deques dlists system ; +threads.private init quotations strings assocs heaps boxes +namespaces deques dlists system ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" @@ -48,7 +48,7 @@ ARTICLE: "thread-state" "Thread-local state and variables" $nl "Global hashtable of all threads, keyed by " { $snippet "id" } ":" { $subsections threads } -"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; +"Threads have an identity independent of continuations. If a continuation is reified in one thread and then reflected in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; ARTICLE: "thread-impl" "Thread implementation" "Thread implementation:" @@ -57,10 +57,8 @@ ARTICLE: "thread-impl" "Thread implementation" sleep-queue } ; -ARTICLE: "threads" "Lightweight co-operative threads" -"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." -$nl -"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." +ARTICLE: "threads" "Co-operative threads" +"Factor supports co-operative threads. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." $nl "Words for working with threads are in the " { $vocab-link "threads" } " vocabulary." { $subsections @@ -78,7 +76,7 @@ HELP: thread { { $snippet "id" } " - a unique identifier assigned to each thread." } { { $snippet "name" } " - the name passed to " { $link spawn } "." } { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." } - { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } + { { $snippet "status" } " - a " { $link string } " indicating what the thread is waiting for, or " { $link f } ". This slot is intended to be used for debugging purposes." } } } ; diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 89a90f87fd..bd30ef4b90 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -3,8 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators combinators.private init boxes -accessors math.order deques strings quotations fry ; +dlists assocs system combinators init boxes accessors math.order +deques strings quotations fry ; IN: threads ; + PRIVATE> SYMBOL: initial-thread @@ -24,7 +40,7 @@ TUPLE: thread { quot callable initial: [ ] } { exit-handler callable initial: [ ] } { id integer } -{ continuation box } +{ context box } state runnable mailbox @@ -34,6 +50,9 @@ sleep-entry ; : self ( -- thread ) 63 special-object { thread } declare ; inline +: thread-continuation ( thread -- continuation ) + context>> check-box value>> continuation-for ; + ! Thread-local storage : tnamespace ( -- assoc ) self variables>> ; inline @@ -45,14 +64,11 @@ sleep-entry ; tnamespace set-at ; : tchange ( key quot -- ) - tnamespace swap change-at ; inline + [ tnamespace ] dip change-at ; inline : threads ( -- assoc ) 64 special-object { hashtable } declare ; inline -: thread ( id -- thread ) - threads at ; - : thread-registered? ( thread -- ? ) id>> threads key? ; @@ -78,23 +94,23 @@ ERROR: not-running thread ; PRIVATE> -: new-thread ( quot name class -- thread ) - new - swap >>name - swap >>quot - \ thread counter >>id - >>continuation - H{ } clone >>variables ; inline - -: ( quot name -- thread ) - \ thread new-thread ; - : run-queue ( -- dlist ) 65 special-object { dlist } declare ; inline : sleep-queue ( -- heap ) 66 special-object { dlist } declare ; inline +: new-thread ( quot name class -- thread ) + new + swap >>name + swap >>quot + \ thread counter >>id + H{ } clone >>variables + >>context ; inline + +: ( quot name -- thread ) + \ thread new-thread ; + : resume ( thread -- ) f >>state check-registered run-queue push-front ; @@ -114,6 +130,13 @@ PRIVATE> [ sleep-queue heap-peek nip nano-count [-] ] } cond ; +: interrupt ( thread -- ) + dup state>> [ + dup sleep-entry>> [ sleep-queue heap-delete ] when* + f >>sleep-entry + dup resume + ] when drop ; + DEFER: stop > [ call stop ] call-clear - ] (( namestack thread -- * )) call-effect-unsafe ; + init-catchstack + self quot>> call + stop + ] start-context ; DEFER: next -: no-runnable-threads ( -- * ) +: no-runnable-threads ( -- obj ) ! We should never be in a state where the only threads ! are sleeping; the I/O wait thread is always runnable. ! However, if it dies, we handle this case @@ -162,31 +183,36 @@ DEFER: next [ (sleep) ] } cond next ; -: (next) ( arg thread -- * ) +: (next) ( obj thread -- obj' ) f >>state dup set-self - dup runnable>> [ - continuation>> box> continue-with - ] [ - t >>runnable start - ] if ; + dup runnable>> + [ context>> box> set-context ] [ t >>runnable drop start ] if ; -: next ( -- * ) +: next ( -- obj ) expire-sleep-loop - run-queue dup deque-empty? [ - drop no-runnable-threads - ] [ - pop-back dup array? [ first2 ] [ f swap ] if (next) - ] if ; + run-queue dup deque-empty? + [ drop no-runnable-threads ] + [ pop-back dup array? [ first2 ] [ [ f ] dip ] if (next) ] if ; + +: recycler-thread ( -- thread ) 68 special-object ; + +: recycler-queue ( -- vector ) 69 special-object ; + +: delete-context-later ( context -- ) + recycler-queue push recycler-thread interrupt ; PRIVATE> : stop ( -- * ) - self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ; + self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi + context delete-context-later next + die 1 exit ; : suspend ( state -- obj ) - self (>>state) - [ self continuation>> >box next ] callcc1 ; inline + [ self ] dip >>state + [ context ] dip context>> >box + next ; : yield ( -- ) self resume f suspend drop ; @@ -196,22 +222,15 @@ M: integer sleep-until [ self ] dip schedule-sleep "sleep" suspend drop ; M: f sleep-until - drop "interrupt" suspend drop ; + drop "standby" suspend drop ; GENERIC: sleep ( dt -- ) M: real sleep >integer nano-count + sleep-until ; -: interrupt ( thread -- ) - dup state>> [ - dup sleep-entry>> [ sleep-queue heap-delete ] when* - f >>sleep-entry - dup resume - ] when drop ; - : (spawn) ( thread -- ) - [ register-thread ] [ namestack swap resume-with ] bi ; + [ register-thread ] [ [ namestack ] dip resume-with ] bi ; : spawn ( quot name -- thread ) [ (spawn) ] keep ; @@ -228,17 +247,35 @@ GENERIC: error-in-thread ( error thread -- ) 65 set-special-object - 66 set-special-object - initial-thread global - [ drop [ ] "Initial" ] cache - >>continuation + 66 set-special-object ; + +: init-initial-thread ( -- ) + [ ] "Initial" t >>runnable - f >>state - dup register-thread - set-self ; + [ initial-thread set-global ] + [ register-thread ] + [ set-self ] + tri ; + +! The recycler thread deletes contexts belonging to stopped +! threads + +: recycler-loop ( -- ) + recycler-queue [ [ delete-context ] each ] [ delete-all ] bi + f sleep-until + recycler-loop ; + +: init-recycler ( -- ) + [ recycler-loop ] "Context recycler" spawn 68 set-special-object + V{ } clone 69 set-special-object ; + +: init-threads ( -- ) + init-thread-state + init-initial-thread + init-recycler ; PRIVATE> diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor index ea85fb1129..1bb0918b82 100644 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads kernel prettyprint prettyprint.config io io.styles sequences assocs namespaces sorting boxes @@ -7,7 +7,9 @@ IN: tools.threads : thread. ( thread -- ) dup id>> pprint-cell - dup name>> over [ write-object ] with-cell + dup name>> [ + over write-object + ] with-cell dup state>> [ [ dup self eq? "running" "yield" ? ] unless* write diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 53d3bec56e..ffd0c4cd0e 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs calendar combinators locals source-files.errors colors.constants combinators.short-circuit @@ -30,7 +30,7 @@ output history flag mailbox thread waiting token-model word-model popup ; drop ; : interactor-continuation ( interactor -- continuation ) - thread>> continuation>> value>> ; + thread>> thread-continuation ; : interactor-busy? ( interactor -- ? ) #! We're busy if there's no thread to resume. diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 3019de4e21..9d8e50c615 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -62,10 +62,7 @@ IN: ui.tools.operations ! Thread : com-thread-traceback-window ( thread -- ) - continuation>> dup occupied>> - [ value>> traceback-window ] - [ drop beep ] - if ; + thread-continuation traceback-window ; [ thread? ] \ com-thread-traceback-window H{ { +primary+ t } diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 38e1a380ee..87350f290a 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -343,7 +343,7 @@ tuple { "(execute)" "kernel.private" (( word -- )) } { "(call)" "kernel.private" (( quot -- )) } { "unwind-native-frames" "kernel.private" (( -- )) } - { "set-callstack" "kernel.private" (( cs -- * )) } + { "set-callstack" "kernel.private" (( callstack -- * )) } { "lazy-jit-compile" "kernel.private" (( -- )) } { "c-to-factor" "kernel.private" (( -- )) } { "slot" "slots.private" (( obj m -- value )) } @@ -441,23 +441,22 @@ tuple { "fwrite" "io.streams.c" "primitive_fwrite" (( data length alien -- )) } { "(clone)" "kernel" "primitive_clone" (( obj -- newobj )) } { "" "kernel" "primitive_wrapper" (( obj -- wrapper )) } - { "callstack" "kernel" "primitive_callstack" (( -- cs )) } + { "callstack" "kernel" "primitive_callstack" (( -- callstack )) } { "callstack>array" "kernel" "primitive_callstack_to_array" (( callstack -- array )) } - { "datastack" "kernel" "primitive_datastack" (( -- ds )) } + { "datastack" "kernel" "primitive_datastack" (( -- array )) } { "die" "kernel" "primitive_die" (( -- )) } - { "retainstack" "kernel" "primitive_retainstack" (( -- rs )) } + { "retainstack" "kernel" "primitive_retainstack" (( -- array )) } { "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" (( obj -- code )) } { "become" "kernel.private" "primitive_become" (( old new -- )) } - { "call-clear" "kernel.private" "primitive_call_clear" (( quot -- * )) } { "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) } { "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) } { "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) } { "innermost-frame-executing" "kernel.private" "primitive_innermost_stack_frame_executing" (( callstack -- obj )) } { "innermost-frame-scan" "kernel.private" "primitive_innermost_stack_frame_scan" (( callstack -- n )) } { "set-context-object" "kernel.private" "primitive_set_context_object" (( obj n -- )) } - { "set-datastack" "kernel.private" "primitive_set_datastack" (( ds -- )) } + { "set-datastack" "kernel.private" "primitive_set_datastack" (( array -- )) } { "set-innermost-frame-quot" "kernel.private" "primitive_set_innermost_stack_frame_quot" (( n callstack -- )) } - { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( rs -- )) } + { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( array -- )) } { "set-special-object" "kernel.private" "primitive_set_special_object" (( obj n -- )) } { "special-object" "kernel.private" "primitive_special_object" (( n -- obj )) } { "strip-stack-traces" "kernel.private" "primitive_strip_stack_traces" (( -- )) } @@ -536,8 +535,12 @@ tuple { "nano-count" "system" "primitive_nano_count" (( -- ns )) } { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } - { "context" "threads.private" "primitive_context" (( -- c-ptr )) } - { "delete-context" "threads.private" "primitive_delete_context" (( c-ptr -- )) } + { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) } + { "context" "threads.private" "primitive_context" (( -- context )) } + { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) } + { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) } + { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) } + { "delete-context" "threads.private" "primitive_delete_context" (( context -- )) } { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) } { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) } { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8512700852..064978f99b 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -26,28 +26,28 @@ HELP: -rot ( x y z -- z x y ) $complex-shuffle ; HELP: dupd ( x y -- x x y ) $complex-shuffle ; HELP: swapd ( x y z -- y x z ) $complex-shuffle ; -HELP: datastack ( -- ds ) -{ $values { "ds" array } } +HELP: datastack ( -- array ) +{ $values { "array" array } } { $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ; -HELP: set-datastack ( ds -- ) -{ $values { "ds" array } } +HELP: set-datastack ( array -- ) +{ $values { "array" array } } { $description "Replaces the data stack contents with a copy of an array. The end of the array becomes the top of the stack." } ; -HELP: retainstack ( -- rs ) -{ $values { "rs" array } } +HELP: retainstack ( -- array ) +{ $values { "array" array } } { $description "Outputs an array containing a copy of the retain stack contents right before the call to this word, with the top of the stack at the end of the array." } ; -HELP: set-retainstack ( rs -- ) -{ $values { "rs" array } } +HELP: set-retainstack ( array -- ) +{ $values { "array" array } } { $description "Replaces the retain stack contents with a copy of an array. The end of the array becomes the top of the stack." } ; -HELP: callstack ( -- cs ) -{ $values { "cs" callstack } } +HELP: callstack ( -- callstack ) +{ $values { "callstack" callstack } } { $description "Outputs a copy of the call stack contents, with the top of the stack at the end of the vector. The stack frame of the caller word is " { $emphasis "not" } " included." } ; -HELP: set-callstack ( cs -- * ) -{ $values { "cs" callstack } } +HELP: set-callstack ( callstack -- * ) +{ $values { "callstack" callstack } } { $description "Replaces the call stack contents. Control flow is transferred immediately to the innermost frame of the new call stack." } ; HELP: clear @@ -208,11 +208,6 @@ HELP: call { call POSTPONE: call( } related-words -HELP: call-clear ( quot -- * ) -{ $values { "quot" callable } } -{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } -{ $notes "Used to implement " { $link "threads" } "." } ; - HELP: keep { $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 7268d6ab91..ad7528ab84 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -42,7 +42,7 @@ This means that if 'callstack' is called in tail position, we will have popped a necessary frame... however this word is only called by continuation implementation, and user code shouldn't be calling it at all, so we leave it as it is for now. */ -stack_frame *factor_vm::second_from_top_stack_frame() +stack_frame *factor_vm::second_from_top_stack_frame(context *ctx) { stack_frame *frame = ctx->callstack_bottom - 1; while(frame >= ctx->callstack_top @@ -54,16 +54,27 @@ stack_frame *factor_vm::second_from_top_stack_frame() return frame + 1; } -void factor_vm::primitive_callstack() +cell factor_vm::capture_callstack(context *ctx) { - stack_frame *top = second_from_top_stack_frame(); + stack_frame *top = second_from_top_stack_frame(ctx); stack_frame *bottom = ctx->callstack_bottom; fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top); callstack *stack = allot_callstack(size); memcpy(stack->top(),top,size); - ctx->push(tag(stack)); + return tag(stack); +} + +void factor_vm::primitive_callstack() +{ + ctx->push(capture_callstack(ctx)); +} + +void factor_vm::primitive_callstack_for() +{ + context *other_ctx = (context *)pinned_alien_offset(ctx->pop()); + ctx->push(capture_callstack(other_ctx)); } code_block *factor_vm::frame_code(stack_frame *frame) diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 8734ff8486..20dac9f4e5 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -160,31 +160,68 @@ void factor_vm::primitive_set_context_object() ctx->context_objects[n] = value; } -bool factor_vm::stack_to_array(cell bottom, cell top) +void factor_vm::primitive_context_object_for() +{ + context *other_ctx = (context *)pinned_alien_offset(ctx->pop()); + fixnum n = untag_fixnum(ctx->pop()); + ctx->push(other_ctx->context_objects[n]); +} + +cell factor_vm::stack_to_array(cell bottom, cell top) { fixnum depth = (fixnum)(top - bottom + sizeof(cell)); if(depth < 0) - return false; + return false_object; else { array *a = allot_uninitialized_array(depth / sizeof(cell)); memcpy(a + 1,(void*)bottom,depth); - ctx->push(tag(a)); - return true; + return tag(a); } } +cell factor_vm::datastack_to_array(context *ctx) +{ + cell array = stack_to_array(ctx->datastack_seg->start,ctx->datastack); + if(array == false_object) + general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); + else + return array; +} + void factor_vm::primitive_datastack() { - if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack)) - general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); + ctx->push(datastack_to_array(ctx)); +} + +void factor_vm::primitive_datastack_for() +{ + context *other_ctx = (context *)pinned_alien_offset(ctx->pop()); + ctx->push(datastack_to_array(other_ctx)); +} + +cell factor_vm::retainstack_to_array(context *ctx) +{ + cell array = stack_to_array(ctx->retainstack_seg->start,ctx->retainstack); + if(array == false_object) + { + general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object); + return false_object; + } + else + return array; } void factor_vm::primitive_retainstack() { - if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack)) - general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object); + ctx->push(retainstack_to_array(ctx)); +} + +void factor_vm::primitive_retainstack_for() +{ + context *other_ctx = (context *)pinned_alien_offset(ctx->pop()); + ctx->push(retainstack_to_array(other_ctx)); } /* returns pointer to top of stack */ @@ -195,14 +232,24 @@ cell factor_vm::array_to_stack(array *array, cell bottom) return bottom + depth - sizeof(cell); } +void factor_vm::set_datastack(context *ctx, array *array) +{ + ctx->datastack = array_to_stack(array,ctx->datastack_seg->start); +} + void factor_vm::primitive_set_datastack() { - ctx->datastack = array_to_stack(untag_check(ctx->pop()),ctx->datastack_seg->start); + set_datastack(ctx,untag_check(ctx->pop())); +} + +void factor_vm::set_retainstack(context *ctx, array *array) +{ + ctx->retainstack = array_to_stack(array,ctx->retainstack_seg->start); } void factor_vm::primitive_set_retainstack() { - ctx->retainstack = array_to_stack(untag_check(ctx->pop()),ctx->retainstack_seg->start); + set_retainstack(ctx,untag_check(ctx->pop())); } /* Used to implement call( */ diff --git a/vm/errors.cpp b/vm/errors.cpp index f6ceee9966..1867965108 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -120,11 +120,6 @@ void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *stack) general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,stack); } -void factor_vm::primitive_call_clear() -{ - unwind_native_frames(ctx->pop(),ctx->callstack_bottom); -} - /* For testing purposes */ void factor_vm::primitive_unimplemented() { diff --git a/vm/objects.hpp b/vm/objects.hpp index 772863d3f1..4c5dd64632 100644 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -92,7 +92,10 @@ enum special_object { OBJ_RUN_QUEUE = 65, OBJ_SLEEP_QUEUE = 66, - OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */ + OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */ + + OBJ_RECYCLE_THREAD = 68, + OBJ_RECYCLE_QUEUE = 69, }; /* save-image-and-exit discards special objects that are filled in on startup diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 4d72cf1abb..cb5626c894 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -33,9 +33,9 @@ namespace factor _(bits_float) \ _(byte_array) \ _(byte_array_to_bignum) \ - _(call_clear) \ _(callback) \ _(callstack) \ + _(callstack_for) \ _(callstack_to_array) \ _(check_datastack) \ _(clone) \ @@ -45,9 +45,11 @@ namespace factor _(compute_identity_hashcode) \ _(context) \ _(context_object) \ + _(context_object_for) \ _(current_callback) \ _(data_room) \ _(datastack) \ + _(datastack_for) \ _(delete_context) \ _(die) \ _(disable_gc_events) \ @@ -109,6 +111,7 @@ namespace factor _(resize_byte_array) \ _(resize_string) \ _(retainstack) \ + _(retainstack_for) \ _(save_image) \ _(save_image_and_exit) \ _(set_context_object) \ diff --git a/vm/vm.hpp b/vm/vm.hpp index d304543879..973d5f0dda 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -119,12 +119,19 @@ struct factor_vm void end_callback(); void primitive_current_callback(); void primitive_context_object(); + void primitive_context_object_for(); void primitive_set_context_object(); - bool stack_to_array(cell bottom, cell top); - cell array_to_stack(array *array, cell bottom); + cell stack_to_array(cell bottom, cell top); + cell datastack_to_array(context *ctx); void primitive_datastack(); + void primitive_datastack_for(); + cell retainstack_to_array(context *ctx); void primitive_retainstack(); + void primitive_retainstack_for(); + cell array_to_stack(array *array, cell bottom); + void set_datastack(context *ctx, array *array); void primitive_set_datastack(); + void set_retainstack(context *ctx, array *array); void primitive_set_retainstack(); void primitive_check_datastack(); void primitive_load_locals(); @@ -172,7 +179,6 @@ struct factor_vm void signal_error(cell signal, stack_frame *stack); void divide_by_zero_error(); void fp_trap_error(unsigned int fpu_status, stack_frame *stack); - void primitive_call_clear(); void primitive_unimplemented(); void memory_signal_handler_impl(); void misc_signal_handler_impl(); @@ -586,8 +592,10 @@ struct factor_vm void check_frame(stack_frame *frame); callstack *allot_callstack(cell size); stack_frame *fix_callstack_top(stack_frame *top); - stack_frame *second_from_top_stack_frame(); + stack_frame *second_from_top_stack_frame(context *ctx); + cell capture_callstack(context *ctx); void primitive_callstack(); + void primitive_callstack_for(); code_block *frame_code(stack_frame *frame); code_block_type frame_type(stack_frame *frame); cell frame_executing(stack_frame *frame); From c36d85ab47965da60129010182fcc92209eb4e2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Mar 2010 01:10:39 -0400 Subject: [PATCH 070/123] sets, hash-sets, bit-sets: fix some typos in the documentation --- basis/bit-sets/bit-sets-docs.factor | 4 ++-- core/hash-sets/hash-sets-docs.factor | 4 ++-- core/sets/sets-docs.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/bit-sets/bit-sets-docs.factor b/basis/bit-sets/bit-sets-docs.factor index bb4dc75cac..706ffb5cf1 100644 --- a/basis/bit-sets/bit-sets-docs.factor +++ b/basis/bit-sets/bit-sets-docs.factor @@ -3,9 +3,9 @@ IN: bit-sets ARTICLE: "bit-sets" "Bit sets" "The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl -"Bit sets are of the class" +"Bit sets form a class:" { $subsection bit-set } -"They can be instantiated with the word" +"Constructing new bit sets:" { $subsection } ; ABOUT: "bit-sets" diff --git a/core/hash-sets/hash-sets-docs.factor b/core/hash-sets/hash-sets-docs.factor index e771442932..d59ebeca10 100644 --- a/core/hash-sets/hash-sets-docs.factor +++ b/core/hash-sets/hash-sets-docs.factor @@ -2,9 +2,9 @@ USING: help.markup help.syntax sequences ; IN: hash-sets ARTICLE: "hash-sets" "Hash sets" -"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-backed sets. These are of the class:" +"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-backed sets. Hash sets form a class:" { $subsection hash-set } -"They can be instantiated with the word" +"Constructing new hash sets:" { $subsection } "The syntax for hash sets is described in " { $link "syntax-hash-sets" } "." ; diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 75df4069dc..5bde8a1feb 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -61,9 +61,9 @@ ARTICLE: "set-implementations" "Set implementations" ARTICLE: "sequence-sets" "Sequences as sets" "Any sequence can be used as a set. The members of this set are the elements of the sequence. Calling the word " { $link members } " on a sequence returns a copy of the sequence with only one listing of each member. Destructive operations " { $link adjoin } " and " { $link delete } " only work properly on growable sequences like " { $link vector } "s." $nl -"Care must be taken in writing efficient code using sequence sets. Testing for membership with " { $link in? } ", as well as the destructive set operations, take time proportional to the size of the sequence. Another representation, like " { $link "hash-sets" } ", would take constant time for membership tests. But binary operations like " { $link union } "are asymptotically optimal, taking time proportional to the sum of the size of the inputs." +"Care must be taken in writing efficient code using sequence sets. Testing for membership with " { $link in? } ", as well as the destructive set operations, take time proportional to the size of the sequence. Another representation, like " { $link "hash-sets" } ", would take constant time for membership tests. But binary operations like " { $link union } " are asymptotically optimal, taking time proportional to the sum of the size of the inputs." $nl -"As one particlar example, " { $link POSTPONE: f } " is a representation of the empty set, as it represents the empty sequence." ; +"As one particular example, " { $link POSTPONE: f } " is a representation of the empty set, since it is an empty sequence." ; HELP: set { $class-description "The class of all sets. Custom implementations of the set protocol should be declared as instances of this mixin for all set implementation to work correctly." } ; From 000c21fc665a0fa096297d637e419516965f8373 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Mar 2010 01:17:39 -0400 Subject: [PATCH 071/123] concurrency.distributed: fix for removal of 'thread' word --- basis/concurrency/distributed/distributed.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index 0015b10cef..229cea8548 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -20,7 +20,7 @@ PRIVATE> registered-remote-threads delete-at ; : get-remote-thread ( name -- thread ) - dup registered-remote-threads at [ ] [ thread ] ?if ; + dup registered-remote-threads at [ ] [ threads at ] ?if ; SYMBOL: local-node From 26c4aec91a192aa73f9b5f56b50ca1645a9ccccb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Mar 2010 15:35:36 -0400 Subject: [PATCH 072/123] validators: fix v-default (reported by Niklas Waern) --- basis/validators/validators-tests.factor | 19 +++++++++++-------- basis/validators/validators.factor | 4 ++-- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/basis/validators/validators-tests.factor b/basis/validators/validators-tests.factor index acdcdda5d2..6b5936977f 100644 --- a/basis/validators/validators-tests.factor +++ b/basis/validators/validators-tests.factor @@ -2,17 +2,12 @@ IN: validators.tests USING: kernel sequences tools.test validators accessors namespaces assocs ; -[ "" v-one-line ] must-fail -[ "hello world" ] [ "hello world" v-one-line ] unit-test -[ "hello\nworld" v-one-line ] must-fail - -[ "" v-one-word ] must-fail -[ "hello" ] [ "hello" v-one-word ] unit-test -[ "hello world" v-one-word ] must-fail - [ t ] [ "on" v-checkbox ] unit-test [ f ] [ "off" v-checkbox ] unit-test +[ "default test" ] [ "" "default test" v-default ] unit-test +[ "blah" ] [ "blah" "default test" v-default ] unit-test + [ "foo" v-number ] must-fail [ 123 ] [ "123" v-number ] unit-test [ 123 ] [ "123" v-integer ] unit-test @@ -42,6 +37,14 @@ namespaces assocs ; [ "http:/www.factorcode.org" v-url ] [ "invalid URL" = ] must-fail-with +[ "" v-one-line ] must-fail +[ "hello world" ] [ "hello world" v-one-line ] unit-test +[ "hello\nworld" v-one-line ] must-fail + +[ "" v-one-word ] must-fail +[ "hello" ] [ "hello" v-one-word ] unit-test +[ "hello world" v-one-word ] must-fail + [ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test [ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index cf45e7b13f..45287a60c6 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2008 Slava Pestov +! Copyright (C) 2006, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces make sets math.parser math.ranges assocs regexp unicode.categories arrays @@ -9,7 +9,7 @@ IN: validators >lower "on" = ; : v-default ( str def -- str/def ) - [ nip empty? ] 2keep ? ; + [ drop empty? not ] 2keep ? ; : v-required ( str -- str ) dup empty? [ "required" throw ] when ; From 2b68f56c89667a62c0b49487ee6f54efc6be38ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Mar 2010 17:31:41 -0400 Subject: [PATCH 073/123] Document (free), move it out of libc.private and mention it in the "c-strings" help article (reported by Blei) --- basis/alien/data/data-docs.factor | 6 ++++-- basis/cocoa/messages/messages.factor | 3 +-- basis/libc/libc-docs.factor | 4 ++++ basis/libc/libc.factor | 6 +++--- 4 files changed, 12 insertions(+), 7 deletions(-) diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 4600ea6837..d36a4d5fd2 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -60,6 +60,8 @@ $nl } "You must always free pointers returned by any of the above words when the block of memory is no longer in use:" { $subsections free } +"The above words record memory allocations, to help catch double frees and track down memory leaks with " { $link "tools.destructors" } ". To free memory allocated by a C library, another word can be used:" +{ $subsections (free) } "Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":" { $subsections &free @@ -148,9 +150,9 @@ $nl } "The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." $nl -"The C type " { $link char } { $snippet "*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion." +"The C type " { $snippet "char*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion." $nl "A word to read strings from arbitrary addresses:" { $subsections alien>string } -"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call one of the above words before passing the pointer to " { $link free } "." ; +"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ; diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index a744087037..c422d85423 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,8 +5,7 @@ classes.struct continuations combinators compiler compiler.alien core-graphics.types stack-checker kernel math namespaces make quotations sequences strings words cocoa.runtime cocoa.types io macros memoize io.encodings.utf8 effects layouts libc -libc.private lexer init core-foundation fry generalizations -specialized-arrays ; +lexer init core-foundation fry generalizations specialized-arrays ; QUALIFIED-WITH: alien.c-types c IN: cocoa.messages diff --git a/basis/libc/libc-docs.factor b/basis/libc/libc-docs.factor index b89f4174bf..74e96b08d3 100644 --- a/basis/libc/libc-docs.factor +++ b/basis/libc/libc-docs.factor @@ -32,6 +32,10 @@ HELP: free { $values { "alien" c-ptr } } { $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ; +HELP: (free) +{ $values { "alien" c-ptr } } +{ $description "Deallocates a block of memory allocated by an external C library." } ; + HELP: &free { $values { "alien" c-ptr } } { $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ; diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 5f6a808b2e..4a887e695f 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -1,5 +1,5 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight -! Copyright (C) 2007, 2009 Slava Pestov +! Copyright (C) 2007, 2010 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types assocs continuations alien.destructors kernel @@ -18,8 +18,6 @@ IN: libc : preserve-errno ( quot -- ) errno [ call ] dip set-errno ; inline - Date: Tue, 30 Mar 2010 17:33:08 -0400 Subject: [PATCH 074/123] models.product: fix example (reported by Muzzleflash) --- basis/models/product/product-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/models/product/product-docs.factor b/basis/models/product/product-docs.factor index b4288891e0..29b26159a7 100644 --- a/basis/models/product/product-docs.factor +++ b/basis/models/product/product-docs.factor @@ -13,7 +13,7 @@ $nl "ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes" "ui.gadgets.sliders ;" "" - ": ( -- model ) 0 10 0 100 ;" + ": ( -- model ) 0 10 0 100 1 ;" ": ( model -- slider ) horizontal ;" "" " 2array" From fb2ecab614c0cd604864962b924991998eab7667 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Mar 2010 21:47:48 -0400 Subject: [PATCH 075/123] threads: delete old contexts immediately instead of handing them off to a 'context recycler' thread --- basis/cpu/x86/32/bootstrap.factor | 81 ++++++++++------ basis/cpu/x86/64/bootstrap.factor | 90 +++++++++++------- basis/stack-checker/backend/backend.factor | 7 -- .../known-words/known-words.factor | 95 ++++++++----------- basis/threads/threads.factor | 84 ++++++---------- basis/tools/deploy/shaker/shaker.factor | 1 - core/bootstrap/primitives.factor | 7 +- core/system/system.factor | 4 +- vm/contexts.cpp | 14 +-- vm/contexts.hpp | 1 + vm/objects.hpp | 3 - vm/primitives.hpp | 1 - vm/vm.hpp | 1 - 13 files changed, 195 insertions(+), 194 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index dde800760e..5b3bff1fc6 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -72,6 +72,12 @@ IN: bootstrap.x86 jit-restore-context ] jit-primitive jit-define +: jit-jump-quot ( -- ) + EAX quot-entry-point-offset [+] JMP ; + +: jit-call-quot ( -- ) + EAX quot-entry-point-offset [+] CALL ; + [ jit-load-vm ESP [] vm-reg MOV @@ -92,8 +98,7 @@ IN: bootstrap.x86 ESP ctx-reg context-callstack-bottom-offset [+] MOV ESP 4 ADD - ! call the quotation - EAX quot-entry-point-offset [+] CALL + jit-call-quot jit-load-vm jit-save-context @@ -109,8 +114,8 @@ IN: bootstrap.x86 EAX ds-reg [] MOV ds-reg bootstrap-cell SUB ] -[ EAX quot-entry-point-offset [+] CALL ] -[ EAX quot-entry-point-offset [+] JMP ] +[ jit-call-quot ] +[ jit-jump-quot ] \ (call) define-combinator-primitive [ @@ -133,8 +138,7 @@ IN: bootstrap.x86 jit-load-context jit-restore-context - ! Call quotation - EAX quot-entry-point-offset [+] JMP + jit-jump-quot ] \ unwind-native-frames define-sub-primitive [ @@ -175,8 +179,8 @@ IN: bootstrap.x86 ! Call VM "lazy_jit_compile" jit-call ] -[ EAX quot-entry-point-offset [+] CALL ] -[ EAX quot-entry-point-offset [+] JMP ] +[ jit-call-quot ] +[ jit-jump-quot ] \ lazy-jit-compile define-combinator-primitive ! Inline cache miss entry points @@ -247,8 +251,8 @@ IN: bootstrap.x86 jit-conditional ] \ fixnum* define-sub-primitive -! Threads -: jit-set-context ( reg -- ) +! Contexts +: jit-switch-context ( reg -- ) ! Save ds, rs registers jit-load-vm jit-save-context @@ -263,7 +267,26 @@ IN: bootstrap.x86 ! Load new ds, rs registers jit-restore-context ; -[ +: jit-set-context ( -- ) + ! Load context and parameter from datastack + EAX ds-reg [] MOV + EAX EAX alien-offset [+] MOV + EBX ds-reg -4 [+] MOV + ds-reg 8 SUB + + ! Make the new context active + EAX jit-switch-context + + ! Twiddle stack for return + ESP 4 ADD + + ! Store parameter to datastack + ds-reg 4 ADD + ds-reg [] EBX MOV ; + +[ jit-set-context ] \ (set-context) define-sub-primitive + +: jit-start-context ( -- ) ! Create the new context in return-reg jit-load-vm ESP [] vm-reg MOV @@ -274,7 +297,7 @@ IN: bootstrap.x86 ds-reg 8 SUB ! Make the new context active - EAX jit-set-context + EAX jit-switch-context ! Push parameter EAX EBX -4 [+] MOV @@ -283,26 +306,26 @@ IN: bootstrap.x86 ! Jump to initial quotation EAX EBX [] MOV - EAX quot-entry-point-offset [+] JMP -] \ (start-context) define-sub-primitive + jit-jump-quot ; + +[ jit-start-context ] \ (start-context) define-sub-primitive + +: jit-delete-current-context ( -- ) + jit-load-vm + jit-load-context + ESP [] vm-reg MOV + ESP 4 [+] ctx-reg MOV + "delete_context" jit-call ; [ - ! Load context and parameter from datastack - EAX ds-reg [] MOV - EAX EAX alien-offset [+] MOV - EBX ds-reg -4 [+] MOV - ds-reg 8 SUB + jit-delete-current-context + jit-set-context +] \ (set-context-and-delete) define-sub-primitive - ! Make the new context active - EAX jit-set-context - - ! Twiddle stack for return - ESP 4 ADD - - ! Store parameter to datastack - ds-reg 4 ADD - ds-reg [] EBX MOV -] \ (set-context) define-sub-primitive +[ + jit-delete-current-context + jit-start-context +] \ (start-context-and-delete) define-sub-primitive << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 9eb59e2c86..b068c60352 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -70,6 +70,10 @@ IN: bootstrap.x86 jit-restore-context ] jit-primitive jit-define +: jit-jump-quot ( -- ) arg1 quot-entry-point-offset [+] JMP ; + +: jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ; + [ nv-reg arg1 MOV @@ -87,7 +91,7 @@ IN: bootstrap.x86 ! call the quotation arg1 nv-reg MOV - arg1 quot-entry-point-offset [+] CALL + jit-call-quot jit-save-context @@ -102,8 +106,8 @@ IN: bootstrap.x86 arg1 ds-reg [] MOV ds-reg bootstrap-cell SUB ] -[ arg1 quot-entry-point-offset [+] CALL ] -[ arg1 quot-entry-point-offset [+] JMP ] +[ jit-call-quot ] +[ jit-jump-quot ] \ (call) define-combinator-primitive [ @@ -124,7 +128,7 @@ IN: bootstrap.x86 jit-restore-context ! Call quotation - arg1 quot-entry-point-offset [+] JMP + jit-jump-quot ] \ unwind-native-frames define-sub-primitive [ @@ -157,9 +161,10 @@ IN: bootstrap.x86 jit-save-context arg2 vm-reg MOV "lazy_jit_compile" jit-call + arg1 return-reg MOV ] [ return-reg quot-entry-point-offset [+] CALL ] -[ return-reg quot-entry-point-offset [+] JMP ] +[ jit-jump-quot ] \ lazy-jit-compile define-combinator-primitive ! Inline cache miss entry points @@ -222,8 +227,8 @@ IN: bootstrap.x86 jit-conditional ] \ fixnum* define-sub-primitive -! Threads -: jit-set-context ( reg -- ) +! Contexts +: jit-switch-context ( reg -- ) ! Save ds, rs registers jit-save-context @@ -237,44 +242,59 @@ IN: bootstrap.x86 ! Load new ds, rs registers jit-restore-context ; -[ +: jit-pop-context-and-param ( -- ) + arg1 ds-reg [] MOV + arg1 arg1 alien-offset [+] MOV + arg2 ds-reg -8 [+] MOV + ds-reg 16 SUB ; + +: jit-push-param ( -- ) + ds-reg 8 ADD + ds-reg [] arg2 MOV ; + +: jit-set-context ( -- ) + jit-pop-context-and-param + arg1 jit-switch-context + RSP 8 ADD + jit-push-param ; + +[ jit-set-context ] \ (set-context) define-sub-primitive + +: jit-pop-quot-and-param ( -- ) + arg1 ds-reg [] MOV + arg2 ds-reg -8 [+] MOV + ds-reg 16 SUB ; + +: jit-start-context ( -- ) ! Create the new context in return-reg arg1 vm-reg MOV "new_context" jit-call - ! Load quotation and parameter from datastack - arg1 ds-reg [] MOV - arg2 ds-reg -8 [+] MOV - ds-reg 16 SUB + jit-pop-quot-and-param - ! Make the new context active - return-reg jit-set-context + return-reg jit-switch-context - ! Push parameter - ds-reg 8 ADD - ds-reg [] arg2 MOV + jit-push-param - ! Jump to initial quotation - arg1 quot-entry-point-offset [+] JMP -] \ (start-context) define-sub-primitive + jit-jump-quot ; + +[ jit-start-context ] \ (start-context) define-sub-primitive + +: jit-delete-current-context ( -- ) + jit-load-context + arg1 vm-reg MOV + arg2 ctx-reg MOV + "delete_context" jit-call ; [ - ! Load context and parameter from datastack - temp0 ds-reg [] MOV - temp0 temp0 alien-offset [+] MOV - temp1 ds-reg -8 [+] MOV - ds-reg 16 SUB + jit-delete-current-context + jit-set-context +] \ (set-context-and-delete) define-sub-primitive - ! Make the new context active - temp0 jit-set-context - - ! Twiddle stack for return - RSP 8 ADD - - ! Store parameter to datastack - ds-reg 8 ADD - ds-reg [] temp1 MOV -] \ (set-context) define-sub-primitive +[ + jit-delete-current-context + jit-start-context +] \ (start-context-and-delete) define-sub-primitive << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 51b5f0cdaf..7a18133eff 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -151,13 +151,6 @@ M: bad-call summary : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: infer-word ( word -- ) - { - { [ dup macro? ] [ do-not-compile ] } - { [ dup "no-compile" word-prop ] [ do-not-compile ] } - [ dup required-stack-effect apply-word/effect ] - } cond ; - : with-infer ( quot -- effect visitor ) [ init-inference diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index b0a751b172..f6c7cf5859 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -14,7 +14,7 @@ compiler.units system.private combinators combinators.short-circuit locals locals.backend locals.types combinators.private stack-checker.values generic.single generic.single.private alien.libraries tools.dispatch.private -tools.profiler.private +tools.profiler.private macros stack-checker.alien stack-checker.state stack-checker.errors @@ -27,11 +27,41 @@ stack-checker.recursive-state stack-checker.row-polymorphism ; IN: stack-checker.known-words -: infer-primitive ( word -- ) - dup - [ "input-classes" word-prop ] - [ "default-output-classes" word-prop ] bi - apply-word/effect ; +: infer-special ( word -- ) + [ current-word set ] [ "special" word-prop call( -- ) ] bi ; + +: infer-shuffle ( shuffle -- ) + [ in>> length consume-d ] keep ! inputs shuffle + [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies + [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping + #shuffle, ; + +: infer-shuffle-word ( word -- ) + "shuffle" word-prop infer-shuffle ; + +: infer-local-reader ( word -- ) + (( -- value )) apply-word/effect ; + +: infer-local-writer ( word -- ) + (( value -- )) apply-word/effect ; + +: infer-local-word ( word -- ) + "local-word-def" word-prop infer-quot-here ; + +: non-inline-word ( word -- ) + dup depends-on-effect + { + { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } + { [ dup "special" word-prop ] [ infer-special ] } + { [ dup "transform-quot" word-prop ] [ apply-transform ] } + { [ dup macro? ] [ apply-macro ] } + { [ dup local? ] [ infer-local-reader ] } + { [ dup local-reader? ] [ infer-local-reader ] } + { [ dup local-writer? ] [ infer-local-writer ] } + { [ dup local-word? ] [ infer-local-word ] } + { [ dup "no-compile" word-prop ] [ do-not-compile ] } + [ dup required-stack-effect apply-word/effect ] + } cond ; { { drop (( x -- )) } @@ -51,15 +81,6 @@ IN: stack-checker.known-words { swap (( x y -- y x )) } } [ "shuffle" set-word-prop ] assoc-each -: infer-shuffle ( shuffle -- ) - [ in>> length consume-d ] keep ! inputs shuffle - [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies - [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping - #shuffle, ; - -: infer-shuffle-word ( word -- ) - "shuffle" word-prop infer-shuffle ; - : check-declaration ( declaration -- declaration ) dup { [ array? ] [ [ class? ] all? ] } 1&& [ bad-declaration-error ] unless ; @@ -180,11 +201,6 @@ M: bad-executable summary \ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop -: infer-exit ( -- ) - \ exit (( n -- * )) apply-word/effect ; - -\ exit [ infer-exit ] "special" set-word-prop - : infer-load-locals ( -- ) pop-literal nip consume-d dup copy-values dup output-r @@ -249,22 +265,10 @@ M: bad-executable summary c-to-factor } [ dup '[ _ do-not-compile ] "special" set-word-prop ] each -: infer-special ( word -- ) - [ current-word set ] [ "special" word-prop call( -- ) ] bi ; - -: infer-local-reader ( word -- ) - (( -- value )) apply-word/effect ; - -: infer-local-writer ( word -- ) - (( value -- )) apply-word/effect ; - -: infer-local-word ( word -- ) - "local-word-def" word-prop infer-quot-here ; - { declare call (call) dip 2dip 3dip curry compose execute (execute) call-effect-unsafe execute-effect-unsafe if - dispatch exit load-local load-locals get-local + dispatch load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect alien-callback } [ t "no-compile" set-word-prop ] each @@ -276,26 +280,10 @@ M: bad-executable summary ! More words not to compile \ clear t "no-compile" set-word-prop -: non-inline-word ( word -- ) - dup depends-on-effect - { - { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } - { [ dup "special" word-prop ] [ infer-special ] } - { [ dup "primitive" word-prop ] [ infer-primitive ] } - { [ dup "transform-quot" word-prop ] [ apply-transform ] } - { [ dup "macro" word-prop ] [ apply-macro ] } - { [ dup local? ] [ infer-local-reader ] } - { [ dup local-reader? ] [ infer-local-reader ] } - { [ dup local-writer? ] [ infer-local-writer ] } - { [ dup local-word? ] [ infer-local-word ] } - [ infer-word ] - } cond ; - : define-primitive ( word inputs outputs -- ) - [ 2drop t "primitive" set-word-prop ] - [ drop "input-classes" set-word-prop ] - [ nip "default-output-classes" set-word-prop ] - 3tri ; + [ "input-classes" set-word-prop ] + [ "default-output-classes" set-word-prop ] + bi-curry* bi ; ! Stack effects for all primitives \ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable @@ -311,8 +299,10 @@ M: bad-executable summary \ (save-image) { byte-array byte-array } { } define-primitive \ (save-image-and-exit) { byte-array byte-array } { } define-primitive \ (set-context) { object alien } { object } define-primitive +\ (set-context-and-delete) { object alien } { } define-primitive \ (sleep) { integer } { } define-primitive \ (start-context) { object quotation } { object } define-primitive +\ (start-context-and-delete) { object quotation } { } define-primitive \ (word) { object object object } { word } define-primitive \ (word) make-flushable \ { integer object } { array } define-primitive \ make-flushable \ { integer } { byte-array } define-primitive \ make-flushable @@ -376,7 +366,6 @@ M: bad-executable summary \ data-room { } { byte-array } define-primitive \ data-room make-flushable \ datastack { } { array } define-primitive \ datastack make-flushable \ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable -\ delete-context { c-ptr } { } define-primitive \ die { } { } define-primitive \ disable-gc-events { } { object } define-primitive \ dispatch-stats { } { byte-array } define-primitive diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index bd30ef4b90..117e941aa7 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -9,13 +9,21 @@ IN: threads > call stop - ] start-context ; + ] -DEFER: next - -: no-runnable-threads ( -- obj ) - ! We should never be in a state where the only threads - ! are sleeping; the I/O wait thread is always runnable. - ! However, if it dies, we handle this case - ! semi-gracefully. - ! - ! And if sleep-time outputs f, there are no sleeping - ! threads either... so WTF. - sleep-time { - { [ dup not ] [ drop die ] } - { [ dup 0 = ] [ drop ] } - [ (sleep) ] - } cond next ; +: no-runnable-threads ( -- ) die ; : (next) ( obj thread -- obj' ) - f >>state - dup set-self dup runnable>> - [ context>> box> set-context ] [ t >>runnable drop start ] if ; + [ context>> box> set-context ] + [ t >>runnable drop [start] start-context ] if ; -: next ( -- obj ) +: (stop) ( obj thread -- * ) + dup runnable>> + [ context>> box> set-context-and-delete ] + [ t >>runnable drop [start] start-context-and-delete ] if ; + +: next ( -- obj thread ) expire-sleep-loop - run-queue dup deque-empty? - [ drop no-runnable-threads ] - [ pop-back dup array? [ first2 ] [ [ f ] dip ] if (next) ] if ; - -: recycler-thread ( -- thread ) 68 special-object ; - -: recycler-queue ( -- vector ) 69 special-object ; - -: delete-context-later ( context -- ) - recycler-queue push recycler-thread interrupt ; + run-queue pop-back + dup array? [ first2 ] [ [ f ] dip ] if + f >>state + dup set-self ; PRIVATE> : stop ( -- * ) self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi - context delete-context-later next - die 1 exit ; + next (stop) ; : suspend ( state -- obj ) [ self ] dip >>state [ context ] dip context>> >box - next ; + next (next) ; : yield ( -- ) self resume f suspend drop ; @@ -260,22 +251,9 @@ GENERIC: error-in-thread ( error thread -- ) [ set-self ] tri ; -! The recycler thread deletes contexts belonging to stopped -! threads - -: recycler-loop ( -- ) - recycler-queue [ [ delete-context ] each ] [ delete-all ] bi - f sleep-until - recycler-loop ; - -: init-recycler ( -- ) - [ recycler-loop ] "Context recycler" spawn 68 set-special-object - V{ } clone 69 set-special-object ; - : init-threads ( -- ) init-thread-state - init-initial-thread - init-recycler ; + init-initial-thread ; PRIVATE> diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 6fb6ab91ec..e7eea1179a 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -175,7 +175,6 @@ IN: tools.deploy.shaker "predicate" "predicate-definition" "predicating" - "primitive" "reader" "reading" "recursive" diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 87350f290a..52ee1e14b4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -370,7 +370,9 @@ tuple { "fixnum>" "math.private" (( x y -- ? )) } { "fixnum>=" "math.private" (( x y -- ? )) } { "(set-context)" "threads.private" (( obj context -- obj' )) } + { "(set-context-and-delete)" "threads.private" (( obj context -- * )) } { "(start-context)" "threads.private" (( obj quot -- obj' )) } + { "(start-context-and-delete)" "threads.private" (( obj quot -- * )) } } [ first3 make-sub-primitive ] each ! Primitive words @@ -531,7 +533,7 @@ tuple { "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) } { "set-string-nth-slow" "strings.private" "primitive_set_string_nth_slow" (( ch n string -- )) } { "string-nth" "strings.private" "primitive_string_nth" (( n string -- ch )) } - { "(exit)" "system" "primitive_exit" (( n -- )) } + { "(exit)" "system" "primitive_exit" (( n -- * )) } { "nano-count" "system" "primitive_nano_count" (( -- ns )) } { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } @@ -540,13 +542,12 @@ tuple { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) } { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) } { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) } - { "delete-context" "threads.private" "primitive_delete_context" (( context -- )) } { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) } { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) } { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) } { "optimized?" "words" "primitive_optimized_p" (( word -- ? )) } { "word-code" "words" "primitive_word_code" (( word -- start end )) } - { "(word)" "words.private" "primitive_word" (( name vocab -- word )) } + { "(word)" "words.private" "primitive_word" (( name vocab hashcode -- word )) } } [ first4 make-primitive ] each ! Bump build number diff --git a/core/system/system.factor b/core/system/system.factor index 765861c62f..ecd5047fba 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences math namespaces init splitting assocs system.private layouts words ; @@ -57,4 +57,4 @@ PRIVATE> : embedded? ( -- ? ) 15 special-object ; -: exit ( n -- ) do-shutdown-hooks (exit) ; +: exit ( n -- * ) do-shutdown-hooks (exit) ; diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 20dac9f4e5..9364f2e362 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -119,6 +119,11 @@ void factor_vm::delete_context(context *old_context) active_contexts.erase(old_context); } +VM_C_API void delete_context(factor_vm *parent, context *old_context) +{ + parent->delete_context(old_context); +} + void factor_vm::begin_callback() { ctx->reset(); @@ -185,7 +190,10 @@ cell factor_vm::datastack_to_array(context *ctx) { cell array = stack_to_array(ctx->datastack_seg->start,ctx->datastack); if(array == false_object) + { general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); + return false_object; + } else return array; } @@ -293,10 +301,4 @@ void factor_vm::primitive_context() ctx->push(allot_alien(ctx)); } -void factor_vm::primitive_delete_context() -{ - context *old_context = (context *)pinned_alien_offset(ctx->pop()); - delete_context(old_context); -} - } diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 441b5916c8..f3aba0e5a6 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -70,6 +70,7 @@ struct context { }; VM_C_API context *new_context(factor_vm *parent); +VM_C_API void delete_context(factor_vm *parent, context *old_context); VM_C_API void begin_callback(factor_vm *parent); VM_C_API void end_callback(factor_vm *parent); diff --git a/vm/objects.hpp b/vm/objects.hpp index 4c5dd64632..778df8642e 100644 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -93,9 +93,6 @@ enum special_object { OBJ_SLEEP_QUEUE = 66, OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */ - - OBJ_RECYCLE_THREAD = 68, - OBJ_RECYCLE_QUEUE = 69, }; /* save-image-and-exit discards special objects that are filled in on startup diff --git a/vm/primitives.hpp b/vm/primitives.hpp index cb5626c894..7e95a3bad5 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -50,7 +50,6 @@ namespace factor _(data_room) \ _(datastack) \ _(datastack_for) \ - _(delete_context) \ _(die) \ _(disable_gc_events) \ _(dispatch_stats) \ diff --git a/vm/vm.hpp b/vm/vm.hpp index 973d5f0dda..ad74a8e090 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -136,7 +136,6 @@ struct factor_vm void primitive_check_datastack(); void primitive_load_locals(); void primitive_context(); - void primitive_delete_context(); template void iterate_active_callstacks(Iterator &iter) { From 1b271f820261fce0e0fb6e4f6c59e95c59a83ef8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Mar 2010 21:56:51 -0400 Subject: [PATCH 076/123] locals: remove some dead code --- basis/locals/errors/errors.factor | 5 ----- basis/locals/parser/parser.factor | 4 ---- basis/locals/rewrite/point-free/point-free.factor | 2 -- basis/locals/rewrite/sugar/sugar.factor | 3 --- basis/locals/types/types.factor | 9 ++------- basis/stack-checker/known-words/known-words.factor | 4 ---- 6 files changed, 2 insertions(+), 25 deletions(-) diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor index 468671361f..d8a53b3c4e 100644 --- a/basis/locals/errors/errors.factor +++ b/basis/locals/errors/errors.factor @@ -19,11 +19,6 @@ ERROR: local-writer-in-literal-error ; M: local-writer-in-literal-error summary drop "Local writer words not permitted inside literals" ; -ERROR: local-word-in-literal-error ; - -M: local-word-in-literal-error summary - drop "Local words not permitted inside literals" ; - ERROR: :>-outside-lambda-error ; M: :>-outside-lambda-error summary diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index e742b4768a..01be7bcd20 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -24,10 +24,6 @@ SYMBOL: in-lambda? : parse-local-defs ( -- words assoc ) [ "|" [ make-local ] map-tokens ] H{ } make-assoc ; -: make-local-word ( name def -- word ) - [ [ dup name>> set ] [ ] [ ] tri ] dip - "local-word-def" set-word-prop ; - SINGLETON: lambda-parser SYMBOL: locals diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor index 4e91e3d87b..0b010a5591 100644 --- a/basis/locals/rewrite/point-free/point-free.factor +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -21,8 +21,6 @@ M: local localize dupd read-local-quot ; M: quote localize dupd local>> read-local-quot ; -M: local-word localize dupd read-local-quot [ call ] append ; - M: local-reader localize dupd read-local-quot [ local-value ] append ; M: local-writer localize diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index a8a12d2614..9dfc733fff 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -82,9 +82,6 @@ M: local-reader rewrite-element , ; M: local-writer rewrite-element local-writer-in-literal-error ; -M: local-word rewrite-element - local-word-in-literal-error ; - M: word rewrite-element , ; : rewrite-wrapper ( wrapper -- ) diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor index 424ef68243..a930765b7c 100644 --- a/basis/locals/types/types.factor +++ b/basis/locals/types/types.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2010 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators kernel sequences words quotations ; @@ -35,11 +35,6 @@ PREDICATE: local < word "local?" word-prop ; M: local literalize ; -PREDICATE: local-word < word "local-word?" word-prop ; - -: ( name -- word ) - f dup t "local-word?" set-word-prop ; - PREDICATE: local-reader < word "local-reader?" word-prop ; : ( name -- word ) @@ -58,5 +53,5 @@ PREDICATE: local-writer < word "local-writer?" word-prop ; [ nip ] } 2cleave ; -UNION: lexical local local-reader local-writer local-word ; +UNION: lexical local local-reader local-writer ; UNION: special lexical quote def ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index f6c7cf5859..01f3ff77c0 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -45,9 +45,6 @@ IN: stack-checker.known-words : infer-local-writer ( word -- ) (( value -- )) apply-word/effect ; -: infer-local-word ( word -- ) - "local-word-def" word-prop infer-quot-here ; - : non-inline-word ( word -- ) dup depends-on-effect { @@ -58,7 +55,6 @@ IN: stack-checker.known-words { [ dup local? ] [ infer-local-reader ] } { [ dup local-reader? ] [ infer-local-reader ] } { [ dup local-writer? ] [ infer-local-writer ] } - { [ dup local-word? ] [ infer-local-word ] } { [ dup "no-compile" word-prop ] [ do-not-compile ] } [ dup required-stack-effect apply-word/effect ] } cond ; From 587664efbfc5b90004765c0b61f766fdc241eae1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 31 Mar 2010 10:27:24 -0400 Subject: [PATCH 077/123] tools.deploy.shaker: don't strip out io-thread, since new thread implementation requires at least one thread to be runnable at any time --- basis/tools/deploy/shaker/shaker.factor | 7 ------- 1 file changed, 7 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e7eea1179a..21f28d6ae2 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -42,12 +42,8 @@ IN: tools.deploy.shaker deploy-threads? get [ "threads" startup-hooks get delete-at ] unless - native-io? [ - "io.thread" startup-hooks get delete-at - ] unless strip-io? [ "io.backend" startup-hooks get delete-at - "io.thread" startup-hooks get delete-at ] when strip-dictionary? [ { @@ -402,9 +398,6 @@ IN: tools.deploy.shaker [ c-io-backend forget "io.streams.c" forget-vocab - "io-thread-running?" "io.thread" lookup [ - global delete-at - ] when* ] with-compilation-unit ] when ; From ce42aea6a4594e5ee74e7674d74ef26f5eb0ed56 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 31 Mar 2010 13:29:44 -0400 Subject: [PATCH 078/123] tools.deploy.shaker: make sure an io-multiplex method remains even if C streams are stripped out --- basis/tools/deploy/shaker/shaker.factor | 10 ++++++---- basis/tools/deploy/shaker/strip-c-io.factor | 10 ++++++++++ 2 files changed, 16 insertions(+), 4 deletions(-) create mode 100644 basis/tools/deploy/shaker/strip-c-io.factor diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 21f28d6ae2..a2a2dbbc86 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -392,13 +392,15 @@ IN: tools.deploy.shaker ] [ drop ] if ; : strip-c-io ( -- ) + ! On all platforms, if deploy-io is 1, we strip out C streams. + ! On Unix, if deploy-io is 3, we strip out C streams as well. + ! On Windows, even if deploy-io is 3, C streams are still used + ! for the console, so don't strip it there. strip-io? deploy-io get 3 = os windows? not and or [ - [ - c-io-backend forget - "io.streams.c" forget-vocab - ] with-compilation-unit + "Stripping C I/O" show + "vocab:tools/deploy/shaker/strip-c-io.factor" run-file ] when ; : compress ( pred post-process string -- ) diff --git a/basis/tools/deploy/shaker/strip-c-io.factor b/basis/tools/deploy/shaker/strip-c-io.factor new file mode 100644 index 0000000000..44c63c509c --- /dev/null +++ b/basis/tools/deploy/shaker/strip-c-io.factor @@ -0,0 +1,10 @@ +USING: compiler.units definitions io.backend io.streams.c kernel +math threads.private vocabs ; + +[ + c-io-backend forget + "io.streams.c" forget-vocab +] with-compilation-unit + +M: object io-multiplex + dup 0 = [ drop ] [ 60 60 * 1000 * 1000 * or (sleep) ] if ; From 8f0487f1c3de9729cff98d181693efe3d3130dee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 31 Mar 2010 15:19:00 -0400 Subject: [PATCH 079/123] cpu.x86: remove useless crap from c-to-factor sub-primitive --- basis/cpu/x86/32/bootstrap.factor | 10 ---------- basis/cpu/x86/64/bootstrap.factor | 10 ---------- 2 files changed, 20 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 5b3bff1fc6..15a7dc1c29 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -91,21 +91,11 @@ IN: bootstrap.x86 jit-load-context jit-restore-context - ! save C callstack pointer - ctx-reg context-callstack-save-offset [+] ESP MOV - - ! load Factor callstack pointer - ESP ctx-reg context-callstack-bottom-offset [+] MOV - ESP 4 ADD - jit-call-quot jit-load-vm jit-save-context - ! load C callstack pointer - ESP ctx-reg context-callstack-save-offset [+] MOV - ESP [] vm-reg MOV "end_callback" jit-call ] \ c-to-factor define-sub-primitive diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index b068c60352..2f03823d45 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -82,22 +82,12 @@ IN: bootstrap.x86 jit-restore-context - ! save C callstack pointer - ctx-reg context-callstack-save-offset [+] stack-reg MOV - - ! load Factor callstack pointer - stack-reg ctx-reg context-callstack-bottom-offset [+] MOV - stack-reg 8 ADD - ! call the quotation arg1 nv-reg MOV jit-call-quot jit-save-context - ! load C callstack pointer - stack-reg ctx-reg context-callstack-save-offset [+] MOV - arg1 vm-reg MOV "end_callback" jit-call ] \ c-to-factor define-sub-primitive From 4b1361833e73d556bab6a86418adbcb36aecd332 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 31 Mar 2010 15:19:14 -0400 Subject: [PATCH 080/123] cpu.ppc: updating non-optimizing compiler backend for green threads (untested) --- basis/cpu/ppc/bootstrap.factor | 169 +++++++++++++++++++++++++++------ vm/cpu-ppc.hpp | 2 +- 2 files changed, 140 insertions(+), 31 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 58c0a4ef7b..53edcd427d 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -3,7 +3,8 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.units compiler.constants math math.private math.ranges layouts words vocabs slots.private -locals locals.backend generic.single.private fry sequences ; +locals locals.backend generic.single.private fry sequences +threads.private ; FROM: cpu.ppc.assembler => B ; IN: bootstrap.ppc @@ -14,6 +15,22 @@ CONSTANT: ds-reg 13 CONSTANT: rs-reg 14 CONSTANT: vm-reg 15 CONSTANT: ctx-reg 16 +CONSTANT: nv-reg 17 + +: jit-call ( string -- ) + 0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym + 2 MTLR + BLRL ; + +: jit-call-quot ( -- ) + 4 3 quot-entry-point-offset LWZ + 4 MTLR + BLRL ; + +: jit-jump-quot ( -- ) + 4 3 quot-entry-point-offset LWZ + 4 MTCTR + BCTR ; : factor-area-size ( -- n ) 16 ; @@ -52,27 +69,59 @@ CONSTANT: ctx-reg 16 saved-int-regs-size + saved-fp-regs-size + saved-vec-regs-size + + 4 + 16 align ; +: old-context-save-offset ( -- n ) + 432 save-at ; + [ + ! Create stack frame 0 MFLR 1 1 callback-frame-size neg STWU 0 1 callback-frame-size lr-save + STW + ! Save all non-volatile registers nv-int-regs [ 4 * save-int ] each-index nv-fp-regs [ 8 * 80 + save-fp ] each-index nv-vec-regs [ 16 * 224 + save-vec ] each-index + ! Load VM into vm-reg 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel + ! Save old context + 2 vm-reg vm-context-offset LWZ + 2 1 old-context-save-offset STW + + ! Switch over to the spare context + 2 vm-reg vm-spare-context-offset LWZ + 2 vm-reg vm-context-offset STW + + ! Save C callstack pointer + 2 context-callstack-save-offset 1 STW + + ! Load Factor callstack pointer + 1 2 context-callstack-bottom-offset LWZ + + ! Call into Factor code 0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel 2 MTLR BLRL + ! Load C callstack pointer + 2 vm-reg vm-context-offset LWZ + 1 2 context-callstack-save-offset LWZ + + ! Load old context + 2 1 old-context-save-offset LWZ + 2 vm-reg vm-context-offset STW + + ! Restore non-volatile registers nv-vec-regs [ 16 * 224 + restore-vec ] each-index nv-fp-regs [ 8 * 80 + restore-fp ] each-index nv-int-regs [ 4 * restore-int ] each-index + ! Tear down stack frame and return 0 1 callback-frame-size lr-save + LWZ 1 1 0 LWZ 0 MTLR @@ -267,9 +316,7 @@ CONSTANT: ctx-reg 16 jit-save-context 3 6 MR 4 vm-reg MR - 0 5 LOAD32 "inline_cache_miss" rc-absolute-ppc-2/2 jit-dlsym - 5 MTLR - BLRL + "inline_cache_miss" jit-call jit-restore-context ; [ jit-load-return-address jit-inline-cache-miss ] @@ -321,10 +368,9 @@ CONSTANT: ctx-reg 16 [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - 5 3 quot-entry-point-offset LWZ ] -[ 5 MTLR BLRL ] -[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive +[ jit-call-quot ] +[ jit-jump-quot ] \ (call) define-combinator-primitive [ 3 ds-reg 0 LWZ @@ -343,14 +389,20 @@ CONSTANT: ctx-reg 16 ! Special primitives [ + nv-reg 3 MR + + 3 vm-reg MR + "begin_callback" jit-call + jit-restore-context - ! Save ctx->callstack_bottom - 1 ctx-reg context-callstack-bottom-offset STW + ! Call quotation - 5 3 quot-entry-point-offset LWZ - 5 MTLR - BLRL + jit-call-quot + jit-save-context + + 3 vm-reg MR + "end_callback" jit-call ] \ c-to-factor define-sub-primitive [ @@ -369,9 +421,7 @@ CONSTANT: ctx-reg 16 0 MTLR ! Call quotation - 4 3 quot-entry-point-offset LWZ - 4 MTCTR - BCTR + jit-call-quot ] \ unwind-native-frames define-sub-primitive [ @@ -392,9 +442,7 @@ CONSTANT: ctx-reg 16 1 3 MR ! Call memcpy; arguments are now in the correct registers 1 1 -64 STWU - 0 2 LOAD32 "factor_memcpy" rc-absolute-ppc-2/2 jit-dlsym - 2 MTLR - BLRL + "factor_memcpy" jit-call 1 1 0 LWZ ! Return with new callstack 0 1 lr-save LWZ @@ -405,13 +453,10 @@ CONSTANT: ctx-reg 16 [ jit-save-context 4 vm-reg MR - 0 2 LOAD32 "lazy_jit_compile" rc-absolute-ppc-2/2 jit-dlsym - 2 MTLR - BLRL - 5 3 quot-entry-point-offset LWZ + "lazy_jit_compile" jit-call ] -[ 5 MTLR BLRL ] -[ 5 MTCTR BCTR ] +[ jit-call-quot ] +[ jit-jump-quot ] \ lazy-jit-compile define-combinator-primitive ! Objects @@ -665,9 +710,7 @@ CONSTANT: ctx-reg 16 [ BNO ] [ 5 vm-reg MR - 0 6 LOAD32 func rc-absolute-ppc-2/2 jit-dlsym - 6 MTLR - BLRL + func jit-call ] jit-conditional* ; @@ -689,11 +732,77 @@ CONSTANT: ctx-reg 16 [ 4 4 tag-bits get SRAWI 5 vm-reg MR - 0 6 LOAD32 "overflow_fixnum_multiply" rc-absolute-ppc-2/2 jit-dlsym - 6 MTLR - BLRL + "overflow_fixnum_multiply" jit-call ] jit-conditional* ] \ fixnum* define-sub-primitive +! Contexts +: jit-switch-context ( reg -- ) + ! Save ds, rs registers + jit-save-context + + ! Make the new context the current one + ctx-reg swap MR + ctx-reg vm-reg vm-context-offset STW + + ! Load new stack pointer + 1 ctx-reg context-callstack-top-offset LWZ + + ! Load new ds, rs registers + jit-restore-context ; + +: jit-pop-context-and-param ( -- ) + 3 ds-reg 0 LWZ + 3 3 alien-offset LWZ + 4 ds-reg -8 LWZ + ds-reg ds-reg 16 SUBI ; + +: jit-push-param ( -- ) + ds-reg ds-reg 8 ADDI + 4 ds-reg 0 STW ; + +: jit-set-context ( -- ) + jit-pop-context-and-param + 4 jit-switch-context + jit-push-param ; + +[ jit-set-context ] \ (set-context) define-sub-primitive + +: jit-pop-quot-and-param ( -- ) + 3 ds-reg 0 LWZ + 4 ds-reg -8 LWZ + ds-reg ds-reg 16 SUBI ; + +: jit-start-context ( -- ) + ! Create the new context in return-reg + 3 vm-reg MR + "new_context" jit-call + + jit-pop-quot-and-param + + 3 jit-switch-context + + jit-push-param + + jit-jump-quot ; + +[ jit-start-context ] \ (start-context) define-sub-primitive + +: jit-delete-current-context ( -- ) + jit-load-context + 3 vm-reg MR + 4 ctx-reg MR + "delete_context" jit-call ; + +[ + jit-delete-current-context + jit-set-context +] \ (set-context-and-delete) define-sub-primitive + +[ + jit-delete-current-context + jit-start-context +] \ (start-context-and-delete) define-sub-primitive + [ "bootstrap.ppc" forget-vocab ] with-compilation-unit diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 6e76164308..e6244e366e 100644 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -3,7 +3,7 @@ namespace factor #define FACTOR_CPU_STRING "ppc" -#define CALLSTACK_BOTTOM(ctx) (stack_frame *)ctx->callstack_seg->end +#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - 32) /* In the instruction sequence: From be514688633cf232a68065d62d146ad9a865caae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 31 Mar 2010 07:23:19 -0500 Subject: [PATCH 081/123] Report the Win32 error code along with the error message --- basis/windows/errors/errors.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) mode change 100644 => 100755 basis/windows/errors/errors.factor diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor old mode 100644 new mode 100755 index c5dedb090a..67757d05d2 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -719,8 +719,10 @@ ERROR: error-message-failed id ; : win32-error-string ( -- str ) GetLastError n>win32-error-string ; +ERROR: windows-error n string ; + : (win32-error) ( n -- ) - [ win32-error-string throw ] unless-zero ; + [ dup win32-error-string windows-error ] unless-zero ; : win32-error ( -- ) GetLastError (win32-error) ; From c49f45f051c1ae53f2c9d927bfa3c028b5e8c6c8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 31 Mar 2010 07:24:00 -0500 Subject: [PATCH 082/123] Make literals work with aliases, add flags{ parsing word to clean boilerplate with $[ --- basis/literals/literals.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index 001c56525f..3e541a80ce 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,6 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations -vectors sequences fry ; +USING: accessors combinators continuations fry kernel lexer +math parser quotations sequences vectors words words.alias ; IN: literals > call so that CONSTANT:s defined in the same file can ! be called +: expand-alias ( obj -- obj' ) + dup alias? [ def>> first expand-alias ] when ; + : expand-literal ( seq obj -- seq' ) - '[ _ dup word? [ def>> call ] when ] with-datastack ; + '[ + _ expand-alias dup word? [ def>> call ] when + ] with-datastack ; : expand-literals ( seq -- seq' ) [ [ { } ] dip expand-literal ] map concat ; @@ -19,3 +24,7 @@ PRIVATE> SYNTAX: $ scan-word expand-literal >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; SYNTAX: ${ \ } [ expand-literals ] parse-literal ; +SYNTAX: flags{ + "}" [ parse-word ] map-tokens + expand-literals + 0 [ bitor ] reduce suffix! ; From e7487bfe988c97bbc5ea75f4403f0701f6c1bbdb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 31 Mar 2010 07:25:07 -0500 Subject: [PATCH 083/123] More constants and functions in windows.advapi32 --- basis/windows/advapi32/advapi32.factor | 346 ++++++++++++++++++++++--- 1 file changed, 310 insertions(+), 36 deletions(-) mode change 100644 => 100755 basis/windows/advapi32/advapi32.factor diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor old mode 100644 new mode 100755 index d5fe33b745..72769971e6 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,28 +1,9 @@ -USING: alien.c-types alien.syntax kernel math windows.types -windows.kernel32 math.bitwise classes.struct ; +USING: alien.c-types alien.syntax classes.struct kernel +literals math math.bitwise windows.kernel32 windows.types ; IN: windows.advapi32 LIBRARY: advapi32 -CONSTANT: PROV_RSA_FULL 1 -CONSTANT: PROV_RSA_SIG 2 -CONSTANT: PROV_DSS 3 -CONSTANT: PROV_FORTEZZA 4 -CONSTANT: PROV_MS_EXCHANGE 5 -CONSTANT: PROV_SSL 6 -CONSTANT: PROV_RSA_SCHANNEL 12 -CONSTANT: PROV_DSS_DH 13 -CONSTANT: PROV_EC_ECDSA_SIG 14 -CONSTANT: PROV_EC_ECNRA_SIG 15 -CONSTANT: PROV_EC_ECDSA_FULL 16 -CONSTANT: PROV_EC_ECNRA_FULL 17 -CONSTANT: PROV_DH_SCHANNEL 18 -CONSTANT: PROV_SPYRUS_LYNKS 20 -CONSTANT: PROV_RNG 21 -CONSTANT: PROV_INTEL_SEC 22 -CONSTANT: PROV_REPLACE_OWF 23 -CONSTANT: PROV_RSA_AES 24 - CONSTANT: MS_DEF_DH_SCHANNEL_PROV "Microsoft DH Schannel Cryptographic Provider" CONSTANT: MS_DEF_DSS_DH_PROV @@ -56,12 +37,6 @@ CONSTANT: MS_SCARD_PROV CONSTANT: MS_STRONG_PROV "Microsoft Strong Cryptographic Provider" -CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000 -CONSTANT: CRYPT_NEWKEYSET HEX: 8 -CONSTANT: CRYPT_DELETEKEYSET HEX: 10 -CONSTANT: CRYPT_MACHINE_KEYSET HEX: 20 -CONSTANT: CRYPT_SILENT HEX: 40 - STRUCT: ACL { AclRevision BYTE } { Sbz1 BYTE } @@ -361,18 +336,18 @@ CONSTANT: TOKEN_IMPERSONATE HEX: 0004 CONSTANT: TOKEN_QUERY HEX: 0008 CONSTANT: TOKEN_QUERY_SOURCE HEX: 0010 CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 -: TOKEN_READ ( -- n ) { STANDARD_RIGHTS_READ TOKEN_QUERY } flags ; +CONSTANT: TOKEN_READ flags{ STANDARD_RIGHTS_READ TOKEN_QUERY } -: TOKEN_WRITE ( -- n ) - { +CONSTANT: TOKEN_WRITE + flags{ STANDARD_RIGHTS_WRITE TOKEN_ADJUST_PRIVILEGES TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT - } flags ; foldable + } -: TOKEN_ALL_ACCESS ( -- n ) - { +CONSTANT: TOKEN_ALL_ACCESS + flags{ STANDARD_RIGHTS_REQUIRED TOKEN_ASSIGN_PRIMARY TOKEN_DUPLICATE @@ -383,7 +358,7 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 TOKEN_ADJUST_GROUPS TOKEN_ADJUST_SESSIONID TOKEN_ADJUST_DEFAULT - } flags ; foldable + } CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000 CONSTANT: HKEY_CURRENT_USER HEX: 80000001 @@ -426,6 +401,305 @@ CONSTANT: REG_QWORD_LITTLE_ENDIAN 11 CONSTANT: REG_CREATED_NEW_KEY 1 CONSTANT: REG_OPENED_EXISTING_KEY 2 + + +CONSTANT: ALG_CLASS_ANY 0 +CONSTANT: ALG_CLASS_SIGNATURE 8192 +CONSTANT: ALG_CLASS_MSG_ENCRYPT 16384 +CONSTANT: ALG_CLASS_DATA_ENCRYPT 24576 +CONSTANT: ALG_CLASS_HASH 32768 +CONSTANT: ALG_CLASS_KEY_EXCHANGE 40960 +CONSTANT: ALG_CLASS_ALL 57344 +CONSTANT: ALG_TYPE_ANY 0 +CONSTANT: ALG_TYPE_DSS 512 +CONSTANT: ALG_TYPE_RSA 1024 +CONSTANT: ALG_TYPE_BLOCK 1536 +CONSTANT: ALG_TYPE_STREAM 2048 +CONSTANT: ALG_TYPE_DH 2560 +CONSTANT: ALG_TYPE_SECURECHANNEL 3072 +CONSTANT: ALG_SID_ANY 0 +CONSTANT: ALG_SID_RSA_ANY 0 +CONSTANT: ALG_SID_RSA_PKCS 1 +CONSTANT: ALG_SID_RSA_MSATWORK 2 +CONSTANT: ALG_SID_RSA_ENTRUST 3 +CONSTANT: ALG_SID_RSA_PGP 4 +CONSTANT: ALG_SID_DSS_ANY 0 +CONSTANT: ALG_SID_DSS_PKCS 1 +CONSTANT: ALG_SID_DSS_DMS 2 +CONSTANT: ALG_SID_DES 1 +CONSTANT: ALG_SID_3DES 3 +CONSTANT: ALG_SID_DESX 4 +CONSTANT: ALG_SID_IDEA 5 +CONSTANT: ALG_SID_CAST 6 +CONSTANT: ALG_SID_SAFERSK64 7 +CONSTANT: ALG_SID_SAFERSK128 8 +CONSTANT: ALG_SID_3DES_112 9 +CONSTANT: ALG_SID_SKIPJACK 10 +CONSTANT: ALG_SID_TEK 11 +CONSTANT: ALG_SID_CYLINK_MEK 12 +CONSTANT: ALG_SID_RC5 13 +CONSTANT: ALG_SID_RC2 2 +CONSTANT: ALG_SID_RC4 1 +CONSTANT: ALG_SID_SEAL 2 +CONSTANT: ALG_SID_MD2 1 +CONSTANT: ALG_SID_MD4 2 +CONSTANT: ALG_SID_MD5 3 +CONSTANT: ALG_SID_SHA 4 +CONSTANT: ALG_SID_MAC 5 +CONSTANT: ALG_SID_RIPEMD 6 +CONSTANT: ALG_SID_RIPEMD160 7 +CONSTANT: ALG_SID_SSL3SHAMD5 8 +CONSTANT: ALG_SID_HMAC 9 +CONSTANT: ALG_SID_TLS1PRF 10 +CONSTANT: ALG_SID_EXAMPLE 80 + +CONSTANT: CALG_MD2 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD2 } +CONSTANT: CALG_MD4 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD4 } +CONSTANT: CALG_MD5 flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MD5 } +CONSTANT: CALG_SHA flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_SHA } +CONSTANT: CALG_MAC flags{ ALG_CLASS_HASH ALG_TYPE_ANY ALG_SID_MAC } +CONSTANT: CALG_3DES flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 3 } +CONSTANT: CALG_CYLINK_MEK flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 12 } +CONSTANT: CALG_SKIPJACK flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK 10 } +CONSTANT: CALG_KEA_KEYX flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_STREAM ALG_TYPE_DSS 4 } +CONSTANT: CALG_RSA_SIGN flags{ ALG_CLASS_SIGNATURE ALG_TYPE_RSA ALG_SID_RSA_ANY } +CONSTANT: CALG_DSS_SIGN flags{ ALG_CLASS_SIGNATURE ALG_TYPE_DSS ALG_SID_DSS_ANY } +CONSTANT: CALG_RSA_KEYX flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_RSA ALG_SID_RSA_ANY } +CONSTANT: CALG_DES flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_DES } +CONSTANT: CALG_RC2 flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_RC2 } +CONSTANT: CALG_RC4 flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_STREAM ALG_SID_RC4 } +CONSTANT: CALG_SEAL flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_STREAM ALG_SID_SEAL } +CONSTANT: CALG_DH_EPHEM flags{ ALG_CLASS_KEY_EXCHANGE ALG_TYPE_STREAM ALG_TYPE_DSS ALG_SID_DSS_DMS } +CONSTANT: CALG_DESX flags{ ALG_CLASS_DATA_ENCRYPT ALG_TYPE_BLOCK ALG_SID_DESX } +! CONSTANT: CALG_TLS1PRF flags{ ALG_CLASS_DHASH ALG_TYPE_ANY ALG_SID_TLS1PRF } + +CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000 +CONSTANT: CRYPT_NEWKEYSET 8 +CONSTANT: CRYPT_DELETEKEYSET 16 +CONSTANT: CRYPT_MACHINE_KEYSET 32 +CONSTANT: CRYPT_SILENT 64 +CONSTANT: CRYPT_EXPORTABLE 1 +CONSTANT: CRYPT_USER_PROTECTED 2 +CONSTANT: CRYPT_CREATE_SALT 4 +CONSTANT: CRYPT_UPDATE_KEY 8 +CONSTANT: AT_KEYEXCHANGE 1 +CONSTANT: AT_SIGNATURE 2 +CONSTANT: CRYPT_USERDATA 1 +CONSTANT: KP_IV 1 +CONSTANT: KP_SALT 2 +CONSTANT: KP_PADDING 3 +CONSTANT: KP_MODE 4 +CONSTANT: KP_MODE_BITS 5 +CONSTANT: KP_PERMISSIONS 6 +CONSTANT: KP_ALGID 7 +CONSTANT: KP_BLOCKLEN 8 +CONSTANT: PKCS5_PADDING 1 +CONSTANT: CRYPT_MODE_CBC 1 +CONSTANT: CRYPT_MODE_ECB 2 +CONSTANT: CRYPT_MODE_OFB 3 +CONSTANT: CRYPT_MODE_CFB 4 +CONSTANT: CRYPT_MODE_CTS 5 +CONSTANT: CRYPT_MODE_CBCI 6 +CONSTANT: CRYPT_MODE_CFBP 7 +CONSTANT: CRYPT_MODE_OFBP 8 +CONSTANT: CRYPT_MODE_CBCOFM 9 +CONSTANT: CRYPT_MODE_CBCOFMI 10 +CONSTANT: CRYPT_ENCRYPT 1 +CONSTANT: CRYPT_DECRYPT 2 +CONSTANT: CRYPT_EXPORT 4 +CONSTANT: CRYPT_READ 8 +CONSTANT: CRYPT_WRITE 16 +CONSTANT: CRYPT_MAC 32 +CONSTANT: HP_ALGID 1 +CONSTANT: HP_HASHVAL 2 +CONSTANT: HP_HASHSIZE 4 +CONSTANT: PP_ENUMALGS 1 +CONSTANT: PP_ENUMCONTAINERS 2 +CONSTANT: PP_IMPTYPE 3 +CONSTANT: PP_NAME 4 +CONSTANT: PP_VERSION 5 +CONSTANT: PP_CONTAINER 6 +CONSTANT: PP_ENUMMANDROOTS 25 +CONSTANT: PP_ENUMELECTROOTS 26 +CONSTANT: PP_KEYSET_TYPE 27 +CONSTANT: PP_ADMIN_PIN 31 +CONSTANT: PP_KEYEXCHANGE_PIN 32 +CONSTANT: PP_SIGNATURE_PIN 33 +CONSTANT: PP_SIG_KEYSIZE_INC 34 +CONSTANT: PP_KEYX_KEYSIZE_INC 35 +CONSTANT: PP_UNIQUE_CONTAINER 36 +CONSTANT: PP_SGC_INFO 37 +CONSTANT: PP_USE_HARDWARE_RNG 38 +CONSTANT: PP_KEYSPEC 39 +CONSTANT: PP_ENUMEX_SIGNING_PROT 40 +CONSTANT: CRYPT_FIRST 1 +CONSTANT: CRYPT_NEXT 2 +CONSTANT: CRYPT_IMPL_HARDWARE 1 +CONSTANT: CRYPT_IMPL_SOFTWARE 2 +CONSTANT: CRYPT_IMPL_MIXED 3 +CONSTANT: CRYPT_IMPL_UNKNOWN 4 +CONSTANT: PROV_RSA_FULL 1 +CONSTANT: PROV_RSA_SIG 2 +CONSTANT: PROV_DSS 3 +CONSTANT: PROV_FORTEZZA 4 +CONSTANT: PROV_MS_MAIL 5 +CONSTANT: PROV_SSL 6 +CONSTANT: PROV_STT_MER 7 +CONSTANT: PROV_STT_ACQ 8 +CONSTANT: PROV_STT_BRND 9 +CONSTANT: PROV_STT_ROOT 10 +CONSTANT: PROV_STT_ISS 11 +CONSTANT: PROV_RSA_SCHANNEL 12 +CONSTANT: PROV_DSS_DH 13 +CONSTANT: PROV_EC_ECDSA_SIG 14 +CONSTANT: PROV_EC_ECNRA_SIG 15 +CONSTANT: PROV_EC_ECDSA_FULL 16 +CONSTANT: PROV_EC_ECNRA_FULL 17 +CONSTANT: PROV_DH_SCHANNEL 18 +CONSTANT: PROV_SPYRUS_LYNKS 20 +CONSTANT: PROV_RNG 21 +CONSTANT: PROV_INTEL_SEC 22 +CONSTANT: PROV_REPLACE_OWF 23 +CONSTANT: PROV_RSA_AES 24 +CONSTANT: MAXUIDLEN 64 +CONSTANT: CUR_BLOB_VERSION 2 +CONSTANT: X509_ASN_ENCODING 1 +CONSTANT: PKCS_7_ASN_ENCODING 65536 +CONSTANT: CERT_V1 0 +CONSTANT: CERT_V2 1 +CONSTANT: CERT_V3 2 +CONSTANT: CERT_E_CHAINING -2146762486 +CONSTANT: CERT_E_CN_NO_MATCH -2146762481 +CONSTANT: CERT_E_EXPIRED -2146762495 +CONSTANT: CERT_E_PURPOSE -2146762490 +CONSTANT: CERT_E_REVOCATION_FAILURE -2146762482 +CONSTANT: CERT_E_REVOKED -2146762484 +CONSTANT: CERT_E_ROLE -2146762493 +CONSTANT: CERT_E_UNTRUSTEDROOT -2146762487 +CONSTANT: CERT_E_UNTRUSTEDTESTROOT -2146762483 +CONSTANT: CERT_E_VALIDITYPERIODNESTING -2146762494 +CONSTANT: CERT_E_WRONG_USAGE -2146762480 +CONSTANT: CERT_E_PATHLENCONST -2146762492 +CONSTANT: CERT_E_CRITICAL -2146762491 +CONSTANT: CERT_E_ISSUERCHAINING -2146762489 +CONSTANT: CERT_E_MALFORMED -2146762488 +CONSTANT: CRYPT_E_REVOCATION_OFFLINE -2146885613 +CONSTANT: CRYPT_E_REVOKED -2146885616 +CONSTANT: TRUST_E_BASIC_CONSTRAINTS -2146869223 +CONSTANT: TRUST_E_CERT_SIGNATURE -2146869244 +CONSTANT: TRUST_E_FAIL -2146762485 +CONSTANT: CERT_TRUST_NO_ERROR 0 +CONSTANT: CERT_TRUST_IS_NOT_TIME_VALID 1 +CONSTANT: CERT_TRUST_IS_NOT_TIME_NESTED 2 +CONSTANT: CERT_TRUST_IS_REVOKED 4 +CONSTANT: CERT_TRUST_IS_NOT_SIGNATURE_VALID 8 +CONSTANT: CERT_TRUST_IS_NOT_VALID_FOR_USAGE 16 +CONSTANT: CERT_TRUST_IS_UNTRUSTED_ROOT 32 +CONSTANT: CERT_TRUST_REVOCATION_STATUS_UNKNOWN 64 +CONSTANT: CERT_TRUST_IS_CYCLIC 128 +CONSTANT: CERT_TRUST_IS_PARTIAL_CHAIN 65536 +CONSTANT: CERT_TRUST_CTL_IS_NOT_TIME_VALID 131072 +CONSTANT: CERT_TRUST_CTL_IS_NOT_SIGNATURE_VALID 262144 +CONSTANT: CERT_TRUST_CTL_IS_NOT_VALID_FOR_USAGE 524288 +CONSTANT: CERT_TRUST_HAS_EXACT_MATCH_ISSUER 1 +CONSTANT: CERT_TRUST_HAS_KEY_MATCH_ISSUER 2 +CONSTANT: CERT_TRUST_HAS_NAME_MATCH_ISSUER 4 +CONSTANT: CERT_TRUST_IS_SELF_SIGNED 8 +CONSTANT: CERT_TRUST_IS_COMPLEX_CHAIN 65536 +CONSTANT: CERT_CHAIN_POLICY_BASE 1 +CONSTANT: CERT_CHAIN_POLICY_AUTHENTICODE 2 +CONSTANT: CERT_CHAIN_POLICY_AUTHENTICODE_TS 3 +CONSTANT: CERT_CHAIN_POLICY_SSL 4 +CONSTANT: CERT_CHAIN_POLICY_BASIC_CONSTRAINTS 5 +CONSTANT: CERT_CHAIN_POLICY_NT_AUTH 6 +CONSTANT: USAGE_MATCH_TYPE_AND 0 +CONSTANT: USAGE_MATCH_TYPE_OR 1 +CONSTANT: CERT_SIMPLE_NAME_STR 1 +CONSTANT: CERT_OID_NAME_STR 2 +CONSTANT: CERT_X500_NAME_STR 3 +CONSTANT: CERT_NAME_STR_SEMICOLON_FLAG 1073741824 +CONSTANT: CERT_NAME_STR_CRLF_FLAG 134217728 +CONSTANT: CERT_NAME_STR_NO_PLUS_FLAG 536870912 +CONSTANT: CERT_NAME_STR_NO_QUOTING_FLAG 268435456 +CONSTANT: CERT_NAME_STR_REVERSE_FLAG 33554432 +CONSTANT: CERT_NAME_STR_ENABLE_T61_UNICODE_FLAG 131072 +CONSTANT: CERT_FIND_ANY 0 +CONSTANT: CERT_FIND_CERT_ID 1048576 +CONSTANT: CERT_FIND_CTL_USAGE 655360 +CONSTANT: CERT_FIND_ENHKEY_USAGE 655360 +CONSTANT: CERT_FIND_EXISTING 851968 +CONSTANT: CERT_FIND_HASH 65536 +CONSTANT: CERT_FIND_ISSUER_ATTR 196612 +CONSTANT: CERT_FIND_ISSUER_NAME 131076 +CONSTANT: CERT_FIND_ISSUER_OF 786432 +CONSTANT: CERT_FIND_KEY_IDENTIFIER 983040 +CONSTANT: CERT_FIND_KEY_SPEC 589824 +CONSTANT: CERT_FIND_MD5_HASH 262144 +CONSTANT: CERT_FIND_PROPERTY 327680 +CONSTANT: CERT_FIND_PUBLIC_KEY 393216 +CONSTANT: CERT_FIND_SHA1_HASH 65536 +CONSTANT: CERT_FIND_SIGNATURE_HASH 917504 +CONSTANT: CERT_FIND_SUBJECT_ATTR 196615 +CONSTANT: CERT_FIND_SUBJECT_CERT 720896 +CONSTANT: CERT_FIND_SUBJECT_NAME 131079 +CONSTANT: CERT_FIND_SUBJECT_STR_A 458759 +CONSTANT: CERT_FIND_SUBJECT_STR_W 524295 +CONSTANT: CERT_FIND_ISSUER_STR_A 458756 +CONSTANT: CERT_FIND_ISSUER_STR_W 524292 +CONSTANT: CERT_FIND_OR_ENHKEY_USAGE_FLAG 16 +CONSTANT: CERT_FIND_OPTIONAL_ENHKEY_USAGE_FLAG 1 +CONSTANT: CERT_FIND_NO_ENHKEY_USAGE_FLAG 8 +CONSTANT: CERT_FIND_VALID_ENHKEY_USAGE_FLAG 32 +CONSTANT: CERT_FIND_EXT_ONLY_ENHKEY_USAGE_FLAG 2 +CONSTANT: CERT_CASE_INSENSITIVE_IS_RDN_ATTRS_FLAG 2 +CONSTANT: CERT_UNICODE_IS_RDN_ATTRS_FLAG 1 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER 1 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_COMPARE_KEY_FLAG 1 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_COMPLEX_CHAIN_FLAG 2 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_CACHE_ONLY_FLAG 32768 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_CACHE_ONLY_URL_FLAG 4 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_LOCAL_MACHINE_FLAG 8 +CONSTANT: CERT_CHAIN_FIND_BY_ISSUER_NO_KEY_FLAG 16384 +CONSTANT: CERT_STORE_PROV_SYSTEM 10 +CONSTANT: CERT_SYSTEM_STORE_LOCAL_MACHINE 131072 +CONSTANT: szOID_PKIX_KP_SERVER_AUTH "4235600" +CONSTANT: szOID_SERVER_GATED_CRYPTO "4235658" +CONSTANT: szOID_SGC_NETSCAPE "2.16.840.1.113730.4.1" +CONSTANT: szOID_PKIX_KP_CLIENT_AUTH "1.3.6.1.5.5.7.3.2" + +CONSTANT: CRYPT_NOHASHOID HEX: 00000001 +CONSTANT: CRYPT_NO_SALT HEX: 10 +CONSTANT: CRYPT_PREGEN HEX: 40 +CONSTANT: CRYPT_RECIPIENT HEX: 10 +CONSTANT: CRYPT_INITIATOR HEX: 40 +CONSTANT: CRYPT_ONLINE HEX: 80 +CONSTANT: CRYPT_SF HEX: 100 +CONSTANT: CRYPT_CREATE_IV HEX: 200 +CONSTANT: CRYPT_KEK HEX: 400 +CONSTANT: CRYPT_DATA_KEY HEX: 800 +CONSTANT: CRYPT_VOLATILE HEX: 1000 +CONSTANT: CRYPT_SGCKEY HEX: 2000 + +CONSTANT: KEYSTATEBLOB HEX: C +CONSTANT: OPAQUEKEYBLOB HEX: 9 +CONSTANT: PLAINTEXTKEYBLOB HEX: 8 +CONSTANT: PRIVATEKEYBLOB HEX: 7 +CONSTANT: PUBLICKEYBLOB HEX: 6 +CONSTANT: PUBLICKEYBLOBEX HEX: A +CONSTANT: SIMPLEBLOB HEX: 1 +CONSTANT: SYMMETRICWRAPKEYBLOB HEX: B + +TYPEDEF: uint ALG_ID + +STRUCT: PUBLICKEYSTRUC + { bType BYTE } + { bVersion BYTE } + { reserved WORD } + { aiKeyAlg ALG_ID } ; + +TYPEDEF: PUBLICKEYSTRUC BLOBHEADER +TYPEDEF: LONG HCRYPTHASH +TYPEDEF: LONG HCRYPTKEY TYPEDEF: DWORD REGSAM ! : I_ScGetCurrentGroupStateW ; @@ -590,7 +864,7 @@ FUNCTION: BOOL CryptAcquireContextW ( HCRYPTPROV* phProv, ALIAS: CryptAcquireContext CryptAcquireContextW ! : CryptContextAddRef ; -! : CryptCreateHash ; +FUNCTION: BOOL CryptCreateHash ( HCRYPTPROV hProv, ALG_ID Algid, HCRYPTKEY hKey, DWORD dwFlags, HCRYPTHASH *pHash ) ; ! : CryptDecrypt ; ! : CryptDeriveKey ; ! : CryptDestroyHash ; @@ -613,7 +887,7 @@ FUNCTION: BOOL CryptGenRandom ( HCRYPTPROV hProv, DWORD dwLen, BYTE* pbBuffer ) ! : CryptGetUserKey ; ! : CryptHashData ; ! : CryptHashSessionKey ; -! : CryptImportKey ; +FUNCTION: BOOL CryptImportKey ( HCRYPTPROV hProv, BYTE *pbData, DWORD dwDataLen, HCRYPTKEY hPubKey, DWORD dwFlags, HCRYPTKEY *phKey ) ; FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : CryptSetHashParam ; ! : CryptSetKeyParam ; From 077e5dea2ad4fb860fa2c01eff7566bc9f3cec5e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 20 Mar 2010 18:38:23 -0500 Subject: [PATCH 084/123] Always do a leap year check when adding timestamps --- basis/calendar/calendar-tests.factor | 10 ++++++++++ basis/calendar/calendar.factor | 14 +++++++------- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 2490b87c37..3f52b4d2e7 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -176,3 +176,13 @@ IN: calendar.tests [ t ] [ 1356998399 unix-time>timestamp 2013 1 seconds time- = ] unit-test [ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test + +[ t ] [ + 2009 1 29 1 months time+ + 2009 3 1 = +] unit-test + +[ t ] [ + 2008 1 29 1 months time+ + 2008 2 29 = +] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index cd87701aa9..8758b8198b 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -99,12 +99,12 @@ CONSTANT: day-abbreviations3 : day-abbreviation3 ( n -- string ) day-abbreviations3 nth ; inline -: average-month ( -- ratio ) 30+5/12 ; inline -: months-per-year ( -- integer ) 12 ; inline -: days-per-year ( -- ratio ) 3652425/10000 ; inline -: hours-per-year ( -- ratio ) 876582/100 ; inline -: minutes-per-year ( -- ratio ) 5259492/10 ; inline -: seconds-per-year ( -- integer ) 31556952 ; inline +CONSTANT: average-month 30+5/12 +CONSTANT: months-per-year 12 +CONSTANT: days-per-year 3652425/10000 +CONSTANT: hours-per-year 876582/100 +CONSTANT: minutes-per-year 5259492/10 +CONSTANT: seconds-per-year 31556952 :: julian-day-number ( year month day -- n ) #! Returns a composite date number @@ -200,7 +200,7 @@ GENERIC: +second ( timestamp x -- timestamp ) [ 3 >>month 1 >>day ] when ; M: integer +year ( timestamp n -- timestamp ) - [ [ + ] curry change-year adjust-leap-year ] unless-zero ; + [ + ] curry change-year adjust-leap-year ; M: real +year ( timestamp n -- timestamp ) [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; From b39e3f47007535b31f305c9e956ac746a4e7b552 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 24 Mar 2010 03:04:48 -0500 Subject: [PATCH 085/123] Link a word in math docs --- basis/math/bitwise/bitwise-docs.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index bbc72d99e4..ee94479b46 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -375,6 +375,10 @@ $nl bit? bit-clear? } +"Toggling a bit:" +{ $subsections + toggle-bit +} "Operations with bitmasks:" { $subsections mask From dc52f177f529ca31277db3cd812a3a8708db3525 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 24 Mar 2010 17:52:28 -0500 Subject: [PATCH 086/123] Add utiltity words for io.files.unique --- basis/io/files/unique/unique-docs.factor | 20 +++++++++++++++----- basis/io/files/unique/unique.factor | 15 +++++++++++---- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index a2051bd10a..7e8d166b32 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -54,12 +54,19 @@ HELP: with-unique-directory } { $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ; -HELP: move-file-unique +HELP: copy-file-unique { $values - { "path" "a pathname string" } { "directory" "a directory" } + { "path" "a pathname string" } { "prefix" string } { "suffix" string } { "path'" "a pathname string" } } -{ $description "Moves " { $snippet "path" } " to " { $snippet "directory" } " by creating a unique file in this directory. Returns the new path." } ; +{ $description "Copies " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ; + +HELP: move-file-unique +{ $values + { "path" "a pathname string" } { "prefix" string } { "suffix" string } + { "path'" "a pathname string" } +} +{ $description "Moves " { $snippet "path" } " to a new unique file in the directory stored in " { $link current-temporary-directory } ". Returns the new path." } ; HELP: current-temporary-directory { $values @@ -98,7 +105,10 @@ ARTICLE: "io.files.unique" "Unique files" } "Default temporary directory:" { $subsections default-temporary-directory } -"Moving files into a directory safely:" -{ $subsections move-file-unique } ; +"Copying and moving files to a new unique file:" +{ $subsections + copy-file-unique + move-file-unique +} ; ABOUT: "io.files.unique" diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 07f7b25140..5bf89b9520 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -70,10 +70,17 @@ PRIVATE> : unique-file ( prefix -- path ) "" make-unique-file ; -: move-file-unique ( path directory -- path' ) - [ - "" unique-file [ move-file ] keep - ] with-temporary-directory ; +: move-file-unique ( path prefix suffix -- path' ) + make-unique-file [ move-file ] keep ; + +: copy-file-unique ( path prefix suffix -- path' ) + make-unique-file [ copy-file ] keep ; + +: temporary-file ( -- path ) "" unique-file ; + +: with-working-directory ( path quot -- ) + over make-directories + dupd '[ _ _ with-temporary-directory ] with-directory ; inline { { [ os unix? ] [ "io.files.unique.unix" ] } From 0569f08ea272b5ada1d648abc252382eaf2ad012 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 31 Mar 2010 17:37:22 -0500 Subject: [PATCH 087/123] Fix calendar docs --- basis/calendar/calendar-docs.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 6ce8b1d5fd..a5a31ebd65 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -76,27 +76,27 @@ HELP: day-abbreviation3 } related-words HELP: average-month -{ $values { "ratio" ratio } } +{ $values { "value" ratio } } { $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ; HELP: months-per-year -{ $values { "integer" integer } } +{ $values { "value" integer } } { $description "Returns the number of months in a year." } ; HELP: days-per-year -{ $values { "ratio" ratio } } +{ $values { "value" ratio } } { $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ; HELP: hours-per-year -{ $values { "ratio" ratio } } +{ $values { "value" ratio } } { $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ; HELP: minutes-per-year -{ $values { "ratio" ratio } } +{ $values { "value" ratio } } { $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ; HELP: seconds-per-year -{ $values { "integer" integer } } +{ $values { "value" integer } } { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ; HELP: julian-day-number From ef53e6ecd576641b71f71409889b64ab84585e02 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 31 Mar 2010 17:06:50 -0400 Subject: [PATCH 088/123] cpu.x86.64: eliminate useless instruction from primitive call sequence for a marginal to non-existent gain --- basis/cpu/x86/32/bootstrap.factor | 3 ++- basis/cpu/x86/64/bootstrap.factor | 6 +++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 15a7dc1c29..a428a66ace 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -63,12 +63,13 @@ IN: bootstrap.x86 rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ + ! ctx-reg is preserved across the call because it is non-volatile + ! in the C ABI jit-load-vm jit-save-context ! call the primitive ESP [] vm-reg MOV 0 CALL rc-relative rt-dlsym jit-rel - ! restore ds, rs registers jit-restore-context ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 2f03823d45..4cd2d8104b 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -57,11 +57,12 @@ IN: bootstrap.x86 ctx-reg context-retainstack-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) - jit-load-context ds-reg ctx-reg context-datastack-offset [+] MOV rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ + ! ctx-reg is preserved across the call because it is non-volatile + ! in the C ABI jit-save-context ! call the primitive arg1 vm-reg MOV @@ -80,6 +81,7 @@ IN: bootstrap.x86 arg1 vm-reg MOV "begin_callback" jit-call + jit-load-context jit-restore-context ! call the quotation @@ -115,6 +117,7 @@ IN: bootstrap.x86 vm-reg 0 MOV 0 rc-absolute-cell jit-vm ! Load ds and rs registers + jit-load-context jit-restore-context ! Call quotation @@ -168,6 +171,7 @@ IN: bootstrap.x86 arg1 RBX MOV arg2 vm-reg MOV "inline_cache_miss" jit-call + jit-load-context jit-restore-context ; [ jit-load-return-address jit-inline-cache-miss ] From 7d24459bb8a21bf4920386d93df1cf83a8ef3ae0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 31 Mar 2010 20:47:13 -0400 Subject: [PATCH 089/123] cpu.x86.assembler: add segment override prefixes --- basis/cpu/x86/assembler/assembler-tests.factor | 2 ++ basis/cpu/x86/assembler/assembler.factor | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 531110da7b..0a6ae5a484 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -164,3 +164,5 @@ IN: cpu.x86.assembler.tests [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test +[ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test + diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index b075b121a5..32eeaaad1d 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -188,6 +188,13 @@ M: register displacement, drop ; PRIVATE> +! Segment override prefixes +: CS ( -- ) HEX: 2e , ; +: ES ( -- ) HEX: 26 , ; +: SS ( -- ) HEX: 36 , ; +: FS ( -- ) HEX: 64 , ; +: GS ( -- ) HEX: 65 , ; + ! Moving stuff GENERIC: PUSH ( op -- ) M: register PUSH f HEX: 50 short-operand ; From 1e1425a6e18fb03340ace8432b4cb64e49c0f782 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 00:21:41 -0400 Subject: [PATCH 090/123] cpu.ppc: non-optimizing compiler backend fixes --- basis/cpu/ppc/bootstrap.factor | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 53edcd427d..83be0150d8 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -98,7 +98,7 @@ CONSTANT: nv-reg 17 2 vm-reg vm-context-offset STW ! Save C callstack pointer - 2 context-callstack-save-offset 1 STW + 1 2 context-callstack-save-offset STW ! Load Factor callstack pointer 1 2 context-callstack-bottom-offset LWZ @@ -108,6 +108,9 @@ CONSTANT: nv-reg 17 2 MTLR BLRL + ! Load VM again, pointlessly + 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel + ! Load C callstack pointer 2 vm-reg vm-context-offset LWZ 1 2 context-callstack-save-offset LWZ @@ -141,7 +144,6 @@ CONSTANT: nv-reg 17 rs-reg ctx-reg context-retainstack-offset STW ; : jit-restore-context ( -- ) - jit-load-context ds-reg ctx-reg context-datastack-offset LWZ rs-reg ctx-reg context-retainstack-offset LWZ ; @@ -317,6 +319,7 @@ CONSTANT: nv-reg 17 3 6 MR 4 vm-reg MR "inline_cache_miss" jit-call + jit-load-context jit-restore-context ; [ jit-load-return-address jit-inline-cache-miss ] @@ -394,9 +397,11 @@ CONSTANT: nv-reg 17 3 vm-reg MR "begin_callback" jit-call + jit-load-context jit-restore-context ! Call quotation + 3 nv-reg MR jit-call-quot jit-save-context @@ -414,6 +419,7 @@ CONSTANT: nv-reg 17 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm ! Load ds and rs registers + jit-load-context jit-restore-context ! We have changed the stack; load return address again @@ -755,33 +761,34 @@ CONSTANT: nv-reg 17 : jit-pop-context-and-param ( -- ) 3 ds-reg 0 LWZ 3 3 alien-offset LWZ - 4 ds-reg -8 LWZ - ds-reg ds-reg 16 SUBI ; + 4 ds-reg -4 LWZ + ds-reg ds-reg 8 SUBI ; : jit-push-param ( -- ) - ds-reg ds-reg 8 ADDI + ds-reg ds-reg 4 ADDI 4 ds-reg 0 STW ; : jit-set-context ( -- ) jit-pop-context-and-param - 4 jit-switch-context + 3 jit-switch-context jit-push-param ; [ jit-set-context ] \ (set-context) define-sub-primitive : jit-pop-quot-and-param ( -- ) 3 ds-reg 0 LWZ - 4 ds-reg -8 LWZ - ds-reg ds-reg 16 SUBI ; + 4 ds-reg -4 LWZ + ds-reg ds-reg 8 SUBI ; : jit-start-context ( -- ) ! Create the new context in return-reg 3 vm-reg MR "new_context" jit-call + 6 3 MR jit-pop-quot-and-param - 3 jit-switch-context + 6 jit-switch-context jit-push-param From 1f9fbd22eb6d54bb8fc953def8a34f2ae01772a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 00:22:10 -0400 Subject: [PATCH 091/123] cpu.ppc: updating optimizing compiler backend for recent changes (untested) --- basis/cpu/ppc/ppc.factor | 45 ++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 25 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 36beb86792..dbc313052f 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -678,8 +678,6 @@ M: ppc %box-large-struct ( n c-type -- ) M:: ppc %restore-context ( temp1 temp2 -- ) temp1 "ctx" %vm-field - temp2 1 stack-frame get total-size>> ADDI - temp2 temp1 "callstack-bottom" context-field-offset STW ds-reg temp1 "datastack" context-field-offset LWZ rs-reg temp1 "retainstack" context-field-offset LWZ ; @@ -692,14 +690,6 @@ M:: ppc %save-context ( temp1 temp2 -- ) M: ppc %alien-invoke ( symbol dll -- ) [ 11 ] 2dip %alien-global 11 MTLR BLRL ; -M: ppc %alien-callback ( quot -- ) - 3 4 %restore-context - 3 swap %load-reference - 4 3 quot-entry-point-offset LWZ - 4 MTLR - BLRL - 3 4 %save-context ; - M: ppc %prepare-alien-indirect ( -- ) 3 ds-reg 0 LWZ ds-reg ds-reg 4 SUBI @@ -710,18 +700,6 @@ M: ppc %prepare-alien-indirect ( -- ) M: ppc %alien-indirect ( -- ) 16 MTLR BLRL ; -M: ppc %callback-value ( ctype -- ) - ! Save top of data stack - 3 ds-reg 0 LWZ - 3 1 0 local@ STW - 3 %load-vm-addr - ! Restore data/call/retain stacks - "unnest_context" f %alien-invoke - ! Restore top of data stack - 3 1 0 local@ LWZ - ! Unbox former top of data stack to return registers - unbox-return ; - M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ; M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ; @@ -757,14 +735,31 @@ M: ppc %box-small-struct ( c-type -- ) 4 3 4 LWZ 3 3 0 LWZ ; -M: ppc %nest-context ( -- ) +M: ppc %begin-callback ( -- ) 3 %load-vm-addr - "nest_context" f %alien-invoke ; + "begin_callback" f %alien-invoke ; -M: ppc %unnest-context ( -- ) +M: ppc %alien-callback ( quot -- ) + 3 4 %restore-context + 3 swap %load-reference + 4 3 quot-entry-point-offset LWZ + 4 MTLR + BLRL + 3 4 %save-context ; + +M: ppc %end-callback ( -- ) 3 %load-vm-addr "unnest_context" f %alien-invoke ; +M: ppc %end-callback-value ( ctype -- ) + ! Save top of data stack + 12 ds-reg 0 LWZ + %end-callback + ! Restore top of data stack + 3 12 MR + ! Unbox former top of data stack to return registers + unbox-return ; + M: ppc %unbox-small-struct ( size -- ) heap-size cell align cell /i { { 1 [ %unbox-struct-1 ] } From 026499e64fd6718418310dfdbff41e3350efb900 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 14:43:27 -0500 Subject: [PATCH 092/123] Use flags{ instead of flags all over the place --- .../file-descriptors/file-descriptors.factor | 5 +-- basis/core-graphics/core-graphics.factor | 5 ++- .../unix/multiplexers/kqueue/kqueue.factor | 6 ++-- .../windows/nt/privileges/privileges.factor | 4 +-- basis/io/backend/windows/windows.factor | 8 ++--- basis/io/directories/unix/unix.factor | 5 ++- basis/io/files/unique/unix/unix.factor | 5 ++- basis/io/files/unix/unix-tests.factor | 6 ++-- basis/io/files/unix/unix.factor | 12 +++---- basis/io/files/windows/windows.factor | 9 ++--- basis/io/mmap/unix/unix.factor | 10 +++--- basis/io/mmap/windows/windows.factor | 8 ++--- basis/io/monitors/linux/linux.factor | 6 ++-- basis/io/monitors/windows/nt/nt.factor | 4 +-- basis/io/pipes/windows/nt/nt.factor | 4 +-- basis/literals/literals-docs.factor | 15 ++++++++- basis/literals/literals-tests.factor | 15 ++++++++- basis/literals/literals.factor | 7 ++-- basis/math/bitwise/bitwise-docs.factor | 13 -------- basis/math/bitwise/bitwise-tests.factor | 13 +------- basis/math/bitwise/bitwise.factor | 4 --- basis/openssl/libssl/libssl.factor | 9 +++-- basis/random/windows/windows.factor | 2 +- basis/ui/backend/windows/windows.factor | 7 ++-- basis/unix/linux/inotify/inotify.factor | 19 ++++++----- basis/unix/statfs/macosx/macosx.factor | 11 +++---- .../directx/d3d9types/d3d9types.factor | 33 ++++++++++--------- basis/windows/errors/errors.factor | 6 ++-- basis/windows/gdi32/gdi32.factor | 4 +-- basis/windows/user32/user32.factor | 17 +++++----- basis/windows/winsock/winsock.factor | 5 ++- basis/x11/windows/windows.factor | 10 +++--- basis/x11/xlib/xlib.factor | 7 ++-- extra/fullscreen/fullscreen.factor | 10 +++--- extra/io/serial/unix/bsd/bsd.factor | 5 +-- extra/io/serial/unix/unix-tests.factor | 11 ++++--- extra/io/serial/unix/unix.factor | 5 +-- extra/model-viewer/model-viewer.factor | 6 ++-- extra/webkit-demo/webkit-demo.factor | 8 ++--- 39 files changed, 168 insertions(+), 171 deletions(-) diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor index ec5581d463..4ec362f0fc 100644 --- a/basis/core-foundation/file-descriptors/file-descriptors.factor +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ; +USING: alien.c-types alien.syntax kernel math.bitwise core-foundation +literals ; IN: core-foundation.file-descriptors TYPEDEF: void* CFFileDescriptorRef @@ -25,7 +26,7 @@ FUNCTION: void CFFileDescriptorEnableCallBacks ( ) ; : enable-all-callbacks ( fd -- ) - { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags + flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } CFFileDescriptorEnableCallBacks ; : ( fd callback -- handle ) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index f3f759115c..82b8191621 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.destructors alien.syntax accessors destructors fry kernel math math.bitwise sequences libc colors images images.memory core-graphics.types core-foundation.utilities -opengl.gl ; +opengl.gl literals ; IN: core-graphics ! CGImageAlphaInfo @@ -121,8 +121,7 @@ FUNCTION: uint GetCurrentButtonState ( ) ; > close-file ; M: kqueue-mx add-input-callback ( thread fd mx -- ) [ call-next-method ] [ - [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip + [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip register-kevent ] 2bi ; M: kqueue-mx add-output-callback ( thread fd mx -- ) [ call-next-method ] [ - [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip + [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip register-kevent ] 2bi ; diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor index 6022e91efd..53a67bbeab 100644 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types alien.data alien.syntax arrays continuations destructors generic io.mmap io.ports io.backend.windows io.files.windows kernel libc locals math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 windows.types io.backend system accessors -io.backend.windows.privileges classes.struct windows.errors ; +io.backend.windows.privileges classes.struct windows.errors literals ; IN: io.backend.windows.nt.privileges TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES @@ -11,7 +11,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES ! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ : (open-process-token) ( handle -- handle ) - { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE + flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE [ OpenProcessToken win32-error=0/f ] keep *void* ; : open-process-token ( -- handle ) diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 6ec2ec4dc5..0e0a803679 100644 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -5,7 +5,7 @@ io.buffers io.files io.ports io.binary io.timeouts system strings kernel math namespaces sequences windows.errors windows.kernel32 windows.shell32 windows.types splitting continuations math.bitwise accessors init sets assocs -classes.struct classes ; +classes.struct classes literals ; IN: io.backend.windows TUPLE: win32-handle < disposable handle ; @@ -43,12 +43,12 @@ HOOK: add-completion io-backend ( port -- ) |dispose dup add-completion ; -: share-mode ( -- n ) - { +CONSTANT: share-mode + flags{ FILE_SHARE_READ FILE_SHARE_WRITE FILE_SHARE_DELETE - } flags ; foldable + } : default-security-attributes ( -- obj ) SECURITY_ATTRIBUTES diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 77d7f2d1b2..0cc8aaa0e4 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -4,11 +4,10 @@ USING: accessors alien.c-types alien.strings combinators continuations destructors fry io io.backend io.backend.unix io.directories io.encodings.binary io.encodings.utf8 io.files io.pathnames io.files.types kernel math.bitwise sequences system -unix unix.stat vocabs.loader classes.struct unix.ffi ; +unix unix.stat vocabs.loader classes.struct unix.ffi literals ; IN: io.directories.unix -: touch-mode ( -- n ) - { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable +CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL } M: unix touch-file ( path -- ) normalize-path diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor index ec72d9128b..cd60e3d4b8 100644 --- a/basis/io/files/unique/unix/unix.factor +++ b/basis/io/files/unique/unix/unix.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.ports io.backend.unix math.bitwise -unix system io.files.unique unix.ffi ; +unix system io.files.unique unix.ffi literals ; IN: io.files.unique.unix -: open-unique-flags ( -- flags ) - { O_RDWR O_CREAT O_EXCL } flags ; +CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL } M: unix (touch-unique-file) ( path -- ) open-unique-flags file-mode open-file close-file ; diff --git a/basis/io/files/unix/unix-tests.factor b/basis/io/files/unix/unix-tests.factor index 93e499a576..06f7473aed 100644 --- a/basis/io/files/unix/unix-tests.factor +++ b/basis/io/files/unix/unix-tests.factor @@ -2,7 +2,7 @@ USING: tools.test io.files io.files.temp io.pathnames io.directories io.files.info io.files.info.unix continuations kernel io.files.unix math.bitwise calendar accessors math.functions math unix.users unix.groups arrays sequences -grouping io.pathnames.private ; +grouping io.pathnames.private literals ; IN: io.files.unix.tests [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test @@ -45,7 +45,7 @@ IN: io.files.unix.tests prepare-test-file [ t ] -[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test +[ test-file flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions perms OCT: 777 = ] unit-test [ t ] [ test-file user-read? ] unit-test [ t ] [ test-file user-write? ] unit-test @@ -85,7 +85,7 @@ prepare-test-file [ f ] [ test-file file-info other-read? ] unit-test [ t ] -[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test +[ test-file flags{ USER-ALL GROUP-ALL OTHER-EXECUTE } set-file-permissions perms OCT: 771 = ] unit-test prepare-test-file diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index bf0a21f997..e695345125 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: unix byte-arrays kernel io.backend.unix math.bitwise io.ports io.files io.files.private io.pathnames environment -destructors system unix.ffi ; +destructors system unix.ffi literals ; IN: io.files.unix M: unix cwd ( -- path ) @@ -12,15 +12,14 @@ M: unix cwd ( -- path ) M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; -: read-flags ( -- n ) O_RDONLY ; inline +CONSTANT: read-flags flags{ O_RDONLY } -: open-read ( path -- fd ) O_RDONLY file-mode open-file ; +: open-read ( path -- fd ) read-flags file-mode open-file ; M: unix (file-reader) ( path -- stream ) open-read init-fd ; -: write-flags ( -- n ) - { O_WRONLY O_CREAT O_TRUNC } flags ; inline +CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC } : open-write ( path -- fd ) write-flags file-mode open-file ; @@ -28,8 +27,7 @@ M: unix (file-reader) ( path -- stream ) M: unix (file-writer) ( path -- stream ) open-write init-fd ; -: append-flags ( -- n ) - { O_WRONLY O_APPEND O_CREAT } flags ; inline +CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT } : open-append ( path -- fd ) [ diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index c4c848cb64..4fc2057a74 100644 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -6,7 +6,8 @@ io.backend.windows kernel math splitting fry alien.strings windows windows.kernel32 windows.time windows.types calendar combinators math.functions sequences namespaces make words system destructors accessors math.bitwise continuations -windows.errors arrays byte-arrays generalizations alien.data ; +windows.errors arrays byte-arrays generalizations alien.data +literals ; IN: io.files.windows : open-file ( path access-mode create-mode flags -- handle ) @@ -16,7 +17,7 @@ IN: io.files.windows ] with-destructors ; : open-r/w ( path -- win32-file ) - { GENERIC_READ GENERIC_WRITE } flags + flags{ GENERIC_READ GENERIC_WRITE } OPEN_EXISTING 0 open-file ; : open-read ( path -- win32-file ) @@ -29,7 +30,7 @@ IN: io.files.windows GENERIC_WRITE OPEN_ALWAYS 0 open-file ; : open-existing ( path -- win32-file ) - { GENERIC_READ GENERIC_WRITE } flags + flags{ GENERIC_READ GENERIC_WRITE } share-mode f OPEN_EXISTING @@ -38,7 +39,7 @@ IN: io.files.windows : maybe-create-file ( path -- win32-file ? ) #! return true if file was just created - { GENERIC_READ GENERIC_WRITE } flags + flags{ GENERIC_READ GENERIC_WRITE } share-mode f OPEN_ALWAYS diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index f426201b06..84378efeb8 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors destructors io.backend.unix io.mmap +USING: accessors destructors io.backend.unix io.mmap literals io.mmap.private kernel locals math.bitwise system unix unix.ffi ; IN: io.mmap.unix @@ -12,13 +12,13 @@ IN: io.mmap.unix ] with-destructors ; M: unix (mapped-file-r/w) - { PROT_READ PROT_WRITE } flags - { MAP_FILE MAP_SHARED } flags + flags{ PROT_READ PROT_WRITE } + flags{ MAP_FILE MAP_SHARED } O_RDWR mmap-open ; M: unix (mapped-file-reader) - { PROT_READ } flags - { MAP_FILE MAP_SHARED } flags + flags{ PROT_READ } + flags{ MAP_FILE MAP_SHARED } O_RDONLY mmap-open ; M: unix close-mapped-file ( mmap -- ) diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index e3e3116b59..b1191082b3 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.backend.windows io.files.windows io.backend.windows.privileges io.mmap.private kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system -accessors locals windows.errors ; +accessors locals windows.errors literals ; IN: io.mmap.windows : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) @@ -29,9 +29,9 @@ C: win32-mapped-file M: windows (mapped-file-r/w) [ - { GENERIC_WRITE GENERIC_READ } flags + flags{ GENERIC_WRITE GENERIC_READ } OPEN_ALWAYS - { PAGE_READWRITE SEC_COMMIT } flags + flags{ PAGE_READWRITE SEC_COMMIT } FILE_MAP_ALL_ACCESS mmap-open -rot ] with-destructors ; @@ -40,7 +40,7 @@ M: windows (mapped-file-reader) [ GENERIC_READ OPEN_ALWAYS - { PAGE_READONLY SEC_COMMIT } flags + flags{ PAGE_READONLY SEC_COMMIT } FILE_MAP_READ mmap-open -rot ] with-destructors ; diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index 31442b7f0b..9b2440aec8 100644 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -5,7 +5,7 @@ io.files io.pathnames io.buffers io.ports io.timeouts io.backend.unix io.encodings.utf8 unix.linux.inotify assocs namespaces make threads continuations init math math.bitwise sets alien alien.strings alien.c-types vocabs.loader accessors -system hashtables destructors unix classes.struct ; +system hashtables destructors unix classes.struct literals ; FROM: namespaces => set ; IN: io.monitors.linux @@ -65,13 +65,13 @@ M: linux-monitor dispose* ( monitor -- ) tri ; : ignore-flags? ( mask -- ? ) - { + flags{ IN_DELETE_SELF IN_MOVE_SELF IN_UNMOUNT IN_Q_OVERFLOW IN_IGNORED - } flags bitand 0 > ; + } bitand 0 > ; : parse-action ( mask -- changed ) [ diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index 4d061cbb1a..e6a055a9d6 100644 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -5,7 +5,7 @@ locals kernel math assocs namespaces make continuations sequences hashtables sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.backend.windows io.backend.windows.nt io.files.windows.nt io.monitors io.ports -io.buffers io.files io.timeouts io.encodings.string +io.buffers io.files io.timeouts io.encodings.string literals io.encodings.utf16n io windows.errors windows.kernel32 windows.types io.pathnames classes.struct ; IN: io.monitors.windows.nt @@ -16,7 +16,7 @@ IN: io.monitors.windows.nt share-mode f OPEN_EXISTING - { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags + flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } f CreateFile opened-file ; diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor index 7fce8b4de2..f87a98ab91 100644 --- a/basis/io/pipes/windows/nt/nt.factor +++ b/basis/io/pipes/windows/nt/nt.factor @@ -10,7 +10,7 @@ IN: io.pipes.windows.nt ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py : create-named-pipe ( name -- handle ) - { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags + flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } PIPE_TYPE_BYTE 1 4096 @@ -21,7 +21,7 @@ IN: io.pipes.windows.nt : open-other-end ( name -- handle ) GENERIC_WRITE - { FILE_SHARE_READ FILE_SHARE_WRITE } flags + flags{ FILE_SHARE_READ FILE_SHARE_WRITE } default-security-attributes OPEN_EXISTING FILE_FLAG_OVERLAPPED diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index a464d75b22..6fcf8a5e07 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel multiline ; +USING: help.markup help.syntax kernel multiline sequences ; IN: literals HELP: $ @@ -62,6 +62,19 @@ ${ five six 7 } . { POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words +HELP: flags{ +{ $values { "values" sequence } } +{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." } +{ $examples + { $example "USING: literals kernel prettyprint ;" + "IN: scratchpad" + "CONSTANT: x HEX: 1" + "flags{ HEX: 20 x BIN: 100 } .h" + "25" + } +} ; + + ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." { $example """ diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index d7256a64b1..4357198db6 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -1,4 +1,4 @@ -USING: kernel literals math tools.test ; +USING: accessors kernel literals math tools.test ; IN: literals.tests << @@ -27,3 +27,16 @@ CONSTANT: constant-a 3 : sixty-nine ( -- a b ) 6 9 ; [ { 6 9 } ] [ ${ sixty-nine } ] unit-test + +CONSTANT: a 1 +CONSTANT: b 2 +ALIAS: c b +ALIAS: d c + +CONSTANT: foo flags{ a b d } + +[ 3 ] [ foo ] unit-test +[ 3 ] [ flags{ a b d } ] unit-test +\ foo def>> must-infer + +[ 1 ] [ flags{ 1 } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index 3e541a80ce..42a7ab9668 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -25,6 +25,7 @@ SYNTAX: $ scan-word expand-literal >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; SYNTAX: ${ \ } [ expand-literals ] parse-literal ; SYNTAX: flags{ - "}" [ parse-word ] map-tokens - expand-literals - 0 [ bitor ] reduce suffix! ; + \ } [ + expand-literals + 0 [ bitor ] reduce + ] parse-literal ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index ee94479b46..4024953070 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -135,18 +135,6 @@ HELP: clear-bit } } ; -HELP: flags -{ $values { "values" sequence } } -{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." } -{ $examples - { $example "USING: math.bitwise kernel prettyprint ;" - "IN: scratchpad" - "CONSTANT: x HEX: 1" - "{ HEX: 20 x BIN: 100 } flags .h" - "25" - } -} ; - HELP: symbols>flags { $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } } { $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." } @@ -408,7 +396,6 @@ $nl } "Bitfields:" { $subsections - flags "math-bitfields" } ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index a5919d3ec3..93d2d9e882 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -1,6 +1,6 @@ USING: accessors math math.bitwise tools.test kernel words specialized-arrays alien.c-types math.vectors.simd -sequences destructors libc ; +sequences destructors libc literals ; SPECIALIZED-ARRAY: int IN: math.bitwise.tests @@ -23,17 +23,6 @@ IN: math.bitwise.tests : test-1+ ( x -- y ) 1 + ; [ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test -CONSTANT: a 1 -CONSTANT: b 2 - -: foo ( -- flags ) { a b } flags ; - -[ 3 ] [ foo ] unit-test -[ 3 ] [ { a b } flags ] unit-test -\ foo def>> must-infer - -[ 1 ] [ { 1 } flags ] unit-test - [ 8 ] [ 0 3 toggle-bit ] unit-test [ 0 ] [ 8 3 toggle-bit ] unit-test diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 15db425137..cd38c8513c 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -44,10 +44,6 @@ IN: math.bitwise : W- ( x y -- z ) - 64 bits ; inline : W* ( x y -- z ) * 64 bits ; inline -! flags -MACRO: flags ( values -- ) - [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; - : symbols>flags ( symbols assoc -- flag-bits ) [ at ] curry map 0 [ bitor ] reduce ; diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index bfd59cde25..96d235d271 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax combinators kernel system namespaces assocs parser lexer sequences words -quotations math.bitwise alien.libraries ; +quotations math.bitwise alien.libraries literals ; IN: openssl.libssl @@ -258,15 +258,14 @@ CONSTANT: SSL_SESS_CACHE_OFF HEX: 0000 CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001 CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002 -: SSL_SESS_CACHE_BOTH ( -- n ) - { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline +CONSTANT: SSL_SESS_CACHE_BOTH flags{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 -: SSL_SESS_CACHE_NO_INTERNAL ( -- n ) - { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline +CONSTANT: SSL_SESS_CACHE_NO_INTERNAL + flags{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } ! =============================================== ! x509_vfy.h diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 30b169bfed..72b908a32f 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -36,7 +36,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer" ] if ; : create-crypto-context ( provider type -- handle ) - { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags + flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } (acquire-crypto-context) win32-error=0/f *void* ; ERROR: acquire-crypto-context-failed provider type ; diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 8a4ae9853f..c0829e5c8d 100644 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -628,7 +628,7 @@ M: windows-ui-backend do-events WNDCLASSEX f GetModuleHandle class-name-ptr pick GetClassInfoEx 0 = [ WNDCLASSEX heap-size >>cbSize - { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style + flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style ui-wndproc >>lpfnWndProc 0 >>cbClsExtra 0 >>cbWndExtra @@ -811,8 +811,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- ) f ClipCursor drop 1 ShowCursor drop ; -: fullscreen-flags ( -- n ) - { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline +CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME } : enter-fullscreen ( world -- ) handle>> hWnd>> @@ -838,7 +837,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- ) [ f over hwnd>RECT get-RECT-dimensions - { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags + flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } SetWindowPos win32-error=0/f ] [ SW_RESTORE ShowWindow win32-error=0/f ] diff --git a/basis/unix/linux/inotify/inotify.factor b/basis/unix/linux/inotify/inotify.factor index c296cc8166..947191e7dd 100644 --- a/basis/unix/linux/inotify/inotify.factor +++ b/basis/unix/linux/inotify/inotify.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax math math.bitwise classes.struct ; +USING: alien.c-types alien.syntax math math.bitwise classes.struct +literals ; IN: unix.linux.inotify STRUCT: inotify-event @@ -27,8 +28,8 @@ CONSTANT: IN_UNMOUNT HEX: 2000 ! Backing fs was unmounted CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored -: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close -: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves +CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE } +CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO } CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link @@ -36,20 +37,20 @@ CONSTANT: IN_MASK_ADD HEX: 20000000 ! add to the mask of an already existing w CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once -: IN_CHANGE_EVENTS ( -- n ) - { +CONSTANT: IN_CHANGE_EVENTS + flags{ IN_MODIFY IN_ATTRIB IN_MOVED_FROM IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF IN_MOVE_SELF - } flags ; foldable + } -: IN_ALL_EVENTS ( -- n ) - { +CONSTANT: IN_ALL_EVENTS + flags{ IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF IN_MOVE_SELF - } flags ; foldable + } FUNCTION: int inotify_init ( ) ; FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ; diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 75b231da96..b5ae2c2223 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -3,7 +3,7 @@ USING: alien.c-types io.encodings.utf8 io.encodings.string kernel sequences unix.stat accessors unix combinators math grouping system alien.strings math.bitwise alien.syntax -unix.types classes.struct unix.ffi ; +unix.types classes.struct unix.ffi literals ; IN: unix.statfs.macosx CONSTANT: MNT_RDONLY HEX: 00000001 @@ -29,8 +29,8 @@ CONSTANT: MNT_MULTILABEL HEX: 04000000 CONSTANT: MNT_NOATIME HEX: 10000000 ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP -: MNT_VISFLAGMASK ( -- n ) - { +CONSTANT: MNT_VISFLAGMASK + flags{ MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC MNT_NOSUID MNT_NODEV MNT_UNION MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE @@ -38,14 +38,13 @@ ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME - } flags ; inline + } CONSTANT: MNT_UPDATE HEX: 00010000 CONSTANT: MNT_RELOAD HEX: 00040000 CONSTANT: MNT_FORCE HEX: 00080000 -: MNT_CMDFLAGS ( -- n ) - { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline +CONSTANT: MNT_CMDFLAGS flags{ MNT_UPDATE MNT_RELOAD MNT_FORCE } CONSTANT: VFS_GENERIC 0 CONSTANT: VFS_NUMMNTOPS 1 diff --git a/basis/windows/directx/d3d9types/d3d9types.factor b/basis/windows/directx/d3d9types/d3d9types.factor index dc02849553..618d3c79e5 100644 --- a/basis/windows/directx/d3d9types/d3d9types.factor +++ b/basis/windows/directx/d3d9types/d3d9types.factor @@ -1,5 +1,5 @@ USING: alien.syntax windows.types classes.struct math alien.c-types -math.bitwise kernel locals windows.kernel32 ; +math.bitwise kernel locals windows.kernel32 literals ; IN: windows.directx.d3d9types TYPEDEF: DWORD D3DCOLOR @@ -54,19 +54,21 @@ CONSTANT: D3DCS_PLANE3 HEX: 00000200 CONSTANT: D3DCS_PLANE4 HEX: 00000400 CONSTANT: D3DCS_PLANE5 HEX: 00000800 -: D3DCS_ALL ( -- n ) - { D3DCS_LEFT - D3DCS_RIGHT - D3DCS_TOP - D3DCS_BOTTOM - D3DCS_FRONT - D3DCS_BACK - D3DCS_PLANE0 - D3DCS_PLANE1 - D3DCS_PLANE2 - D3DCS_PLANE3 - D3DCS_PLANE4 - D3DCS_PLANE5 } flags ; inline +CONSTANT: D3DCS_ALL + flags{ + D3DCS_LEFT + D3DCS_RIGHT + D3DCS_TOP + D3DCS_BOTTOM + D3DCS_FRONT + D3DCS_BACK + D3DCS_PLANE0 + D3DCS_PLANE1 + D3DCS_PLANE2 + D3DCS_PLANE3 + D3DCS_PLANE4 + D3DCS_PLANE5 + } STRUCT: D3DCLIPSTATUS9 { ClipUnion DWORD } @@ -777,8 +779,7 @@ CONSTANT: D3DVS_SWIZZLE_MASK HEX: 00FF0000 : D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline : D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline -: D3DVS_NOSWIZZLE ( -- n ) - { D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } flags ; inline +CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } CONSTANT: D3DSP_SWIZZLE_SHIFT 16 CONSTANT: D3DSP_SWIZZLE_MASK HEX: 00FF0000 diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 67757d05d2..a22b6ec007 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.data kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays literals windows.types specialized-arrays ; +arrays literals windows.types specialized-arrays literals ; SPECIALIZED-ARRAY: TCHAR IN: windows.errors @@ -705,10 +705,10 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ERROR: error-message-failed id ; :: n>win32-error-string ( id -- string ) - { + flags{ FORMAT_MESSAGE_FROM_SYSTEM FORMAT_MESSAGE_ARGUMENT_ARRAY - } flags + } f id LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 43307cb6ba..93784ea370 100644 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax alien.destructors -kernel windows.types math.bitwise ; +kernel windows.types math.bitwise literals ; IN: windows.gdi32 CONSTANT: BI_RGB 0 @@ -818,7 +818,7 @@ CONSTANT: TA_RIGHT 2 CONSTANT: TA_RTLREADING 256 CONSTANT: TA_NOUPDATECP 0 CONSTANT: TA_UPDATECP 1 -: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable +CONSTANT: TA_MASK flags{ TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } CONSTANT: VTA_BASELINE 24 CONSTANT: VTA_CENTER 6 ALIAS: VTA_LEFT TA_BOTTOM diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 1c23c36071..54d31bb12b 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -33,18 +33,17 @@ CONSTANT: WS_MINIMIZEBOX HEX: 00020000 CONSTANT: WS_MAXIMIZEBOX HEX: 00010000 ! Common window styles -: WS_OVERLAPPEDWINDOW ( -- n ) - { +CONSTANT: WS_OVERLAPPEDWINDOW + flags{ WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX - } flags ; foldable + } -: WS_POPUPWINDOW ( -- n ) - { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable +CONSTANT: WS_POPUPWINDOW flags{ WS_POPUP WS_BORDER WS_SYSMENU } ALIAS: WS_CHILDWINDOW WS_CHILD @@ -76,11 +75,11 @@ CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000 CONSTANT: WS_EX_STATICEDGE HEX: 00020000 CONSTANT: WS_EX_APPWINDOW HEX: 00040000 -: WS_EX_OVERLAPPEDWINDOW ( -- n ) - WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable +CONSTANT: WS_EX_OVERLAPPEDWINDOW + flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE } -: WS_EX_PALETTEWINDOW ( -- n ) - { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable +CONSTANT: WS_EX_PALETTEWINDOW + flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } CONSTANT: CS_VREDRAW HEX: 0001 CONSTANT: CS_HREDRAW HEX: 0002 diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index b58cbcacbd..49a3d6e9fa 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel literals math sequences windows.types windows.kernel32 windows.errors math.bitwise io.encodings.utf16n -classes.struct windows.com.syntax init ; +classes.struct windows.com.syntax init literals ; FROM: alien.c-types => short ; IN: windows.winsock @@ -73,8 +73,7 @@ CONSTANT: AI_PASSIVE 1 CONSTANT: AI_CANONNAME 2 CONSTANT: AI_NUMERICHOST 4 -: AI_MASK ( -- n ) - { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline +CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } CONSTANT: NI_NUMERICHOST 1 CONSTANT: NI_NUMERICSERV 2 diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index ad0a8b11a6..7b7ae8b106 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -5,15 +5,15 @@ namespaces sequences x11 x11.xlib x11.constants x11.glx arrays fry classes.struct ; IN: x11.windows -: create-window-mask ( -- n ) - { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; +CONSTANT: create-window-mask + flags{ CWBackPixel CWBorderPixel CWColormap CWEventMask } : create-colormap ( visinfo -- colormap ) [ dpy get root get ] dip visual>> AllocNone XCreateColormap ; -: event-mask ( -- n ) - { +CONSTANT: event-mask + flags{ ExposureMask StructureNotifyMask KeyPressMask @@ -25,7 +25,7 @@ IN: x11.windows EnterWindowMask LeaveWindowMask PropertyChangeMask - } flags ; + } : window-attributes ( visinfo -- attributes ) XSetWindowAttributes diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 1c5ff2e3ef..ac9e5591dc 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -12,7 +12,8 @@ ! and note the section. USING: accessors kernel arrays alien alien.c-types alien.data alien.strings alien.syntax classes.struct math math.bitwise words -sequences namespaces continuations io io.encodings.ascii x11.syntax ; +sequences namespaces continuations io io.encodings.ascii x11.syntax +literals ; FROM: alien.c-types => short ; IN: x11.xlib @@ -1134,8 +1135,8 @@ X-FUNCTION: Status XWithdrawWindow ( : PAspect ( -- n ) 7 2^ ; inline : PBaseSize ( -- n ) 8 2^ ; inline : PWinGravity ( -- n ) 9 2^ ; inline -: PAllHints ( -- n ) - { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable +CONSTANT: PAllHints + flags{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } STRUCT: XSizeHints { flags long } diff --git a/extra/fullscreen/fullscreen.factor b/extra/fullscreen/fullscreen.factor index a233d6f4f5..458ef3d51e 100755 --- a/extra/fullscreen/fullscreen.factor +++ b/extra/fullscreen/fullscreen.factor @@ -16,7 +16,7 @@ IN: fullscreen :: (monitor-info>devmodes) ( monitor-info n -- ) DEVMODE DEVMODE heap-size >>dmSize - { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields + flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields :> devmode monitor-info szDevice>> @@ -73,11 +73,11 @@ ERROR: display-change-error n ; : set-fullscreen-styles ( hwnd -- ) [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ] - [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ; + [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ; : set-non-fullscreen-styles ( hwnd -- ) [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ] - [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ; + [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ; ERROR: unsupported-resolution triple ; @@ -92,10 +92,10 @@ ERROR: unsupported-resolution triple ; hwnd f desktop-monitor-info rcMonitor>> slots{ left top } first2 triple first2 - { + flags{ SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER SWP_NOREPOSITION SWP_NOZORDER - } flags + } SetWindowPos win32-error=0/f ; :: enable-fullscreen ( triple hwnd -- rect ) diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor index dbb013aca0..14d4f515ae 100644 --- a/extra/io/serial/unix/bsd/bsd.factor +++ b/extra/io/serial/unix/bsd/bsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitwise sequences system io.serial ; +USING: alien.syntax kernel math.bitwise sequences system io.serial +literals ; IN: io.serial.unix M: bsd lookup-baud ( m -- n ) @@ -60,7 +61,7 @@ CONSTANT: HUPCL HEX: 00004000 CONSTANT: CLOCAL HEX: 00008000 CONSTANT: CCTS_OFLOW HEX: 00010000 CONSTANT: CRTS_IFLOW HEX: 00020000 -: CRTSCTS ( -- n ) { CCTS_OFLOW CRTS_IFLOW } flags ; inline +CONSTANT: CRTSCTS flags{ CCTS_OFLOW CRTS_IFLOW } CONSTANT: CDTR_IFLOW HEX: 00040000 CONSTANT: CDSR_OFLOW HEX: 00080000 CONSTANT: CCAR_OFLOW HEX: 00100000 diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor index f4c0c6b45a..422844ab82 100644 --- a/extra/io/serial/unix/unix-tests.factor +++ b/extra/io/serial/unix/unix-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.bitwise io.serial io.serial.unix ; +USING: accessors kernel math.bitwise io.serial io.serial.unix +literals ; IN: io.serial.unix : serial-obj ( -- obj ) @@ -10,10 +11,10 @@ IN: io.serial.unix ! "/dev/ttyd0" >>path ! freebsd ! "/dev/ttyU0" >>path ! openbsd 19200 >>baud - { IGNPAR ICRNL } flags >>iflag - { } flags >>oflag - { CS8 CLOCAL CREAD } flags >>cflag - { ICANON } flags >>lflag ; + flags{ IGNPAR ICRNL } >>iflag + flags{ } >>oflag + flags{ CS8 CLOCAL CREAD } >>cflag + flags{ ICANON } >>lflag ; : serial-test ( -- serial ) serial-obj diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor index 6c0de55ec8..fc613da423 100644 --- a/extra/io/serial/unix/unix.factor +++ b/extra/io/serial/unix/unix.factor @@ -3,7 +3,8 @@ USING: accessors alien.c-types alien.syntax alien.data classes.struct combinators io.ports io.streams.duplex system kernel math math.bitwise vocabs.loader io.serial -io.serial.unix.termios io.backend.unix unix unix.ffi ; +io.serial.unix.termios io.backend.unix unix unix.ffi +literals ; IN: io.serial.unix << { @@ -33,7 +34,7 @@ FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ; M: unix open-serial ( serial -- serial' ) dup - path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file + path>> flags{ O_RDWR O_NOCTTY O_NDELAY } file-mode open-file fd>duplex-stream >>stream ; : serial-fd ( serial -- fd ) diff --git a/extra/model-viewer/model-viewer.factor b/extra/model-viewer/model-viewer.factor index 061ce07d1e..f1b184f220 100644 --- a/extra/model-viewer/model-viewer.factor +++ b/extra/model-viewer/model-viewer.factor @@ -11,7 +11,7 @@ ui.gadgets.worlds ui.pixel-formats specialized-arrays specialized-vectors literals fry sequences.deep destructors math.bitwise opengl.gl game.models game.models.obj game.models.loader game.models.collada -prettyprint images.tga ; +prettyprint images.tga literals ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-VECTOR: uint @@ -164,9 +164,9 @@ TUPLE: vbo 0 0 0 0 glClearColor 1 glClearDepth HEX: ffffffff glClearStencil - { GL_COLOR_BUFFER_BIT + flags{ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT - GL_STENCIL_BUFFER_BIT } flags glClear ; + GL_STENCIL_BUFFER_BIT } glClear ; : draw-model ( world -- ) clear-screen diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor index e6178a55c3..eb24d035dc 100644 --- a/extra/webkit-demo/webkit-demo.factor +++ b/extra/webkit-demo/webkit-demo.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows -core-graphics.types kernel math.bitwise ; +core-graphics.types kernel math.bitwise literals ; IN: webkit-demo FRAMEWORK: /System/Library/Frameworks/WebKit.framework @@ -13,13 +13,13 @@ IMPORT: WebView WebView -> alloc rect f f -> initWithFrame:frameName:groupName: ; -: window-style ( -- n ) - { +CONSTANT: window-style ( -- n ) + flags{ NSClosableWindowMask NSMiniaturizableWindowMask NSResizableWindowMask NSTitledWindowMask - } flags ; + } : ( -- id ) rect window-style ; From 8a46a201fcc12ed2c465f6c179c5ac973a796c26 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 15:37:57 -0500 Subject: [PATCH 093/123] Fix bootstrap --- basis/core-graphics/core-graphics.factor | 19 ++++++++++--------- basis/x11/windows/windows.factor | 2 +- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 82b8191621..1b7693da14 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -16,15 +16,15 @@ kCGImageAlphaFirst kCGImageAlphaNoneSkipLast kCGImageAlphaNoneSkipFirst ; -: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline -: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline +CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f +CONSTANT: kCGBitmapFloatComponents 256 -: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline -: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline -: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline -: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline -: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline -: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline +CONSTANT: kCGBitmapByteOrderMask HEX: 7000 +CONSTANT: kCGBitmapByteOrderDefault 0 +CONSTANT: kCGBitmapByteOrder16Little 4096 +CONSTANT: kCGBitmapByteOrder32Little 8192 +CONSTANT: kCGBitmapByteOrder16Big 12288 +CONSTANT: kCGBitmapByteOrder32Big 16384 : kCGBitmapByteOrder16Host ( -- n ) little-endian? @@ -121,7 +121,8 @@ FUNCTION: uint GetCurrentButtonState ( ) ; Date: Thu, 1 Apr 2010 14:25:02 -0700 Subject: [PATCH 094/123] statically link factor executable to VM so dylib is only needed for embedding --- GNUmakefile | 14 ++++---------- vm/os-macosx.hpp | 2 +- vm/os-unix.cpp | 1 - 3 files changed, 5 insertions(+), 12 deletions(-) diff --git a/GNUmakefile b/GNUmakefile index 12ca388f87..9f93deedf2 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -169,22 +169,16 @@ macosx.app: factor mkdir -p $(BUNDLE)/Contents/Frameworks mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor ln -s Factor.app/Contents/MacOS/factor ./factor - cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE) - - install_name_tool \ - -change libfactor.dylib \ - @executable_path/../Frameworks/libfactor.dylib \ - Factor.app/Contents/MacOS/factor $(ENGINE): $(DLL_OBJS) $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS) -factor: $(EXE_OBJS) $(ENGINE) - $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ +factor: $(EXE_OBJS) $(DLL_OBJS) + $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \ $(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS) -factor-console: $(EXE_OBJS) $(ENGINE) - $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ +factor-console: $(EXE_OBJS) $(DLL_OBJS) + $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS) factor-ffi-test: $(FFI_TEST_LIBRARY) diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 8428f56998..4d4499461d 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -3,7 +3,7 @@ namespace factor #define VM_C_API extern "C" __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" -#define NULL_DLL "libfactor.dylib" +#define NULL_DLL NULL void early_init(); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index a8898eccab..60ac00fb39 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -46,7 +46,6 @@ void sleep_nanos(u64 nsec) void factor_vm::init_ffi() { - /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic Unix */ null_dll = dlopen(NULL_DLL,RTLD_LAZY); } From 6fdba565a146bb6ad3ca46ce817d8dcf473e9068 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 1 Apr 2010 14:26:56 -0700 Subject: [PATCH 095/123] update deploy backends not to include dll in deployed apps --- basis/tools/deploy/macosx/macosx.factor | 11 +++-------- basis/tools/deploy/windows/windows.factor | 4 ---- 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index c02642ba1d..4718e3792f 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -34,9 +34,6 @@ IN: tools.deploy.macosx "Contents/Info.plist" append-path write-plist ; -: copy-dll ( bundle-name -- ) - "Frameworks/libfactor.dylib" copy-bundle-dir ; - : copy-nib ( bundle-name -- ) deploy-ui? get [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir @@ -50,11 +47,9 @@ IN: tools.deploy.macosx : create-app-dir ( vocab bundle-name -- vm ) { [ - nip { - [ copy-dll ] - [ copy-nib ] - [ "Contents/Resources" append-path make-directories ] - } cleave + nip + [ copy-nib ] + [ "Contents/Resources" append-path make-directories ] bi ] [ copy-icns ] [ create-app-plist ] diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index f592ff2d69..7981859573 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -11,16 +11,12 @@ IN: tools.deploy.windows CONSTANT: app-icon-resource-id "APPICON" -: copy-dll ( bundle-name -- ) - "resource:factor.dll" swap copy-file-into ; - :: copy-vm ( executable bundle-name extension -- vm ) vm "." split1-last drop extension append bundle-name executable ".exe" append append-path [ copy-file ] keep ; : create-exe-dir ( vocab bundle-name -- vm ) - dup copy-dll deploy-console? get ".com" ".exe" ? copy-vm ; : open-in-explorer ( dir -- ) From 6bc8beb070620f8283bd30368767de14effc3aa0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 1 Apr 2010 14:44:18 -0700 Subject: [PATCH 096/123] tools.deploy.macosx: make sure Contents/Frameworks dir still gets created for apps that deploy third-party libraries --- basis/tools/deploy/macosx/macosx.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index 4718e3792f..446f453709 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -49,7 +49,8 @@ IN: tools.deploy.macosx [ nip [ copy-nib ] - [ "Contents/Resources" append-path make-directories ] bi + [ "Contents/Resources" append-path make-directories ] + [ "Contents/Frameworks" append-path make-directories ] tri ] [ copy-icns ] [ create-app-plist ] From bbe6b729bf243884474c38cb68639ac07d72b6ed Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 1 Apr 2010 15:11:52 -0700 Subject: [PATCH 097/123] =?UTF-8?q?tools.deploy:=20add=20a=20=C2=ABdeploy-?= =?UTF-8?q?image-only=C2=BB=20word=20that=20only=20builds=20the=20image=20?= =?UTF-8?q?file=20to=20a=20specified=20location?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- basis/tools/deploy/deploy-docs.factor | 9 ++++++++- basis/tools/deploy/deploy.factor | 7 +++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 976fc25357..169fdd501a 100755 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -18,6 +18,7 @@ $nl ARTICLE: "tools.deploy.usage" "Deploy tool usage" "Once the necessary deployment flags have been set, the application can be deployed:" { $subsections deploy } +{ $subsections deploy-image-only } "For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:" { $code "\"hello-ui\" deploy" } { $list @@ -61,4 +62,10 @@ ABOUT: "tools.deploy" HELP: deploy { $values { "vocab" "a vocabulary specifier" } } -{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image as " { $snippet { $emphasis "vocab" } ".image" } "." } ; +{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on." } ; + +HELP: deploy-image-only +{ $values { "vocab" "a vocabulary specifier" } { "image" "a pathname" } } +{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image to the location specified by " { $snippet "image" } ". This only builds the Factor image for the vocabulary; to create a complete packaged application, use " { $link deploy } "." } ; + +{ deploy deploy-image-only } related-words diff --git a/basis/tools/deploy/deploy.factor b/basis/tools/deploy/deploy.factor index e57cc1f04b..9430802803 100644 --- a/basis/tools/deploy/deploy.factor +++ b/basis/tools/deploy/deploy.factor @@ -1,13 +1,16 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: tools.deploy.backend system vocabs.loader kernel -combinators ; +combinators tools.deploy.config.editor ; IN: tools.deploy : deploy ( vocab -- ) deploy* ; +: deploy-image-only ( vocab image -- ) + [ vm ] 2dip swap dup deploy-config make-deploy-image drop ; + { { [ os macosx? ] [ "tools.deploy.macosx" ] } { [ os winnt? ] [ "tools.deploy.windows" ] } { [ os unix? ] [ "tools.deploy.unix" ] } -} cond require \ No newline at end of file +} cond require From 7a5a6c779e08687115a5a43e30721a0d19e2d454 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 1 Apr 2010 15:23:29 -0700 Subject: [PATCH 098/123] =?UTF-8?q?add=20note=20to=20deploy=20docs=20that?= =?UTF-8?q?=20=C2=ABdeploy=C2=BB=20creates=20a=20bundle=20directory=20with?= =?UTF-8?q?=20all=20the=20parts,=20and=20=C2=ABdeploy-image-only=C2=BB=20d?= =?UTF-8?q?eploys=20only=20the=20image?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- basis/tools/deploy/deploy-docs.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 169fdd501a..27c5bbccf1 100755 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -17,8 +17,7 @@ $nl ARTICLE: "tools.deploy.usage" "Deploy tool usage" "Once the necessary deployment flags have been set, the application can be deployed:" -{ $subsections deploy } -{ $subsections deploy-image-only } +{ $subsections deploy deploy-image-only } "For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:" { $code "\"hello-ui\" deploy" } { $list @@ -62,7 +61,7 @@ ABOUT: "tools.deploy" HELP: deploy { $values { "vocab" "a vocabulary specifier" } } -{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on." } ; +{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on. On Mac OS X, the deployment directory will be a standard " { $snippet ".app" } " bundle executable from Finder. To only generate the Factor image, use " { $link deploy-image-only } "." } ; HELP: deploy-image-only { $values { "vocab" "a vocabulary specifier" } { "image" "a pathname" } } From 51fd5e34e8fb74fddf99336abc5945c452f98125 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 18:48:25 -0500 Subject: [PATCH 099/123] Fix bootstrap on windows --- basis/io/pipes/windows/nt/nt.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor index f87a98ab91..d58e5e3d5f 100644 --- a/basis/io/pipes/windows/nt/nt.factor +++ b/basis/io/pipes/windows/nt/nt.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.backend.windows libc windows.types math.bitwise windows.kernel32 windows namespaces make kernel sequences windows.errors assocs math.parser system -random combinators accessors io.pipes io.ports ; +random combinators accessors io.pipes io.ports literals ; IN: io.pipes.windows.nt ! This code is based on From 1b4b1a180c67e4ca4d4cd5007b1796082e7282a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 20:05:32 -0400 Subject: [PATCH 100/123] Some minor pointless optimizations --- basis/boxes/boxes.factor | 6 +-- .../concurrency/conditions/conditions.factor | 8 ++-- basis/concurrency/mailboxes/mailboxes.factor | 21 +++++---- basis/concurrency/messaging/messaging.factor | 20 +++++---- basis/dlists/dlists.factor | 2 +- basis/heaps/heaps.factor | 2 +- basis/threads/threads.factor | 44 +++++++------------ 7 files changed, 47 insertions(+), 56 deletions(-) diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 811c5addb0..a159e1402b 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -11,7 +11,7 @@ ERROR: box-full box ; : >box ( value box -- ) dup occupied>> - [ box-full ] [ t >>occupied (>>value) ] if ; + [ box-full ] [ t >>occupied (>>value) ] if ; inline ERROR: box-empty box ; @@ -19,10 +19,10 @@ ERROR: box-empty box ; dup occupied>> [ box-empty ] unless ; inline : box> ( box -- value ) - check-box [ f ] change-value f >>occupied drop ; + check-box [ f ] change-value f >>occupied drop ; inline : ?box ( box -- value/f ? ) - dup occupied>> [ box> t ] [ drop f f ] if ; + dup occupied>> [ box> t ] [ drop f f ] if ; inline : if-box? ( box quot -- ) [ ?box ] dip [ drop ] if ; inline diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 4a1c7d3370..2fb75226eb 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -4,10 +4,10 @@ USING: deques threads kernel arrays sequences alarms fry ; IN: concurrency.conditions : notify-1 ( deque -- ) - dup deque-empty? [ drop ] [ pop-back resume-now ] if ; + dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline : notify-all ( deque -- ) - [ resume-now ] slurp-deque ; + [ resume-now ] slurp-deque ; inline : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the @@ -23,7 +23,7 @@ IN: concurrency.conditions ERROR: wait-timeout ; : queue ( queue -- ) - [ self ] dip push-front ; + [ self ] dip push-front ; inline : wait ( queue timeout status -- ) over [ @@ -31,4 +31,4 @@ ERROR: wait-timeout ; [ wait-timeout ] [ cancel-alarm ] if ] [ [ drop queue ] dip suspend drop - ] if ; + ] if ; inline diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index e245f93bd5..163873575c 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads locals fry ; IN: concurrency.mailboxes -TUPLE: mailbox threads data ; +TUPLE: mailbox { threads dlist } { data dlist } ; : ( -- mailbox ) mailbox new >>threads - >>data ; + >>data ; inline : mailbox-empty? ( mailbox -- bool ) - data>> deque-empty? ; + data>> deque-empty? ; inline -: mailbox-put ( obj mailbox -- ) +GENERIC: mailbox-put ( obj mailbox -- ) + +M: mailbox mailbox-put [ data>> push-front ] [ threads>> notify-all ] bi yield ; : wait-for-mailbox ( mailbox timeout -- ) - [ threads>> ] dip "mailbox" wait ; + [ threads>> ] dip "mailbox" wait ; inline :: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... ) mailbox data>> pred dlist-any? [ @@ -34,16 +36,17 @@ TUPLE: mailbox threads data ; 2dup wait-for-mailbox block-if-empty ] [ drop - ] if ; + ] if ; inline recursive : mailbox-peek ( mailbox -- obj ) data>> peek-back ; -: mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty data>> pop-back ; +GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj ) + +M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ; : mailbox-get ( mailbox -- obj ) - f mailbox-get-timeout ; + f mailbox-get-timeout ; inline : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 37965309e8..3f55b0969b 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -1,20 +1,22 @@ -! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! Copyright (C) 2005, 2010 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads concurrency.mailboxes continuations -namespaces assocs accessors summary fry ; +USING: kernel kernel.private threads concurrency.mailboxes +continuations namespaces assocs accessors summary fry ; IN: concurrency.messaging GENERIC: send ( message thread -- ) -: mailbox-of ( thread -- mailbox ) - dup mailbox>> [ ] [ - [ >>mailbox drop ] keep - ] ?if ; +GENERIC: mailbox-of ( thread -- mailbox ) + +M: thread mailbox-of + dup mailbox>> + [ { mailbox } declare ] + [ [ >>mailbox drop ] keep ] ?if ; inline M: thread send ( message thread -- ) - check-registered mailbox-of mailbox-put ; + mailbox-of mailbox-put ; -: my-mailbox ( -- mailbox ) self mailbox-of ; +: my-mailbox ( -- mailbox ) self mailbox-of ; inline : receive ( -- message ) my-mailbox mailbox-get ?linked ; diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 44140d3109..53e134fad9 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -29,7 +29,7 @@ TUPLE: dlist : ( -- search-deque ) 20 ; -M: dlist deque-empty? front>> not ; +M: dlist deque-empty? front>> not ; inline M: dlist-node node-value obj>> ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 677daca69d..28d18cb53a 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -35,7 +35,7 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; M: heap heap-empty? ( heap -- ? ) - data>> empty? ; + data>> empty? ; inline M: heap heap-size ( heap -- n ) data>> length ; diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 117e941aa7..404c8112fb 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -80,23 +80,13 @@ sleep-entry ; : thread-registered? ( thread -- ? ) id>> threads key? ; -ERROR: already-stopped thread ; - -: check-unregistered ( thread -- thread ) - dup thread-registered? [ already-stopped ] when ; - -ERROR: not-running thread ; - -: check-registered ( thread -- thread ) - dup thread-registered? [ not-running ] unless ; - > threads set-at ; + dup id>> threads set-at ; : unregister-thread ( thread -- ) - check-registered id>> threads delete-at ; + id>> threads delete-at ; : set-self ( thread -- ) 63 set-special-object ; inline @@ -106,7 +96,7 @@ PRIVATE> 65 special-object { dlist } declare ; inline : sleep-queue ( -- heap ) - 66 special-object { dlist } declare ; inline + 66 special-object { min-heap } declare ; inline : new-thread ( quot name class -- thread ) new @@ -120,16 +110,13 @@ PRIVATE> \ thread new-thread ; : resume ( thread -- ) - f >>state - check-registered run-queue push-front ; + f >>state run-queue push-front ; : resume-now ( thread -- ) - f >>state - check-registered run-queue push-back ; + f >>state run-queue push-back ; : resume-with ( obj thread -- ) - f >>state - check-registered 2array run-queue push-front ; + f >>state 2array run-queue push-front ; : sleep-time ( -- nanos/f ) { @@ -150,22 +137,19 @@ DEFER: stop >sleep-entry drop ; + dupd sleep-queue heap-push* >>sleep-entry drop ; -: expire-sleep? ( heap -- ? ) - dup heap-empty? +: expire-sleep? ( -- ? ) + sleep-queue dup heap-empty? [ drop f ] [ heap-peek nip nano-count <= ] if ; : expire-sleep ( thread -- ) f >>sleep-entry resume ; : expire-sleep-loop ( -- ) - sleep-queue - [ dup expire-sleep? ] - [ dup heap-pop drop expire-sleep ] - while - drop ; + [ expire-sleep? ] + [ sleep-queue heap-pop drop expire-sleep ] + while ; CONSTANT: [start] [ @@ -177,7 +161,9 @@ CONSTANT: [start] : no-runnable-threads ( -- ) die ; -: (next) ( obj thread -- obj' ) +GENERIC: (next) ( obj thread -- obj' ) + +M: thread (next) dup runnable>> [ context>> box> set-context ] [ t >>runnable drop [start] start-context ] if ; From eceabbc57e7ecd1ad6a406db4e65ed538185f169 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 20:06:18 -0400 Subject: [PATCH 101/123] compiler: new set-special-object intrinsic; more efficient special-object intrinsic --- .../cfg/alias-analysis/alias-analysis.factor | 8 +++--- .../cfg/instructions/instructions.factor | 14 +++++------ .../compiler/cfg/intrinsics/intrinsics.factor | 1 + .../compiler/cfg/intrinsics/misc/misc.factor | 25 +++++++++++++------ basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/tests/alien.factor | 11 +++++--- basis/cpu/architecture/architecture.factor | 6 +++-- basis/cpu/ppc/ppc.factor | 16 +++++------- basis/cpu/x86/32/32.factor | 9 ++++--- basis/cpu/x86/64/64.factor | 13 ++++++---- basis/cpu/x86/x86.factor | 15 +++++++---- 11 files changed, 72 insertions(+), 48 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 24433ad594..44326c179f 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; -M: ##vm-field-ptr insn-slot# field-name>> ; +M: ##vm-field insn-slot# offset>> ; +M: ##set-vm-field insn-slot# offset>> ; M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; +M: ##vm-field insn-object drop \ ##vm-field ; +M: ##set-vm-field insn-object drop \ ##vm-field ; : init-alias-analysis ( insns -- insns' ) H{ } clone histories set @@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; 0 ac-counter set next-ac heap-ac set - \ ##vm-field-ptr set-new-ac + \ ##vm-field set-new-ac \ ##alien-global set-new-ac dup local-live-in [ set-heap-ac ] each ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 678ce76860..c015cb640b 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -660,13 +660,13 @@ INSN: ##alien-global def: dst/int-rep literal: symbol library ; -INSN: ##vm-field-ptr -def: dst/int-rep -literal: field-name ; - INSN: ##vm-field def: dst/int-rep -literal: field-name ; +literal: offset ; + +INSN: ##set-vm-field +use: src/int-rep +literal: offset ; ! FFI INSN: ##alien-invoke @@ -835,8 +835,8 @@ UNION: ##allocation ##box-displaced-alien ; ! For alias analysis -UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ; -UNION: ##write ##set-slot ##set-slot-imm ; +UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; +UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; ! Instructions that kill all live vregs but cannot trigger GC UNION: partial-sync-insn diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 4ebc818b83..2b2ae7d160 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -32,6 +32,7 @@ IN: compiler.cfg.intrinsics { kernel.private:tag [ drop emit-tag ] } { kernel.private:context-object [ emit-context-object ] } { kernel.private:special-object [ emit-special-object ] } + { kernel.private:set-special-object [ emit-set-special-object ] } { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] } { math.private:fixnum+ [ drop emit-fixnum+ ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index 9731d2f6f5..da77bcaa09 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -1,30 +1,39 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces layouts sequences kernel math accessors compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.builder.blocks compiler.cfg.utilities ; -FROM: vm => context-field-offset ; +FROM: vm => context-field-offset vm-field-offset ; IN: compiler.cfg.intrinsics.misc : emit-tag ( -- ) ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; +: special-object-offset ( n -- offset ) + cells "special-objects" vm-field-offset + ; + : emit-special-object ( node -- ) dup node-input-infos first literal>> [ - "special-objects" ^^vm-field-ptr - ds-drop swap 0 ^^slot-imm + ds-drop + special-object-offset ^^vm-field ds-push ] [ emit-primitive ] ?if ; -: context-object-offset ( -- n ) - "context-objects" context-field-offset cell /i ; +: emit-set-special-object ( node -- ) + dup node-input-infos second literal>> [ + ds-drop + [ ds-pop ] dip special-object-offset ##set-vm-field + ] [ emit-primitive ] ?if ; + +: context-object-offset ( n -- n ) + cells "context-objects" context-field-offset + ; : emit-context-object ( node -- ) dup node-input-infos first literal>> [ - "ctx" ^^vm-field - ds-drop swap context-object-offset + 0 ^^slot-imm ds-push + "ctx" vm-field-offset ^^vm-field + ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push ] [ emit-primitive ] ?if ; : emit-identity-hashcode ( -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d82ced8a1d..4208fec0a7 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -210,8 +210,8 @@ CODEGEN: ##compare-imm %compare-imm CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##save-context %save-context -CODEGEN: ##vm-field-ptr %vm-field-ptr CODEGEN: ##vm-field %vm-field +CODEGEN: ##set-vm-field %set-vm-field CODEGEN: _fixnum-add %fixnum-add CODEGEN: _fixnum-sub %fixnum-sub diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 692dbee4c5..ceac1b094c 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -432,14 +432,17 @@ STRUCT: double-rect void { void* void* double-rect } "cdecl" [ "example" set-global 2drop ] alien-callback ; -: double-rect-test ( arg -- arg' ) - f f rot - double-rect-callback +: double-rect-test ( arg callback -- arg' ) + [ f f ] 2dip void { void* void* double-rect } "cdecl" alien-indirect "example" get-global ; [ 1.0 2.0 3.0 4.0 ] -[ 1.0 2.0 3.0 4.0 double-rect-test >double-rect< ] unit-test +[ + 1.0 2.0 3.0 4.0 + double-rect-callback double-rect-test + >double-rect< +] unit-test STRUCT: test_struct_14 { x1 double } diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index b617746a06..ad1a4be2eb 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -447,8 +447,10 @@ HOOK: %set-alien-double cpu ( ptr offset value -- ) HOOK: %set-alien-vector cpu ( ptr offset value rep -- ) HOOK: %alien-global cpu ( dst symbol library -- ) -HOOK: %vm-field cpu ( dst fieldname -- ) -HOOK: %vm-field-ptr cpu ( dst fieldname -- ) +HOOK: %vm-field cpu ( dst offset -- ) +HOOK: %set-vm-field cpu ( src offset -- ) + +: %context ( dst -- ) 0 %vm-field ; HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src slot temp1 temp2 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index dbc313052f..3fd0552a99 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -58,11 +58,7 @@ CONSTANT: vm-reg 15 : %load-vm-addr ( reg -- ) vm-reg MR ; -M: ppc %vm-field ( dst field -- ) - [ vm-reg ] dip vm-field-offset LWZ ; - -M: ppc %vm-field-ptr ( dst field -- ) - [ vm-reg ] dip vm-field-offset ADDI ; +M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ; GENERIC: loc-reg ( loc -- reg ) @@ -385,7 +381,7 @@ M: ppc %set-alien-float -rot STFS ; M: ppc %set-alien-double -rot STFD ; : load-zone-ptr ( reg -- ) - "nursery" %vm-field-ptr ; + vm-reg "nursery" vm-field-offset ADDI ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ; @@ -604,14 +600,14 @@ M: ppc %push-stack ( -- ) int-regs return-reg ds-reg 0 STW ; M: ppc %push-context-stack ( -- ) - 11 "ctx" %vm-field + 11 %context 12 11 "datastack" context-field-offset LWZ 12 12 4 ADDI 12 11 "datastack" context-field-offset STW int-regs return-reg 12 0 STW ; M: ppc %pop-context-stack ( -- ) - 11 "ctx" %vm-field + 11 %context 12 11 "datastack" context-field-offset LWZ int-regs return-reg 12 0 LWZ 12 12 4 SUBI @@ -677,12 +673,12 @@ M: ppc %box-large-struct ( n c-type -- ) "from_value_struct" f %alien-invoke ; M:: ppc %restore-context ( temp1 temp2 -- ) - temp1 "ctx" %vm-field + temp1 %context ds-reg temp1 "datastack" context-field-offset LWZ rs-reg temp1 "retainstack" context-field-offset LWZ ; M:: ppc %save-context ( temp1 temp2 -- ) - temp1 "ctx" %vm-field + temp1 %context 1 temp1 "callstack-top" context-field-offset STW ds-reg temp1 "datastack" context-field-offset STW rs-reg temp1 "retainstack" context-field-offset STW ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 09f1ecb32b..8b97eb9351 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -28,10 +28,13 @@ M: x86.32 %mov-vm-ptr ( reg -- ) 0 MOV 0 rc-absolute-cell rel-vm ; M: x86.32 %vm-field ( dst field -- ) - [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; + [ 0 [] MOV ] dip rc-absolute-cell rel-vm ; + +M: x86.32 %set-vm-field ( dst field -- ) + [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ; M: x86.32 %vm-field-ptr ( dst field -- ) - [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; + [ 0 MOV ] dip rc-absolute-cell rel-vm ; : local@ ( n -- op ) stack-frame get extra-stack-space dup 16 assert= + stack@ ; @@ -166,7 +169,7 @@ M: x86.32 %pop-stack ( n -- ) EAX swap ds-reg reg-stack MOV ; M: x86.32 %pop-context-stack ( -- ) - temp-reg "ctx" %vm-field + temp-reg %context EAX temp-reg "datastack" context-field-offset [+] MOV EAX EAX [] MOV temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 04f64f96b6..bea5d4da1f 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -43,11 +43,14 @@ M: x86.64 machine-registers M: x86.64 %mov-vm-ptr ( reg -- ) vm-reg MOV ; -M: x86.64 %vm-field ( dst field -- ) - [ vm-reg ] dip vm-field-offset [+] MOV ; +M: x86.64 %vm-field ( dst offset -- ) + [ vm-reg ] dip [+] MOV ; -M: x86.64 %vm-field-ptr ( dst field -- ) - [ vm-reg ] dip vm-field-offset [+] LEA ; +M: x86.64 %set-vm-field ( src offset -- ) + [ vm-reg ] dip [+] swap MOV ; + +M: x86.64 %vm-field-ptr ( dst offset -- ) + [ vm-reg ] dip [+] LEA ; : param@ ( n -- op ) reserved-stack-space + stack@ ; @@ -111,7 +114,7 @@ M: x86.64 %pop-stack ( n -- ) param-reg-0 swap ds-reg reg-stack MOV ; M: x86.64 %pop-context-stack ( -- ) - temp-reg "ctx" %vm-field + temp-reg %context param-reg-0 temp-reg "datastack" context-field-offset [+] MOV param-reg-0 param-reg-0 [] MOV temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index dbb112bf4b..acd2e1358d 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -423,8 +423,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ; HOOK: %mov-vm-ptr cpu ( reg -- ) +HOOK: %vm-field-ptr cpu ( reg offset -- ) + +: load-zone-offset ( nursery-ptr -- ) + "nursery" vm-field-offset %vm-field-ptr ; + : load-allot-ptr ( nursery-ptr allot-ptr -- ) - [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ; + [ drop load-zone-offset ] [ swap [] MOV ] 2bi ; : inc-allot-ptr ( nursery-ptr n -- ) [ [] ] dip data-alignment get align ADD ; @@ -456,7 +461,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ; M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ; M:: x86 %check-nursery ( label size temp1 temp2 -- ) - temp1 "nursery" %vm-field-ptr + temp1 load-zone-offset ! Load 'here' into temp2 temp2 temp1 [] MOV temp2 size ADD @@ -477,7 +482,7 @@ M: x86 %push-stack ( -- ) ds-reg [] int-regs return-reg MOV ; M: x86 %push-context-stack ( -- ) - temp-reg "ctx" %vm-field + temp-reg %context temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD temp-reg temp-reg "datastack" context-field-offset [+] MOV temp-reg [] int-regs return-reg MOV ; @@ -1403,7 +1408,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ; M:: x86 %restore-context ( temp1 temp2 -- ) #! Load Factor stack pointers on entry from C to Factor. - temp1 "ctx" %vm-field + temp1 %context ds-reg temp1 "datastack" context-field-offset [+] MOV rs-reg temp1 "retainstack" context-field-offset [+] MOV ; @@ -1411,7 +1416,7 @@ M:: x86 %save-context ( temp1 temp2 -- ) #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - temp1 "ctx" %vm-field + temp1 %context temp2 stack-reg cell neg [+] LEA temp1 "callstack-top" context-field-offset [+] temp2 MOV temp1 "datastack" context-field-offset [+] ds-reg MOV From 2cab0bb86cc8cc6a48ca4dca1f2f0c141448e7f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 22:39:46 -0400 Subject: [PATCH 102/123] cpu.ppc: stick old stack pointer in a register for use by callbacks --- basis/cpu/ppc/bootstrap.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 83be0150d8..f7a1917d0e 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -76,9 +76,12 @@ CONSTANT: nv-reg 17 432 save-at ; [ + ! Save old stack pointer + 11 1 MR + ! Create stack frame 0 MFLR - 1 1 callback-frame-size neg STWU + 1 1 callback-frame-size SUBI 0 1 callback-frame-size lr-save + STW ! Save all non-volatile registers @@ -86,6 +89,10 @@ CONSTANT: nv-reg 17 nv-fp-regs [ 8 * 80 + save-fp ] each-index nv-vec-regs [ 16 * 224 + save-vec ] each-index + ! Stick old stack pointer in a non-volatile register so that + ! callbacks can access their arguments + nv-reg 11 MR + ! Load VM into vm-reg 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel @@ -126,7 +133,7 @@ CONSTANT: nv-reg 17 ! Tear down stack frame and return 0 1 callback-frame-size lr-save + LWZ - 1 1 0 LWZ + 1 1 callback-frame-size ADDI 0 MTLR BLR ] callback-stub jit-define From 044171e6b9296245cc8741fc0c4e9513eec0b328 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 21:41:13 -0500 Subject: [PATCH 103/123] cpu.ppc: fix optimizing compiler backend --- basis/cpu/ppc/ppc.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 3fd0552a99..cf8a832386 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -60,6 +60,8 @@ CONSTANT: vm-reg 15 M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ; +M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ; + GENERIC: loc-reg ( loc -- reg ) M: ds-loc loc-reg drop ds-reg ; @@ -563,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) } case ; : next-param@ ( n -- reg x ) - 2 1 stack-frame get total-size>> LWZ - [ 2 ] dip param@ ; + [ 17 ] dip param@ ; : store-to-frame ( src n rep -- ) { @@ -745,14 +746,14 @@ M: ppc %alien-callback ( quot -- ) M: ppc %end-callback ( -- ) 3 %load-vm-addr - "unnest_context" f %alien-invoke ; + "end_callback" f %alien-invoke ; M: ppc %end-callback-value ( ctype -- ) ! Save top of data stack - 12 ds-reg 0 LWZ + 16 ds-reg 0 LWZ %end-callback ! Restore top of data stack - 3 12 MR + 3 16 MR ! Unbox former top of data stack to return registers unbox-return ; From 0c0935dfc182e6289da084cd6b78c2bafaa670e6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 22:24:46 -0500 Subject: [PATCH 104/123] Fix typo in webkit demo --- extra/webkit-demo/webkit-demo.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor index eb24d035dc..8f89b1b4ae 100644 --- a/extra/webkit-demo/webkit-demo.factor +++ b/extra/webkit-demo/webkit-demo.factor @@ -13,7 +13,7 @@ IMPORT: WebView WebView -> alloc rect f f -> initWithFrame:frameName:groupName: ; -CONSTANT: window-style ( -- n ) +CONSTANT: window-style flags{ NSClosableWindowMask NSMiniaturizableWindowMask From 0faa3bcf4a24dd8da0cff04d76bfbdb6be31378a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 22:12:45 -0400 Subject: [PATCH 105/123] vm: pre-allocate context alien --- basis/cpu/x86/32/32.factor | 1 + basis/cpu/x86/32/bootstrap.factor | 6 ++--- basis/cpu/x86/64/64.factor | 1 + basis/cpu/x86/64/bootstrap.factor | 5 ++-- .../known-words/known-words.factor | 1 - basis/threads/threads.factor | 11 +++++--- core/bootstrap/primitives.factor | 1 - vm/contexts.cpp | 26 ++++++++++++------- vm/contexts.hpp | 3 ++- vm/primitives.hpp | 1 - vm/vm.hpp | 4 +-- 11 files changed, 34 insertions(+), 26 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 8b97eb9351..97f0cfb668 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -244,6 +244,7 @@ M: x86.32 %alien-indirect ( -- ) M: x86.32 %begin-callback ( -- ) 0 save-vm-ptr + ESP 4 [+] 0 MOV "begin_callback" f %alien-invoke ; M: x86.32 %alien-callback ( quot -- ) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index a428a66ace..293d99fe93 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -82,11 +82,9 @@ IN: bootstrap.x86 [ jit-load-vm ESP [] vm-reg MOV - "begin_callback" jit-call - - ! load quotation - EBP is ctx-reg so it will get clobbered - ! later on EAX EBP 8 [+] MOV + ESP 4 [+] EAX MOV + "begin_callback" jit-call jit-load-vm jit-load-context diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index bea5d4da1f..7e1c5c1f48 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -231,6 +231,7 @@ M: x86.64 %alien-indirect ( -- ) M: x86.64 %begin-callback ( -- ) param-reg-0 %mov-vm-ptr + param-reg-1 0 MOV "begin_callback" f %alien-invoke ; M: x86.64 %alien-callback ( quot -- ) diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 4cd2d8104b..6c0d50f1b7 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -76,8 +76,7 @@ IN: bootstrap.x86 : jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ; [ - nv-reg arg1 MOV - + arg2 arg1 MOV arg1 vm-reg MOV "begin_callback" jit-call @@ -85,7 +84,7 @@ IN: bootstrap.x86 jit-restore-context ! call the quotation - arg1 nv-reg MOV + arg1 return-reg MOV jit-call-quot jit-save-context diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 01f3ff77c0..15895184df 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -355,7 +355,6 @@ M: bad-executable summary \ code-room { } { byte-array } define-primitive \ code-room make-flushable \ compact-gc { } { } define-primitive \ compute-identity-hashcode { object } { } define-primitive -\ context { } { c-ptr } define-primitive \ context make-flushable \ context-object { fixnum } { object } define-primitive \ context-object make-flushable \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 404c8112fb..330b4abd6c 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -11,17 +11,20 @@ IN: threads ! Wrap sub-primitives; we don't want them inlined into callers ! since their behavior depends on what frames are on the callstack +: context ( -- context ) + 2 context-object ; inline + : set-context ( obj context -- obj' ) - (set-context) ; + (set-context) ; inline : start-context ( obj quot: ( obj -- * ) -- obj' ) - (start-context) ; + (start-context) ; inline : set-context-and-delete ( obj context -- * ) - (set-context-and-delete) ; + (set-context-and-delete) ; inline : start-context-and-delete ( obj quot: ( obj -- * ) -- * ) - (start-context-and-delete) ; + (start-context-and-delete) ; inline ! Context introspection : namestack-for ( context -- namestack ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 52ee1e14b4..8a412b8a14 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -538,7 +538,6 @@ tuple { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) } - { "context" "threads.private" "primitive_context" (( -- context )) } { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) } { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) } { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) } diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 9364f2e362..25fe0e5280 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -108,9 +108,16 @@ context *factor_vm::new_context() return new_context; } +void factor_vm::init_context(context *ctx) +{ + ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx); +} + context *new_context(factor_vm *parent) { - return parent->new_context(); + context *new_context = parent->new_context(); + parent->init_context(new_context); + return new_context; } void factor_vm::delete_context(context *old_context) @@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context) parent->delete_context(old_context); } -void factor_vm::begin_callback() +cell factor_vm::begin_callback(cell quot_) { + data_root quot(quot_,this); + ctx->reset(); spare_ctx = new_context(); callback_ids.push_back(callback_id++); + + init_context(ctx); + + return quot.value(); } -void begin_callback(factor_vm *parent) +cell begin_callback(factor_vm *parent, cell quot) { - parent->begin_callback(); + return parent->begin_callback(quot); } void factor_vm::end_callback() @@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals() ctx->retainstack += sizeof(cell) * count; } -void factor_vm::primitive_context() -{ - ctx->push(allot_alien(ctx)); -} - } diff --git a/vm/contexts.hpp b/vm/contexts.hpp index f3aba0e5a6..85338ca91d 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -6,6 +6,7 @@ static const cell context_object_count = 10; enum context_object { OBJ_NAMESTACK, OBJ_CATCHSTACK, + OBJ_CONTEXT, }; static const cell stack_reserved = 1024; @@ -71,7 +72,7 @@ struct context { VM_C_API context *new_context(factor_vm *parent); VM_C_API void delete_context(factor_vm *parent, context *old_context); -VM_C_API void begin_callback(factor_vm *parent); +VM_C_API cell begin_callback(factor_vm *parent, cell quot); VM_C_API void end_callback(factor_vm *parent); } diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 7e95a3bad5..ff0947912c 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -43,7 +43,6 @@ namespace factor _(code_room) \ _(compact_gc) \ _(compute_identity_hashcode) \ - _(context) \ _(context_object) \ _(context_object_for) \ _(current_callback) \ diff --git a/vm/vm.hpp b/vm/vm.hpp index ad74a8e090..cf2f0ca433 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -112,10 +112,11 @@ struct factor_vm // contexts context *new_context(); + void init_context(context *ctx); void delete_context(context *old_context); void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_); void delete_contexts(); - void begin_callback(); + cell begin_callback(cell quot); void end_callback(); void primitive_current_callback(); void primitive_context_object(); @@ -135,7 +136,6 @@ struct factor_vm void primitive_set_retainstack(); void primitive_check_datastack(); void primitive_load_locals(); - void primitive_context(); template void iterate_active_callstacks(Iterator &iter) { From d9d12ab8fb5af2fedfeb99b08b4536cbd0ffe480 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 00:03:26 -0400 Subject: [PATCH 106/123] vm: don't try loading Factor VM DLL anymore --- vm/os-genunix.hpp | 1 - vm/os-macosx.hpp | 1 - vm/os-unix.cpp | 2 +- vm/os-windows-nt.hpp | 4 ++-- 4 files changed, 3 insertions(+), 5 deletions(-) diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index c6123eca56..a40e891a6e 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -2,7 +2,6 @@ namespace factor { #define VM_C_API extern "C" -#define NULL_DLL NULL void early_init(); const char *vm_executable_path(); diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 4d4499461d..27eba77215 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -3,7 +3,6 @@ namespace factor #define VM_C_API extern "C" __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" -#define NULL_DLL NULL void early_init(); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 60ac00fb39..034dfcbf5f 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -46,7 +46,7 @@ void sleep_nanos(u64 nsec) void factor_vm::init_ffi() { - null_dll = dlopen(NULL_DLL,RTLD_LAZY); + null_dll = dlopen(NULL,RTLD_LAZY); } void factor_vm::ffi_dlopen(dll *dll) diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index c5e721c56d..869205b67e 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -20,7 +20,7 @@ typedef char symbol_char; #define FACTOR_OS_STRING "winnt" -#define FACTOR_DLL L"factor.dll" +#define FACTOR_DLL NULL #ifdef _MSC_VER #define FACTOR_STDCALL(return_type) return_type __stdcall @@ -28,7 +28,7 @@ typedef char symbol_char; #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type #endif -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); +VM_C_API exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) // SSE traps raise these exception codes, which are defined in internal NT headers // but not winbase.h From fa9b6e086b94be5f1670cd1fa226f4ff67a3c147 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 00:22:16 -0400 Subject: [PATCH 107/123] vm: oops --- vm/os-windows-nt.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 869205b67e..f274d7813f 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -28,7 +28,7 @@ typedef char symbol_char; #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type #endif -VM_C_API exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) +FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); // SSE traps raise these exception codes, which are defined in internal NT headers // but not winbase.h From 279ff3a7d311b00dd85d1701f32bd91f52b2353e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 00:36:45 -0400 Subject: [PATCH 108/123] vm: smaller default callstack size on OpenBSD --- vm/factor.cpp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/vm/factor.cpp b/vm/factor.cpp index e726ebf6da..983e12bdcd 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -14,7 +14,12 @@ void factor_vm::default_parameters(vm_parameters *p) p->datastack_size = 32 * sizeof(cell); p->retainstack_size = 32 * sizeof(cell); + +#ifdef __OpenBSD__ + p->callstack_size = 32 * sizeof(cell); +#else p->callstack_size = 128 * sizeof(cell); +#endif p->code_size = 8 * sizeof(cell); p->young_size = sizeof(cell) / 4; From fa49520cbf019f7e02b0879f0bdfd73308cbfacd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 1 Apr 2010 21:59:02 -0700 Subject: [PATCH 109/123] update nmakefile to statically link VM to exe just like GNUmakefile --- Nmakefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Nmakefile b/Nmakefile index a73a59d0f5..0d815b6161 100755 --- a/Nmakefile +++ b/Nmakefile @@ -6,7 +6,7 @@ LINK_FLAGS = /nologo shell32.lib CL_FLAGS = /nologo /O2 /W3 !ENDIF -EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res +EXE_OBJS = vm\main-windows-nt.obj vm\factor.res DLL_OBJS = vm\os-windows-nt.obj \ vm\os-windows.obj \ @@ -63,7 +63,7 @@ DLL_OBJS = vm\os-windows-nt.obj \ .rs.res: rc $< -all: factor.com factor.exe libfactor-ffi-test.dll +all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll libfactor-ffi-test.dll: vm/ffi_test.obj link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj @@ -71,11 +71,11 @@ libfactor-ffi-test.dll: vm/ffi_test.obj factor.dll.lib: $(DLL_OBJS) link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS) -factor.com: $(EXE_OBJS) - link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) +factor.com: $(EXE_OBJS) $(DLL_OBJS) + link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS) -factor.exe: $(EXE_OBJS) - link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) +factor.exe: $(EXE_OBJS) $(DLL_OBJS) + link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS) clean: del vm\*.obj From d24ce84dded12eb2bd1155dfa3868cfa3872a23b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 14:09:58 -0400 Subject: [PATCH 110/123] vm: larger default callstack on PowerPC --- vm/factor.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/factor.cpp b/vm/factor.cpp index 983e12bdcd..89da7a2db7 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -15,8 +15,8 @@ void factor_vm::default_parameters(vm_parameters *p) p->datastack_size = 32 * sizeof(cell); p->retainstack_size = 32 * sizeof(cell); -#ifdef __OpenBSD__ - p->callstack_size = 32 * sizeof(cell); +#ifdef FACTOR_PPC + p->callstack_size = 256 * sizeof(cell); #else p->callstack_size = 128 * sizeof(cell); #endif From b740a1fe5d34c872f58e9dac2491d3b7715adcdd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 14:10:55 -0400 Subject: [PATCH 111/123] vm: use C++ exceptions instead of longjmp(), to make Windows crash more --- vm/collector.hpp | 5 +-- vm/gc.cpp | 84 ++++++++++++++++++++++++++---------------------- vm/gc.hpp | 1 - vm/master.hpp | 1 - 4 files changed, 49 insertions(+), 42 deletions(-) diff --git a/vm/collector.hpp b/vm/collector.hpp index ece4926c28..0b8b473e8b 100644 --- a/vm/collector.hpp +++ b/vm/collector.hpp @@ -1,6 +1,8 @@ namespace factor { +struct must_start_gc_again {}; + template struct data_workhorse { factor_vm *parent; TargetGeneration *target; @@ -27,8 +29,7 @@ template struct data_workhorse { { cell size = untagged->size(); object *newpointer = target->allot(size); - /* XXX not exception-safe */ - if(!newpointer) longjmp(parent->current_gc->gc_unwind,1); + if(!newpointer) throw must_start_gc_again(); memcpy(newpointer,untagged,size); untagged->forward_to(newpointer); diff --git a/vm/gc.cpp b/vm/gc.cpp index a57f338c44..e01a05aa5b 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -135,49 +135,57 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) /* Keep trying to GC higher and higher generations until we don't run out of space */ - if(setjmp(current_gc->gc_unwind)) + for(;;) { - /* We come back here if a generation is full */ - start_gc_again(); - } - - current_gc->event->op = current_gc->op; - - switch(current_gc->op) - { - case collect_nursery_op: - collect_nursery(); - break; - case collect_aging_op: - collect_aging(); - if(data->high_fragmentation_p()) + try { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; - collect_full(trace_contexts_p); + current_gc->event->op = current_gc->op; + + switch(current_gc->op) + { + case collect_nursery_op: + collect_nursery(); + break; + case collect_aging_op: + collect_aging(); + if(data->high_fragmentation_p()) + { + current_gc->op = collect_full_op; + current_gc->event->op = collect_full_op; + collect_full(trace_contexts_p); + } + break; + case collect_to_tenured_op: + collect_to_tenured(); + if(data->high_fragmentation_p()) + { + current_gc->op = collect_full_op; + current_gc->event->op = collect_full_op; + collect_full(trace_contexts_p); + } + break; + case collect_full_op: + collect_full(trace_contexts_p); + break; + case collect_compact_op: + collect_compact(trace_contexts_p); + break; + case collect_growing_heap_op: + collect_growing_heap(requested_bytes,trace_contexts_p); + break; + default: + critical_error("Bad GC op",current_gc->op); + break; + } + + break; } - break; - case collect_to_tenured_op: - collect_to_tenured(); - if(data->high_fragmentation_p()) + catch(const must_start_gc_again e) { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; - collect_full(trace_contexts_p); + /* We come back here if a generation is full */ + start_gc_again(); + continue; } - break; - case collect_full_op: - collect_full(trace_contexts_p); - break; - case collect_compact_op: - collect_compact(trace_contexts_p); - break; - case collect_growing_heap_op: - collect_growing_heap(requested_bytes,trace_contexts_p); - break; - default: - critical_error("Bad GC op",current_gc->op); - break; } end_gc(); diff --git a/vm/gc.hpp b/vm/gc.hpp index 5224dec3e2..5129ced909 100755 --- a/vm/gc.hpp +++ b/vm/gc.hpp @@ -45,7 +45,6 @@ struct gc_event { struct gc_state { gc_op op; u64 start_time; - jmp_buf gc_unwind; gc_event *event; explicit gc_state(gc_op op_, factor_vm *parent); diff --git a/vm/master.hpp b/vm/master.hpp index 9879fa607a..a111a86b69 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -16,7 +16,6 @@ #include #include #include -#include #include #include #include From 68073831f9585fb31d99645866c19b4668cf3106 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 14:14:25 -0400 Subject: [PATCH 112/123] mason.common: increase timeout because Windows is damn slow --- extra/mason/common/common.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 912cd48c79..db68a558e0 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -17,8 +17,8 @@ SYMBOL: current-git-id : short-running-process ( command -- ) #! Give network operations and shell commands at most - #! 15 minutes to complete, to catch hangs. - >process 15 minutes >>timeout try-output-process ; + #! 30 minutes to complete, to catch hangs. + >process 30 minutes >>timeout try-output-process ; HOOK: really-delete-tree os ( path -- ) From de4343eaf7e14260b288632764f4108261eabd2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 15:42:29 -0400 Subject: [PATCH 113/123] vm: re-organize context structure --- basis/vm/vm.factor | 4 ++-- vm/contexts.hpp | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index b0f2c945f7..b4c5734810 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -11,10 +11,10 @@ STRUCT: context { datastack cell } { retainstack cell } { callstack-save cell } -{ context-objects cell[10] } { datastack-region void* } { retainstack-region void* } -{ callstack-region void* } ; +{ callstack-region void* } +{ context-objects cell[10] } ; : context-field-offset ( field -- offset ) context offset-of ; inline diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 85338ca91d..582fab173f 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -28,14 +28,14 @@ struct context { /* C callstack pointer */ cell callstack_save; - /* context-specific special objects, accessed by context-object and - set-context-object primitives */ - cell context_objects[context_object_count]; - segment *datastack_seg; segment *retainstack_seg; segment *callstack_seg; + /* context-specific special objects, accessed by context-object and + set-context-object primitives */ + cell context_objects[context_object_count]; + context(cell datastack_size, cell retainstack_size, cell callstack_size); ~context(); From f86c9439e9bf29fb9d3109a2acd7b835d5f9e3b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 15:58:47 -0400 Subject: [PATCH 114/123] windows.errors: redundant USING: list entry --- basis/windows/errors/errors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index a22b6ec007..a3dbaf40ff 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.data kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays literals windows.types specialized-arrays literals ; +arrays literals windows.types specialized-arrays ; SPECIALIZED-ARRAY: TCHAR IN: windows.errors From be024c228c15b2cceb64314e2637ca1a4d0b2230 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Apr 2010 19:10:21 -0400 Subject: [PATCH 115/123] continuations: faster with-datastack --- core/continuations/continuations-docs.factor | 2 +- core/continuations/continuations.factor | 17 ++++++++--------- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 3710680269..8775e599a6 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -235,7 +235,7 @@ HELP: save-error $low-level-note ; HELP: with-datastack -{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } +{ $values { "stack" sequence } { "quot" quotation } { "new-stack" sequence } } { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index cfceb1f715..196a12d0d2 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,10 +1,17 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs combinators combinators.private accessors words ; IN: continuations +: with-datastack ( stack quot -- new-stack ) + [ + [ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip + swap [ call datastack ] dip + swap [ set-datastack ] dip + ] (( stack quot -- new-stack )) call-effect-unsafe ; + SYMBOL: error SYMBOL: error-continuation SYMBOL: error-thread @@ -90,14 +97,6 @@ SYMBOL: return-continuation : return ( -- * ) return-continuation get continue ; -: with-datastack ( stack quot -- newstack ) - [ - [ - [ [ { } like set-datastack ] dip call datastack ] dip - continue-with - ] (( stack quot continuation -- * )) call-effect-unsafe - ] callcc1 2nip ; - GENERIC: compute-restarts ( error -- seq ) Date: Sat, 3 Apr 2010 20:24:33 -0400 Subject: [PATCH 116/123] Get green threads working on Windows - store stack base and limit in TIB - set up a frame-based structured exception handler in each context's callstack - boot.x86.32.image has now been replaced by boot.winnt-x86.32.image and boot.unix-x86.32.image --- Nmakefile | 2 +- basis/bootstrap/image/image.factor | 9 ++-- basis/compiler/constants/constants.factor | 5 +++ basis/cpu/x86/32/bootstrap.factor | 25 ++++++++--- basis/cpu/x86/32/unix/bootstrap.factor | 14 ++++++ basis/cpu/x86/32/winnt/bootstrap.factor | 54 +++++++++++++++++++++++ basis/cpu/x86/64/bootstrap.factor | 5 +++ basis/cpu/x86/bootstrap.factor | 8 +++- basis/threads/threads-tests.factor | 3 ++ core/bootstrap/primitives.factor | 3 +- vm/callbacks.cpp | 20 +++++++-- vm/code_blocks.cpp | 5 +++ vm/cpu-x86.hpp | 2 +- vm/instruction_operands.hpp | 5 +++ vm/os-windows-nt.cpp | 25 +++-------- vm/os-windows-nt.hpp | 8 +--- vm/vm.hpp | 2 +- 17 files changed, 151 insertions(+), 44 deletions(-) create mode 100644 basis/cpu/x86/32/unix/bootstrap.factor create mode 100644 basis/cpu/x86/32/winnt/bootstrap.factor mode change 100644 => 100755 vm/callbacks.cpp mode change 100644 => 100755 vm/cpu-x86.hpp diff --git a/Nmakefile b/Nmakefile index 0d815b6161..9df7a6a1ee 100755 --- a/Nmakefile +++ b/Nmakefile @@ -2,7 +2,7 @@ LINK_FLAGS = /nologo /DEBUG shell32.lib CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG !ELSE -LINK_FLAGS = /nologo shell32.lib +LINK_FLAGS = /nologo /safeseh:no shell32.lib CL_FLAGS = /nologo /O2 /W3 !ENDIF diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 141a77d2b2..62240f73ce 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -15,10 +15,11 @@ generalizations ; IN: bootstrap.image : arch ( os cpu -- arch ) + [ dup "winnt" = "winnt" "unix" ? ] dip { - { "ppc" [ "-ppc" append ] } - { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] } - [ nip ] + { "ppc" [ drop "-ppc" append ] } + { "x86.32" [ nip "-x86.32" append ] } + { "x86.64" [ nip "-x86.64" append ] } } case ; : my-arch ( -- arch ) @@ -32,7 +33,7 @@ IN: bootstrap.image : images ( -- seq ) { - "x86.32" + "winnt-x86.32" "unix-x86.32" "winnt-x86.64" "unix-x86.64" "linux-ppc" "macosx-ppc" } ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 9769b72801..ac0fcff0ff 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -34,6 +34,10 @@ CONSTANT: deck-bits 18 : context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline : context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline : context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline +: context-callstack-seg-offset ( -- n ) 7 bootstrap-cells ; inline +: segment-start-offset ( -- n ) 0 bootstrap-cells ; inline +: segment-size-offset ( -- n ) 1 bootstrap-cells ; inline +: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 @@ -61,6 +65,7 @@ CONSTANT: rt-megamorphic-cache-hits 8 CONSTANT: rt-vm 9 CONSTANT: rt-cards-offset 10 CONSTANT: rt-decks-offset 11 +CONSTANT: rt-exception-handler 12 : rc-absolute? ( n -- ? ) ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 293d99fe93..9b1a1de23d 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -108,6 +108,14 @@ IN: bootstrap.x86 \ (call) define-combinator-primitive [ + ! Load ds and rs registers + jit-load-vm + jit-load-context + jit-restore-context + + ! Windows-specific setup + ctx-reg jit-update-seh + ! Clear x87 stack, but preserve rounding mode and exception flags ESP 2 SUB ESP [] FNSTCW @@ -122,11 +130,6 @@ IN: bootstrap.x86 ! Unwind stack frames ESP EDX MOV - ! Load ds and rs registers - jit-load-vm - jit-load-context - jit-restore-context - jit-jump-quot ] \ unwind-native-frames define-sub-primitive @@ -253,6 +256,9 @@ IN: bootstrap.x86 ! Load new stack pointer ESP ctx-reg context-callstack-top-offset [+] MOV + ! Windows-specific setup + ctx-reg jit-update-tib + ! Load new ds, rs registers jit-restore-context ; @@ -266,6 +272,9 @@ IN: bootstrap.x86 ! Make the new context active EAX jit-switch-context + ! Windows-specific setup + ctx-reg jit-update-seh + ! Twiddle stack for return ESP 4 ADD @@ -293,6 +302,12 @@ IN: bootstrap.x86 ds-reg 4 ADD ds-reg [] EAX MOV + ! Windows-specific setup + jit-install-seh + + ! Push a fake return address + 0 PUSH + ! Jump to initial quotation EAX EBX [] MOV jit-jump-quot ; diff --git a/basis/cpu/x86/32/unix/bootstrap.factor b/basis/cpu/x86/32/unix/bootstrap.factor new file mode 100644 index 0000000000..1e3bee4961 --- /dev/null +++ b/basis/cpu/x86/32/unix/bootstrap.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: cpu.x86.assembler cpu.x86.assembler.operands kernel +layouts parser sequences ; +IN: bootstrap.x86 + +: jit-save-tib ( -- ) ; +: jit-restore-tib ( -- ) ; +: jit-update-tib ( ctx-reg -- ) drop ; +: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; +: jit-update-seh ( ctx-reg -- ) drop ; + +<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> +call diff --git a/basis/cpu/x86/32/winnt/bootstrap.factor b/basis/cpu/x86/32/winnt/bootstrap.factor new file mode 100644 index 0000000000..b8ee1dacaf --- /dev/null +++ b/basis/cpu/x86/32/winnt/bootstrap.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private compiler.constants +cpu.x86.assembler cpu.x86.assembler.operands kernel layouts +locals parser sequences ; +IN: bootstrap.x86 + +: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ; +: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ; +: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ; + +: jit-save-tib ( -- ) + tib-exception-list-offset [] FS PUSH + tib-stack-base-offset [] FS PUSH + tib-stack-limit-offset [] FS PUSH ; + +: jit-restore-tib ( -- ) + tib-stack-limit-offset [] FS POP + tib-stack-base-offset [] FS POP + tib-exception-list-offset [] FS POP ; + +:: jit-update-tib ( ctx-reg -- ) + ! There's a redundant load here because we're not allowed + ! to clobber ctx-reg. Clobbers EAX. + ! Save callstack base in TIB + EAX ctx-reg context-callstack-seg-offset [+] MOV + EAX EAX segment-end-offset [+] MOV + tib-stack-base-offset [] EAX FS MOV + ! Save callstack limit in TIB + EAX ctx-reg context-callstack-seg-offset [+] MOV + EAX EAX segment-start-offset [+] MOV + tib-stack-limit-offset [] EAX FS MOV ; + +: jit-install-seh ( -- ) + ! Create a new exception record and store it in the TIB. + ! Align stack + ESP 3 bootstrap-cells ADD + ! Exception handler address filled in by callback.cpp + 0 PUSH rc-absolute-cell rt-exception-handler jit-rel + ! No next handler + 0 PUSH + ! This is the new exception handler + tib-exception-list-offset [] ESP FS MOV ; + +:: jit-update-seh ( ctx-reg -- ) + ! Load exception record structure that jit-install-seh + ! created from the bottom of the callstack. Clobbers EAX. + EAX ctx-reg context-callstack-bottom-offset [+] MOV + EAX bootstrap-cell ADD + ! Store exception record in TIB. + tib-exception-list-offset [] EAX FS MOV ; + +<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> +call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 6c0d50f1b7..c7f9901d33 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -26,6 +26,11 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 1 ; +: jit-save-tib ( -- ) ; +: jit-restore-tib ( -- ) ; +: jit-update-tib ( ctx-reg -- ) drop ; +: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; + : jit-call ( name -- ) RAX 0 MOV rc-absolute-cell jit-dlsym RAX CALL ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 961f0c9977..80b56f9f91 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -20,6 +20,8 @@ big-endian off ! Save all non-volatile registers nv-regs [ PUSH ] each + jit-save-tib + ! Load VM into vm-reg vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel @@ -36,7 +38,9 @@ big-endian off ! Load Factor callstack pointer stack-reg nv-reg context-callstack-bottom-offset [+] MOV - stack-reg bootstrap-cell ADD + + nv-reg jit-update-tib + jit-install-seh ! Call into Factor code nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel @@ -55,6 +59,8 @@ big-endian off vm-reg vm-context-offset [+] nv-reg MOV ! Restore non-volatile registers + jit-restore-tib + nv-regs [ POP ] each frame-reg POP diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 742ecaa1f7..01578d4e64 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -56,3 +56,6 @@ yield [ "x" tget "p" get fulfill ] in-thread [ f ] [ "p" get ?promise ] unit-test + +! Test system traps inside threads +[ ] [ [ dup ] in-thread yield ] unit-test diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8a412b8a14..87963848bf 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -18,7 +18,8 @@ H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file architecture get { - { "x86.32" "x86/32" } + { "winnt-x86.32" "x86/32/winnt" } + { "unix-x86.32" "x86/32/unix" } { "winnt-x86.64" "x86/64/winnt" } { "unix-x86.64" "x86/64/unix" } { "linux-ppc" "ppc/linux" } diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp old mode 100644 new mode 100755 index 6c8165f5c4..fbf36c7cea --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -38,7 +38,12 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va void callback_heap::update(code_block *stub) { - store_callback_operand(stub,1,(cell)callback_entry_point(stub)); +#ifdef WIN32 + cell index = 2; +#else + cell index = 1; +#endif + store_callback_operand(stub,index,(cell)callback_entry_point(stub)); stub->flush_icache(); } @@ -64,12 +69,21 @@ code_block *callback_heap::add(cell owner, cell return_rewind) /* Store VM pointer */ store_callback_operand(stub,0,(cell)parent); - store_callback_operand(stub,2,(cell)parent); + +#ifdef WIN32 + store_callback_operand(stub,1,(cell)&exception_handler); + cell index = 1; +#else + cell index = 0; +#endif + + /* Store VM pointer */ + store_callback_operand(stub,index + 2,(cell)parent); /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ #if defined(FACTOR_X86) || defined(FACTOR_AMD64) - store_callback_operand(stub,3,return_rewind); + store_callback_operand(stub,index + 3,return_rewind); #endif update(stub); diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 894e49846d..64b218f377 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -225,6 +225,11 @@ void factor_vm::store_external_address(instruction_operand op) case RT_DECKS_OFFSET: op.store_value(decks_offset); break; +#ifdef WINDOWS + case RT_EXCEPTION_HANDLER: + op.store_value(&factor::exception_handler); + break; +#endif default: critical_error("Bad rel type",op.rel_type()); break; diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp old mode 100644 new mode 100755 index bfdcd8afb2..89d7fb792a --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -5,7 +5,7 @@ namespace factor #define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1) -#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell)) +#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell) * 5) inline static void flush_icache(cell start, cell len) {} diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp index dc8aa9d841..66ffddc24e 100644 --- a/vm/instruction_operands.hpp +++ b/vm/instruction_operands.hpp @@ -26,6 +26,10 @@ enum relocation_type { RT_CARDS_OFFSET, /* value of vm->decks_offset */ RT_DECKS_OFFSET, + /* address of exception_handler -- this exists as a separate relocation + type since its used in a situation where relocation arguments cannot + be passed in, and so RT_DLSYM is inappropriate (Windows only) */ + RT_EXCEPTION_HANDLER, }; enum relocation_class { @@ -105,6 +109,7 @@ struct relocation_entry { case RT_MEGAMORPHIC_CACHE_HITS: case RT_CARDS_OFFSET: case RT_DECKS_OFFSET: + case RT_EXCEPTION_HANDLER: return 0; default: critical_error("Bad rel type",rel_type()); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 2d5881252a..4f90d7f641 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -48,11 +48,8 @@ void sleep_nanos(u64 nsec) Sleep((DWORD)(nsec/1000000)); } -LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) +LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { - PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; - CONTEXT *c = (CONTEXT*)pe->ContextRecord; - c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); signal_callstack_top = (stack_frame *)c->ESP; @@ -81,35 +78,23 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) MXCSR(c) &= 0xffffffc0; c->EIP = (cell)factor::fp_signal_handler_impl; break; - case 0x40010006: - /* If the Widcomm bluetooth stack is installed, the BTTray.exe - process injects code into running programs. For some reason this - results in random SEH exceptions with this (undocumented) - exception code being raised. The workaround seems to be ignoring - this altogether, since that is what happens if SEH is not - enabled. Don't really have any idea what this exception means. */ - break; default: signal_number = e->ExceptionCode; c->EIP = (cell)factor::misc_signal_handler_impl; break; } - return EXCEPTION_CONTINUE_EXECUTION; + + return ExceptionContinueExecution; } -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe) +LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { - return current_vm()->exception_handler(pe); + return current_vm()->exception_handler(e,frame,c,dispatch); } void factor_vm::c_to_factor_toplevel(cell quot) { - if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler)) - fatal_error("AddVectoredExceptionHandler failed", 0); - c_to_factor(quot); - - RemoveVectoredExceptionHandler((void *)factor::exception_handler); } void factor_vm::open_console() diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index f274d7813f..d84ac97298 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -22,13 +22,7 @@ typedef char symbol_char; #define FACTOR_DLL NULL -#ifdef _MSC_VER - #define FACTOR_STDCALL(return_type) return_type __stdcall -#else - #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type -#endif - -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); +LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); // SSE traps raise these exception codes, which are defined in internal NT headers // but not winbase.h diff --git a/vm/vm.hpp b/vm/vm.hpp index cf2f0ca433..36ec3260d6 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -706,7 +706,7 @@ struct factor_vm #if defined(WINNT) void open_console(); - LONG exception_handler(PEXCEPTION_POINTERS pe); + LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); #endif #else // UNIX From b16d91576cc94dc52edf1ad90d29cc7af8d5132e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Apr 2010 21:11:04 -0400 Subject: [PATCH 117/123] cpu.x86.64: fix typo that caused bootstrap crash --- basis/cpu/x86/64/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index c7f9901d33..a82c8c17e2 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -29,7 +29,7 @@ IN: bootstrap.x86 : jit-save-tib ( -- ) ; : jit-restore-tib ( -- ) ; : jit-update-tib ( ctx-reg -- ) drop ; -: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; +: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ; : jit-call ( name -- ) RAX 0 MOV rc-absolute-cell jit-dlsym From 52736dd94ff4ddf3196d8a57c1a73809b210cbb3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 12:20:56 -0400 Subject: [PATCH 118/123] mason.child: fix unit test for boot image renaming --- extra/mason/child/child-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 6fedac87bd..f8046ac8e5 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -33,7 +33,7 @@ USING: mason.child mason.config tools.test namespaces io kernel sequences ; ] with-scope ] unit-test -[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [ +[ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [ [ "winnt" target-os set "x86.32" target-cpu set From d70cf197f268e9863538a20603f93eb1adbb13a4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 13:53:17 -0500 Subject: [PATCH 119/123] vm: fix compile error --- vm/code_blocks.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 64b218f377..de103cda12 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -227,7 +227,7 @@ void factor_vm::store_external_address(instruction_operand op) break; #ifdef WINDOWS case RT_EXCEPTION_HANDLER: - op.store_value(&factor::exception_handler); + op.store_value((cell)&factor::exception_handler); break; #endif default: From 6e40b77a9fb33b96fce62757100006aee427cba3 Mon Sep 17 00:00:00 2001 From: Sheepson Apprentice Date: Sun, 4 Apr 2010 14:30:29 -0500 Subject: [PATCH 120/123] When curl fails with a 404 error, don't write this error to disk --- build-support/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 3a5fb4e253..38bdc8183c 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -68,7 +68,7 @@ set_downloader() { if [[ $? -ne 0 ]] ; then DOWNLOADER=wget else - DOWNLOADER="curl -O" + DOWNLOADER="curl -f -O" fi } From cd05b1007dda4b68b625ab9d345c435d492e18e4 Mon Sep 17 00:00:00 2001 From: Sheepson Apprentice Date: Sun, 4 Apr 2010 14:39:59 -0500 Subject: [PATCH 121/123] Support unix-x86.32 and winnt-x86.32 boot images in factor.sh --- build-support/factor.sh | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index 38bdc8183c..68d138c3ef 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -291,9 +291,15 @@ set_build_info() { elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_TARGET=winnt-x86-64 + elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then + MAKE_IMAGE_TARGET=winnt-x86.32 + MAKE_TARGET=winnt-x86-32 elif [[ $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=unix-x86.64 MAKE_TARGET=$OS-x86-64 + elif [[ $ARCH == x86 && $WORD == 32 ]] ; then + MAKE_IMAGE_TARGET=unix-x86.32 + MAKE_TARGET=$OS-x86-32 else MAKE_IMAGE_TARGET=$ARCH.$WORD MAKE_TARGET=$OS-$ARCH-$WORD From ce16c4ec2cfa309f71b4db91fc014e6f7ce7bbdf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 17:46:36 -0400 Subject: [PATCH 122/123] vm: fix callback heap code on 64-bit Windows --- vm/callbacks.cpp | 60 ++++++++++++++++++++++++++++++++++-------------- vm/callbacks.hpp | 4 ++++ 2 files changed, 47 insertions(+), 17 deletions(-) diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp index fbf36c7cea..38479a3cb4 100755 --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -19,7 +19,25 @@ void factor_vm::init_callbacks(cell size) callbacks = new callback_heap(size,this); } -void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) +bool callback_heap::setup_seh_p() +{ +#if defined(WINDOWS) && defined(FACTOR_X86) + return true; +#else + return false; +#endif +} + +bool callback_heap::return_takes_param_p() +{ +#if defined(FACTOR_X86) || defined(FACTOR_AMD64) + return true; +#else + return false; +#endif +} + +instruction_operand callback_heap::callback_operand(code_block *stub, cell index) { tagged code_template(parent->special_objects[CALLBACK_STUB]); @@ -33,17 +51,23 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va offset); instruction_operand op(rel,stub,0); - op.store_value(value); + + return op; +} + +void callback_heap::store_callback_operand(code_block *stub, cell index) +{ + parent->store_external_address(callback_operand(stub,index)); +} + +void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) +{ + callback_operand(stub,index).store_value(value); } void callback_heap::update(code_block *stub) { -#ifdef WIN32 - cell index = 2; -#else - cell index = 1; -#endif - store_callback_operand(stub,index,(cell)callback_entry_point(stub)); + store_callback_operand(stub,setup_seh_p() ? 2 : 1,(cell)callback_entry_point(stub)); stub->flush_icache(); } @@ -70,21 +94,23 @@ code_block *callback_heap::add(cell owner, cell return_rewind) /* Store VM pointer */ store_callback_operand(stub,0,(cell)parent); -#ifdef WIN32 - store_callback_operand(stub,1,(cell)&exception_handler); - cell index = 1; -#else - cell index = 0; -#endif + cell index; + + if(setup_seh_p()) + { + store_callback_operand(stub,1); + index = 1; + } + else + index = 0; /* Store VM pointer */ store_callback_operand(stub,index + 2,(cell)parent); /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ -#if defined(FACTOR_X86) || defined(FACTOR_AMD64) - store_callback_operand(stub,index + 3,return_rewind); -#endif + if(return_takes_param_p()) + store_callback_operand(stub,index + 3,return_rewind); update(stub); diff --git a/vm/callbacks.hpp b/vm/callbacks.hpp index 607984ad23..a0ab3d6bf9 100644 --- a/vm/callbacks.hpp +++ b/vm/callbacks.hpp @@ -38,6 +38,10 @@ struct callback_heap { return w->entry_point; } + bool setup_seh_p(); + bool return_takes_param_p(); + instruction_operand callback_operand(code_block *stub, cell index); + void store_callback_operand(code_block *stub, cell index); void store_callback_operand(code_block *stub, cell index, cell value); void update(code_block *stub); From c0af678c5bc13c8f096609223ae81a8c8a4afa90 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 19:42:57 -0400 Subject: [PATCH 123/123] cpu.x86.assembler: add support for absolute addressing on x86-64; [RIP+] now behaves like [] did, and [] now does absolute addressing just like in 32-bit mode --- basis/cpu/x86/64/64.factor | 4 ++-- basis/cpu/x86/64/bootstrap.factor | 2 +- basis/cpu/x86/assembler/assembler-tests.factor | 10 ++++++++-- basis/cpu/x86/assembler/assembler.factor | 16 ++++++++++------ basis/cpu/x86/assembler/operands/operands.factor | 14 ++++++++------ 5 files changed, 29 insertions(+), 17 deletions(-) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 7e1c5c1f48..4dfb250348 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -55,13 +55,13 @@ M: x86.64 %vm-field-ptr ( dst offset -- ) : param@ ( n -- op ) reserved-stack-space + stack@ ; M: x86.64 %prologue ( n -- ) - temp-reg -7 [] LEA + temp-reg -7 [RIP+] LEA dup PUSH temp-reg PUSH stack-reg swap 3 cells - SUB ; M: x86.64 %prepare-jump - pic-tail-reg xt-tail-pic-offset [] LEA ; + pic-tail-reg xt-tail-pic-offset [RIP+] LEA ; : load-cards-offset ( dst -- ) 0 MOV rc-absolute-cell rel-cards-offset ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index a82c8c17e2..69734df225 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -47,7 +47,7 @@ IN: bootstrap.x86 ] jit-prolog jit-define [ - temp3 5 [] LEA + temp3 5 [RIP+] LEA 0 JMP rc-relative rt-entry-point-pic-tail jit-rel ] jit-word-jump jit-define diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 0a6ae5a484..8ed789f392 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -1,5 +1,5 @@ USING: cpu.x86.assembler cpu.x86.assembler.operands -kernel tools.test namespaces make ; +kernel tools.test namespaces make layouts ; IN: cpu.x86.assembler.tests [ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test @@ -164,5 +164,11 @@ IN: cpu.x86.assembler.tests [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test -[ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test +bootstrap-cell 4 = [ + [ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test +] when +bootstrap-cell 8 = [ + [ { 72 137 13 123 0 0 0 } ] [ [ 123 [RIP+] RCX MOV ] { } make ] unit-test + [ { 101 72 137 12 37 123 0 0 0 } ] [ [ 123 [] GS RCX MOV ] { } make ] unit-test +] when diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 32eeaaad1d..b91083dad1 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io.binary kernel combinators kernel.private math -math.bitwise locals namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.operands -cpu.x86.assembler.operands.private ; +USING: arrays io.binary kernel combinators +combinators.short-circuit math math.bitwise locals namespaces +make sequences words system layouts math.order accessors +cpu.x86.assembler.operands cpu.x86.assembler.operands.private ; QUALIFIED: sequences IN: cpu.x86.assembler @@ -22,7 +22,11 @@ IN: cpu.x86.assembler GENERIC: sib-present? ( op -- ? ) M: indirect sib-present? - [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ; + { + [ base>> { ESP RSP R12 } member? ] + [ index>> ] + [ scale>> ] + } 1|| ; M: register sib-present? drop f ; diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor index bd9a3f6cdd..e8d98cde17 100644 --- a/basis/cpu/x86/assembler/operands/operands.factor +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -1,13 +1,9 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words math accessors sequences namespaces assocs layouts cpu.x86.assembler.syntax ; IN: cpu.x86.assembler.operands -! In 32-bit mode, { 1234 } is absolute indirect addressing. -! In 64-bit mode, { 1234 } is RIP-relative. -! Beware! - REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ; ALIAS: AH SPL @@ -90,7 +86,13 @@ M: object operand-64? drop f ; PRIVATE> : [] ( reg/displacement -- indirect ) - dup integer? [ [ f f f ] dip ] [ f f f ] if ; + dup integer? + [ [ f f bootstrap-cell 8 = 0 f ? ] dip ] + [ f f f ] + if ; + +: [RIP+] ( displacement -- indirect ) + [ f f f ] dip ; : [+] ( reg displacement -- indirect ) dup integer?