From 1c97d338549a8b73eaa3f49694473cd46b1799c4 Mon Sep 17 00:00:00 2001 From: Jon Harper Date: Sun, 6 Sep 2009 19:00:03 +0900 Subject: [PATCH 1/5] Fix documentation errors --- core/make/make-docs.factor | 4 ++-- core/sequences/sequences-docs.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/make/make-docs.factor b/core/make/make-docs.factor index 1fc59fce62..db2031f48e 100644 --- a/core/make/make-docs.factor +++ b/core/make/make-docs.factor @@ -23,7 +23,7 @@ $nl "and" { $code "[ [ reverse % ] each ] \"\" make" } "is equivalent to" -{ $code "[ [ reverse ] map concat" } +{ $code "[ reverse ] map concat" } { $heading "Utilities for simple make patterns" } "Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:" { $code "[ , % ] { } make" } @@ -70,4 +70,4 @@ HELP: , HELP: % { $values { "seq" sequence } } -{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ; \ No newline at end of file +{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 258b484764..48d0134658 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -278,7 +278,7 @@ HELP: reduce-index HELP: accumulate { $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } } -{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." +{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." $nl "When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } { $examples From a1ae209f8187aa4d1c31dff80f7018bd1888104a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Sep 2009 17:45:03 -0500 Subject: [PATCH 2/5] compiler.tree.propagation.call-effect: stronger call( inlining; now can inline 'a [ b ] curry call(' where 'a' is literal, [ b ] doesn't infer, but [ a b ] does infer. This simplifies classes.struct:memory>struct --- basis/classes/struct/struct-tests.factor | 6 ++ basis/classes/struct/struct.factor | 8 +- .../call-effect/call-effect-tests.factor | 10 ++- .../call-effect/call-effect.factor | 84 ++++++++++++------- .../tree/propagation/inlining/inlining.factor | 14 ++-- .../struct-arrays/struct-arrays-tests.factor | 11 ++- 6 files changed, 86 insertions(+), 47 deletions(-) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 195664b8b6..d76013e138 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -316,6 +316,11 @@ STRUCT: struct-test-optimization [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test +[ t ] [ + [ struct-test-optimization struct-test-optimization [ x>> ] bi@ ] + { x>> } inlined? +] unit-test + ! Test cloning structs STRUCT: clone-test-struct { x int } { y char[3] } ; @@ -340,3 +345,4 @@ STRUCT: struct-that's-a-word { x int } ; : struct-that's-a-word ( -- ) "OOPS" throw ; [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test + diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 09d80e5003..dc7fa965db 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -42,11 +42,9 @@ M: struct hashcode* : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable : memory>struct ( ptr class -- struct ) - [ 1array ] dip slots>tuple ; - -\ memory>struct [ - dup struct-class? [ '[ _ boa ] ] [ drop f ] if -] 1 define-partial-eval + ! This is sub-optimal if the class is not literal, but gets + ! optimized down to efficient code if it is. + '[ _ boa ] call( ptr -- struct ) ; inline > ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ; +: safe-infer ( quot -- effect ) + [ infer ] [ 2drop +unknown+ ] recover ; + M: quotation cached-effect dup cached-effect>> - [ ] [ - [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep - (>>cached-effect) - ] ?if ; + [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ; : call-effect-unsafe? ( quot effect -- ? ) [ cached-effect ] dip @@ -116,6 +116,29 @@ M: quotation cached-effect : execute-effect>quot ( effect -- quot ) inline-cache new '[ drop _ _ execute-effect-ic ] ; +! Some bookkeeping to make sure that crap like +! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] +! doesn't hang the compiler. +GENERIC: already-inlined-quot? ( quot -- ? ) + +M: curry already-inlined-quot? quot>> already-inlined-quot? ; + +M: compose already-inlined-quot? + [ first>> already-inlined-quot? ] + [ second>> already-inlined-quot? ] bi or ; + +M: quotation already-inlined-quot? already-inlined? ; + +GENERIC: add-quot-to-history ( quot -- ) + +M: curry add-quot-to-history quot>> add-quot-to-history ; + +M: compose add-quot-to-history + [ first>> add-quot-to-history ] + [ second>> add-quot-to-history ] bi ; + +M: quotation add-quot-to-history add-to-history ; + : last2 ( seq -- penultimate ultimate ) 2 tail* first2 ; @@ -129,22 +152,18 @@ ERROR: uninferable ; (( -- object )) swap compose-effects ; : (infer-value) ( value-info -- effect ) - dup class>> { - { \ quotation [ - literal>> [ uninferable ] unless* - dup already-inlined? [ uninferable ] when - cached-effect dup +unknown+ = [ uninferable ] when - ] } - { \ curry [ - slots>> third (infer-value) - remove-effect-input - ] } - { \ compose [ - slots>> last2 [ (infer-value) ] bi@ - compose-effects - ] } - [ uninferable ] - } case ; + dup literal?>> [ + literal>> + [ callable? [ uninferable ] unless ] + [ already-inlined-quot? [ uninferable ] when ] + [ safe-infer dup +unknown+ = [ uninferable ] when ] tri + ] [ + dup class>> { + { \ curry [ slots>> third (infer-value) remove-effect-input ] } + { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] } + [ uninferable ] + } case + ] if ; : infer-value ( value-info -- effect/f ) [ (infer-value) ] @@ -152,17 +171,20 @@ ERROR: uninferable ; recover ; : (value>quot) ( value-info -- quot ) - dup class>> { - { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] } - { \ curry [ - slots>> third (value>quot) - '[ [ obj>> ] [ quot>> @ ] bi ] - ] } - { \ compose [ - slots>> last2 [ (value>quot) ] bi@ - '[ [ first>> @ ] [ second>> @ ] bi ] - ] } - } case ; + dup literal?>> [ + literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi + ] [ + dup class>> { + { \ curry [ + slots>> third (value>quot) + '[ [ obj>> ] [ quot>> @ ] bi ] + ] } + { \ compose [ + slots>> last2 [ (value>quot) ] bi@ + '[ [ first>> @ ] [ second>> @ ] bi ] + ] } + } case + ] if ; : value>quot ( value-info -- quot: ( code effect -- ) ) (value>quot) '[ drop @ ] ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 3836e0f3ba..0b50632e4e 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -97,11 +97,9 @@ SYMBOL: history :: inline-word ( #call word -- ? ) word already-inlined? [ f ] [ #call word splicing-body [ - [ - word add-to-history - dup (propagate) - ] with-scope - #call (>>body) t + word add-to-history + #call (>>body) + #call propagate-body ] [ f ] if* ] if ; @@ -141,5 +139,7 @@ SYMBOL: history #! Note the logic here: if there's a custom inlining hook, #! it is permitted to return f, which means that we try the #! normal inlining heuristic. - dup custom-inlining? [ 2dup inline-custom ] [ f ] if - [ 2drop t ] [ (do-inlining) ] if ; + [ + dup custom-inlining? [ 2dup inline-custom ] [ f ] if + [ 2drop t ] [ (do-inlining) ] if + ] with-scope ; diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 0a79f47a34..da9f306889 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -1,6 +1,7 @@ IN: struct-arrays.tests USING: classes.struct struct-arrays tools.test kernel math sequences -alien.syntax alien.c-types destructors libc accessors sequences.private ; +alien.syntax alien.c-types destructors libc accessors sequences.private +compiler.tree.debugger ; STRUCT: test-struct-array { x int } @@ -52,4 +53,10 @@ STRUCT: fixed-string { text char[100] } ; ALIEN: 123 4 fixed-string [ (underlying)>> ] { } map-as ] unit-test -[ 10 "int" ] must-fail \ No newline at end of file +[ 10 "int" ] must-fail + +STRUCT: wig { x int } ; +: ( -- wig ) 0 wig ; inline +: waterfall ( -- a b ) 1 wig swap first x>> ; inline + +[ t ] [ [ waterfall ] { x>> } inlined? ] unit-test \ No newline at end of file From ed60c89e94ffa50ef2f73b63b24f5e0e87d7a8b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Sep 2009 17:59:34 -0500 Subject: [PATCH 3/5] tools.deploy: add unit test to ensure Cocoa binding works in deployed apps --- basis/tools/deploy/deploy-tests.factor | 4 ++++ basis/tools/deploy/test/14/14.factor | 26 ++++++++++++++++++++++++ basis/tools/deploy/test/14/authors.txt | 1 + basis/tools/deploy/test/14/deploy.factor | 14 +++++++++++++ 4 files changed, 45 insertions(+) create mode 100644 basis/tools/deploy/test/14/14.factor create mode 100644 basis/tools/deploy/test/14/authors.txt create mode 100644 basis/tools/deploy/test/14/deploy.factor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 9cf21d1716..0f08e79305 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -101,4 +101,8 @@ M: quit-responder call-responder* os windows? os macosx? or [ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test +] when + +os macsx? [ + [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test ] when \ No newline at end of file diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor new file mode 100644 index 0000000000..502377f10b --- /dev/null +++ b/basis/tools/deploy/test/14/14.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors classes.struct cocoa cocoa.classes +cocoa.subclassing core-graphics.types kernel math ; +IN: tools.deploy.test.14 + +CLASS: { + { +superclass+ "NSObject" } + { +name+ "Foo" } +} { + "foo:" + "float" + { "id" "SEL" "NSRect" } + [ + [ origin>> [ x>> ] [ y>> ] bi + ] + [ size>> [ w>> ] [ h>> ] bi + ] + bi + + ] +} ; + +: main ( -- ) + Foo -> alloc -> init + S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> foo: + 10.0 assert= ; + +MAIN: main diff --git a/basis/tools/deploy/test/14/authors.txt b/basis/tools/deploy/test/14/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/deploy/test/14/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/deploy/test/14/deploy.factor b/basis/tools/deploy/test/14/deploy.factor new file mode 100644 index 0000000000..b5bf4d62d0 --- /dev/null +++ b/basis/tools/deploy/test/14/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? t } + { deploy-io 2 } + { deploy-c-types? f } + { deploy-reflection 1 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-word-props? f } + { deploy-threads? t } + { deploy-ui? f } + { deploy-unicode? f } + { deploy-name "tools.deploy.test.14" } +} From 0ad4557d620763d4286cfea8423013feaecce13f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Sep 2009 22:48:57 -0500 Subject: [PATCH 4/5] tools.deploy: fix facepalm --- basis/tools/deploy/deploy-tests.factor | 2 +- basis/tools/deploy/test/14/14.factor | 8 ++++---- basis/tools/deploy/test/14/tags.txt | 1 + 3 files changed, 6 insertions(+), 5 deletions(-) create mode 100644 basis/tools/deploy/test/14/tags.txt diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 0f08e79305..36045a6b22 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -103,6 +103,6 @@ os windows? os macosx? or [ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test ] when -os macsx? [ +os macosx? [ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test ] when \ No newline at end of file diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor index 502377f10b..d6caa0e68b 100644 --- a/basis/tools/deploy/test/14/14.factor +++ b/basis/tools/deploy/test/14/14.factor @@ -6,9 +6,9 @@ IN: tools.deploy.test.14 CLASS: { { +superclass+ "NSObject" } - { +name+ "Foo" } + { +name+ "Bar" } } { - "foo:" + "bar:" "float" { "id" "SEL" "NSRect" } [ @@ -19,8 +19,8 @@ CLASS: { } ; : main ( -- ) - Foo -> alloc -> init - S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> foo: + Bar -> alloc -> init + S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> bar: 10.0 assert= ; MAIN: main diff --git a/basis/tools/deploy/test/14/tags.txt b/basis/tools/deploy/test/14/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/tools/deploy/test/14/tags.txt @@ -0,0 +1 @@ +unportable From 9f9b6bca013ff83c408182d3023ea5d56c1b7fe4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Sep 2009 23:40:23 -0500 Subject: [PATCH 5/5] compiler.tree.propagation: type check inputs to unsafe foldable words manually, so that stuff like [ "Hi" { } fixnum+fast ] doesn't crash in the compiler --- .../tree/propagation/propagation-tests.factor | 3 +++ .../tree/propagation/simple/simple.factor | 26 +++++++++++++------ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 879ab82c4b..209efb3913 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -799,3 +799,6 @@ SYMBOL: not-an-assoc [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test [ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test + +! Don't crash if bad literal inputs are passed to unsafe words +[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 88c9831a24..5de5e26a30 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors kernel sequences sequences.private assocs words -namespaces classes.algebra combinators classes classes.tuple -classes.tuple.private continuations arrays alien.c-types -math math.private slots generic definitions -stack-checker.state +USING: fry accessors kernel sequences sequences.private assocs +words namespaces classes.algebra combinators +combinators.short-circuit classes classes.tuple +classes.tuple.private continuations arrays alien.c-types math +math.private slots generic definitions stack-checker.state compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -63,9 +63,19 @@ M: #declare propagate-before [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi* with-datastack ; +: literal-inputs? ( #call -- ? ) + in-d>> [ value-info literal?>> ] all? ; + +: input-classes-match? ( #call word -- ? ) + [ in-d>> ] [ "input-classes" word-prop ] bi* + [ [ value-info literal>> ] dip instance? ] 2all? ; + : foldable-call? ( #call word -- ? ) - "foldable" word-prop - [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ; + { + [ nip "foldable" word-prop ] + [ drop literal-inputs? ] + [ input-classes-match? ] + } 2&& ; : (fold-call) ( #call word -- info ) [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*