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

@@ -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

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" ;
 
 <PRIVATE
 
-: firstn-safe ( array quot n -- ... )
-    3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
-
 : parse-call( ( accum word -- accum )
     [ ")" parse-effect parsed ] dip parsed ;
 
+: call-effect-unsafe ( quot effect -- )
+    drop call ;
+
+: call-unsafe( \ call-effect-unsafe parse-call( ; parsing
+
 PRIVATE>
 
+: (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

basis/stack-checker/known-words/known-words.factor

@@ -140,13 +140,17 @@ M: object infer-call*
     peek-d literal value>> 2 + { "*" } <effect>
     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 ] }
         { \ <tuple-boa> [ infer-<tuple-boa> ] }
@@ -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 <tuple-boa>
-    (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 <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 }
@@ -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
 

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
 

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 ;

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);

vm/primitives.c

@@ -144,4 +144,5 @@ void *primitives[] = {
 	primitive_clear_gc_stats,
 	primitive_jit_compile,
 	primitive_load_locals,
+	primitive_check_datastack
 };

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());

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);