Non-optimizing compiler now open-codes megamorphic dispatch fast path

basis/bootstrap/image/image.factor

@@ -173,6 +173,11 @@ SYMBOL: pic-check
 SYMBOL: pic-hit
 SYMBOL: pic-miss-word
 
+! Megamorphic dispatch
+SYMBOL: mega-lookup
+SYMBOL: mega-lookup-word
+SYMBOL: mega-miss-word
+
 ! Default definition for undefined words
 SYMBOL: undefined-quot
 
@@ -215,6 +220,9 @@ SYMBOL: undefined-quot
         { pic-check 54 }
         { pic-hit 55 }
         { pic-miss-word 56 }
+        { mega-lookup 57 }
+        { mega-lookup-word 58 }
+        { mega-miss-word 59 }
         { undefined-quot 60 }
     } ; inline
 
@@ -526,6 +534,8 @@ M: quotation '
     \ 3dip jit-3dip-word set
     \ (execute) jit-execute-word set
     \ inline-cache-miss \ pic-miss-word set
+    \ mega-cache-lookup \ mega-lookup-word set
+    \ mega-cache-miss \ mega-miss-word set
     [ undefined ] undefined-quot set
     {
         jit-code-format
@@ -563,6 +573,9 @@ M: quotation '
         pic-check
         pic-hit
         pic-miss-word
+        mega-lookup
+        mega-lookup-word
+        mega-miss-word
         undefined-quot
     } [ emit-userenv ] each ;
 

basis/compiler/codegen/codegen.factor

@@ -44,7 +44,7 @@ SYMBOL: calls
 
 SYMBOL: compiling-word
 
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
 
 ! Mapping _label IDs to label instances
 SYMBOL: labels

basis/compiler/constants/constants.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system strings words quotations byte-arrays alien ;
+USING: math kernel layouts system strings words quotations byte-arrays
+alien arrays ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
@@ -20,8 +21,8 @@ CONSTANT: deck-bits 18
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
 : word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
 : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
 : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
 
 ! Relocation classes

basis/cpu/x86/bootstrap.factor

@@ -3,7 +3,7 @@
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler layouts compiler.units math
 math.private compiler.constants vocabs slots.private words
-locals.backend make sequences combinators ;
+locals.backend make sequences combinators arrays ;
 IN: bootstrap.x86
 
 big-endian off
@@ -181,9 +181,11 @@ big-endian off
 ] pic-load jit-define
 
 ! Tag
-[
+: load-tag ( -- )
     temp1 tag-mask get AND
-] pic-tag jit-define
+    temp1 tag-bits get SHL ;
+
+[ load-tag ] pic-tag jit-define
 
 ! The 'make' trick lets us compute the jump distance for the
 ! conditional branches there
@@ -191,8 +193,8 @@ big-endian off
 ! Hi-tag
 [
     temp0 temp1 MOV
-    temp1 tag-mask get AND
+    load-tag
-    temp1 object tag-number CMP
+    temp1 object tag-number tag-fixnum CMP
     [ temp1 temp0 object tag-number neg [+] MOV ] { } make
     [ length JNE ] [ % ] bi
 ] pic-hi-tag jit-define
@@ -200,8 +202,8 @@ big-endian off
 ! Tuple
 [
     temp0 temp1 MOV
-    temp1 tag-mask get AND
+    load-tag
-    temp1 tuple tag-number CMP
+    temp1 tuple tag-number tag-fixnum CMP
     [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
     [ length JNE ] [ % ] bi
 ] pic-tuple jit-define
@@ -209,21 +211,17 @@ big-endian off
 ! Hi-tag and tuple
 [
     temp0 temp1 MOV
-    temp1 tag-mask get AND
+    load-tag
     ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
     temp1 BIN: 110 tag-fixnum CMP
     [
-        ! Untag temp0 in temp2
+        ! Untag temp0
-        temp2 temp0 MOV
+        temp0 tag-mask get bitnot AND
-        temp2 tag-mask get bitnot AND
+        ! Set temp1 to 0 for objects, and 8 for tuples
-        ! Set temp1 to 0 for objects, and 1 for tuples
+        temp1 1 tag-fixnum AND
-        temp1 1 AND
+        bootstrap-cell 4 = [ temp1 1 SHR ] when
-        bootstrap-cell {
-            { 4 [ temp1 2 SHR ] }
-            { 8 [ temp1 3 SHR ] }
-        } case
         ! Load header cell or tuple layout cell
-        temp1 temp2 temp1 [+] MOV
+        temp1 temp0 temp1 [+] MOV
     ] [ ] make [ length JL ] [ % ] bi
 ] pic-hi-tag-tuple jit-define
 
@@ -238,6 +236,34 @@ big-endian off
 
 [ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
 
+! ! ! Megamorphic caches
+
+[
+    ! cache = ...
+    temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+    ! key = class
+    temp2 temp1 MOV
+    ! compute cache.length - 1
+    temp3 temp0 1 bootstrap-cells array tag-number - [+] MOV
+    temp3 1 SHR
+    temp3 4 SUB
+    ! key &= cache.length - 1
+    temp2 temp3 AND
+    ! cache += array-start-offset
+    temp0 array-start-offset ADD
+    ! cache += key
+    temp0 temp2 ADD
+    ! if(get(cache) == class)
+    temp0 [] temp1 CMP
+    ! ... goto get(cache + bootstrap-cell)
+    [
+        temp0 temp0 bootstrap-cell [+] MOV
+        temp0 word-xt-offset [+] JMP
+    ] [ ] make
+    [ length JNE ] [ % ] bi
+    ! fall-through on miss
+] mega-lookup jit-define
+
 ! ! ! Sub-primitives
 
 ! Quotations and words

core/bootstrap/primitives.factor

@@ -349,6 +349,7 @@ tuple
     { "get-local" "locals.backend" (( n -- obj )) }
     { "load-local" "locals.backend" (( obj -- )) }
     { "drop-locals" "locals.backend" (( n -- )) }
+    { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
 } [ first3 make-sub-primitive ] each
 
 ! Primitive words
@@ -501,8 +502,9 @@ tuple
     { "jit-compile" "quotations" (( quot -- )) }
     { "load-locals" "locals.backend" (( ... n -- )) }
     { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
-    { "lookup-method" "generic.single.private" (( object methods method-cache -- method )) }
+    { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
-    { "inline-cache-miss" "generic.single.private" (( generic methods -- )) }
+    { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
+    { "lookup-method" "generic.single.private" (( object methods -- method )) }
     { "reset-dispatch-stats" "generic.single" (( -- )) }
     { "dispatch-stats" "generic.single" (( -- stats )) }
     { "reset-inline-cache-stats" "generic.single" (( -- )) }

core/generic/hook/hook.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors definitions generic generic.single kernel
+USING: accessors definitions generic generic.single
-namespaces words ;
+generic.single.private kernel namespaces words kernel.private
+quotations sequences ;
 IN: generic.hook
 
 TUPLE: hook-combination < single-combination var ;
@@ -16,6 +17,11 @@ M: hook-combination picker
 
 M: hook-combination dispatch# drop 0 ;
 
+M: hook-combination inline-cache-quot 2drop f ;
+
+M: hook-combination mega-cache-quot
+    1quotation picker [ lookup-method (execute) ] surround ;
+
 M: hook-generic definer drop \ HOOK: f ;
 
 M: hook-generic effective-method

core/generic/single/single.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.algebra
 combinators definitions generic hashtables kernel
-kernel.private layouts make math namespaces quotations
+kernel.private layouts math namespaces quotations
 sequences words generic.single.private effects make ;
 IN: generic.single
 
@@ -29,7 +29,7 @@ SYMBOL: combination
 
 HOOK: picker combination ( -- quot )
 
-M: single-combination next-method-quot*
+M: single-combination next-method-quot* ( class generic combination -- quot )
     [
         2dup next-method dup [
             [
@@ -238,29 +238,19 @@ M: f compile-engine ;
         [ <engine> compile-engine ] bi
     ] tri ;
 
-: make-empty-cache ( -- array )
+HOOK: inline-cache-quot combination ( word methods -- quot/f )
-    generic-word get "methods" word-prop
-    assoc-size 2 * next-power-of-2 f <array> ;
 
-HOOK: direct-entry-def combination ( word methods -- quot/f )
+: define-inline-cache-quot ( word methods -- )
+    [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
 
-M: single-combination direct-entry-def 2drop f ;
+HOOK: mega-cache-quot combination ( methods -- quot/f )
-
-: define-direct-entry ( word methods -- )
-    [ drop ] [ direct-entry-def ] 2bi >>direct-entry-def drop ;
 
 M: single-combination perform-combination
     [
         dup generic-word set
         dup build-decision-tree
         [ "decision-tree" set-word-prop ]
-        [
+        [ mega-cache-quot define ]
-            [
+        [ define-inline-cache-quot ]
-                picker %
+        2tri
-                ,
-                make-empty-cache ,
-                [ lookup-method (execute) ] %
-            ] [ ] make define
-        ]
-        [ define-direct-entry ] 2tri
     ] with-combination ;

core/generic/standard/standard.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors definitions generic generic.single kernel
 namespaces words math math.order combinators sequences
-generic.single.private ;
+generic.single.private quotations kernel.private
+assocs arrays ;
 IN: generic.standard
 
 TUPLE: standard-combination < single-combination # ;
@@ -39,12 +40,19 @@ M: standard-generic effective-method
     [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
     (effective-method) ;
 
-M: standard-combination direct-entry-def ( word methods -- )
+M: standard-combination inline-cache-quot ( word methods -- )
     #! Direct calls to the generic word (not tail calls or indirect calls)
     #! will jump to the inline cache entry point instead of the megamorphic
     #! dispatch entry point.
     combination get #>> [ f inline-cache-miss ] 3curry [ ] like ;
 
+: make-empty-cache ( -- array )
+    generic-word get "methods" word-prop
+    assoc-size 2 * next-power-of-2 f <array> ;
+
+M: standard-combination mega-cache-quot
+    combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
+
 M: standard-generic definer drop \ GENERIC# f ;
 
 M: simple-generic definer drop \ GENERIC: f ;

vm/dispatch.c

@@ -81,30 +81,6 @@ static CELL lookup_hi_tag_method(CELL object, CELL methods)
 	return array_nth(hi_tag_methods,tag);
 }
 
-static CELL method_cache_hashcode(CELL key, F_ARRAY *array)
-{
-	CELL capacity = (array_capacity(array) >> 1) - 1;
-	return ((key >> TAG_BITS) & capacity) << 1;
-}
-
-static CELL lookup_cached_method(CELL key, CELL method_cache)
-{
-	F_ARRAY *array = untag_object(method_cache);
-	CELL hashcode = method_cache_hashcode(key,array);
-	if(array_nth(array,hashcode) == key)
-		return array_nth(array,hashcode + 1);
-	else
-		return F;
-}
-
-static void update_method_cache(CELL key, CELL method_cache, CELL method)
-{
-	F_ARRAY *array = untag_object(method_cache);
-	CELL hashcode = method_cache_hashcode(key,array);
-	set_array_nth(array,hashcode,key);
-	set_array_nth(array,hashcode + 1,method);
-}
-
 static CELL lookup_hairy_method(CELL object, CELL methods)
 {
 	CELL method = array_nth(untag_object(methods),TAG(object));
@@ -127,43 +103,21 @@ static CELL lookup_hairy_method(CELL object, CELL methods)
 	}
 }
 
-static CELL lookup_method_with_cache(CELL object, CELL methods, CELL method_cache)
+CELL lookup_method(CELL object, CELL methods)
 {
 	if(!HI_TAG_OR_TUPLE_P(object))
-	{
-		megamorphic_cache_hits++;
 		return array_nth(untag_object(methods),TAG(object));
-	}
 	else
-	{
+		return lookup_hairy_method(object,methods);
-		CELL key = get(HI_TAG_HEADER(object));
-		CELL method = lookup_cached_method(key,method_cache);
-		if(method != F)
-		{
-			megamorphic_cache_hits++;
-			return method;
-		}
-		else
-		{
-			megamorphic_cache_misses++;
-			method = lookup_hairy_method(object,methods);
-			update_method_cache(key,method_cache,method);
-			return method;
-		}
-	}
 }
 
 void primitive_lookup_method(void)
 {
-	CELL method_cache = get(ds);
+	CELL methods = dpop();
-	CELL methods = get(ds - CELLS);
+	CELL object = dpop();
-	CELL object = get(ds - CELLS * 2);
+	dpush(lookup_method(object,methods));
-	ds -= CELLS * 2;
-	drepl(lookup_method_with_cache(object,methods,method_cache));
 }
 
-/* Next two functions are used for polymorphic inline caching */
-
 CELL object_class(CELL object)
 {
 	if(!HI_TAG_OR_TUPLE_P(object))
@@ -172,12 +126,35 @@ CELL object_class(CELL object)
 		return get(HI_TAG_HEADER(object));
 }
 
-CELL lookup_method(CELL object, CELL methods)
+static CELL method_cache_hashcode(CELL class, F_ARRAY *array)
 {
-	if(!HI_TAG_OR_TUPLE_P(object))
+	CELL capacity = (array_capacity(array) >> 1) - 1;
-		return array_nth(untag_object(methods),TAG(object));
+	return ((class >> TAG_BITS) & capacity) << 1;
-	else
+}
-		return lookup_hairy_method(object,methods);
+
+static void update_method_cache(CELL cache, CELL class, CELL method)
+{
+	F_ARRAY *array = untag_object(cache);
+	CELL hashcode = method_cache_hashcode(class,array);
+	set_array_nth(array,hashcode,class);
+	set_array_nth(array,hashcode + 1,method);
+}
+
+void primitive_mega_cache_miss(void)
+{
+	megamorphic_cache_misses++;
+
+	CELL cache = dpop();
+	F_FIXNUM index = untag_fixnum_fast(dpop());
+	CELL methods = dpop();
+
+	CELL object = get(ds - index * CELLS);
+	CELL class = object_class(object);
+	CELL method = lookup_method(object,methods);
+
+	update_method_cache(cache,class,method);
+
+	dpush(method);
 }
 
 void primitive_reset_dispatch_stats(void)
@@ -194,3 +171,32 @@ void primitive_dispatch_stats(void)
 	GROWABLE_ARRAY_DONE(stats);
 	dpush(stats);
 }
+
+void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type)
+{
+	jit_emit_with(jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS));
+	jit_emit(jit,userenv[type]);
+}
+
+void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache)
+{
+	/* Generate machine code to determine the object's class. */
+	jit_emit_class_lookup(jit,index,PIC_HI_TAG_TUPLE);
+
+	/* Do a cache lookup. */
+	jit_emit_with(jit,userenv[MEGA_LOOKUP],cache);
+	
+	/* If we end up here, the cache missed. */
+	jit_emit(jit,userenv[JIT_PROLOG]);
+
+	/* Push index, method table and cache on the stack. */
+	jit_push(jit,methods);
+	jit_push(jit,tag_fixnum(index));
+	jit_push(jit,cache);
+	jit_word_call(jit,userenv[MEGA_MISS_WORD]);
+
+	/* Now the new method has been stored into the cache, and its on
+	   the stack. */
+	jit_emit(jit,userenv[JIT_EPILOG]);
+	jit_emit(jit,userenv[JIT_EXECUTE_JUMP]);
+}

vm/dispatch.h

@@ -1,10 +1,16 @@
 CELL megamorphic_cache_hits;
 CELL megamorphic_cache_misses;
 
+CELL lookup_method(CELL object, CELL methods);
 void primitive_lookup_method(void);
 
 CELL object_class(CELL object);
-CELL lookup_method(CELL object, CELL methods);
+
+void primitive_mega_cache_miss(void);
 
 void primitive_reset_dispatch_stats(void);
 void primitive_dispatch_stats(void);
+
+void jit_emit_class_lookup(F_JIT *jit, F_FIXNUM index, CELL type);
+
+void jit_emit_mega_cache_lookup(F_JIT *jit, CELL methods, F_FIXNUM index, CELL cache);

vm/image.c

@@ -183,7 +183,7 @@ void primitive_save_image_and_exit(void)
 	for(i = 0; i < FIRST_SAVE_ENV; i++)
 		userenv[i] = F;
 
-	for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++)
+	for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
 		userenv[i] = F;
 
 	/* do a full GC + code heap compaction */

vm/inline_cache.c

@@ -82,8 +82,7 @@ static F_CODE_BLOCK *compile_inline_cache(F_FIXNUM index, CELL generic_word, CEL
 	jit_init(&jit,WORD_TYPE,generic_word);
 
 	/* Generate machine code to determine the object's class. */
-	jit_emit_with(&jit,userenv[PIC_LOAD],tag_fixnum(-index * CELLS));
+	jit_emit_class_lookup(&jit,index,inline_cache_type);
-	jit_emit(&jit,userenv[inline_cache_type]);
 
 	/* Generate machine code to check, in turn, if the class is one of the cached entries. */
 	CELL i;

vm/jit.c

@@ -1,5 +1,11 @@
 #include "master.h"
 
+/* Simple code generator used by:
+- profiler (profiler.c),
+- quotation compiler (quotations.c),
+- megamorphic caches (dispatch.c),
+- polymorphic inline caches (inline_cache.c) */
+
 /* Allocates memory */
 void jit_init(F_JIT *jit, CELL jit_type, CELL owner)
 {

vm/jit.h

@@ -45,6 +45,12 @@ INLINE void jit_word_jump(F_JIT *jit, CELL word)
 	jit_emit_with(jit,userenv[JIT_WORD_JUMP],word);
 }
 
+/* Allocates memory */
+INLINE void jit_word_call(F_JIT *jit, CELL word)
+{
+	jit_emit_with(jit,userenv[JIT_WORD_CALL],word);
+}
+
 /* Allocates memory */
 INLINE void jit_emit_subprimitive(F_JIT *jit, F_WORD *word)
 {

vm/master.h

@@ -50,8 +50,8 @@
 #include "callstack.h"
 #include "alien.h"
 #include "quotations.h"
-#include "dispatch.h"
 #include "jit.h"
+#include "dispatch.h"
 #include "inline_cache.h"
 #include "factor.h"
 #include "utilities.h"

vm/primitives.c

@@ -143,8 +143,9 @@ void *primitives[] = {
 	primitive_jit_compile,
 	primitive_load_locals,
 	primitive_check_datastack,
-	primitive_lookup_method,
 	primitive_inline_cache_miss,
+	primitive_mega_cache_miss,
+	primitive_lookup_method,
 	primitive_reset_dispatch_stats,
 	primitive_dispatch_stats,
 	primitive_reset_inline_cache_stats,

vm/quotations.c

@@ -89,6 +89,15 @@ static bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
 		&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
 }
 
+static bool jit_mega_lookup_p(F_ARRAY *array, CELL i)
+{
+	return (i + 3) < array_capacity(array)
+		&& type_of(array_nth(array,i)) == ARRAY_TYPE
+		&& type_of(array_nth(array,i + 1)) == FIXNUM_TYPE
+		&& type_of(array_nth(array,i + 2)) == ARRAY_TYPE
+		&& array_nth(array,i + 3) == userenv[MEGA_LOOKUP_WORD];
+}
+
 static bool jit_stack_frame_p(F_ARRAY *array)
 {
 	F_FIXNUM length = array_capacity(array);
@@ -189,7 +198,7 @@ void jit_compile(CELL quot, bool relocate)
 					jit_word_jump(&jit,obj);
 				}
 				else
-					jit_emit_with(&jit,userenv[JIT_WORD_CALL],obj);
+					jit_word_call(&jit,obj);
 			}
 			break;
 		case WRAPPER_TYPE:
@@ -257,6 +266,16 @@ void jit_compile(CELL quot, bool relocate)
 				i++;
 				break;
 			}
+			else if(jit_mega_lookup_p(untag_object(array),i))
+			{
+				jit_emit_mega_cache_lookup(&jit,
+					array_nth(untag_object(array),i),
+					untag_fixnum_fast(array_nth(untag_object(array),i + 1)),
+					array_nth(untag_object(array),i + 2));
+				i += 3;
+				tail_call = true;
+				break;
+			}
 		default:
 			jit_push(&jit,obj);
 			break;

vm/run.h

@@ -32,7 +32,7 @@ typedef enum {
 	BOOT_ENV            = 20, /* boot quotation */
 	GLOBAL_ENV,               /* global namespace */
 
-	/* Used by the JIT compiler */
+	/* Quotation compilation in quotations.c */
 	JIT_CODE_FORMAT     = 22,
 	JIT_PROLOG,
 	JIT_PRIMITIVE_WORD,
@@ -60,7 +60,7 @@ typedef enum {
 	JIT_EXECUTE_JUMP,
 	JIT_EXECUTE_CALL,
 
-	/* Used by polymorphic inline cache generation in inline_cache.c */
+	/* Polymorphic inline cache generation in inline_cache.c */
 	PIC_LOAD            = 48,
 	PIC_TAG,
 	PIC_HI_TAG,
@@ -71,7 +71,10 @@ typedef enum {
 	PIC_HIT,
 	PIC_MISS_WORD,
 
-	STACK_TRACES_ENV    = 59,
+	/* Megamorphic cache generation in dispatch.c */
+	MEGA_LOOKUP         = 57,
+	MEGA_LOOKUP_WORD,
+        MEGA_MISS_WORD,
 
 	UNDEFINED_ENV       = 60, /* default quotation for undefined words */
 
@@ -84,6 +87,8 @@ typedef enum {
 	THREADS_ENV         = 64,
 	RUN_QUEUE_ENV       = 65,
 	SLEEP_QUEUE_ENV     = 66,
+
+	STACK_TRACES_ENV    = 67,
 } F_ENVTYPE;
 
 #define FIRST_SAVE_ENV BOOT_ENV