From a1ae209f8187aa4d1c31dff80f7018bd1888104a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Sep 2009 17:45:03 -0500 Subject: [PATCH] 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