From 1559b7464000d16aa20b398adc1bd9b08ffa416d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 06:16:51 -0500 Subject: [PATCH] Add new check-datastack primitive and re-implement call( with it, instead of using with-datastack. call( is now 5x faster --- basis/call/call-tests.factor | 2 +- basis/call/call.factor | 42 ++++++++++++------- .../known-words/known-words.factor | 23 ++++++---- core/bootstrap/primitives.factor | 1 + core/effects/effects.factor | 3 ++ vm/callstack.h | 2 - vm/primitives.c | 1 + vm/run.c | 26 ++++++++++++ vm/run.h | 3 ++ 9 files changed, 79 insertions(+), 24 deletions(-) diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index 4e45c3cf8f..bc6f9a5d4c 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -6,7 +6,7 @@ IN: call.tests [ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test [ 1 2 [ + ] call( -- z ) ] must-fail [ 1 2 [ + ] call( x y -- z a ) ] must-fail -[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test [ [ + ] call( x y -- z ) ] must-infer [ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test diff --git a/basis/call/call.factor b/basis/call/call.factor index 0c1b5bbfbf..e4803c36f9 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,28 +1,39 @@ ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel macros fry summary sequences sequences.private -generalizations accessors continuations effects effects.parser -parser words ; +USING: kernel kernel.private macros fry summary sequences +sequences.private accessors effects effects.parser parser words +make ; IN: call -ERROR: wrong-values values quot length-required ; +ERROR: wrong-values effect ; -M: wrong-values summary - drop "Wrong number of values returned from quotation" ; +M: wrong-values summary drop "Quotation called with stack effect" ; +: (call-effect>quot) ( in out effect -- quot ) + [ + [ [ datastack ] dip dip ] % + [ [ , ] bi@ \ check-datastack , ] dip [ wrong-values ] curry , \ unless , + ] [ ] make ; + +: call-effect>quot ( effect -- quot ) + [ in>> length ] [ out>> length ] [ ] tri + [ (call-effect>quot) ] keep add-effect-input + [ call-effect-unsafe ] 2curry ; + MACRO: call-effect ( effect -- quot ) - [ in>> length ] [ out>> length ] bi - '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ; + call-effect>quot ; : call( \ call-effect parse-call( ; parsing @@ -44,17 +55,20 @@ MACRO: call-effect ( effect -- quot ) over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline : cache-miss ( word effect ic -- ) - [ 2dup execute-effect-unsafe? ] dip - '[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ] + 2over execute-effect-unsafe? + [ [ nip set-first ] [ drop execute-effect-unsafe ] 3bi ] [ execute-effect-slow ] if ; inline : execute-effect-ic ( word effect ic -- ) #! ic is a mutable cell { effect } 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline +: execute-effect>quot ( effect -- quot ) + { f } clone [ execute-effect-ic ] 2curry ; + PRIVATE> MACRO: execute-effect ( effect -- ) - { f } clone '[ _ _ execute-effect-ic ] ; + execute-effect>quot ; : execute( \ execute-effect parse-call( ; parsing diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index e366073326..392cea62d6 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -140,13 +140,17 @@ M: object infer-call* peek-d literal value>> 2 + { "*" } apply-word/effect ; -: infer-execute-effect-unsafe ( -- ) - \ execute +: infer-effect-unsafe ( word -- ) pop-literal nip - [ in>> "word" suffix ] [ out>> ] [ terminated?>> ] tri - effect boa + add-effect-input apply-word/effect ; +: infer-execute-effect-unsafe ( -- ) + \ execute infer-effect-unsafe ; + +: infer-call-effect-unsafe ( -- ) + \ call infer-effect-unsafe ; + : infer-exit ( -- ) \ exit (( n -- * )) apply-word/effect ; @@ -186,6 +190,7 @@ M: object infer-call* { \ execute [ infer-execute ] } { \ (execute) [ infer-execute ] } { \ execute-effect-unsafe [ infer-execute-effect-unsafe ] } + { \ call-effect-unsafe [ infer-call-effect-unsafe ] } { \ if [ infer-if ] } { \ dispatch [ infer-dispatch ] } { \ [ infer- ] } @@ -212,9 +217,10 @@ M: object infer-call* { 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 + execute (execute) call-effect-unsafe 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 } @@ -627,6 +633,9 @@ M: object infer-call* \ datastack { } { array } define-primitive \ datastack make-flushable +\ check-datastack { array integer integer } { object } define-primitive +\ check-datastack make-flushable + \ retainstack { } { array } define-primitive \ retainstack make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 083059cec5..f04a42f493 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -533,6 +533,7 @@ tuple { "gc-reset" "memory" } { "jit-compile" "quotations" } { "load-locals" "locals.backend" } + { "check-datastack" "kernel.private" } } [ [ first2 ] dip make-primitive ] each-index diff --git a/core/effects/effects.factor b/core/effects/effects.factor index d21132aebb..142b9120a8 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -63,3 +63,6 @@ M: effect clone : shuffle ( stack shuffle -- newstack ) shuffle-mapping swap nths ; + +: add-effect-input ( effect -- effect' ) + [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ; diff --git a/vm/callstack.h b/vm/callstack.h index 68937980f6..3c13e7b1cd 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -14,8 +14,6 @@ CELL frame_scan(F_STACK_FRAME *frame); CELL frame_type(F_STACK_FRAME *frame); void primitive_callstack(void); -void primitive_set_datastack(void); -void primitive_set_retainstack(void); void primitive_set_callstack(void); void primitive_callstack_to_array(void); void primitive_innermost_stack_frame_quot(void); diff --git a/vm/primitives.c b/vm/primitives.c index 2bce9eedb7..82b0555894 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -144,4 +144,5 @@ void *primitives[] = { primitive_clear_gc_stats, primitive_jit_compile, primitive_load_locals, + primitive_check_datastack }; diff --git a/vm/run.c b/vm/run.c index c7002eb0ec..e55eb904a7 100755 --- a/vm/run.c +++ b/vm/run.c @@ -155,6 +155,32 @@ void primitive_set_retainstack(void) rs = array_to_stack(untag_array(dpop()),rs_bot); } +/* Used to implement call( */ +void primitive_check_datastack(void) +{ + F_FIXNUM out = to_fixnum(dpop()); + F_FIXNUM in = to_fixnum(dpop()); + F_FIXNUM height = out - in; + F_ARRAY *array = untag_array(dpop()); + F_FIXNUM length = array_capacity(array); + F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; + if(depth - height != length) + dpush(F); + else + { + F_FIXNUM i; + for(i = 0; i < length - in; i++) + { + if(get(ds_bot + i * CELLS) != array_nth(array,i)) + { + dpush(F); + return; + } + } + dpush(T); + } +} + void primitive_getenv(void) { F_FIXNUM e = untag_fixnum_fast(dpeek()); diff --git a/vm/run.h b/vm/run.h index 06b6317015..2acff2cd5a 100755 --- a/vm/run.h +++ b/vm/run.h @@ -236,6 +236,9 @@ void init_stacks(CELL ds_size, CELL rs_size); void primitive_datastack(void); void primitive_retainstack(void); +void primitive_set_datastack(void); +void primitive_set_retainstack(void); +void primitive_check_datastack(void); void primitive_getenv(void); void primitive_setenv(void); void primitive_exit(void);