From 03cb32ad9c3a4deac7f2af01bb5292f4def3b9b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Mar 2009 20:12:35 -0600 Subject: [PATCH] Make execute( faster, add execute-unsafe( and make effect tuple slots read only --- basis/call/call-docs.factor | 31 ++++++++++++++----- basis/call/call-tests.factor | 12 ++++++- basis/call/call.factor | 24 ++++++++++---- .../cfg/instructions/syntax/syntax.factor | 4 +-- .../tree/propagation/inlining/inlining.factor | 5 ++- .../known-words/known-words.factor | 22 ++++++++----- basis/stack-checker/state/state.factor | 4 +-- core/classes/tuple/tuple.factor | 2 +- core/effects/effects.factor | 6 ++-- .../standard/engines/tuple/tuple.factor | 5 ++- 10 files changed, 82 insertions(+), 33 deletions(-) diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor index 463bfdac09..5f76f53fac 100644 --- a/basis/call/call-docs.factor +++ b/basis/call/call-docs.factor @@ -1,19 +1,25 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations effects words ; +USING: help.markup help.syntax quotations effects words call.private ; IN: call ABOUT: "call" ARTICLE: "call" "Calling code with known stack effects" "The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +$nl +"Quotations:" { $subsection POSTPONE: call( } -{ $subsection POSTPONE: execute( } { $subsection call-effect } -{ $subsection execute-effect } ; +"Words:" +{ $subsection POSTPONE: execute( } +{ $subsection execute-effect } +"Unsafe calls:" +{ $subsection POSTPONE: execute-unsafe( } +{ $subsection execute-effect-unsafe } ; HELP: call( -{ $syntax "[ ] call( foo -- bar )" } +{ $syntax "call( stack -- effect )" } { $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; HELP: call-effect @@ -21,12 +27,21 @@ HELP: call-effect { $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; HELP: execute( -{ $syntax "word execute( foo -- bar )" } -{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ; +{ $syntax "execute( stack -- effect )" } +{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ; HELP: execute-effect { $values { "word" word } { "effect" effect } } { $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; -{ execute-effect call-effect } related-words -{ POSTPONE: call( POSTPONE: execute( } related-words +HELP: execute-unsafe( +{ $syntax "execute-unsafe( stack -- effect )" } +{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." } +{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ; +HELP: execute-effect-unsafe +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } +{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ; + +{ call-effect execute-effect execute-effect-unsafe } related-words +{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words \ No newline at end of file diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index a2bd11b06a..002478fb82 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math tools.test call kernel ; +USING: math tools.test call call.private kernel accessors ; IN: call.tests [ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test @@ -13,3 +13,13 @@ IN: call.tests [ 1 2 \ + execute( -- z ) ] must-fail [ 1 2 \ + execute( x y -- z a ) ] must-fail [ \ + execute( x y -- z ) ] must-infer + +[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test +[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test +[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test + +: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ; + +[ t ] [ \ compile-execute(-test optimized>> ] unit-test +[ 4 ] [ 1 3 compile-execute(-test ] unit-test \ No newline at end of file diff --git a/basis/call/call.factor b/basis/call/call.factor index 9b49acf64a..0ccc774ce0 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros fry summary sequences generalizations accessors -continuations effects.parser parser words ; +continuations effects effects.parser parser words ; IN: call ERROR: wrong-values values quot length-required ; @@ -14,17 +14,29 @@ M: wrong-values summary : firstn-safe ( array quot n -- ... ) 3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline +: execute-effect-unsafe ( word effect -- ) + drop execute ; + +: execute-effect-unsafe? ( word effect -- ? ) + swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline + +: parse-call( ( accum word -- accum ) + [ ")" parse-effect parsed ] dip parsed ; + +: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing + PRIVATE> MACRO: call-effect ( effect -- quot ) [ in>> length ] [ out>> length ] bi '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ; -: call( - ")" parse-effect parsed \ call-effect parsed ; parsing +: call( \ call-effect parse-call( ; parsing : execute-effect ( word effect -- ) - [ [ execute ] curry ] dip call-effect ; inline + 2dup execute-effect-unsafe? + [ execute-effect-unsafe ] + [ [ [ execute ] curry ] dip call-effect ] + if ; inline -: execute( - ")" parse-effect parsed \ execute-effect parsed ; parsing +: execute( \ execute-effect parse-call( ; parsing diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index 30d062d4cc..0389841e8f 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes.tuple classes.tuple.parser kernel words -make fry sequences parser accessors ; +make fry sequences parser accessors effects ; IN: compiler.cfg.instructions.syntax : insn-word ( -- word ) @@ -11,7 +11,7 @@ IN: compiler.cfg.instructions.syntax "insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) - boa-effect [ but-last ] change-in { } >>out ; + boa-effect in>> but-last f ; : INSN: parse-tuple-definition "regs" suffix diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 06d8d4f733..b2388c30d2 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -177,6 +177,9 @@ SYMBOL: history : always-inline-word? ( word -- ? ) { curry compose } memq? ; +: never-inline-word? ( word -- ? ) + [ deferred? ] [ { call execute } memq? ] bi or ; + : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; @@ -199,7 +202,7 @@ SYMBOL: history #! calls the compiler at parse time (doing so is #! discouraged, but it should still work.) { - { [ dup deferred? ] [ 2drop f ] } + { [ dup never-inline-word? ] [ 2drop f ] } { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 1b4d9012db..e366073326 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors alien alien.accessors arrays byte-arrays classes sequences.private continuations.private effects generic @@ -11,7 +11,7 @@ strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private -quotations.private stack-checker.values +quotations.private call call.private stack-checker.values stack-checker.alien stack-checker.state stack-checker.errors @@ -137,7 +137,14 @@ M: object infer-call* : infer-(throw) ( -- ) \ (throw) - peek-d literal value>> 2 + f t >>terminated? + peek-d literal value>> 2 + { "*" } + apply-word/effect ; + +: infer-execute-effect-unsafe ( -- ) + \ execute + pop-literal nip + [ in>> "word" suffix ] [ out>> ] [ terminated?>> ] tri + effect boa apply-word/effect ; : infer-exit ( -- ) @@ -178,6 +185,7 @@ M: object infer-call* { \ compose [ infer-compose ] } { \ execute [ infer-execute ] } { \ (execute) [ infer-execute ] } + { \ execute-effect-unsafe [ infer-execute-effect-unsafe ] } { \ if [ infer-if ] } { \ dispatch [ infer-dispatch ] } { \ [ infer- ] } @@ -203,10 +211,10 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - declare call (call) slip 2slip 3slip dip 2dip 3dip - curry compose execute (execute) if dispatch - (throw) exit load-local load-locals get-local drop-locals do-primitive - alien-invoke alien-indirect alien-callback + declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose + execute (execute) execute-effect-unsafe if dispatch + (throw) exit load-local load-locals get-local drop-locals + do-primitive alien-invoke alien-indirect alien-callback } [ t "special" set-word-prop ] each { call execute dispatch load-locals get-local drop-locals } diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 130147f798..6ae12dbd0c 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -37,9 +37,7 @@ SYMBOL: literals : current-stack-height ( -- n ) meta-d length d-in get - ; : current-effect ( -- effect ) - d-in get - meta-d length - terminated? get >>terminated? ; + d-in get meta-d length terminated? get effect boa ; : init-inference ( -- ) terminated? off diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6147dcfbdc..f5dbe6242a 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -278,7 +278,7 @@ M: tuple-class (define-tuple-class) [ 3drop ] [ redefine-tuple-class ] if ; : thrower-effect ( slots -- effect ) - [ dup array? [ first ] when ] map f t >>terminated? ; + [ dup array? [ first ] when ] map { "*" } ; : define-error-class ( class superclass slots -- ) [ define-tuple-class ] diff --git a/core/effects/effects.factor b/core/effects/effects.factor index a9f9634d46..77afa496cc 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -4,14 +4,14 @@ USING: kernel math math.parser namespaces make sequences strings words assocs combinators accessors arrays ; IN: effects -TUPLE: effect in out terminated? ; +TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; : ( in out -- effect ) dup { "*" } sequence= [ drop { } t ] [ f ] if effect boa ; : effect-height ( effect -- n ) - [ out>> length ] [ in>> length ] bi - ; + [ out>> length ] [ in>> length ] bi - ; inline : effect<= ( eff1 eff2 -- ? ) { @@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ; { [ 2dup [ in>> length ] bi@ > ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] } [ t ] - } cond 2nip ; + } cond 2nip ; inline GENERIC: effect>string ( obj -- str ) M: string effect>string ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 78a97547fd..c88bd9d97e 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -77,7 +77,10 @@ PREDICATE: engine-word < word M: engine-word stack-effect "tuple-dispatch-generic" word-prop [ extra-values ] [ stack-effect ] bi - dup [ clone [ length + ] change-in ] [ 2drop f ] if ; + dup [ + [ in>> length + ] [ out>> ] [ terminated?>> ] tri + effect boa + ] [ 2drop f ] if ; M: engine-word crossref? "forgotten" word-prop not ;