From 092dd9fc393a8a71b12a135af7e38e9101ab2bdb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Nov 2009 23:16:26 -0600 Subject: [PATCH 01/52] add sorted-histogram word --- basis/math/statistics/statistics-docs.factor | 14 ++++++++++++++ basis/math/statistics/statistics.factor | 3 +++ 2 files changed, 17 insertions(+) diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 3b6e7d62ba..9834f44add 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -98,6 +98,19 @@ HELP: histogram* } { $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ; +HELP: sorted-histogram +{ $values + { "seq" sequence } + { "alist" "an array of key/value pairs" } +} +{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." } +{ $examples + { $example "USING: prettyprint math.statistics ;" + """"abababbbbbbc" sorted-histogram .""" + "{ { 99 1 } { 97 3 } { 98 8 } }" + } +} ; + HELP: sequence>assoc { $values { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } @@ -145,6 +158,7 @@ ARTICLE: "histogram" "Computing histograms" { $subsections histogram histogram* + sorted-histogram } "Combinators for implementing histogram:" { $subsections diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 9c72b848ca..73a87ffb72 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -79,6 +79,9 @@ PRIVATE> : histogram ( seq -- hashtable ) [ inc-at ] sequence>hashtable ; +: sorted-histogram ( seq -- alist ) + histogram >alist sort-values ; + : collect-values ( seq quot: ( obj hashtable -- ) -- hash ) '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline From d2fe75276ebf33c20655f33abe2fbc4bdf0f9b0e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Nov 2009 13:13:27 -0600 Subject: [PATCH 02/52] custom inlining for diff and intersect, when given a literal sequence. this cuts off 1/3 of the running time of a microbenchmark --- .../tree/propagation/transforms/transforms.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 1f40bf00a2..ff68fb2400 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: kernel sequences words fry generic accessors classes.tuple classes classes.algebra definitions stack-checker.state quotations classes.tuple.private math -math.partial-dispatch math.private math.intervals +math.partial-dispatch math.private math.intervals sets.private math.floats.private math.integers.private layouts math.order vectors hashtables combinators effects generalizations assocs sets combinators.short-circuit sequences.private locals @@ -290,3 +290,13 @@ CONSTANT: lookup-table-at-max 256 ] [ drop f ] if ; \ at* [ at-quot ] 1 define-partial-eval + +: diff-quot ( seq -- quot: ( seq' -- seq'' ) ) + tester '[ [ @ not ] filter ] ; + +\ diff [ diff-quot ] 1 define-partial-eval + +: intersect-quot ( seq -- quot: ( seq' -- seq'' ) ) + tester '[ _ filter ] ; + +\ intersect [ intersect-quot ] 1 define-partial-eval From 02f209b30a06a187036542cfab52fe81669f5f0f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 13:16:20 -0600 Subject: [PATCH 03/52] remove unused nspin generalization --- basis/generalizations/generalizations-docs.factor | 7 ------- basis/generalizations/generalizations-tests.factor | 2 -- basis/generalizations/generalizations.factor | 3 --- 3 files changed, 12 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index e9a709030e..b04d0c53fb 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -338,12 +338,6 @@ HELP: ntuck } { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; -HELP: nspin -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ; - ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsections narray @@ -364,7 +358,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" nnip ndrop ntuck - nspin mnswap nweave } ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index c54e35002f..546413447e 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ 5 nspin ] must-infer -[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 8d6d6f2ac0..dbbfc7354e 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -139,6 +139,3 @@ MACRO: nbi-curry ( n -- ) : nappend ( n -- seq ) narray concat ; inline -MACRO: nspin ( n -- ) - [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ; - From fa6d7b70690d103fdec5f1b4f8420578ddb68313 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 14:05:06 -0600 Subject: [PATCH 04/52] eliminate spin from basis --- basis/images/jpeg/jpeg.factor | 4 ++-- basis/io/backend/windows/nt/nt.factor | 19 ++++++++++--------- basis/math/blas/vectors/vectors.factor | 8 ++++---- .../matrices/elimination/elimination.factor | 15 +++++++-------- .../hashtables/hashtables-tests.factor | 4 ++-- basis/persistent/hashtables/hashtables.factor | 6 +++--- basis/regexp/disambiguate/disambiguate.factor | 12 ++++++------ basis/validators/validators.factor | 2 +- basis/windows/com/com-tests.factor | 4 ++-- basis/windows/com/wrapper/wrapper-docs.factor | 4 ++-- 10 files changed, 39 insertions(+), 39 deletions(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 4f10808b04..e8af7144ad 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators -grouping compression.huffman images +grouping compression.huffman images fry images.processing io io.binary io.encodings.binary io.files io.streams.byte-array kernel locals math math.bitwise math.constants math.functions math.matrices math.order @@ -232,7 +232,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; block dup length>> sqrt >fixnum group flip dup matrix-dim coord-matrix flip [ - [ first2 spin nth nth ] + [ '[ _ [ second ] [ first ] bi ] dip nth nth ] [ x,y v+ color-id jpeg-image draw-color ] bi ] with each^2 ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 452dc4a409..1301d69913 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -50,16 +50,17 @@ M: winnt add-completion ( win32-handle -- ) } cond ] with-timeout ; -:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) +:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? ) master-completion-port get-global - 0 [ ! bytes - f ! key - f [ ! overlapped - us [ 1000 /i ] [ INFINITE ] if* ! timeout - GetQueuedCompletionStatus zero? - ] keep - *void* dup [ OVERLAPPED memory>struct ] when - ] keep *int spin ; + 0 :> bytes + f :> key + f :> overlapped + usec [ 1000 /i ] [ INFINITE ] if* :> timeout + bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error? + + bytes *int + overlapped *void* dup [ OVERLAPPED memory>struct ] when + error? ; : resume-callback ( result overlapped -- ) >c-ptr pending-overlapped get-global delete-at* drop resume-with ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 8d057de720..8fa41c5026 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -78,10 +78,10 @@ PRIVATE> : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline : n*V ( alpha x -- alpha*x ) clone n*V! ; inline -: V+ ( x y -- x+y ) - 1.0 -rot n*V+V ; inline -: V- ( x y -- x-y ) - -1.0 spin n*V+V ; inline +:: V+ ( x y -- x+y ) + 1.0 x y n*V+V ; inline +:: V- ( x y -- x-y ) + -1.0 y x n*V+V ; inline : Vneg ( x -- -x ) -1.0 swap n*V ; inline diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 8411447aac..5c154a6820 100755 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors math.matrices namespaces -sequences ; +USING: kernel locals math math.vectors math.matrices +namespaces sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -85,12 +85,11 @@ SYMBOL: matrix ] each ] with-matrix ; -: basis-vector ( row col# -- ) - [ clone ] dip - [ swap nth neg recip ] 2keep - [ 0 spin set-nth ] 2keep - [ n*v ] dip - matrix get set-nth ; +:: basis-vector ( row col# -- ) + row clone :> row' + col# row' nth neg recip :> a + 0 col# row' set-nth + a row n*v col# matrix get set-nth ; : nullspace ( matrix -- seq ) echelon reduced dup empty? [ diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index eea31dd34e..d66fdd0c08 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -1,6 +1,6 @@ IN: persistent.hashtables.tests USING: persistent.hashtables persistent.assocs hashtables assocs -tools.test kernel namespaces random math.ranges sequences fry ; +tools.test kernel locals namespaces random math.ranges sequences fry ; [ t ] [ PH{ } assoc-empty? ] unit-test @@ -86,7 +86,7 @@ M: hash-0-b hashcode* 2drop 0 ; : random-assocs ( n -- hash phash ) [ random-string ] replicate [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] - [ PH{ } clone swap [ spin new-at ] each-index ] + [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ] bi ; : ok? ( assoc1 assoc2 -- ? ) diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 0179216e62..256baabd5e 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: kernel math accessors assocs fry combinators parser -prettyprint.custom make +prettyprint.custom locals make persistent.assocs persistent.hashtables.nodes persistent.hashtables.nodes.empty @@ -38,8 +38,8 @@ M: persistent-hash pluck-at M: persistent-hash >alist [ root>> >alist% ] { } make ; -: >persistent-hash ( assoc -- phash ) - T{ persistent-hash } swap [ spin new-at ] assoc-each ; +:: >persistent-hash ( assoc -- phash ) + T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ; M: persistent-hash equal? over persistent-hash? [ assoc= ] [ 2drop f ] if ; diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index 876d898cb4..fcde135cf8 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -44,12 +44,12 @@ TUPLE: parts in out ; [ _ meaningful-integers ] keep add-out ] map ; -: class-partitions ( classes -- assoc ) - [ integer? ] partition [ - dup powerset-partition spin add-integers - [ [ partition>class ] keep 2array ] map - [ first ] filter - ] [ '[ _ singleton-partition ] map ] 2bi append ; +:: class-partitions ( classes -- assoc ) + classes [ integer? ] partition :> ( integers classes ) + + classes powerset-partition classes integers add-integers + [ [ partition>class ] keep 2array ] map [ first ] filter + integers [ classes singleton-partition ] map append ; : new-transitions ( transitions -- assoc ) ! assoc is class, partition values [ keys ] gather diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index f0ee13dd38..f2c5691452 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -9,7 +9,7 @@ IN: validators >lower "on" = ; : v-default ( str def -- str/def ) - over empty? spin ? ; + [ nip empty? ] 2keep ? ; : v-required ( str -- str ) dup empty? [ "required" throw ] when ; diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index ae8ef62c16..25e30829c0 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -44,8 +44,8 @@ C: test-implementation [ >>x drop ] ! IInherited::setX } } { IUnrelated { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrelated::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor index 6a6f6f2bb4..0298e80445 100644 --- a/basis/windows/com/wrapper/wrapper-docs.factor +++ b/basis/windows/com/wrapper/wrapper-docs.factor @@ -27,8 +27,8 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} [ >>x drop ] ! IInherited::setX } } { "IUnrelated" { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd } } } """ } ; From 08370a236d2a0c324bbde7d504b6028035ec808b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 14:05:39 -0600 Subject: [PATCH 05/52] update hints docs to demonstrate M\ method syntax instead of old array syntax for referencing methods --- basis/hints/hints-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 56a2cb9142..46bdc698b7 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -20,7 +20,7 @@ HELP: specialized-def { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; HELP: HINTS: -{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } } +{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } } { $description "Defines specialization hints for a word or a method." $nl "Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." } @@ -35,8 +35,8 @@ $nl "M: assoc count-occurrences" " swap [ = nip ] curry assoc-filter assoc-size ;" "" - "HINTS: { sequence count-occurrences } { object array } ;" - "HINTS: { assoc count-occurrences } { object hashtable } ;" + "HINTS: M\ sequence count-occurrences { object array } ;" + "HINTS: M\ assoc count-occurrences { object hashtable } ;" } } ; From 6c48852fb0c22c3b093d179d9f76be33f519e02d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 15:34:31 -0600 Subject: [PATCH 06/52] eliminate most spins from extra --- extra/bank/bank.factor | 2 +- extra/c/preprocessor/preprocessor.factor | 10 +++---- extra/couchdb/couchdb.factor | 9 ++++--- extra/digraphs/digraphs.factor | 2 +- extra/fries/fries.factor | 8 ++++-- extra/gpu/framebuffers/framebuffers.factor | 11 +++++--- extra/jamshred/tunnel/tunnel.factor | 4 +-- extra/koszul/koszul.factor | 26 +++++++++---------- extra/reports/noise/noise.factor | 1 - extra/set-n/set-n.factor | 6 ++--- extra/space-invaders/space-invaders.factor | 15 ++++++----- extra/sudokus/sudokus.factor | 2 +- extra/tetris/game/game.factor | 2 +- .../tokyo/assoc-functor/assoc-functor.factor | 8 +++--- extra/ui/gadgets/layout/layout.factor | 5 ++-- extra/units/units.factor | 6 ++--- 16 files changed, 63 insertions(+), 54 deletions(-) diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index 31a4b75eb2..a379a03828 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; + [ [ dupd process-day ] ] 2dip swap each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 3018fa7a24..77f041835b 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -93,11 +93,11 @@ ERROR: header-file-missing path ; skip-whitespace/comments [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; -: handle-define ( preprocessor-state sequence-parser -- ) - [ take-define-identifier ] - [ skip-whitespace/comments take-rest ] bi - "\\" ?tail [ readlns append ] when - spin symbol-table>> set-at ; +:: handle-define ( preprocessor-state sequence-parser -- ) + sequence-parser take-define-identifier :> ident + sequence-parser skip-whitespace/comments take-rest :> def + def "\\" ?tail [ readlns append ] when :> def + def ident preprocessor-state symbol-table>> set-at ; : handle-undef ( preprocessor-state sequence-parser -- ) take-token swap symbol-table>> delete-at ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index da71acb074..ed5dd1268f 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations debugger hashtables http http.client io io.encodings.string io.encodings.utf8 json.reader -json.writer kernel make math math.parser namespaces sequences strings -urls urls.encoding vectors ; +json.writer kernel locals make math math.parser namespaces sequences +strings urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -136,8 +136,9 @@ C: db : attachments> ( assoc -- attachments ) "_attachments" swap at ; : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; -: copy-key ( to from to-key from-key -- ) - rot at spin set-at ; +:: copy-key ( to from to-key from-key -- ) + from-key from at + to-key to set-at ; : copy-id ( to from -- ) "_id" "id" copy-key ; diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor index 2b3379861f..ccbe90fb3c 100755 --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -44,7 +44,7 @@ DEFER: (topological-sort) ] if ; : topological-sort ( digraph -- seq ) - dup clone V{ } clone spin + [ V{ } clone ] dip [ clone ] keep [ drop (topological-sort) ] assoc-each drop reverse ; : topological-sorted-values ( digraph -- seq ) diff --git a/extra/fries/fries.factor b/extra/fries/fries.factor index 133e8913dd..3f970a86bf 100644 --- a/extra/fries/fries.factor +++ b/extra/fries/fries.factor @@ -1,11 +1,15 @@ USING: arrays vectors combinators effects kernel math sequences splitting strings.parser parser fry sequences.extras ; + +! a b c glue => acb +! c b a [ append ] dip prepend + IN: fries : str-fry ( str on -- quot ) split - [ unclip-last [ [ spin glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; : gen-fry ( str on -- quot ) split - [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: i" parse-string rest "_" str-fry append! ; diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor index efd71782d0..bea72961e4 100755 --- a/extra/gpu/framebuffers/framebuffers.factor +++ b/extra/gpu/framebuffers/framebuffers.factor @@ -157,10 +157,13 @@ M: renderbuffer framebuffer-attachment-dim [ swap depth-attachment>> [ swap call ] [ drop ] if* ] [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline -: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) - [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ] - [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ] - [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline +:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) + framebuffer color-attachments>> + [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index + framebuffer depth-attachment>> + [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when* + framebuffer stencil-attachment>> + [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index f7eac9d02c..e7285dcbbc 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -77,10 +77,10 @@ CONSTANT: default-segment-radius 1 find 2drop ; : nearest-segment-forward ( segments oint start -- segment ) - rot dup length swap find-nearest-segment ; + rot tail-slice find-nearest-segment ; : nearest-segment-backward ( segments oint start -- segment ) - swapd 1 + 0 spin find-nearest-segment ; + 1 + rot head-slice find-nearest-segment ; : nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 59efec1c02..3e3d67195e 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables assocs io kernel math +USING: accessors arrays hashtables assocs io kernel locals math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser splitting sorting shuffle sets math.order ; @@ -191,12 +191,12 @@ DEFER: (d) [ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth dim-im/ker-d ; -: bigraded-ker/im-d ( bigraded-basis -- seq ) - dup length [ - over first length [ - [ 2dup ] dip spin (bigraded-ker/im-d) - ] map 2nip - ] with map ; +:: bigraded-ker/im-d ( basis -- seq ) + basis length iota [| z | + basis first length iota [| u | + u z basis (bigraded-ker/im-d) + ] map + ] map ; : bigraded-betti ( u-generators z-generators -- seq ) [ basis graded ] bi@ tensor bigraded-ker/im-d @@ -270,12 +270,12 @@ DEFER: (d) 3tri 3array ; -: bigraded-triples ( grid -- triples ) - dup length [ - over first length [ - [ 2dup ] dip spin bigraded-triple - ] map 2nip - ] with map ; +:: bigraded-triples ( grid -- triples ) + grid length [| z | + grid first length [| u | + u z grid bigraded-triple + ] map + ] map ; : bigraded-laplacian ( u-generators z-generators quot -- seq ) [ [ basis graded ] bi@ tensor bigraded-triples ] dip diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 9eb2804b42..69ac897e34 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -54,7 +54,6 @@ IN: reports.noise { over 2 } { pick 4 } { rot 3 } - { spin 3 } { swap 1 } { swapd 3 } { tuck 2 } diff --git a/extra/set-n/set-n.factor b/extra/set-n/set-n.factor index 04731b0e27..80d8bf2246 100644 --- a/extra/set-n/set-n.factor +++ b/extra/set-n/set-n.factor @@ -1,9 +1,9 @@ -USING: accessors assocs fry generalizations kernel math -namespaces parser sequences words ; +USING: accessors assocs fry generalizations kernel locals math +namespaces parser sequences shuffle words ; IN: set-n : get* ( var n -- val ) namestack dup length rot - head assoc-stack ; : set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ; ! dynamic lambda -SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ; \ No newline at end of file +SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ; diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 07b5608a76..db6ed7ed04 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -40,12 +40,13 @@ CONSTANT: game-height 256 #! Point is a {x y}. first2 game-width 3 * * swap 3 * + ; -: set-bitmap-pixel ( color point array -- ) - #! 'color' is a {r g b}. Point is {x y}. - [ bitmap-index ] dip ! color index array - [ [ first ] 2dip set-nth ] 3keep - [ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep - [ third ] 2dip [ 2 + ] dip set-nth ; +:: set-bitmap-pixel ( bitmap point color -- ) + color point bitmap + + point color :> index + color first index bitmap set-nth + color second index 1 + bitmap set-nth + color third index 2 + bitmap set-nth ; : get-bitmap-pixel ( point array -- color ) #! Point is a {x y}. color is a {r g b} @@ -317,7 +318,7 @@ CONSTANT: red { 255 0 0 } : plot-bitmap-pixel ( bitmap point color -- ) #! point is a {x y}. color is a {r g b}. - spin set-bitmap-pixel ; + set-bitmap-pixel ; : within ( n a b -- bool ) #! n >= a and n <= b diff --git a/extra/sudokus/sudokus.factor b/extra/sudokus/sudokus.factor index ff20f15204..c7bc6944fb 100644 --- a/extra/sudokus/sudokus.factor +++ b/extra/sudokus/sudokus.factor @@ -21,7 +21,7 @@ IN: sudokus : solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ; : hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ; : create ( difficulty -- puzzle ) 81 [ f ] replicate - 40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ; + 40 random solution [ [ f swap [ length random ] keep set-nth ] curry times ] keep ; : do-sudoku ( -- ) [ [ [ diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor index e1b5867f64..c9e235ff79 100644 --- a/extra/tetris/game/game.factor +++ b/extra/tetris/game/game.factor @@ -38,7 +38,7 @@ CONSTANT: default-height 20 level>> 1 - 60 * 1000 swap - ; : add-block ( tetris block -- ) - over board>> spin current-piece tetromino>> colour>> set-block ; + over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ; : game-over? ( tetris -- ? ) [ board>> ] [ next-piece ] bi piece-valid? not ; diff --git a/extra/tokyo/assoc-functor/assoc-functor.factor b/extra/tokyo/assoc-functor/assoc-functor.factor index 122e613387..bb2b1d8b6d 100644 --- a/extra/tokyo/assoc-functor/assoc-functor.factor +++ b/extra/tokyo/assoc-functor/assoc-functor.factor @@ -44,11 +44,11 @@ M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ; M: TYPE >alist ( db -- alist ) [ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ; -M: TYPE set-at ( value key db -- ) - handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ; +M:: TYPE set-at ( value key db -- ) + db handle>> key value [ object>bytes dup length ] bi@ DBPUT drop ; -M: TYPE delete-at ( key db -- ) - handle>> swap object>bytes dup length DBOUT drop ; +M:: TYPE delete-at ( key db -- ) + db handle>> key object>bytes dup length DBOUT drop ; M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ; diff --git a/extra/ui/gadgets/layout/layout.factor b/extra/ui/gadgets/layout/layout.factor index 7bdde95d60..c287b9a059 100644 --- a/extra/ui/gadgets/layout/layout.factor +++ b/extra/ui/gadgets/layout/layout.factor @@ -23,8 +23,9 @@ TUPLE: placeholder < gadget members ; ! Just take the previous mentioned placeholder and use it ! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves DEFER: with-interface -: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ dup , ] unless* - templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ; +: insertion-quot ( quot -- quot' ) + make:building get [ [ placeholder? ] find-last nip [ dup , ] unless* + [ templates get ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ; SYNTAX: ,% scan string>number [ , ] curry append! ; SYNTAX: ->% scan string>number '[ [ _ , ] [ output-model ] bi ] append! ; diff --git a/extra/units/units.factor b/extra/units/units.factor index b8e3f45a16..a293d79f78 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -28,9 +28,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; dimensioned boa ; : >dimensioned< ( d -- n top bot ) - [ value>> ] [ top>> ] [ bot>> ] tri ; + [ bot>> ] [ top>> ] [ value>> ] tri ; -\ [ >dimensioned< ] define-inverse +\ [ [ dimensioned boa ] undo ] define-inverse : dimensions ( dimensioned -- top bot ) [ top>> ] [ bot>> ] bi ; @@ -65,7 +65,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : d-sq ( d -- d ) dup d* ; : d-recip ( d -- d' ) - >dimensioned< spin recip dimension-op> ; + >dimensioned< recip dimension-op> ; : d/ ( d d -- d ) d-recip d* ; From 6e9d3693312065568bdebe2c9d4cca58fe683cc6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 15:40:48 -0600 Subject: [PATCH 07/52] remove spin from core and retire it to basis/shuffle --- basis/shuffle/shuffle-docs.factor | 1 + basis/shuffle/shuffle.factor | 2 ++ core/generic/single/single.factor | 4 ++-- core/kernel/kernel.factor | 2 -- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/shuffle/shuffle-docs.factor b/basis/shuffle/shuffle-docs.factor index 15398450a7..ebb87eda7a 100644 --- a/basis/shuffle/shuffle-docs.factor +++ b/basis/shuffle/shuffle-docs.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax ; IN: shuffle +HELP: spin $complex-shuffle ; HELP: roll $complex-shuffle ; HELP: -roll $complex-shuffle ; diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 43c0b75be1..4388aedb3e 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -22,6 +22,8 @@ MACRO: shuffle-effect ( effect -- ) SYNTAX: shuffle( ")" parse-effect suffix! \ shuffle-effect suffix! ; +: spin ( x y z -- z y x ) swap rot ; inline deprecated + : roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated : -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 1434acf521..5636c336c3 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -63,7 +63,7 @@ TUPLE: predicate-engine class methods ; C: predicate-engine -: push-method ( method specializer atomic assoc -- ) +: push-method ( specializer method atomic assoc -- ) dupd [ [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep @@ -71,7 +71,7 @@ C: predicate-engine : flatten-method ( class method assoc -- ) [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method + [ swap rot ] dip push-method ] 3curry each ; : flatten-methods ( assoc -- assoc' ) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a0934c2b17..bb27f7e57e 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -8,8 +8,6 @@ DEFER: 2dip DEFER: 3dip ! Stack stuff -: spin ( x y z -- z y x ) swap rot ; inline - : 2over ( x y z -- x y z x y ) pick pick ; inline : clear ( -- ) { } set-datastack ; From 9ec0c3e9239a2fad4bbc415e3b099b7d6d70cf74 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 16:12:13 -0600 Subject: [PATCH 08/52] remove unused ntuck generalization, and rewrite napply not to use tuck --- basis/generalizations/generalizations-docs.factor | 7 ------- basis/generalizations/generalizations.factor | 7 ++----- 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index b04d0c53fb..ef6c376703 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -332,12 +332,6 @@ HELP: nappend-as { nappend nappend-as } related-words -HELP: ntuck -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; - ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsections narray @@ -357,7 +351,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" -nrot nnip ndrop - ntuck mnswap nweave } ; diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index dbbfc7354e..6c8a0b5fde 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -71,9 +71,6 @@ MACRO: ndrop ( n -- ) MACRO: nnip ( n -- ) '[ [ _ ndrop ] dip ] ; -MACRO: ntuck ( n -- ) - 2 + '[ dup _ -nrot ] ; - MACRO: ndip ( n -- ) [ [ dip ] curry ] n*quot [ call ] compose ; @@ -112,8 +109,8 @@ MACRO: cleave* ( n -- ) [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] if-zero ; -MACRO: napply ( n -- ) - [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ; +: napply ( quot n -- ) + [ dupn ] [ spread* ] bi ; inline : apply-curry ( ...a quot n -- ) [ [curry] ] dip napply ; inline From 61d579360dfa9dc7cfc0680a68ad7414202874a2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 17:03:24 -0600 Subject: [PATCH 09/52] remove non-primitive-related uses of tuck from basis --- basis/core-text/core-text-tests.factor | 11 ++++---- basis/csv/csv-tests.factor | 5 ++-- basis/db/sqlite/sqlite.factor | 13 +++++----- basis/fry/fry-docs.factor | 1 - basis/game/input/input.factor | 3 +-- basis/images/jpeg/jpeg.factor | 2 +- basis/io/buffers/buffers-tests.factor | 2 +- basis/io/files/info/windows/windows.factor | 25 ++++++++++++------- basis/io/launcher/windows/windows.factor | 2 +- basis/lists/lazy/lazy.factor | 2 +- basis/math/combinatorics/combinatorics.factor | 6 ++--- basis/math/intervals/intervals-tests.factor | 4 +-- basis/persistent/vectors/vectors.factor | 4 +-- basis/regexp/dfa/dfa.factor | 2 +- basis/regexp/minimize/minimize.factor | 2 +- basis/suffix-arrays/suffix-arrays.factor | 3 +-- basis/tools/scaffold/scaffold.factor | 2 +- basis/ui/traverse/traverse.factor | 9 ++++--- basis/unix/groups/groups.factor | 2 +- basis/xmode/catalog/catalog.factor | 2 +- basis/xmode/marker/marker.factor | 10 ++++---- core/kernel/kernel-docs.factor | 2 -- 22 files changed, 60 insertions(+), 54 deletions(-) diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index a5cf69fdee..b6b54df7c3 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test core-text core-text.fonts core-foundation core-foundation.dictionaries destructors arrays kernel generalizations -math accessors core-foundation.utilities combinators hashtables colors +locals math accessors core-foundation.utilities combinators hashtables colors colors.constants ; IN: core-text.tests @@ -18,10 +18,11 @@ IN: core-text.tests ] with-destructors ] unit-test -: test-typographic-bounds ( string font -- ? ) +:: test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease tuck COLOR: white &CFRelease - compute-line-metrics { + font test-font &CFRelease :> ctfont + string ctfont COLOR: white &CFRelease :> ctline + ctfont ctline compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] @@ -33,4 +34,4 @@ IN: core-text.tests [ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test -[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test \ No newline at end of file +[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 6ba8e2d5b8..829637b4aa 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -70,11 +70,12 @@ IN: csv.tests "can write csv too!" [ "foo1,bar1\nfoo2,bar2\n" ] -[ { { "foo1" "bar1" } { "foo2" "bar2" } } tuck write-csv >string ] named-unit-test +[ { { "foo1" "bar1" } { "foo2" "bar2" } } [ write-csv ] keep >string ] named-unit-test + "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] -[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " +[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } [ write-csv ] keep >string ] named-unit-test ! " [ { { "writing" "some" "csv" "tests" } } ] [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index ffcbec70d0..8d26d3b098 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint fry sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators -math.intervals io nmake accessors vectors math.ranges random +math.intervals io locals nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate io.streams.string make db.private sequences.deep db.errors.sqlite ; @@ -85,12 +85,11 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri ; -M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) - tuck - [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi - rot set-slot-named - [ [ key>> ] [ type>> ] bi ] dip - swap ; +M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + generate-bind generator-singleton>> eval-generator :> obj + generate-bind slot-name>> :> name + obj name tuple set-slot-named + generate-bind key>> obj generate-bind type>> ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 9602933785..3401208858 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -59,7 +59,6 @@ $nl { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index 377a89a884..954602cf06 100755 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -75,9 +75,8 @@ SYMBOLS: get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) get-controllers [ - tuck [ product-id = ] - [ instance-id = ] 2bi* and + [ instance-id = ] bi-curry bi* and ] with with find nip ; TUPLE: keyboard-state keys ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index e8af7144ad..e305c8477a 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -295,7 +295,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; binary [ [ { HEX: FF } read-until - read1 tuck HEX: 00 = and + read1 [ HEX: 00 = and ] keep swap ] [ drop ] produce swap >marker { EOI } assert= diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index d366df7c54..93d2f5b2fc 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -8,7 +8,7 @@ strings accessors destructors ; [ length ] dip buffer-reset ; : string>buffer ( string -- buffer ) - dup length tuck buffer-set ; + dup length [ buffer-set ] keep ; : buffer-read-all ( buffer -- byte-array ) [ [ pos>> ] [ ptr>> ] bi ] diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 5ae21fcfee..6bd3f77ffa 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -151,12 +151,16 @@ PRIVATE> M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory (file-system-info) ; -: volume>paths ( string -- array ) - 16384 tuck dup length - 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ - win32-error-string throw +:: volume>paths ( string -- array ) + 16384 :> names-buf-length + names-buf-length :> names + 0 :> names-length + + string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret + ret 0 = [ + ret win32-error-string throw ] [ - *uint "ushort" heap-size * head + names names-length *uint "ushort" heap-size * head utf16n alien>string CHAR: \0 split ] if ; @@ -166,13 +170,16 @@ M: winnt file-system-info ( path -- file-system-info ) FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; -: find-next-volume ( handle -- string/f ) - MAX_PATH 1 + [ tuck ] keep - FindNextVolume 0 = [ +:: find-next-volume ( handle -- string/f ) + MAX_PATH 1 + :> buf-length + buf-length :> buf + + handle buf buf-length FindNextVolume :> ret + ret 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if ] [ - utf16n alien>string + buf utf16n alien>string ] if ; : find-volumes ( -- array ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 6cae50bd9e..8a800115f6 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -132,7 +132,7 @@ M: windows run-process* ( process -- handle ) current-directory get absolute-path cd dup make-CreateProcess-args - tuck fill-redirection + [ fill-redirection ] keep dup call-CreateProcess lpProcessInformation>> ] with-destructors ; diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 7b386e9c81..57cacaa494 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -114,7 +114,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) + [ quot>> ] [ cons>> unswons ] bi over call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- ? ) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index bc09f9fe0f..5c03e41870 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -96,9 +96,9 @@ C: combo initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; -: combination-indices ( m combo -- seq ) - [ tuck dual-index combinadic ] keep - seq>> length 1 - swap [ - ] with map ; +:: combination-indices ( m combo -- seq ) + combo m combo dual-index combinadic + combo seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 1ee4e1e100..a569b4af7b 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -79,7 +79,7 @@ IN: math.intervals.tests [ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test -[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test +[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test [ t ] [ 0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] = @@ -250,7 +250,7 @@ IN: math.intervals.tests dup full-interval eq? [ drop 32 random-bits 31 2^ - ] [ - dup to>> first over from>> first tuck - random + + [ ] [ from>> first ] [ to>> first ] tri over - random + 2dup swap interval-contains? [ nip ] [ diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 2527959f32..b02604e9bd 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -58,7 +58,7 @@ M: persistent-vector nth-unsafe [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) - dup full? [ tuck level>> 1node ] [ node-add f ] if ; + dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ; : new-last ( val seq -- seq' ) [ length 1 - ] keep new-nth ; @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> last (ppush-new-tail) + [ nip ] 2keep children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 2de4e8b0e0..fa75232fd5 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -25,7 +25,7 @@ IN: regexp.dfa ] unless ; : epsilon-table ( states nfa -- table ) - [ H{ } clone tuck ] dip + [ [ H{ } clone ] dip over ] dip '[ _ _ t epsilon-loop ] each ; : find-epsilon-closure ( states nfa -- dfa-state ) diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index 1885144e6c..a6eb4f00a2 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -85,7 +85,7 @@ IN: regexp.minimize '[ _ delete-duplicates ] change-transitions ; : combine-state-transitions ( hash -- hash ) - H{ } clone tuck '[ + [ H{ } clone ] dip over '[ _ [ 2array ] change-at ] assoc-each [ swap ] assoc-map ; diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 931cb36ea9..f486adcb32 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -22,8 +22,7 @@ IN: suffix-arrays : ( from/f to/f seq -- slice ) [ - tuck - [ drop 0 or ] [ length or ] 2bi* + [ drop 0 or ] [ length or ] bi-curry bi* [ min ] keep ] keep ; inline diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 089bad3158..936d388b01 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -98,7 +98,7 @@ M: bad-developer-name summary [ main-file-string ] dip utf8 set-file-contents ; : scaffold-main ( vocab-root vocab -- ) - tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [ + [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [ set-scaffold-main-file ] [ 2drop diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 11c2a48a2a..5a92a4cea2 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -20,8 +20,9 @@ TUPLE: node value children ; ] [ [ [ children>> swap first head-slice % ] - [ tuck traverse-step traverse-to-path ] - 2bi + [ nip ] + [ traverse-step traverse-to-path ] + 2tri ] make-node ] if ] if ; @@ -35,7 +36,9 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1 + tail-slice % ] 2bi + [ nip ] + [ children>> swap first 1 + tail-slice % ] + 2tri ] make-node ] if ] if ; diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c4392c4c6d..02d9f37023 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -23,7 +23,7 @@ GENERIC: group-struct ( obj -- group/f ) gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - \ unix:group tuck 4096 + [ \ unix:group ] dip over 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 97de95a932..40b8e2191c 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -110,7 +110,7 @@ ERROR: mutually-recursive-rulesets ruleset ; dup [ glob-matches? ] [ 2drop f ] if ; : suitable-mode? ( file-name first-line mode -- ? ) - tuck first-line-glob>> ?glob-matches + [ nip ] 2keep first-line-glob>> ?glob-matches [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ; : find-mode ( file-name first-line -- mode ) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d3a4f1e9a2..6b8db76ac9 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -86,7 +86,7 @@ M: regexp text-matches? [ >string ] dip first-match dup [ to>> ] when ; : rule-start-matches? ( rule -- match-count/f ) - dup start>> tuck swap can-match-here? [ + [ start>> dup ] keep can-match-here? [ rest-of-line swap text>> text-matches? ] [ drop f @@ -96,7 +96,7 @@ M: regexp text-matches? dup mark-following-rule? [ dup start>> swap can-match-here? 0 and ] [ - dup end>> tuck swap can-match-here? [ + [ end>> dup ] keep can-match-here? [ rest-of-line swap text>> context get end>> or text-matches? @@ -170,7 +170,7 @@ M: seq-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck body-token>> next-token, + [ body-token>> next-token, ] keep delegate>> [ push-context ] when* ; UNION: abstract-span-rule span-rule eol-span-rule ; @@ -179,7 +179,7 @@ M: abstract-span-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep ! ... end subst ... dup context get (>>in-rule) delegate>> push-context ; @@ -190,7 +190,7 @@ M: span-rule handle-rule-end M: mark-following-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep f context get (>>end) context get (>>in-rule) ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index f70d9d4214..7327285ffd 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -21,7 +21,6 @@ HELP: 2over $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; -HELP: spin $complex-shuffle ; HELP: rot ( x y z -- y z x ) $complex-shuffle ; HELP: -rot ( x y z -- z x y ) $complex-shuffle ; HELP: dupd ( x y -- x x y ) $complex-shuffle ; @@ -828,7 +827,6 @@ $nl swapd rot -rot - spin } ; ARTICLE: "shuffle-words" "Shuffle words" From dbadab67ef69d40095a9445c942da2515059fdc4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 17:03:39 -0600 Subject: [PATCH 10/52] remove tuck from reports/noise --- extra/reports/noise/noise.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 69ac897e34..cc6c9ee33f 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -49,14 +49,12 @@ IN: reports.noise { nkeep 5 } { npick 6 } { nrot 5 } - { ntuck 6 } { nwith 4 } { over 2 } { pick 4 } { rot 3 } { swap 1 } { swapd 3 } - { tuck 2 } { with 1/2 } { bi 1/2 } From 3e28be6568279df3127d66f88ae515a20c895996 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Nov 2009 17:12:10 -0600 Subject: [PATCH 11/52] move sequence-parser to sequences.parser --- basis/compression/run-length/run-length.factor | 2 +- basis/sequences/parser/authors.txt | 2 ++ .../sequences/parser/parser-tests.factor | 2 +- .../sequences/parser/parser.factor | 2 +- extra/c/lexer/lexer-tests.factor | 2 +- extra/c/lexer/lexer.factor | 2 +- extra/c/preprocessor/preprocessor.factor | 2 +- extra/html/parser/parser.factor | 2 +- 8 files changed, 9 insertions(+), 7 deletions(-) create mode 100644 basis/sequences/parser/authors.txt rename extra/sequence-parser/sequence-parser-tests.factor => basis/sequences/parser/parser-tests.factor (98%) rename extra/sequence-parser/sequence-parser.factor => basis/sequences/parser/parser.factor (99%) diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index cde2a7e113..ce25cd6a63 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators grouping kernel locals math -math.matrices math.order multiline sequence-parser sequences +math.matrices math.order multiline sequences.parser sequences tools.continuations ; IN: compression.run-length diff --git a/basis/sequences/parser/authors.txt b/basis/sequences/parser/authors.txt new file mode 100644 index 0000000000..a07c427c98 --- /dev/null +++ b/basis/sequences/parser/authors.txt @@ -0,0 +1,2 @@ +Daniel Ehrenberg +Doug Coleman diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/basis/sequences/parser/parser-tests.factor similarity index 98% rename from extra/sequence-parser/sequence-parser-tests.factor rename to basis/sequences/parser/parser-tests.factor index af13e5b86e..f788a6da6a 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/basis/sequences/parser/parser-tests.factor @@ -1,6 +1,6 @@ USING: tools.test sequence-parser unicode.categories kernel accessors ; -IN: sequence-parser.tests +IN: sequences.parser.tests [ "hello" ] [ "hello" [ take-rest ] parse-sequence ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/basis/sequences/parser/parser.factor similarity index 99% rename from extra/sequence-parser/sequence-parser.factor rename to basis/sequences/parser/parser.factor index d14a77057f..93bbbdf53d 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/basis/sequences/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors circular combinators.short-circuit fry io kernel locals math math.order sequences sorting.functor sorting.slots unicode.categories ; -IN: sequence-parser +IN: sequences.parser TUPLE: sequence-parser sequence n ; diff --git a/extra/c/lexer/lexer-tests.factor b/extra/c/lexer/lexer-tests.factor index c972b8816c..082827353d 100644 --- a/extra/c/lexer/lexer-tests.factor +++ b/extra/c/lexer/lexer-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors c.lexer kernel sequence-parser tools.test ; +USING: accessors c.lexer kernel sequences.parser tools.test ; IN: c.lexer.tests [ 36 ] diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor index 962407e6ec..57894217bd 100644 --- a/extra/c/lexer/lexer.factor +++ b/extra/c/lexer/lexer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.short-circuit generalizations kernel locals math.order math.ranges -sequence-parser sequences sorting.functor sorting.slots +sequences.parser sequences sorting.functor sorting.slots unicode.categories ; IN: c.lexer diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 3018fa7a24..e8176c8df8 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequence-parser io io.encodings.utf8 io.files +USING: sequences.parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 9fcbffd0db..8d506cda28 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables sequence-parser +USING: accessors arrays hashtables sequences.parser html.parser.utils kernel namespaces sequences math unicode.case unicode.categories combinators.short-circuit quoting fry ; From 72ab6ec5481c51fa18f1a04b7d57f63094d0c12a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 19:03:51 -0600 Subject: [PATCH 12/52] vm: rewrite 'become' primitive so that it uses a slot visitor instead of GC --- Makefile | 1 + vm/aging_space.hpp | 9 --- vm/bump_allocator.hpp | 17 ++++++ vm/code_heap.cpp | 7 +-- vm/contexts.cpp | 8 +++ vm/data_heap.cpp | 20 ++---- vm/data_heap.hpp | 1 + vm/factor.cpp | 1 + vm/full_collector.cpp | 4 ++ vm/gc.cpp | 35 +---------- vm/master.hpp | 1 + vm/objects.cpp | 137 ++++++++++++++++++++++++++++++++++++++++++ vm/objects.hpp | 101 +++++++++++++++++++++++++++++++ vm/primitives.cpp | 8 +-- vm/quotations.cpp | 2 - vm/run.cpp | 52 ---------------- vm/run.hpp | 99 ------------------------------ vm/vm.hpp | 42 ++++++++++--- 18 files changed, 316 insertions(+), 229 deletions(-) create mode 100644 vm/objects.cpp create mode 100644 vm/objects.hpp diff --git a/Makefile b/Makefile index 2ea43706f4..52914d128a 100755 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/math.o \ vm/nursery_collector.o \ vm/object_start_map.o \ + vm/objects.o \ vm/primitives.o \ vm/profiler.o \ vm/quotations.o \ diff --git a/vm/aging_space.hpp b/vm/aging_space.hpp index 7a28f54ebf..ccb2d1a1a2 100644 --- a/vm/aging_space.hpp +++ b/vm/aging_space.hpp @@ -15,15 +15,6 @@ struct aging_space : bump_allocator { starts.record_object_start_offset(obj); return obj; } - - cell next_object_after(cell scan) - { - cell size = ((object *)scan)->size(); - if(scan + size < here) - return scan + size; - else - return 0; - } }; } diff --git a/vm/bump_allocator.hpp b/vm/bump_allocator.hpp index 5488c65323..bbe4df8eec 100644 --- a/vm/bump_allocator.hpp +++ b/vm/bump_allocator.hpp @@ -32,6 +32,23 @@ template struct bump_allocator { { return end - here; } + + cell next_object_after(cell scan) + { + cell size = ((Block *)scan)->size(); + if(scan + size < here) + return scan + size; + else + return 0; + } + + cell first_object() + { + if(start != here) + return start; + else + return 0; + } }; } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index b4e071d644..44a7a54dfa 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -118,10 +118,8 @@ struct word_and_literal_code_heap_updater { void factor_vm::update_code_heap_words_and_literals() { - current_gc->event->started_code_sweep(); word_and_literal_code_heap_updater updater(this); - code->allocator->sweep(updater); - current_gc->event->ended_code_sweep(); + iterate_code_heap(updater); } /* After growing the heap, we have to perform a full relocation to update @@ -152,8 +150,7 @@ void factor_vm::primitive_modify_code_heap() if(count == 0) return; - cell i; - for(i = 0; i < count; i++) + for(cell i = 0; i < count; i++) { data_root pair(array_nth(alist.untagged(),i),this); diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 7af7fdaa57..16b882f2cc 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -196,4 +196,12 @@ void factor_vm::primitive_check_datastack() } } +void factor_vm::primitive_load_locals() +{ + fixnum count = untag_fixnum(dpop()); + memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count); + ds -= sizeof(cell) * count; + rs += sizeof(cell) * count; +} + } diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index bb705e276c..f9771d47a0 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -103,6 +103,12 @@ bool data_heap::low_memory_p() return (tenured->free_space() <= nursery->size + aging->size); } +void data_heap::mark_all_cards() +{ + memset(cards,-1,cards_end - cards); + memset(decks,-1,decks_end - decks); +} + void factor_vm::set_data_heap(data_heap *data_) { data = data_; @@ -115,15 +121,6 @@ void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_si set_data_heap(new data_heap(young_size,aging_size,tenured_size)); } -/* Size of the object pointed to by a tagged pointer */ -cell factor_vm::object_size(cell tagged) -{ - if(immediate_p(tagged)) - return 0; - else - return untag(tagged)->size(); -} - /* Size of the object pointed to by an untagged pointer */ cell object::size() const { @@ -201,11 +198,6 @@ cell object::binary_payload_start() const } } -void factor_vm::primitive_size() -{ - box_unsigned_cell(object_size(dpop())); -} - data_heap_room factor_vm::data_room() { data_heap_room room; diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index 760a10942e..ce156696b8 100755 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -30,6 +30,7 @@ struct data_heap { void reset_generation(aging_space *gen); void reset_generation(tenured_space *gen); bool low_memory_p(); + void mark_all_cards(); }; struct data_heap_room { diff --git a/vm/factor.cpp b/vm/factor.cpp index d382745da8..589d1898b1 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -86,6 +86,7 @@ void factor_vm::do_stage1_init() fflush(stdout); compile_all_words(); + update_code_heap_words(); special_objects[OBJ_STAGE2] = true_object; std::cout << "done\n"; diff --git a/vm/full_collector.cpp b/vm/full_collector.cpp index 3b92e2574e..07c410218c 100644 --- a/vm/full_collector.cpp +++ b/vm/full_collector.cpp @@ -116,6 +116,10 @@ void factor_vm::collect_sweep_impl() data->tenured->sweep(); update_code_roots_for_sweep(); current_gc->event->ended_data_sweep(); + + current_gc->event->started_code_sweep(); + code->allocator->sweep(); + current_gc->event->ended_code_sweep(); } void factor_vm::collect_full(bool trace_contexts_p) diff --git a/vm/gc.cpp b/vm/gc.cpp index de8a2886f7..79f04db802 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -218,37 +218,6 @@ void factor_vm::primitive_compact_gc() true /* trace contexts? */); } -/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this - to coalesce equal but distinct quotations and wrappers. */ -void factor_vm::primitive_become() -{ - array *new_objects = untag_check(dpop()); - array *old_objects = untag_check(dpop()); - - cell capacity = array_capacity(new_objects); - if(capacity != array_capacity(old_objects)) - critical_error("bad parameters to become",0); - - cell i; - - for(i = 0; i < capacity; i++) - { - tagged old_obj(array_nth(old_objects,i)); - tagged new_obj(array_nth(new_objects,i)); - - if(old_obj != new_obj) - old_obj->h.forward_to(new_obj.untagged()); - } - - primitive_full_gc(); - - /* If a word's definition quotation was in old_objects and the - quotation in new_objects is not compiled, we might leak memory - by referencing the old quotation unless we recompile all - unoptimized words. */ - compile_all_words(); -} - void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size) { for(cell i = 0; i < data_roots_size; i++) @@ -290,9 +259,7 @@ object *factor_vm::allot_large_object(header header, cell size) /* Allows initialization code to store old->new pointers without hitting the write barrier in the common case of a nursery allocation */ - char *start = (char *)obj; - for(cell offset = 0; offset < size; offset += card_size) - write_barrier((cell *)(start + offset)); + write_barrier(obj,size); obj->h = header; return obj; diff --git a/vm/master.hpp b/vm/master.hpp index 39242a36af..23c70782df 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -44,6 +44,7 @@ namespace factor #include "segments.hpp" #include "contexts.hpp" #include "run.hpp" +#include "objects.hpp" #include "profiler.hpp" #include "errors.hpp" #include "bignumint.hpp" diff --git a/vm/objects.cpp b/vm/objects.cpp new file mode 100644 index 0000000000..ad76d7c1b6 --- /dev/null +++ b/vm/objects.cpp @@ -0,0 +1,137 @@ +#include "master.hpp" + +namespace factor +{ + +void factor_vm::primitive_special_object() +{ + fixnum e = untag_fixnum(dpeek()); + drepl(special_objects[e]); +} + +void factor_vm::primitive_set_special_object() +{ + fixnum e = untag_fixnum(dpop()); + cell value = dpop(); + special_objects[e] = value; +} + +void factor_vm::primitive_set_slot() +{ + fixnum slot = untag_fixnum(dpop()); + object *obj = untag(dpop()); + cell value = dpop(); + + cell *slot_ptr = &obj->slots()[slot]; + *slot_ptr = value; + write_barrier(slot_ptr); +} + +cell factor_vm::clone_object(cell obj_) +{ + data_root obj(obj_,this); + + if(immediate_p(obj.value())) + return obj.value(); + else + { + cell size = object_size(obj.value()); + object *new_obj = allot_object(header(obj.type()),size); + memcpy(new_obj,obj.untagged(),size); + return tag_dynamic(new_obj); + } +} + +void factor_vm::primitive_clone() +{ + drepl(clone_object(dpeek())); +} + +/* Size of the object pointed to by a tagged pointer */ +cell factor_vm::object_size(cell tagged) +{ + if(immediate_p(tagged)) + return 0; + else + return untag(tagged)->size(); +} + +void factor_vm::primitive_size() +{ + box_unsigned_cell(object_size(dpop())); +} + +struct slot_become_visitor { + std::map *become_map; + + explicit slot_become_visitor(std::map *become_map_) : + become_map(become_map_) {} + + object *operator()(object *old) + { + std::map::const_iterator iter = become_map->find(old); + if(iter != become_map->end()) + return iter->second; + else + return old; + } +}; + +struct object_become_visitor { + slot_visitor *workhorse; + + explicit object_become_visitor(slot_visitor *workhorse_) : + workhorse(workhorse_) {} + + void operator()(cell obj) + { + workhorse->visit_slots(tagged(obj).untagged()); + } +}; + +/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this + to coalesce equal but distinct quotations and wrappers. */ +void factor_vm::primitive_become() +{ + array *new_objects = untag_check(dpop()); + array *old_objects = untag_check(dpop()); + + cell capacity = array_capacity(new_objects); + if(capacity != array_capacity(old_objects)) + critical_error("bad parameters to become",0); + + /* Build the forwarding map */ + std::map become_map; + + for(cell i = 0; i < capacity; i++) + { + tagged old_obj(array_nth(old_objects,i)); + tagged new_obj(array_nth(new_objects,i)); + + if(old_obj != new_obj) + become_map[old_obj.untagged()] = new_obj.untagged(); + } + + /* Update all references to old objects to point to new objects */ + slot_visitor workhorse(this,slot_become_visitor(&become_map)); + workhorse.visit_roots(); + workhorse.visit_contexts(); + + object_become_visitor object_visitor(&workhorse); + each_object(object_visitor); + + /* Since we may have introduced old->new references, need to revisit + all objects on a minor GC. */ + data->mark_all_cards(); + + /* If a word's definition quotation was in old_objects and the + quotation in new_objects is not compiled, we might leak memory + by referencing the old quotation unless we recompile all + unoptimized words. */ + compile_all_words(); + + /* Update references to old objects in the code heap */ + update_code_heap_words_and_literals(); +} + +} diff --git a/vm/objects.hpp b/vm/objects.hpp new file mode 100644 index 0000000000..c4e8547ce6 --- /dev/null +++ b/vm/objects.hpp @@ -0,0 +1,101 @@ +namespace factor +{ + +static const cell special_object_count = 70; + +enum special_object { + OBJ_NAMESTACK, /* used by library only */ + OBJ_CATCHSTACK, /* used by library only, per-callback */ + + OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */ + OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */ + OBJ_CALLCC_1, /* used to pass the value in callcc1 */ + + OBJ_BREAK = 5, /* quotation called by throw primitive */ + OBJ_ERROR, /* a marker consed onto kernel errors */ + + OBJ_CELL_SIZE = 7, /* sizeof(cell) */ + OBJ_CPU, /* CPU architecture */ + OBJ_OS, /* operating system name */ + + OBJ_ARGS = 10, /* command line arguments */ + OBJ_STDIN, /* stdin FILE* handle */ + OBJ_STDOUT, /* stdout FILE* handle */ + + OBJ_IMAGE = 13, /* image path name */ + OBJ_EXECUTABLE, /* runtime executable path name */ + + OBJ_EMBEDDED = 15, /* are we embedded in another app? */ + OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */ + OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */ + OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */ + + OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */ + + OBJ_BOOT = 20, /* boot quotation */ + OBJ_GLOBAL, /* global namespace */ + + /* Quotation compilation in quotations.c */ + JIT_PROLOG = 23, + JIT_PRIMITIVE_WORD, + JIT_PRIMITIVE, + JIT_WORD_JUMP, + JIT_WORD_CALL, + JIT_WORD_SPECIAL, + JIT_IF_WORD, + JIT_IF, + JIT_EPILOG, + JIT_RETURN, + JIT_PROFILING, + JIT_PUSH_IMMEDIATE, + JIT_DIP_WORD, + JIT_DIP, + JIT_2DIP_WORD, + JIT_2DIP, + JIT_3DIP_WORD, + JIT_3DIP, + JIT_EXECUTE_WORD, + JIT_EXECUTE_JUMP, + JIT_EXECUTE_CALL, + JIT_DECLARE_WORD, + + /* Callback stub generation in callbacks.c */ + CALLBACK_STUB = 45, + + /* Polymorphic inline cache generation in inline_cache.c */ + PIC_LOAD = 47, + PIC_TAG, + PIC_TUPLE, + PIC_CHECK_TAG, + PIC_CHECK_TUPLE, + PIC_HIT, + PIC_MISS_WORD, + PIC_MISS_TAIL_WORD, + + /* Megamorphic cache generation in dispatch.c */ + MEGA_LOOKUP = 57, + MEGA_LOOKUP_WORD, + MEGA_MISS_WORD, + + OBJ_UNDEFINED = 60, /* default quotation for undefined words */ + + OBJ_STDERR = 61, /* stderr FILE* handle */ + + OBJ_STAGE2 = 62, /* have we bootstrapped? */ + + OBJ_CURRENT_THREAD = 63, + + OBJ_THREADS = 64, + OBJ_RUN_QUEUE = 65, + OBJ_SLEEP_QUEUE = 66, +}; + +#define OBJ_FIRST_SAVE OBJ_BOOT +#define OBJ_LAST_SAVE OBJ_STAGE2 + +inline static bool save_env_p(cell i) +{ + return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE); +} + +} diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 957e6128ed..b8d909fbe8 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -49,8 +49,8 @@ PRIMITIVE_FORWARD(float_greater) PRIMITIVE_FORWARD(float_greatereq) PRIMITIVE_FORWARD(word) PRIMITIVE_FORWARD(word_xt) -PRIMITIVE_FORWARD(getenv) -PRIMITIVE_FORWARD(setenv) +PRIMITIVE_FORWARD(special_object) +PRIMITIVE_FORWARD(set_special_object) PRIMITIVE_FORWARD(existsp) PRIMITIVE_FORWARD(minor_gc) PRIMITIVE_FORWARD(full_gc) @@ -185,8 +185,8 @@ const primitive_type primitives[] = { primitive_float_greatereq, primitive_word, primitive_word_xt, - primitive_getenv, - primitive_setenv, + primitive_special_object, + primitive_set_special_object, primitive_existsp, primitive_minor_gc, primitive_full_gc, diff --git a/vm/quotations.cpp b/vm/quotations.cpp index fc19266cee..8ccafc9d8f 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -341,8 +341,6 @@ void factor_vm::compile_all_words() update_word_xt(word.untagged()); } - - update_code_heap_words(); } /* Allocates memory */ diff --git a/vm/run.cpp b/vm/run.cpp index 6d3e9f7374..59375df1fb 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -3,19 +3,6 @@ namespace factor { -void factor_vm::primitive_getenv() -{ - fixnum e = untag_fixnum(dpeek()); - drepl(special_objects[e]); -} - -void factor_vm::primitive_setenv() -{ - fixnum e = untag_fixnum(dpop()); - cell value = dpop(); - special_objects[e] = value; -} - void factor_vm::primitive_exit() { exit(to_fixnum(dpop())); @@ -31,43 +18,4 @@ void factor_vm::primitive_sleep() sleep_micros(to_cell(dpop())); } -void factor_vm::primitive_set_slot() -{ - fixnum slot = untag_fixnum(dpop()); - object *obj = untag(dpop()); - cell value = dpop(); - - cell *slot_ptr = &obj->slots()[slot]; - *slot_ptr = value; - write_barrier(slot_ptr); -} - -void factor_vm::primitive_load_locals() -{ - fixnum count = untag_fixnum(dpop()); - memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count); - ds -= sizeof(cell) * count; - rs += sizeof(cell) * count; -} - -cell factor_vm::clone_object(cell obj_) -{ - data_root obj(obj_,this); - - if(immediate_p(obj.value())) - return obj.value(); - else - { - cell size = object_size(obj.value()); - object *new_obj = allot_object(header(obj.type()),size); - memcpy(new_obj,obj.untagged(),size); - return tag_dynamic(new_obj); - } -} - -void factor_vm::primitive_clone() -{ - drepl(clone_object(dpeek())); -} - } diff --git a/vm/run.hpp b/vm/run.hpp index 6ca2e50464..412ef35bb4 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -1,103 +1,4 @@ namespace factor { -static const cell special_object_count = 70; - -enum special_object { - OBJ_NAMESTACK, /* used by library only */ - OBJ_CATCHSTACK, /* used by library only, per-callback */ - - OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */ - OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */ - OBJ_CALLCC_1, /* used to pass the value in callcc1 */ - - OBJ_BREAK = 5, /* quotation called by throw primitive */ - OBJ_ERROR, /* a marker consed onto kernel errors */ - - OBJ_CELL_SIZE = 7, /* sizeof(cell) */ - OBJ_CPU, /* CPU architecture */ - OBJ_OS, /* operating system name */ - - OBJ_ARGS = 10, /* command line arguments */ - OBJ_STDIN, /* stdin FILE* handle */ - OBJ_STDOUT, /* stdout FILE* handle */ - - OBJ_IMAGE = 13, /* image path name */ - OBJ_EXECUTABLE, /* runtime executable path name */ - - OBJ_EMBEDDED = 15, /* are we embedded in another app? */ - OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */ - OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */ - OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */ - - OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */ - - OBJ_BOOT = 20, /* boot quotation */ - OBJ_GLOBAL, /* global namespace */ - - /* Quotation compilation in quotations.c */ - JIT_PROLOG = 23, - JIT_PRIMITIVE_WORD, - JIT_PRIMITIVE, - JIT_WORD_JUMP, - JIT_WORD_CALL, - JIT_WORD_SPECIAL, - JIT_IF_WORD, - JIT_IF, - JIT_EPILOG, - JIT_RETURN, - JIT_PROFILING, - JIT_PUSH_IMMEDIATE, - JIT_DIP_WORD, - JIT_DIP, - JIT_2DIP_WORD, - JIT_2DIP, - JIT_3DIP_WORD, - JIT_3DIP, - JIT_EXECUTE_WORD, - JIT_EXECUTE_JUMP, - JIT_EXECUTE_CALL, - JIT_DECLARE_WORD, - - /* Callback stub generation in callbacks.c */ - CALLBACK_STUB = 45, - - /* Polymorphic inline cache generation in inline_cache.c */ - PIC_LOAD = 47, - PIC_TAG, - PIC_TUPLE, - PIC_CHECK_TAG, - PIC_CHECK_TUPLE, - PIC_HIT, - PIC_MISS_WORD, - PIC_MISS_TAIL_WORD, - - /* Megamorphic cache generation in dispatch.c */ - MEGA_LOOKUP = 57, - MEGA_LOOKUP_WORD, - MEGA_MISS_WORD, - - OBJ_UNDEFINED = 60, /* default quotation for undefined words */ - - OBJ_STDERR = 61, /* stderr FILE* handle */ - - OBJ_STAGE2 = 62, /* have we bootstrapped? */ - - OBJ_CURRENT_THREAD = 63, - - OBJ_THREADS = 64, - OBJ_RUN_QUEUE = 65, - OBJ_SLEEP_QUEUE = 66, -}; - -#define OBJ_FIRST_SAVE OBJ_BOOT -#define OBJ_LAST_SAVE OBJ_STAGE2 - -inline static bool save_env_p(cell i) -{ - return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE); } - -} - - diff --git a/vm/vm.hpp b/vm/vm.hpp index aa5a3051e6..0a65873f6c 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -102,6 +102,7 @@ struct factor_vm void primitive_set_datastack(); void primitive_set_retainstack(); void primitive_check_datastack(); + void primitive_load_locals(); template void iterate_active_frames(Iterator &iter) { @@ -116,15 +117,18 @@ struct factor_vm } // run - void primitive_getenv(); - void primitive_setenv(); void primitive_exit(); void primitive_micros(); void primitive_sleep(); void primitive_set_slot(); - void primitive_load_locals(); + + // objects + void primitive_special_object(); + void primitive_set_special_object(); + cell object_size(cell tagged); cell clone_object(cell obj_); void primitive_clone(); + void primitive_become(); // profiler void init_profiler(); @@ -225,15 +229,27 @@ struct factor_vm void primitive_next_object(); void primitive_end_scan(); cell find_all_words(); - cell object_size(cell tagged); + + template + inline void each_object(Generation *gen, Iterator &iterator) + { + cell obj = gen->first_object(); + while(obj) + { + iterator(obj); + obj = gen->next_object_after(obj); + } + } template inline void each_object(Iterator &iterator) { - begin_scan(); - cell obj; - while(to_boolean(obj = next_object())) - iterator(obj); - end_scan(); + gc_off = true; + + each_object(data->tenured,iterator); + each_object(data->aging,iterator); + each_object(data->nursery,iterator); + + gc_off = false; } /* the write barrier must be called any time we are potentially storing a @@ -244,6 +260,13 @@ struct factor_vm *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits)) = card_mark_mask; } + inline void write_barrier(object *obj, cell size) + { + char *start = (char *)obj; + for(cell offset = 0; offset < size; offset += card_size) + write_barrier((cell *)(start + offset)); + } + // gc void end_gc(); void start_gc_again(); @@ -264,7 +287,6 @@ struct factor_vm void primitive_minor_gc(); void primitive_full_gc(); void primitive_compact_gc(); - void primitive_become(); void inline_gc(cell *data_roots_base, cell data_roots_size); void primitive_enable_gc_events(); void primitive_disable_gc_events(); From 22c717616c924ed2281d372d1b527575685482fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 19:29:27 -0600 Subject: [PATCH 13/52] vm: speed up some bit twiddling on 32-bit --- basis/vm/vm.factor | 2 +- vm/bitwise_hacks.hpp | 59 +++++++++++++++++++---------------------- vm/mark_bits.hpp | 40 +++++++++++++++------------- vm/object_start_map.cpp | 7 ++++- 4 files changed, 55 insertions(+), 53 deletions(-) diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index ba057edffa..86ff4497b8 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -3,7 +3,7 @@ USING: classes.struct alien.c-types alien.syntax ; IN: vm -TYPEDEF: intptr_t cell +TYPEDEF: uintptr_t cell C-TYPE: context STRUCT: zone diff --git a/vm/bitwise_hacks.hpp b/vm/bitwise_hacks.hpp index dc685bb28c..8830e4f876 100644 --- a/vm/bitwise_hacks.hpp +++ b/vm/bitwise_hacks.hpp @@ -3,65 +3,60 @@ namespace factor /* These algorithms were snarfed from various places. I did not come up with them myself */ -inline cell popcount(u64 x) +inline cell popcount(cell x) { +#ifdef FACTOR_64 u64 k1 = 0x5555555555555555ll; u64 k2 = 0x3333333333333333ll; u64 k4 = 0x0f0f0f0f0f0f0f0fll; u64 kf = 0x0101010101010101ll; + cell ks = 56; +#else + u32 k1 = 0x55555555; + u32 k2 = 0x33333333; + u32 k4 = 0xf0f0f0f; + u32 kf = 0x1010101; + cell ks = 24; +#endif + x = x - ((x >> 1) & k1); // put count of each 2 bits into those 2 bits x = (x & k2) + ((x >> 2) & k2); // put count of each 4 bits into those 4 bits x = (x + (x >> 4)) & k4 ; // put count of each 8 bits into those 8 bits - x = (x * kf) >> 56; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ... + x = (x * kf) >> ks; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ... return (cell)x; } -inline cell log2(u64 x) +inline cell log2(cell x) { -#ifdef FACTOR_AMD64 +#if defined(FACTOR_X86) cell n; - asm ("bsr %1, %0;":"=r"(n):"r"((cell)x)); + asm ("bsr %1, %0;":"=r"(n):"r"(x)); +#elif defined(FACTOR_AMD64) + cell n; + asm ("bsr %1, %0;":"=r"(n):"r"(x)); #else cell n = 0; +#ifdef FACTOR_64 if (x >= (u64)1 << 32) { x >>= 32; n += 32; } - if (x >= (u64)1 << 16) { x >>= 16; n += 16; } - if (x >= (u64)1 << 8) { x >>= 8; n += 8; } - if (x >= (u64)1 << 4) { x >>= 4; n += 4; } - if (x >= (u64)1 << 2) { x >>= 2; n += 2; } - if (x >= (u64)1 << 1) { n += 1; } +#endif + if (x >= (u32)1 << 16) { x >>= 16; n += 16; } + if (x >= (u32)1 << 8) { x >>= 8; n += 8; } + if (x >= (u32)1 << 4) { x >>= 4; n += 4; } + if (x >= (u32)1 << 2) { x >>= 2; n += 2; } + if (x >= (u32)1 << 1) { n += 1; } #endif return n; } -inline cell log2(u16 x) -{ -#if defined(FACTOR_X86) || defined(FACTOR_AMD64) - cell n; - asm ("bsr %1, %0;":"=r"(n):"r"((cell)x)); -#else - cell n = 0; - if (x >= 1 << 8) { x >>= 8; n += 8; } - if (x >= 1 << 4) { x >>= 4; n += 4; } - if (x >= 1 << 2) { x >>= 2; n += 2; } - if (x >= 1 << 1) { n += 1; } -#endif - return n; -} - -inline cell rightmost_clear_bit(u64 x) +inline cell rightmost_clear_bit(cell x) { return log2(~x & (x + 1)); } -inline cell rightmost_set_bit(u64 x) +inline cell rightmost_set_bit(cell x) { return log2(x & -x); } -inline cell rightmost_set_bit(u16 x) -{ - return log2((u16)(x & -x)); -} - } diff --git a/vm/mark_bits.hpp b/vm/mark_bits.hpp index b54a2c9d46..d4b1dcda8d 100644 --- a/vm/mark_bits.hpp +++ b/vm/mark_bits.hpp @@ -2,18 +2,19 @@ namespace factor { const int block_granularity = 16; -const int forwarding_granularity = 64; +const int mark_bits_granularity = sizeof(cell) * 8; +const int mark_bits_mask = sizeof(cell) * 8 - 1; template struct mark_bits { cell size; cell start; cell bits_size; - u64 *marked; + cell *marked; cell *forwarding; void clear_mark_bits() { - memset(marked,0,bits_size * sizeof(u64)); + memset(marked,0,bits_size * sizeof(cell)); } void clear_forwarding() @@ -24,8 +25,8 @@ template struct mark_bits { explicit mark_bits(cell size_, cell start_) : size(size_), start(start_), - bits_size(size / block_granularity / forwarding_granularity), - marked(new u64[bits_size]), + bits_size(size / block_granularity / mark_bits_granularity), + marked(new cell[bits_size]), forwarding(new cell[bits_size]) { clear_mark_bits(); @@ -53,15 +54,15 @@ template struct mark_bits { std::pair bitmap_deref(Block *address) { cell line_number = block_line(address); - cell word_index = (line_number >> 6); - cell word_shift = (line_number & 63); + cell word_index = (line_number / mark_bits_granularity); + cell word_shift = (line_number & mark_bits_mask); return std::make_pair(word_index,word_shift); } - bool bitmap_elt(u64 *bits, Block *address) + bool bitmap_elt(cell *bits, Block *address) { std::pair position = bitmap_deref(address); - return (bits[position.first] & ((u64)1 << position.second)) != 0; + return (bits[position.first] & ((cell)1 << position.second)) != 0; } Block *next_block_after(Block *block) @@ -69,13 +70,13 @@ template struct mark_bits { return (Block *)((cell)block + block->size()); } - void set_bitmap_range(u64 *bits, Block *address) + void set_bitmap_range(cell *bits, Block *address) { std::pair start = bitmap_deref(address); std::pair end = bitmap_deref(next_block_after(address)); - u64 start_mask = ((u64)1 << start.second) - 1; - u64 end_mask = ((u64)1 << end.second) - 1; + cell start_mask = ((cell)1 << start.second) - 1; + cell end_mask = ((cell)1 << end.second) - 1; if(start.first == end.first) bits[start.first] |= start_mask ^ end_mask; @@ -87,7 +88,7 @@ template struct mark_bits { bits[start.first] |= ~start_mask; for(cell index = start.first + 1; index < end.first; index++) - bits[index] = (u64)-1; + bits[index] = (cell)-1; if(end_mask != 0) { @@ -121,7 +122,8 @@ template struct mark_bits { } } - /* We have the popcount for every 64 entries; look up and compute the rest */ + /* We have the popcount for every mark_bits_granularity entries; look + up and compute the rest */ Block *forward_block(Block *original) { #ifdef FACTOR_DEBUG @@ -130,7 +132,7 @@ template struct mark_bits { std::pair position = bitmap_deref(original); cell approx_popcount = forwarding[position.first]; - u64 mask = ((u64)1 << position.second) - 1; + cell mask = ((cell)1 << position.second) - 1; cell new_line_number = approx_popcount + popcount(marked[position.first] & mask); Block *new_block = line_block(new_line_number); @@ -147,13 +149,13 @@ template struct mark_bits { for(cell index = position.first; index < bits_size; index++) { - u64 mask = ((s64)marked[index] >> bit_index); + cell mask = ((fixnum)marked[index] >> bit_index); if(~mask) { /* Found an unmarked block on this page. Stop, it's hammer time */ cell clear_bit = rightmost_clear_bit(mask); - return line_block(index * 64 + bit_index + clear_bit); + return line_block(index * mark_bits_granularity + bit_index + clear_bit); } else { @@ -174,13 +176,13 @@ template struct mark_bits { for(cell index = position.first; index < bits_size; index++) { - u64 mask = (marked[index] >> bit_index); + cell mask = (marked[index] >> bit_index); if(mask) { /* Found an marked block on this page. Stop, it's hammer time */ cell set_bit = rightmost_set_bit(mask); - return line_block(index * 64 + bit_index + set_bit); + return line_block(index * mark_bits_granularity + bit_index + set_bit); } else { diff --git a/vm/object_start_map.cpp b/vm/object_start_map.cpp index 724f365e79..3159313dd5 100644 --- a/vm/object_start_map.cpp +++ b/vm/object_start_map.cpp @@ -79,11 +79,16 @@ void object_start_map::update_for_sweep(mark_bits *state) { for(cell index = 0; index < state->bits_size; index++) { - u64 mask = state->marked[index]; + cell mask = state->marked[index]; +#ifdef FACTOR_64 update_card_for_sweep(index * 4, mask & 0xffff); update_card_for_sweep(index * 4 + 1, (mask >> 16) & 0xffff); update_card_for_sweep(index * 4 + 2, (mask >> 32) & 0xffff); update_card_for_sweep(index * 4 + 3, (mask >> 48) & 0xffff); +#else + update_card_for_sweep(index * 2, mask & 0xffff); + update_card_for_sweep(index * 2 + 1, (mask >> 16) & 0xffff); +#endif } } From 18a2ce1f8cd0208af1ccd0e2b942ddd84ac8b991 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 19:32:26 -0600 Subject: [PATCH 14/52] vm: remove some dead code --- vm/code_heap.cpp | 6 ----- vm/free_list_allocator.hpp | 54 -------------------------------------- vm/vm.hpp | 1 - 3 files changed, 61 deletions(-) diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 44a7a54dfa..98da158b16 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -135,12 +135,6 @@ struct code_heap_relocator { } }; -void factor_vm::relocate_code_heap() -{ - code_heap_relocator relocator(this); - code->allocator->sweep(relocator); -} - void factor_vm::primitive_modify_code_heap() { data_root alist(dpop(),this); diff --git a/vm/free_list_allocator.hpp b/vm/free_list_allocator.hpp index a4801daa72..62e4e09758 100644 --- a/vm/free_list_allocator.hpp +++ b/vm/free_list_allocator.hpp @@ -23,7 +23,6 @@ template struct free_list_allocator { cell largest_free_block(); cell free_block_count(); void sweep(); - template void sweep(Iterator &iter); template void compact(Iterator &iter, Sizer &sizer); template void iterate(Iterator &iter, Sizer &sizer); template void iterate(Iterator &iter); @@ -152,59 +151,6 @@ void free_list_allocator::sweep() } } -template -template -void free_list_allocator::sweep(Iterator &iter) -{ - free_blocks.clear_free_list(); - - Block *prev = NULL; - Block *scan = this->first_block(); - Block *end = this->last_block(); - - while(scan != end) - { - cell size = scan->size(); - - if(scan->free_p()) - { - if(prev && prev->free_p()) - { - free_heap_block *free_prev = (free_heap_block *)prev; - free_prev->make_free(free_prev->size() + size); - } - else - prev = scan; - } - else if(this->state.marked_p(scan)) - { - if(prev && prev->free_p()) - free_blocks.add_to_free_list((free_heap_block *)prev); - prev = scan; - iter(scan,size); - } - else - { - if(prev && prev->free_p()) - { - free_heap_block *free_prev = (free_heap_block *)prev; - free_prev->make_free(free_prev->size() + size); - } - else - { - free_heap_block *free_block = (free_heap_block *)scan; - free_block->make_free(size); - prev = scan; - } - } - - scan = (Block *)((cell)scan + size); - } - - if(prev && prev->free_p()) - free_blocks.add_to_free_list((free_heap_block *)prev); -} - template struct heap_compactor { mark_bits *state; char *address; diff --git a/vm/vm.hpp b/vm/vm.hpp index 0a65873f6c..81dd30000e 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -530,7 +530,6 @@ struct factor_vm void jit_compile_word(cell word_, cell def_, bool relocate); void update_code_heap_words(); void update_code_heap_words_and_literals(); - void relocate_code_heap(); void primitive_modify_code_heap(); code_heap_room code_room(); void primitive_code_room(); From 4061951d1c94bd9cd0db6500e95506c80122c297 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 21:49:03 -0600 Subject: [PATCH 15/52] vm: simpler object space implementation. begin-scan/next-object/end-scan primitives replaced by a single all-instances primitive --- .../known-words/known-words.factor | 6 +- basis/tools/memory/memory-docs.factor | 7 +- core/bootstrap/primitives.factor | 4 +- core/bootstrap/stage1.factor | 16 +--- core/memory/memory-docs.factor | 35 +------ core/memory/memory.factor | 19 +--- vm/compaction.cpp | 4 +- vm/data_heap.cpp | 92 ++++++------------- vm/debug.cpp | 21 +++-- vm/image.cpp | 2 +- vm/objects.cpp | 5 +- vm/primitives.cpp | 8 +- vm/vm.hpp | 20 ++-- 13 files changed, 64 insertions(+), 175 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2c0ce853aa..26b122257f 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -623,11 +623,7 @@ M: bad-executable summary \ { integer object } { array } define-primitive \ make-flushable -\ begin-scan { } { } define-primitive - -\ next-object { } { object } define-primitive - -\ end-scan { } { } define-primitive +\ all-instances { } { array } define-primitive \ size { object } { fixnum } define-primitive \ size make-flushable diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor index f729e8945f..b18396538f 100644 --- a/basis/tools/memory/memory-docs.factor +++ b/basis/tools/memory/memory-docs.factor @@ -13,11 +13,8 @@ ARTICLE: "tools.memory" "Object memory tools" data-room code-room } -"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:" -{ $subsections - each-object - instances -} +"A combinator to get objects from the heap:" +{ $subsections instances } "You can check an object's the heap memory usage:" { $subsections size } "The garbage collector can be invoked manually:" diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5d4144e354..07e5eee1c3 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -473,9 +473,7 @@ tuple { "resize-array" "arrays" (( n array -- newarray )) } { "resize-string" "strings" (( n str -- newstr )) } { "" "arrays" (( n elt -- array )) } - { "begin-scan" "memory" (( -- )) } - { "next-object" "memory" (( -- obj )) } - { "end-scan" "memory" (( -- )) } + { "all-instances" "memory" (( -- array )) } { "size" "memory" (( obj -- n )) } { "die" "kernel" (( -- )) } { "(fopen)" "io.streams.c" (( path mode -- alien )) } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 9c84904ff7..1a2cdf6a70 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -17,25 +17,19 @@ load-help? off ! Create a boot quotation for the target [ [ - ! Rehash hashtables, since bootstrap.image creates them - ! using the host image's hashing algorithms. We don't - ! use each-object here since the catch stack isn't yet - ! set up. - gc - begin-scan - [ hashtable? ] pusher [ (each-object) ] dip - end-scan - [ rehash ] each + ! Rehash hashtables first, since bootstrap.image creates + ! them using the host image's hashing algorithms. + [ hashtable? ] instances [ rehash ] each boot ] % "math.integers" require "math.floats" require "memory" require - + "io.streams.c" require "vocabs.loader" require - + "syntax" require "bootstrap.layouts" require diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index d40705a531..d1832b41ba 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -2,31 +2,9 @@ USING: help.markup help.syntax debugger sequences kernel quotations math ; IN: memory -HELP: begin-scan ( -- ) -{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." -$nl -"This word must always be paired with a call to " { $link end-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: next-object ( -- obj ) -{ $values { "obj" object } } -{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." } -{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: end-scan ( -- ) -{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: each-object -{ $values { "quot" { $quotation "( obj -- )" } } } -{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." } -{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ; - HELP: instances { $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } } -{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } -{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ; +{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ; HELP: gc ( -- ) { $description "Performs a full garbage collection." } ; @@ -56,17 +34,6 @@ HELP: save-image-and-exit ( path -- ) HELP: save { $description "Saves a snapshot of the heap to the current image file." } ; -HELP: count-instances -{ $values - { "quot" quotation } - { "n" integer } } -{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." } -{ $examples { $unchecked-example - "USING: memory words prettyprint ;" - "[ word? ] count-instances ." - "24210" -} } ; - ARTICLE: "images" "Images" "Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance." { $subsections diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 1c61e33d83..4ab68a1ef1 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,26 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences vectors arrays system math +USING: kernel continuations sequences system io.backend alien.strings memory.private ; IN: memory -: (each-object) ( quot: ( obj -- ) -- ) - next-object dup [ - swap [ call ] keep (each-object) - ] [ 2drop ] if ; inline recursive - -: each-object ( quot -- ) - gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline - -: count-instances ( quot -- n ) - 0 swap [ 1 0 ? + ] compose each-object ; inline - : instances ( quot -- seq ) - #! To ensure we don't need to grow the vector while scanning - #! the heap, we do two scans, the first one just counts the - #! number of objects that satisfy the predicate. - [ count-instances 100 + ] keep swap - [ [ push-if ] 2curry each-object ] keep >array ; inline + [ all-instances ] dip filter ; inline : save-image ( path -- ) normalize-path native-string>alien (save-image) ; diff --git a/vm/compaction.cpp b/vm/compaction.cpp index 10e37db263..1c9dfc0def 100644 --- a/vm/compaction.cpp +++ b/vm/compaction.cpp @@ -150,9 +150,9 @@ struct object_code_block_updater { explicit object_code_block_updater(code_block_visitor > *visitor_) : visitor(visitor_) {} - void operator()(cell obj) + void operator()(object *obj) { - visitor->visit_object_code_block(tagged(obj).untagged()); + visitor->visit_object_code_block(obj); } }; diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index f9771d47a0..9791c33892 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -226,82 +226,42 @@ void factor_vm::primitive_data_room() dpush(tag(byte_array_from_value(&room))); } -/* Disables GC and activates next-object ( -- obj ) primitive */ -void factor_vm::begin_scan() +struct object_accumulator { + cell type; + std::vector objects; + + explicit object_accumulator(cell type_) : type(type_) {} + + void operator()(object *obj) + { + if(type == TYPE_COUNT || obj->h.hi_tag() == type) + objects.push_back(tag_dynamic(obj)); + } +}; + +cell factor_vm::instances(cell type) { - heap_scan_ptr = data->tenured->first_object(); + object_accumulator accum(type); + each_object(accum); + cell object_count = accum.objects.size(); + gc_off = true; -} - -void factor_vm::end_scan() -{ + array *objects = allot_array(object_count,false_object); + memcpy(objects->data(),&accum.objects[0],object_count * sizeof(cell)); gc_off = false; + + return tag(objects); } -void factor_vm::primitive_begin_scan() +void factor_vm::primitive_all_instances() { - begin_scan(); + primitive_full_gc(); + dpush(instances(TYPE_COUNT)); } -cell factor_vm::next_object() -{ - if(!gc_off) - general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL); - - if(heap_scan_ptr) - { - cell current = heap_scan_ptr; - heap_scan_ptr = data->tenured->next_object_after(heap_scan_ptr); - return tag_dynamic((object *)current); - } - else - return false_object; -} - -/* Push object at heap scan cursor and advance; pushes f when done */ -void factor_vm::primitive_next_object() -{ - dpush(next_object()); -} - -/* Re-enables GC */ -void factor_vm::primitive_end_scan() -{ - gc_off = false; -} - -struct word_counter { - cell count; - - explicit word_counter() : count(0) {} - - void operator()(cell obj) - { - if(tagged(obj).type_p(WORD_TYPE)) - count++; - } -}; - -struct word_accumulator { - growable_array words; - - explicit word_accumulator(int count,factor_vm *vm) : words(vm,count) {} - - void operator()(cell obj) - { - if(tagged(obj).type_p(WORD_TYPE)) - words.add(obj); - } -}; - cell factor_vm::find_all_words() { - word_counter counter; - each_object(counter); - word_accumulator accum(counter.count,this); - each_object(accum); - accum.words.trim(); - return accum.words.elements.value(); + return instances(WORD_TYPE); } } diff --git a/vm/debug.cpp b/vm/debug.cpp index fee3e6a257..df23615419 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -241,12 +241,12 @@ struct object_dumper { explicit object_dumper(factor_vm *parent_, cell type_) : parent(parent_), type(type_) {} - void operator()(cell obj) + void operator()(object *obj) { - if(type == TYPE_COUNT || tagged(obj).type_p(type)) + if(type == TYPE_COUNT || obj->h.hi_tag() == type) { - std::cout << padded_address(obj) << " "; - parent->print_nested_obj(obj,2); + std::cout << padded_address((cell)obj) << " "; + parent->print_nested_obj(tag_dynamic(obj),2); std::cout << std::endl; } } @@ -260,18 +260,19 @@ void factor_vm::dump_objects(cell type) } struct data_reference_slot_visitor { - cell look_for, obj; + cell look_for; + object *obj; factor_vm *parent; - explicit data_reference_slot_visitor(cell look_for_, cell obj_, factor_vm *parent_) : + explicit data_reference_slot_visitor(cell look_for_, object *obj_, factor_vm *parent_) : look_for(look_for_), obj(obj_), parent(parent_) { } void operator()(cell *scan) { if(look_for == *scan) { - std::cout << padded_address(obj) << " "; - parent->print_nested_obj(obj,2); + std::cout << padded_address((cell)obj) << " "; + parent->print_nested_obj(tag_dynamic(obj),2); std::cout << std::endl; } } @@ -284,10 +285,10 @@ struct data_reference_object_visitor { explicit data_reference_object_visitor(cell look_for_, factor_vm *parent_) : look_for(look_for_), parent(parent_) {} - void operator()(cell obj) + void operator()(object *obj) { data_reference_slot_visitor visitor(look_for,obj,parent); - parent->do_slots(UNTAG(obj),visitor); + parent->do_slots(obj,visitor); } }; diff --git a/vm/image.cpp b/vm/image.cpp index b3a9eae7a5..be6cd813fc 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -154,7 +154,7 @@ void factor_vm::relocate_object(object *object, else { object_fixupper fixupper(this,data_relocation_base); - do_slots((cell)object,fixupper); + do_slots(object,fixupper); switch(hi_tag) { diff --git a/vm/objects.cpp b/vm/objects.cpp index ad76d7c1b6..fa2446d54f 100644 --- a/vm/objects.cpp +++ b/vm/objects.cpp @@ -83,9 +83,9 @@ struct object_become_visitor { explicit object_become_visitor(slot_visitor *workhorse_) : workhorse(workhorse_) {} - void operator()(cell obj) + void operator()(object *obj) { - workhorse->visit_slots(tagged(obj).untagged()); + workhorse->visit_slots(obj); } }; @@ -123,6 +123,7 @@ void factor_vm::primitive_become() /* Since we may have introduced old->new references, need to revisit all objects on a minor GC. */ data->mark_all_cards(); + primitive_minor_gc(); /* If a word's definition quotation was in old_objects and the quotation in new_objects is not compiled, we might leak memory diff --git a/vm/primitives.cpp b/vm/primitives.cpp index b8d909fbe8..013250a502 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -82,9 +82,7 @@ PRIMITIVE_FORWARD(set_string_nth_slow) PRIMITIVE_FORWARD(resize_array) PRIMITIVE_FORWARD(resize_string) PRIMITIVE_FORWARD(array) -PRIMITIVE_FORWARD(begin_scan) -PRIMITIVE_FORWARD(next_object) -PRIMITIVE_FORWARD(end_scan) +PRIMITIVE_FORWARD(all_instances) PRIMITIVE_FORWARD(size) PRIMITIVE_FORWARD(die) PRIMITIVE_FORWARD(fopen) @@ -244,9 +242,7 @@ const primitive_type primitives[] = { primitive_resize_array, primitive_resize_string, primitive_array, - primitive_begin_scan, - primitive_next_object, - primitive_end_scan, + primitive_all_instances, primitive_size, primitive_die, primitive_fopen, diff --git a/vm/vm.hpp b/vm/vm.hpp index 81dd30000e..b89dda4085 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -40,10 +40,6 @@ struct factor_vm unsigned int signal_fpu_status; stack_frame *signal_callstack_top; - /* A heap walk allows useful things to be done, like finding all - references to an object for debugging purposes. */ - cell heap_scan_ptr; - /* GC is off during heap walking */ bool gc_off; @@ -224,10 +220,8 @@ struct factor_vm void primitive_data_room(); void begin_scan(); void end_scan(); - void primitive_begin_scan(); - cell next_object(); - void primitive_next_object(); - void primitive_end_scan(); + cell instances(cell type); + void primitive_all_instances(); cell find_all_words(); template @@ -236,7 +230,7 @@ struct factor_vm cell obj = gen->first_object(); while(obj) { - iterator(obj); + iterator((object *)obj); obj = gen->next_object_after(obj); } } @@ -589,11 +583,11 @@ struct factor_vm /* Every object has a regular representation in the runtime, which makes GC much simpler. Every slot of the object until binary_payload_start is a pointer to some other object. */ - template void do_slots(cell obj, Iterator &iter) + template void do_slots(object *obj, Iterator &iter) { - cell scan = obj; - cell payload_start = ((object *)obj)->binary_payload_start(); - cell end = obj + payload_start; + cell scan = (cell)obj; + cell payload_start = obj->binary_payload_start(); + cell end = scan + payload_start; scan += sizeof(cell); From c08d325132fb9469276a0e5ca7f824d70fc39bb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Nov 2009 21:52:31 -0600 Subject: [PATCH 16/52] Remove unused error from VM --- basis/debugger/debugger-docs.factor | 3 --- basis/debugger/debugger.factor | 18 +++++++----------- vm/errors.hpp | 1 - 3 files changed, 7 insertions(+), 15 deletions(-) diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 87e70d69e7..4bcd9c5b78 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -129,9 +129,6 @@ HELP: c-string-error. HELP: ffi-error. { $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ; -HELP: heap-scan-error. -{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ; - HELP: undefined-symbol-error. { $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 690e631e81..f1e23b18f5 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -103,9 +103,6 @@ HOOK: signal-error. os ( obj -- ) : ffi-error. ( obj -- ) "FFI error" print drop ; -: heap-scan-error. ( obj -- ) - "Cannot do next-object outside begin/end-scan" print drop ; - : undefined-symbol-error. ( obj -- ) "The image refers to a library or symbol that was not found at load time" print drop ; @@ -148,14 +145,13 @@ PREDICATE: vm-error < array { 6 [ array-size-error. ] } { 7 [ c-string-error. ] } { 8 [ ffi-error. ] } - { 9 [ heap-scan-error. ] } - { 10 [ undefined-symbol-error. ] } - { 11 [ datastack-underflow. ] } - { 12 [ datastack-overflow. ] } - { 13 [ retainstack-underflow. ] } - { 14 [ retainstack-overflow. ] } - { 15 [ memory-error. ] } - { 16 [ fp-trap-error. ] } + { 9 [ undefined-symbol-error. ] } + { 10 [ datastack-underflow. ] } + { 11 [ datastack-overflow. ] } + { 12 [ retainstack-underflow. ] } + { 13 [ retainstack-overflow. ] } + { 14 [ memory-error. ] } + { 15 [ fp-trap-error. ] } } ; inline M: vm-error summary drop "VM error" ; diff --git a/vm/errors.hpp b/vm/errors.hpp index c1ea2e1907..4b237e03a0 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -13,7 +13,6 @@ enum vm_error_type ERROR_ARRAY_SIZE, ERROR_C_STRING, ERROR_FFI, - ERROR_HEAP_SCAN, ERROR_UNDEFINED_SYMBOL, ERROR_DS_UNDERFLOW, ERROR_DS_OVERFLOW, From a5957b188d770a60d86e64e0e998f0dfc8c28649 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 22:22:21 -0600 Subject: [PATCH 17/52] nip most uses of tuck from extra --- .../benchmark/knucleotide/knucleotide.factor | 15 ++++++-------- extra/curses/curses.factor | 6 ++++-- extra/decimals/decimals.factor | 2 +- extra/ecdsa/ecdsa.factor | 2 +- extra/io/serial/windows/windows.factor | 3 +-- extra/jamshred/gl/gl.factor | 7 ++++--- extra/jamshred/oint/oint.factor | 4 ++-- extra/jamshred/player/player.factor | 5 +++-- extra/jamshred/tunnel/tunnel.factor | 7 ++++--- extra/joystick-demo/joystick-demo.factor | 12 +++++------ extra/key-handlers/key-handlers.factor | 2 +- extra/koszul/koszul.factor | 14 ++++++------- .../affine-transforms.factor | 2 +- extra/math/binpack/binpack.factor | 12 ++++++----- extra/math/finance/finance.factor | 2 +- extra/math/quadratic/quadratic.factor | 4 ++-- extra/models/combinators/combinators.factor | 4 ++-- extra/mongodb/msg/msg.factor | 2 +- extra/mongodb/tuple/state/state.factor | 2 +- .../parser-combinators.factor | 12 ++++++----- extra/project-euler/002/002.factor | 8 ++++---- extra/project-euler/100/100.factor | 15 +++++++------- extra/project-euler/117/117.factor | 2 +- extra/project-euler/ave-time/ave-time.factor | 4 ++-- extra/quadtrees/quadtrees.factor | 17 ++++++++-------- .../blum-blum-shub-tests.factor | 2 +- extra/rot13/rot13.factor | 2 +- extra/sequences/abbrev/abbrev.factor | 2 +- extra/sequences/modified/modified.factor | 10 +++++----- extra/space-invaders/space-invaders.factor | 20 ++++++++----------- extra/spider/spider.factor | 2 +- extra/tetris/piece/piece.factor | 2 +- extra/trees/avl/avl.factor | 2 +- extra/trees/splay/splay.factor | 2 +- extra/trees/trees.factor | 3 ++- extra/ui/gadgets/lists/lists.factor | 10 +++++----- extra/units/units-tests.factor | 2 +- extra/usa-cities/usa-cities.factor | 2 +- 38 files changed, 113 insertions(+), 113 deletions(-) diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index fb4f17cca5..a28a676b90 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings io.encodings.ascii +USING: kernel locals io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -21,10 +21,7 @@ IN: benchmark.knucleotide CHAR: \n swap remove >upper ; : tally ( x exemplar -- b ) - clone tuck - [ - [ [ 1 + ] [ 1 ] if* ] change-at - ] curry each ; + clone [ [ inc-at ] curry each ] keep ; : small-groups ( x n -- b ) swap @@ -42,10 +39,10 @@ IN: benchmark.knucleotide ] each drop ; -: handle-n ( inputs x -- ) - tuck length - small-groups H{ } tally - at [ 0 ] unless* +:: handle-n ( inputs x -- ) + inputs x length small-groups :> groups + groups H{ } tally :> b + x b at [ 0 ] unless* number>string 8 CHAR: \s pad-tail write ; : process-input ( input -- ) diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index 4d6c77fd23..23adf31700 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -123,8 +123,10 @@ PRIVATE> : curses-writef ( window string -- ) [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ; -: (curses-read) ( window-ptr n encoding -- string ) - [ [ tuck ] keep wgetnstr curses-error ] dip alien>string ; +:: (curses-read) ( window-ptr n encoding -- string ) + n :> buf + window-ptr buf n wgetnstr curses-error + buf encoding alien>string ; : curses-read ( window n -- string ) utf8 [ window-ptr ] 2dip (curses-read) ; diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor index cc12b4fed1..d5c62fee5e 100644 --- a/extra/decimals/decimals.factor +++ b/extra/decimals/decimals.factor @@ -37,7 +37,7 @@ SYNTAX: D: parse-decimal suffix! ; ] 2bi ; : scale-decimals ( D1 D2 -- D1' D2' ) - scale-mantissas tuck [ ] 2dip ; + scale-mantissas [ ] curry bi@ ; ERROR: decimal-types-expected d1 d2 ; diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index c4d889991e..8e285a0904 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -50,7 +50,7 @@ PRIVATE> : get-private-key ( -- bin/f ) ec-key-handle EC_KEY_get0_private_key - dup [ dup BN_num_bits bits>bytes tuck BN_bn2bin drop ] when ; + dup [ dup BN_num_bits bits>bytes [ BN_bn2bin drop ] keep ] when ; :: get-public-key ( -- bin/f ) ec-key-handle :> KEY diff --git a/extra/io/serial/windows/windows.factor b/extra/io/serial/windows/windows.factor index 551fd16b33..645e4939de 100755 --- a/extra/io/serial/windows/windows.factor +++ b/extra/io/serial/windows/windows.factor @@ -11,8 +11,7 @@ IN: io.serial.windows : get-comm-state ( duplex -- dcb ) in>> handle>> - DCB tuck - GetCommState win32-error=0/f ; + DCB [ GetCommState win32-error=0/f ] keep ; : set-comm-state ( duplex dcb -- ) [ in>> handle>> ] dip diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 60e9e39d9f..48bf2b693a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu -opengl.demo-support sequences specialized-arrays ; +opengl.demo-support sequences specialized-arrays locals ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: jamshred.gl @@ -50,8 +50,9 @@ CONSTANT: wall-drawing-offset 0.15 over color>> gl-color segment-vertex-and-normal gl-normal gl-vertex ; -: draw-vertex-pair ( theta next-segment segment -- ) - rot tuck draw-segment-vertex draw-segment-vertex ; +:: draw-vertex-pair ( theta next-segment segment -- ) + segment theta draw-segment-vertex + next-segment theta draw-segment-vertex ; : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index ae72bd847c..b1644ef443 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -53,13 +53,13 @@ C: oint : scalar-projection ( v1 v2 -- n ) #! the scalar projection of v1 onto v2 - tuck v. swap norm / ; + [ v. ] [ norm ] bi / ; : proj-perp ( u v -- w ) dupd proj v- ; : perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup left>> scalar-projection abs + [ distance-vector ] keep 2dup left>> scalar-projection abs -rot up>> scalar-projection abs + ; :: reflect ( v n -- v' ) diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index baeacd750b..ecce29180c 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -31,8 +31,9 @@ CONSTANT: max-speed 30.0 forward-pivot ; : to-tunnel-start ( player -- ) - [ tunnel>> first dup location>> ] - [ tuck (>>location) (>>nearest-segment) ] bi ; + dup tunnel>> first + [ >>nearest-segment ] + [ location>> >>location ] bi drop ; : play-in-tunnel ( player segments -- ) >>tunnel to-tunnel-start ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index e7285dcbbc..7f8646b778 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -63,9 +63,10 @@ CONSTANT: default-segment-radius 1 #! valid values [ '[ _ clamp-length ] bi@ ] keep ; -: nearer-segment ( segment segment oint -- segment ) - #! return whichever of the two segments is nearer to the oint - [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ; +:: nearer-segment ( seg-a seg-b oint -- segment ) + seg-a oint distance + seg-b oint distance < + seg-a seg-b ? ; : (find-nearest-segment) ( nearest next oint -- nearest ? ) #! find the nearest of 'next' and 'nearest' to 'oint', and return diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 90e28594e7..6ea1dc5633 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -50,10 +50,10 @@ CONSTANT: pov-polygons [ [ 0.0 ] unless* ] tri@ [ (xy>loc) ] dip (z>loc) ; -: move-axis ( gadget x y z -- ) - (xyz>loc) rot tuck - [ indicator>> (>>loc) ] - [ z-indicator>> (>>loc) ] 2bi* ; +:: move-axis ( gadget x y z -- ) + x y z (xyz>loc) :> ( xy z ) + xy gadget indicator>> (>>loc) + z gadget z-indicator>> (>>loc) ; : move-pov ( gadget pov -- ) swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ] @@ -82,10 +82,10 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; [ >>controller ] [ product-string