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/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* 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 diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 9cf21d1716..36045a6b22 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 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 new file mode 100644 index 0000000000..d6caa0e68b --- /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+ "Bar" } +} { + "bar:" + "float" + { "id" "SEL" "NSRect" } + [ + [ origin>> [ x>> ] [ y>> ] bi + ] + [ size>> [ w>> ] [ h>> ] bi + ] + bi + + ] +} ; + +: main ( -- ) + 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/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" } +} 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 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