! 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
{ $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
! 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
[ 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
! 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 ;
: 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
! 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 )
"insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect [ but-last ] change-in { } >>out ;
+ boa-effect in>> but-last f <effect> ;
: INSN:
parse-tuple-definition "regs" suffix
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
+: never-inline-word? ( word -- ? )
+ [ deferred? ] [ { call execute } memq? ] bi or ;
+
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
#! 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 ] }
-! 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
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
: infer-(throw) ( -- )
\ (throw)
- peek-d literal value>> 2 + f <effect> t >>terminated?
+ peek-d literal value>> 2 + { "*" } <effect>
+ apply-word/effect ;
+
+: infer-execute-effect-unsafe ( -- )
+ \ execute
+ pop-literal nip
+ [ in>> "word" suffix ] [ out>> ] [ terminated?>> ] tri
+ effect boa
apply-word/effect ;
: infer-exit ( -- )
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
{ \ (execute) [ infer-execute ] }
+ { \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
{ \ if [ infer-if ] }
{ \ dispatch [ infer-dispatch ] }
{ \ <tuple-boa> [ infer-<tuple-boa> ] }
"local-word-def" word-prop infer-quot-here ;
{
- declare call (call) slip 2slip 3slip dip 2dip 3dip
- curry compose execute (execute) if dispatch <tuple-boa>
- (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 <tuple-boa>
+ (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 }
: current-stack-height ( -- n ) meta-d length d-in get - ;
: current-effect ( -- effect )
- d-in get
- meta-d length <effect>
- terminated? get >>terminated? ;
+ d-in get meta-d length terminated? get effect boa ;
: init-inference ( -- )
terminated? off
[ 3drop ] [ redefine-tuple-class ] if ;
: thrower-effect ( slots -- effect )
- [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
+ [ dup array? [ first ] when ] map { "*" } <effect> ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ]
words assocs combinators accessors arrays ;
IN: effects
-TUPLE: effect in out terminated? ;
+TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
: <effect> ( 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 -- ? )
{
{ [ 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 ;
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 ;
projects / factor.git / commitdiff