From 1648a54655e5890f0e3f9870a8ec759bfba5e908 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 07:01:43 -0500
Subject: [PATCH] Add inline caching for execute( -- regex-dna is now only 1%
 slower if regexp uses execute( rather than execute-unsafe(

---
 basis/call/call-tests.factor | 18 +++++++++----
 basis/call/call.factor       | 50 ++++++++++++++++++++++++------------
 2 files changed, 47 insertions(+), 21 deletions(-)

diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor
index 002478fb82..4e45c3cf8f 100644
--- a/basis/call/call-tests.factor
+++ b/basis/call/call-tests.factor
@@ -14,12 +14,20 @@ IN: call.tests
 [ 1 2 \ + execute( x y -- z a ) ] must-fail
 [ \ + execute( x y -- z ) ] must-infer
 
+: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
+[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
+
+: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
+[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+
 [ 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 0ccc774ce0..0c1b5bbfbf 100644
--- a/basis/call/call.factor
+++ b/basis/call/call.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2009 Daniel Ehrenberg.
+! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros fry summary sequences generalizations accessors
-continuations effects effects.parser parser words ;
+USING: kernel macros fry summary sequences sequences.private
+generalizations accessors continuations effects effects.parser
+parser words ;
 IN: call
 
 ERROR: wrong-values values quot length-required ;
@@ -14,17 +15,9 @@ 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 )
@@ -33,10 +26,35 @@ MACRO: call-effect ( effect -- quot )
 
 : call( \ call-effect parse-call( ; parsing
 
-: execute-effect ( word effect -- )
-    2dup execute-effect-unsafe?
-    [ execute-effect-unsafe ]
-    [ [ [ execute ] curry ] dip call-effect ]
-    if ; inline
+<PRIVATE
+
+: execute-effect-unsafe ( word effect -- )
+    drop execute ;
+
+: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
+
+: execute-effect-slow ( word effect -- )
+    [ [ execute ] curry ] dip call-effect ; inline
+
+: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
+
+: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+    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 ]
+    [ 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
+
+PRIVATE>
+
+MACRO: execute-effect ( effect -- )
+    { f } clone '[ _ _ execute-effect-ic ] ;
 
 : execute( \ execute-effect parse-call( ; parsing