From 63d89878d82d7e270988ba36da8794b47ab44ce5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 02:21:45 -0600 Subject: [PATCH 1/7] Clean up space invaders (untested) --- extra/channels/examples/examples.factor | 2 +- extra/cpu/8080/8080.factor | 29 --------- extra/cpu/8080/emulator/emulator.factor | 75 +++++----------------- extra/cpu/8080/test/test.factor | 51 +++++++++++++++ extra/space-invaders/space-invaders.factor | 15 +++-- 5 files changed, 75 insertions(+), 97 deletions(-) mode change 100644 => 100755 extra/channels/examples/examples.factor mode change 100644 => 100755 extra/cpu/8080/8080.factor create mode 100755 extra/cpu/8080/test/test.factor diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor old mode 100644 new mode 100755 index 3c87680cd5..87b755614a --- a/extra/channels/examples/examples.factor +++ b/extra/channels/examples/examples.factor @@ -24,7 +24,7 @@ IN: channels.examples from swap dupd mod zero? not [ swap to ] [ 2drop ] if ] 3keep filter ; -:: (sieve) | prime c | +:: (sieve) | prime c | ( prime c -- ) [let | p [ c from ] newc [ ] | p prime to diff --git a/extra/cpu/8080/8080.factor b/extra/cpu/8080/8080.factor old mode 100644 new mode 100755 index fa88cf6c6a..45a5129a72 --- a/extra/cpu/8080/8080.factor +++ b/extra/cpu/8080/8080.factor @@ -249,32 +249,3 @@ INSTRUCTION: EI ; opcode FB cycles 04 INSTRUCTION: CALL M,nn ; opcode FC cycles 11 INSTRUCTION: CP n ; opcode FE cycles 07 INSTRUCTION: RST 38H ; opcode FF cycles 11 - -! : each-8bit ( n quot -- ) -! 8 [ ! n quot bit -! pick over -1 * shift 1 bitand pick call -! ] repeat 2drop ; -! -! : >ppm ( cpu filename -- cpu ) -! #! Dump the current screen image to a ppm image file with the given name. -! [ -! "P3" print -! "256 224" print -! "1" print -! 224 [ -! 32 [ -! over 32 * over + HEX: 2400 + ! cpu h w addr -! >r pick r> swap cpu-ram nth [ -! 0 = [ -! " 0 0 0" write -! ] [ -! " 1 1 1" write -! ] if -! ] each-8bit -! ] repeat nl -! ] repeat -! ] with-stream ; - -: time-test ( -- ) - test-cpu [ 1000000 run-n ] time ; - diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 310e387bd5..a265ca12a6 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel math sequences words arrays io - io.files namespaces math.parser kernel.private - assocs quotations parser parser-combinators tools.time - sequences.private compiler.units ; +USING: kernel math sequences words arrays io io.files namespaces +math.parser assocs quotations parser parser-combinators +tools.time ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; @@ -396,39 +395,18 @@ M: cpu write-port ( value port cpu -- ) : instruction-cycles ( -- vector ) #! Return a 256 element vector containing the cycles for #! each opcode in the 8080 instruction set. - { - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; - -: instructions ( -- vector ) - #! Return a 256 element vector containing the emulation words for - #! each opcode in the 8080 instruction set. - { - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f - f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ; + << 256 f parsed >> ; : not-implemented ( -- ) drop ; -instructions length [ - dup instructions nth [ - drop - ] [ - [ not-implemented ] swap instructions set-nth - ] if -] each +: instructions ( -- vector ) + #! Return a 256 element vector containing the emulation words for + #! each opcode in the 8080 instruction set. + << 256 [ [ not-implemented ] 2array ] map parsed >> ; inline + +: set-instruction ( quot n -- ) + tuck >r 2array r> instructions set-nth ; M: cpu reset ( cpu -- ) #! Reset the CPU to its poweron state @@ -517,15 +495,6 @@ SYMBOL: rom-root ] if ] if ; -: step ( cpu -- ) - #! Run a single 8080 instruction - [ read-instruction ] keep ! n cpu - over get-cycles over inc-cycles - [ swap instructions dispatch ] keep - [ cpu-pc HEX: FFFF bitand ] keep - [ set-cpu-pc ] keep - process-interrupts ; - : peek-instruction ( cpu -- word ) #! Return the next instruction from the cpu's program #! counter, but don't increment the counter. @@ -560,18 +529,6 @@ SYMBOL: rom-root [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep nl drop ; -: test-step ( cpu -- cpu ) - [ step ] keep dup cpu. ; - -: test-cpu ( -- cpu ) - "invaders.rom" over load-rom dup cpu. ; - -: test-n ( n -- ) - test-cpu swap [ test-step ] times ; - -: run-n ( cpu n -- cpu ) - [ dup step ] times ; - : register-lookup ( string -- vector ) #! Given a string containing a register name, return a vector #! where the 1st item is the getter and the 2nd is the setter @@ -1337,11 +1294,9 @@ SYMBOL: last-opcode #! Process the list of strings, which should make #! up an 8080 instruction, and output a quotation #! that would implement that instruction. - [ - dup " " join instruction-quotations - >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at - r> define - ] with-compilation-unit ; + dup " " join instruction-quotations + >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at + r> define ; : INSTRUCTION: ";" parse-tokens parse-instructions ; parsing @@ -1352,5 +1307,5 @@ SYMBOL: last-opcode : opcode ( -- ) #! Set the opcode number for the last instruction that was defined. last-instruction global at 1quotation scan 16 base> - dup last-opcode global set-at instructions set-nth ; parsing + dup last-opcode global set-at set-instruction ; parsing diff --git a/extra/cpu/8080/test/test.factor b/extra/cpu/8080/test/test.factor new file mode 100755 index 0000000000..85f27d7e40 --- /dev/null +++ b/extra/cpu/8080/test/test.factor @@ -0,0 +1,51 @@ +USING: kernel cpu.8080 cpu.8080.emulator math math io +tools.time combinators sequences io.files ; +IN: cpu.8080.test + +: step ( cpu -- ) + #! Run a single 8080 instruction + [ read-instruction ] keep ! n cpu + over get-cycles over inc-cycles + [ swap instructions case ] keep + [ cpu-pc HEX: FFFF bitand ] keep + [ set-cpu-pc ] keep + process-interrupts ; + + +: test-step ( cpu -- cpu ) + [ step ] keep dup cpu. ; + +: test-cpu ( -- cpu ) + "invaders.rom" over load-rom dup cpu. ; + +: test-n ( n -- ) + test-cpu swap [ test-step ] times drop ; + +: run-n ( cpu n -- cpu ) + [ dup step ] times ; + +: each-8bit ( n quot -- ) + 8 -rot [ >r bit? r> call ] 2curry each ; inline + +: >ppm ( cpu filename -- cpu ) + #! Dump the current screen image to a ppm image file with the given name. + [ + "P3" print + "256 224" print + "1" print + 224 [ + 32 [ + over 32 * over + HEX: 2400 + ! cpu h w addr + >r pick r> swap cpu-ram nth [ + 0 = [ + " 0 0 0" write + ] [ + " 1 1 1" write + ] if + ] each-8bit drop + ] each drop nl + ] each + ] with-stream ; + +: time-test ( -- ) + test-cpu [ 1000000 run-n drop ] time ; diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index f5c518865d..57c6b23d19 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel - shuffle arrays io.files combinators kernel.private - ui.gestures ui.gadgets ui.render opengl.gl system - threads concurrency match ui byte-arrays combinators.lib - sequences.private ; +USING: cpu.8080 cpu.8080.emulator openal math alien.c-types +sequences kernel shuffle arrays io.files combinators ui.gestures +ui.gadgets ui.render opengl.gl system threads concurrency match +ui byte-arrays combinators.lib ; IN: space-invaders TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; @@ -191,7 +190,7 @@ M: space-invaders reset ( cpu -- ) : gui-step ( cpu -- ) [ read-instruction ] keep ! n cpu over get-cycles over inc-cycles - [ swap instructions dispatch ] keep + [ swap instructions case ] keep [ cpu-pc HEX: FFFF bitand ] keep set-cpu-pc ; @@ -345,11 +344,13 @@ M: space-invaders update-video ( value addr cpu -- ) #! concurrent process. Messages can be sent to #! signal key presses, etc. dup invaders-gadget-quit? [ + 2drop + ] [ [ sync-frame ] dip [ invaders-gadget-cpu gui-frame ] keep [ relayout-1 ] keep invaders-process - ] unless ; + ] if ; M: invaders-gadget graft* ( gadget -- ) dup invaders-gadget-cpu init-sounds From c559ff4c6f4756b65eeaa3f01c103efff41c11ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 Feb 2008 18:15:18 -0600 Subject: [PATCH 2/7] fix load error --- extra/db/mysql/mysql.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index 040b87c977..91562e89ff 100644 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -26,12 +26,6 @@ M: mysql-statement prepare-statement ( statement -- ) M: mysql-statement bind-statement* ( statement -- ) ; -M: mysql-statement rebind-statement ( statement -- ) - ; - -M: mysql-statement execute-statement ( statement -- ) - ; - M: mysql-statement query-results ( query -- result-set ) ; From d0e5c585f535876ba86c0df5bc8059315e34e1a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 18:47:53 -0600 Subject: [PATCH 3/7] Add a unit test --- core/inference/class/class-tests.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index b77661b899..691010e9ca 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -283,3 +283,8 @@ cell-bits 32 = [ [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ] \ number= inlined? ] unit-test + +[ t ] [ + [ HEX: ff bitand 0 HEX: ff between? ] + \ >= inlined? +] unit-test From c3bb6b911be73f64a5401f3657c7013ed0f72380 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 18:48:06 -0600 Subject: [PATCH 4/7] Tweak --- extra/benchmark/sockets/sockets.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index f19a2127a5..a621331968 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -23,10 +23,9 @@ IN: benchmark.sockets ] with-stream ; : clients ( n -- ) - dup pprint " clients: " write - [ + dup pprint " clients: " write [ [ simple-server ] in-thread - 100 sleep + yield yield [ drop simple-client ] parallel-each stop-server yield yield From 813c1d2f94788ee4f49dee50f5bef43ba7fca628 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 18:49:05 -0600 Subject: [PATCH 5/7] Use rethrow instead of throw in a few places --- extra/concurrency/concurrency.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 1c5f6322a8..b0abac8f5b 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -145,12 +145,12 @@ M: process send ( message process -- ) : receive ( -- message ) self process-mailbox mailbox-get dup linked-exception? [ - linked-exception-error throw + linked-exception-error rethrow ] when ; : receive-if ( pred -- message ) self process-mailbox mailbox-get? dup linked-exception? [ - linked-exception-error throw + linked-exception-error rethrow ] when ; inline : rethrow-linked ( error -- ) @@ -285,7 +285,7 @@ TUPLE: future value processes ; #! place the result on the stack. Return the result #! immediately if the future has completed. dup future-value [ - first2 [ throw ] unless + first2 [ rethrow ] unless ] [ dup [ future-processes push stop ] curry callcc0 ?future ] ?if ; From 9c684bf1c50502899df451d0b74608797be62687 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 18:50:16 -0600 Subject: [PATCH 6/7] Fixing some bugs, tweaking optimizer inlining --- core/generic/generic.factor | 13 +- core/optimizer/inlining/inlining.factor | 118 ++++++++---------- core/optimizer/known-words/known-words.factor | 4 +- core/optimizer/math/math.factor | 6 +- core/optimizer/optimizer-tests.factor | 27 +++- 5 files changed, 91 insertions(+), 77 deletions(-) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 45de3be97f..6d564d518c 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -82,10 +82,19 @@ M: method-body stack-effect [ ] 3keep f \ method construct-boa dup method-word over "method" set-word-prop ; +: redefine-method ( quot method -- ) + 2dup set-method-def + method-word swap define ; + : define-method ( quot class generic -- ) >r bootstrap-word r> - [ ] 2keep - [ set-at ] with-methods ; + 2dup method dup [ + 2nip redefine-method + ] [ + drop + [ ] 2keep + [ set-at ] with-methods + ] if ; : define-default-method ( generic combination -- ) dupd make-default-method object bootstrap-word pick diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index a272d05b5d..9350658611 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -6,62 +6,38 @@ math namespaces sequences vectors words quotations hashtables combinators classes generic.math continuations optimizer.def-use optimizer.backend generic.standard optimizer.specializers optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control ; +optimizer.control kernel.private ; IN: optimizer.inlining -GENERIC: remember-method* ( method-spec node -- ) +: remember-inlining ( node history -- ) + [ swap set-node-history ] curry each-node ; -M: #call remember-method* - [ node-history ?push ] keep set-node-history ; - -M: node remember-method* - 2drop ; - -: remember-method ( method-spec node -- ) - swap dup second +inlined+ depends-on - [ swap remember-method* ] curry each-node ; - -: (splice-method) ( #call method-spec quot -- node ) - #! Must remember the method before splicing in, otherwise - #! the rest of the IR will also remember the method - pick node-in-d dataflow-with - [ remember-method ] keep - [ swap infer-classes/node ] 2keep - [ splice-node ] keep ; - -: splice-quot ( #call quot -- node ) +: inlining-quot ( node quot -- node ) over node-in-d dataflow-with - [ swap infer-classes/node ] 2keep - [ splice-node ] keep ; + dup rot infer-classes/node ; -! #call -: splice-method ( #call method-spec/t quot/t -- node/t ) - #! t indicates failure - { - { [ dup t eq? ] [ 3drop t ] } - { [ 2over swap node-history member? ] [ 3drop t ] } - { [ t ] [ (splice-method) ] } - } cond ; - -! Single dispatch method inlining optimization -: already-inlined? ( node -- ? ) - #! Was this node inlined from definition of 'word'? - dup node-param swap node-history memq? ; - -: specific-method ( class word -- class ) order min-class ; - -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; - -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; +: splice-quot ( #call quot history -- node ) + #! Must add history *before* splicing in, otherwise + #! the rest of the IR will also remember the history + pick node-history append + >r dupd inlining-quot dup r> remember-inlining + tuck splice-node ; ! A heuristic to avoid excessive inlining DEFER: (flat-length) : word-flat-length ( word -- n ) - dup get over inline? not or - [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; + { + ! heuristic: { ... } declare comes up in method bodies + ! and we don't care about it + { [ dup \ declare eq? ] [ drop -2 ] } + ! recursive + { [ dup get ] [ drop 1 ] } + ! not inline + { [ dup inline? not ] [ drop 1 ] } + ! inline + { [ t ] [ dup dup set word-def (flat-length) ] } + } cond ; : (flat-length) ( seq -- n ) [ @@ -76,32 +52,29 @@ DEFER: (flat-length) : flat-length ( seq -- n ) [ word-def (flat-length) ] with-scope ; -: will-inline-method ( node word -- method-spec/t quot/t ) - #! t indicates failure - tuck dispatching-class dup [ - swap [ 2array ] 2keep - method method-word - dup flat-length 10 >= - [ 1quotation ] [ word-def ] if - ] [ - 2drop t t - ] if ; +! Single dispatch method inlining optimization +: specific-method ( class word -- class ) order min-class ; + +: node-class# ( node n -- class ) + over node-in-d ?nth node-class ; + +: dispatching-class ( node word -- class ) + [ dispatch# node-class# ] keep specific-method ; : inline-standard-method ( node word -- node ) - dupd will-inline-method splice-method ; + 2dup dispatching-class dup [ + swap method method-word 1quotation f splice-quot + ] [ + 3drop t + ] if ; ! Partial dispatch of math-generic words : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; -: will-inline-math-method ( word left right -- method-spec/t quot/t ) - #! t indicates failure - 3dup math-both-known? - [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ; - : inline-math-method ( #call word -- node ) - over node-input-classes first2 - will-inline-math-method splice-method ; + over node-input-classes first2 3dup math-both-known? + [ math-method f splice-quot ] [ 2drop 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { @@ -131,7 +104,7 @@ DEFER: (flat-length) : inline-literals ( node literals -- node ) #! Make #shuffle -> #push -> #return -> successor - dupd literal-quot splice-quot ; + dupd literal-quot f splice-quot ; : evaluate-predicate ( #call -- ? ) dup node-param "predicating" word-prop >r @@ -196,7 +169,7 @@ DEFER: (flat-length) nip dup [ second ] when ; : apply-identities ( node -- node/f ) - dup find-identity dup [ splice-quot ] [ 2drop f ] if ; + dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ @@ -206,13 +179,20 @@ DEFER: (flat-length) 2drop f ] if ; +: splice-word-def ( #call word -- node ) + dup +inlined+ depends-on + dup word-def swap 1array splice-quot ; + : optimistic-inline ( #call -- node ) - dup node-param dup +inlined+ depends-on - word-def splice-quot ; + dup node-param over node-history memq? [ + drop t + ] [ + dup node-param splice-word-def + ] if ; : method-body-inline? ( #call -- ? ) node-param dup method-body? - [ flat-length 8 <= ] [ drop f ] if ; + [ flat-length 10 <= ] [ drop f ] if ; M: #call optimize-node* { diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d725396e77..18c98c5115 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -40,7 +40,7 @@ optimizer.inlining float-arrays sequences.private combinators ; : flip-branches ( #call -- #if ) #! If a not is followed by an #if, flip branches and #! remove the not. - dup sole-consumer (flip-branches) [ ] splice-quot ; + dup sole-consumer (flip-branches) [ ] f splice-quot ; \ not { { [ dup flip-branches? ] [ flip-branches ] } @@ -63,7 +63,7 @@ optimizer.inlining float-arrays sequences.private combinators ; [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ; : expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot splice-quot ; + dup node-in-d peek value-literal member-quot f splice-quot ; \ member? { { [ dup literal-member? ] [ expand-member ] } diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 9bd1fe3250..6f535ec8e6 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -366,7 +366,7 @@ most-negative-fixnum most-positive-fixnum [a,b] } [ [ [ dup remove-overflow-check? ] , - [ splice-quot ] curry , + [ f splice-quot ] curry , ] { } make 1array define-optimizers ] assoc-each @@ -436,7 +436,7 @@ most-negative-fixnum most-positive-fixnum [a,b] dup remove-overflow-check? over coereced-to-fixnum? or ] , - [ splice-quot ] curry , + [ f splice-quot ] curry , ] { } make 1array define-optimizers ] assoc-each @@ -461,6 +461,6 @@ most-negative-fixnum most-positive-fixnum [a,b] \ fixnum-shift { { [ dup fixnum-shift-fast? ] - [ [ fixnum-shift-fast ] splice-quot ] + [ [ fixnum-shift-fast ] f splice-quot ] } } define-optimizers diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 7092797acc..66d3956dba 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations growable optimizer.inlining namespaces ; +continuations growable optimizer.inlining namespaces hints ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -351,3 +351,28 @@ M: integer generic-inline-test ; \ generic-inline-test-1 word-def dataflow [ optimize-1 , optimize-1 , drop ] { } make ] unit-test + +! Forgot a recursive inline check +: recursive-inline-hang ( a -- a ) + dup array? [ recursive-inline-hang ] when ; + +HINTS: recursive-inline-hang array ; + +: recursive-inline-hang-1 + { } recursive-inline-hang ; + +[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test + +DEFER: recursive-inline-hang-3 + +: recursive-inline-hang-2 ( a -- a ) + dup array? [ recursive-inline-hang-3 ] when ; + +HINTS: recursive-inline-hang-2 array ; + +: recursive-inline-hang-3 ( a -- a ) + dup array? [ recursive-inline-hang-2 ] when ; + +HINTS: recursive-inline-hang-3 array ; + + From 8c9966b17c667dfd66f85c3e52e3237009b78447 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 Feb 2008 18:50:26 -0600 Subject: [PATCH 7/7] pick pick is 2over --- extra/benchmark/nsieve/nsieve.factor | 2 +- extra/benchmark/recursive/recursive.factor | 2 +- extra/documents/documents.factor | 2 +- extra/id3/id3.factor | 2 +- extra/math/vectors/vectors.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 2 +- extra/sudoku/sudoku.factor | 2 +- extra/xmode/marker/state/state.factor | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/benchmark/nsieve/nsieve.factor b/extra/benchmark/nsieve/nsieve.factor index c567aa8a8f..7cae1e2a9b 100644 --- a/extra/benchmark/nsieve/nsieve.factor +++ b/extra/benchmark/nsieve/nsieve.factor @@ -6,7 +6,7 @@ arrays namespaces io ; 2dup length >= [ 3drop ] [ - f pick pick set-nth-unsafe >r over + r> clear-flags + f 2over set-nth-unsafe >r over + r> clear-flags ] if ; inline : (nsieve) ( count i seq -- count ) diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index 6e3c201cf0..ee66e303ec 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -16,7 +16,7 @@ USING: math kernel hints prettyprint io ; ] if ; : tak ( x y z -- t ) - pick pick swap < [ + 2over swap < [ [ rot 1- -rot tak ] 3keep [ -rot 1- -rot tak ] 3keep 1- -rot tak diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index a9b696179e..34ecce5f8e 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -43,7 +43,7 @@ TUPLE: document locs ; ] if ; : each-line ( from to quot -- ) - pick pick = [ + 2over = [ 3drop ] [ >r [ first ] 2apply 1+ dup r> each diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 4f633f5be1..b894c574f3 100755 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -64,7 +64,7 @@ C: extended-header } cond ; : (read-frame) ( id -- frame ) - read-frame-size read-frame-flags pick pick read-frame-data ; + read-frame-size read-frame-flags 2over read-frame-data ; : read-frame ( -- frame/f ) read-frame-id dup good-frame-id? [ (read-frame) ] [ drop f ] if ; diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index 2be9cf7f58..51efd33d45 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -25,7 +25,7 @@ IN: math.vectors : normalize ( u -- v ) dup norm v/n ; : set-axis ( u v axis -- w ) - dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ; + dup length [ >r zero? 2over ? r> swap nth ] 2map 2nip ; HINTS: vneg { float-array } { array } ; HINTS: norm-sq { float-array } { array } ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index b7b62b3c2e..cdf89e1f37 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -38,7 +38,7 @@ C: parse-result [ [ >upper ] 2apply ] when sequence= ; : string-head? ( str head ignore-case -- ? ) - pick pick shorter? [ + 2over shorter? [ 3drop f ] [ >r [ length head-slice ] keep r> string= diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index f19e536952..db5fb75617 100644 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -35,7 +35,7 @@ DEFER: search { [ t ] [ assume ] } } cond ; -: solve ( x y -- ) 9 [ 1+ pick pick attempt ] each 2drop ; +: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ; : board. ( board -- ) standard-table-style [ diff --git a/extra/xmode/marker/state/state.factor b/extra/xmode/marker/state/state.factor index 35e6bbef18..e3e380798f 100755 --- a/extra/xmode/marker/state/state.factor +++ b/extra/xmode/marker/state/state.factor @@ -26,7 +26,7 @@ SYMBOL: delegate-end-escaped? current-rule-set rule-set-keywords ; : token, ( from to id -- ) - pick pick = [ 3drop ] [ >r line get subseq r> , ] if ; + 2over = [ 3drop ] [ >r line get subseq r> , ] if ; : prev-token, ( id -- ) >r last-offset get position get r> token,