Make execute( faster, add execute-unsafe( and make effect tuple slots read only

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 )" }
+{ $syntax "execute( stack -- effect )" }
-{ $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." } ;
+{ $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
+HELP: execute-unsafe(
-{ POSTPONE: call( POSTPONE: execute( } related-words
+{ $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

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

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(
+: call( \ call-effect parse-call( ; parsing
-    ")" parse-effect parsed \ call-effect parsed ; 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(
+: execute( \ execute-effect parse-call( ; parsing
-    ")" parse-effect parsed \ execute-effect parsed ; parsing

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 <effect> ;
 
 : INSN:
     parse-tuple-definition "regs" suffix

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 ] }

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 <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 ( -- )
@@ -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 ] }
         { \ <tuple-boa> [ infer-<tuple-boa> ] }
@@ -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
+    declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
-    curry compose execute (execute) if dispatch <tuple-boa>
+    execute (execute) execute-effect-unsafe if dispatch <tuple-boa>
-    (throw) exit load-local load-locals get-local drop-locals do-primitive
+    (throw) exit load-local load-locals get-local drop-locals
-    alien-invoke alien-indirect alien-callback
+    do-primitive alien-invoke alien-indirect alien-callback
 } [ t "special" set-word-prop ] each
 
 { call execute dispatch load-locals get-local drop-locals }

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
+    d-in get meta-d length terminated? get effect boa ;
-    meta-d length <effect>
-    terminated? get >>terminated? ;
 
 : init-inference ( -- )
     terminated? off

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 <effect> t >>terminated? ;
+    [ dup array? [ first ] when ] map { "*" } <effect> ;
 
 : define-error-class ( class superclass slots -- )
     [ define-tuple-class ]

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 } ;
 
 : <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 -- ? )
     {
@@ -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 ;

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 ;