Faster compilation of dispatch primitive

core/compiler/test/simple.factor

@@ -63,3 +63,9 @@ IN: temporary
 ! Regression
 
 [ ] [ [ callstack ] compile-call drop ] unit-test
+
+! Regression
+
+: empty ;
+
+[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test

core/cpu/architecture/architecture.factor

@@ -51,19 +51,28 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
 
 M: object %save-dispatch-xt %save-word-xt ;
 
+! Call C primitive
+HOOK: %call-primitive compiler-backend ( label -- )
+
 ! Call another label
 HOOK: %call-label compiler-backend ( label -- )
 
+! Far jump to C primitive
+HOOK: %jump-primitive compiler-backend ( label -- )
+
 ! Local jump for branches
 HOOK: %jump-label compiler-backend ( label -- )
 
 ! Test if vreg is 'f' or not
 HOOK: %jump-t compiler-backend ( label -- )
 
-! We pass the offset of the jump table start in the world table
+HOOK: %call-dispatch compiler-backend ( -- label )
-HOOK: %call-dispatch compiler-backend ( word-table# -- )
 
-HOOK: %jump-dispatch compiler-backend ( word-table# -- )
+HOOK: %jump-dispatch compiler-backend ( -- )
+
+HOOK: %dispatch-label compiler-backend ( word -- )
+
+HOOK: %end-dispatch compiler-backend ( label -- )
 
 ! Return to caller
 HOOK: %return compiler-backend ( -- )

core/cpu/ppc/architecture/architecture.factor

@@ -97,6 +97,22 @@ M: ppc-backend %epilogue ( n -- )
     1 1 rot ADDI
     0 MTLR ;
 
+: %prepare-primitive ( word -- )
+    #! Save stack pointer to stack_chain->callstack_top, load XT
+    4 1 MR
+    0 11 LOAD32
+    rc-absolute-ppc-2/2 rel-primitive ;
+
+: (%call) 11 MTLR BLRL ;
+
+M: ppc-backend %call-primitive ( word -- )
+    %prepare-primitive (%call) ;
+
+: (%jump) 11 MTCTR BCTR ;
+
+M: ppc-backend %jump-primitive ( word -- )
+    %prepare-primitive (%jump) ;
+
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
@@ -107,26 +123,29 @@ M: ppc-backend %jump-label ( label -- ) B ;
 M: ppc-backend %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
-: (%call) 11 MTLR BLRL ;
+: (%dispatch) ( len -- )
-
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
-: dispatch-template ( word-table# quot -- )
+    "offset" operand "n" operand 1 SRAWI
-    [
+    11 11 "offset" operand ADD
-        >r
+    11 dup rot cells LWZ ;
-        "offset" operand "n" operand 1 SRAWI
-        0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
-        11 dup "offset" operand LWZX
-        11 dup word-xt-offset LWZ
-        r> call
-    ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-    } with-template ; inline
 
 M: ppc-backend %call-dispatch ( word-table# -- )
-    [ (%call) ] dispatch-template ;
+    [ 7 (%dispatch) (%call) <label> dup B ] H{
+        { +input+ { { f "n" } } }
+        { +scratch+ { { f "offset" } } }
+    } with-template ;
 
-M: ppc-backend %jump-dispatch ( word-table# -- )
+M: ppc-backend %jump-dispatch ( -- )
-    [ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
+    [ %epilogue-later 6 (%dispatch) (%jump) ] H{
+        { +input+ { { f "n" } } }
+        { +scratch+ { { f "offset" } } }
+    } with-template ;
+
+M: ppc-backend %dispatch-label ( word -- )
+    0 , rc-absolute-cell rel-word ;
+
+M: ppc-backend %end-dispatch ( label -- )
+    resolve-label ;
 
 M: ppc-backend %return ( -- ) %epilogue-later BLR ;
 
@@ -271,7 +290,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
 
 : %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
 
-: %untag-fixnum ( src dest -- ) tag-bits get SRAWI ;
+: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
 
 M: ppc-backend value-structs?
     #! On Linux/PPC, value structs are passed in the same way

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -23,8 +23,8 @@ IN: cpu.ppc.intrinsics
 
 : %slot-any
     "obj" operand "scratch" operand %untag
-    "n" operand dup 1 SRAWI
+    "offset" operand "n" operand 1 SRAWI
-    "scratch" operand "val" operand "n" operand ;
+    "scratch" operand "val" operand "offset" operand ;
 
 \ slot {
     ! Slot number is literal and the tag is known
@@ -47,9 +47,8 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-any LWZX ] H{
             { +input+ { { f "obj" } { f "n" } } }
-            { +scratch+ { { f "val" } { f "scratch" } } }
+            { +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
             { +output+ { "val" } }
-            { +clobber+ { "n" } }
         }
     }
 } define-intrinsics
@@ -88,33 +87,34 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-any STWX %write-barrier ] H{
             { +input+ { { f "val" } { f "obj" } { f "n" } } }
-            { +scratch+ { { f "scratch" } } }
+            { +scratch+ { { f "scratch" } { f "offset" } } }
-            { +clobber+ { "val" "n" } }
+            { +clobber+ { "val" } }
         }
     }
 } define-intrinsics
 
+: (%char-slot)
+    "offset" operand "n" operand 2 SRAWI
+    "offset" operand dup "obj" operand ADD ;
+
 \ char-slot [
-    "out" operand "obj" operand MR
+    (%char-slot)
-    "n" operand dup 2 SRAWI
+    "out" operand "offset" operand string-offset LHZ
-    "n" operand "obj" operand "n" operand ADD
-    "out" operand "n" operand string-offset LHZ
     "out" operand dup %tag-fixnum
 ] H{
     { +input+ { { f "n" } { f "obj" } } }
-    { +scratch+ { { f "out" } } }
+    { +scratch+ { { f "out" } { f "offset" } } }
     { +output+ { "out" } }
-    { +clobber+ { "n" } }
 } define-intrinsic
 
 \ set-char-slot [
+    (%char-slot)
     "val" operand dup %untag-fixnum
-    "slot" operand dup 2 SRAWI
+    "val" operand "offset" operand string-offset STH
-    "slot" operand dup "obj" operand ADD
-    "val" operand "slot" operand string-offset STH
 ] H{
-    { +input+ { { f "val" } { f "slot" } { f "obj" } } }
+    { +input+ { { f "val" } { f "n" } { f "obj" } } }
-    { +clobber+ { "val" "slot" } }
+    { +scratch+ { { f "offset" } } }
+    { +clobber+ { "val" } }
 } define-intrinsic
 
 : fixnum-register-op ( op -- pair )
@@ -185,10 +185,10 @@ IN: cpu.ppc.intrinsics
     {
         [
             { "positive" "end" } [ define-label ] each
-            "y" operand "out" operand swap %untag-fixnum
+            "out" operand "y" operand %untag-fixnum
             0 "y" operand 0 CMPI
             "positive" get BGE
-            "y" operand dup NEG
+            "out" operand dup NEG
             "out" operand "x" operand "out" operand SRAW
             "end" get B
             "positive" resolve-label

core/generator/fixup/fixup.factor

@@ -69,6 +69,7 @@ SYMBOL: label-table
 : rt-literal   2 ;
 : rt-dispatch  3 ;
 : rt-xt        4 ;
+: rt-here      5 ;
 : rt-label     6 ;
 
 TUPLE: label-fixup label class ;
@@ -129,12 +130,18 @@ SYMBOL: word-table
 : rel-word ( word class -- )
     >r add-word r> rt-xt rel-fixup ;
 
+: rel-primitive ( word class -- )
+    >r word-def first r> rt-primitive rel-fixup ;
+
 : rel-literal ( literal class -- )
     >r add-literal r> rt-literal rel-fixup ;
 
 : rel-this ( class -- )
     0 swap rt-label rel-fixup ;
 
+: rel-here ( class -- )
+    0 swap rt-here rel-fixup ;
+
 : init-fixup ( -- )
     V{ } clone relocation-table set
     V{ } clone label-table set ;

core/generator/generator.factor

@@ -104,14 +104,21 @@ UNION: #terminal
 ! node
 M: node generate-node drop iterate-next ;
 
-: %call ( word -- ) %call-label ;
+: %call ( word -- )
+    dup primitive? [ %call-primitive ] [ %call-label ] if ;
 
 : %jump ( word -- )
-    dup compiling-label get eq? [
+    {
-        drop current-label-start get %jump-label
+        { [ dup compiling-label get eq? ] [
-    ] [
+            drop current-label-start get %jump-label
-        %epilogue-later %jump-label
+        ] }
-    ] if ;
+        { [ dup primitive? ] [
+            %epilogue-later %jump-primitive
+        ] }
+        { [ t ] [
+            %epilogue-later %jump-label
+        ] }
+    } cond ;
 
 : generate-call ( label -- next )
     dup maybe-compile
@@ -162,22 +169,22 @@ M: #if generate-node
         ] generate-1
     ] keep ;
 
-: dispatch-branches ( node -- syms )
+: dispatch-branches ( node -- )
-    node-children
+    node-children [
-    [ compiling-word get dispatch-branch ] map
+        compiling-word get dispatch-branch %dispatch-label
-    word-table get push-all ;
+    ] each ;
-
-: %dispatch ( word-table# -- )
-    tail-call? [
-        %jump-dispatch
-    ] [
-        0 frame-required
-        %call-dispatch
-    ] if ;
 
 M: #dispatch generate-node
-    word-table get length %dispatch
+    #! The order here is important, dispatch-branches must
-    dispatch-branches init-templates iterate-next ;
+    #! run after %dispatch, so that each branch gets the
+    #! correct register state
+    tail-call? [
+        %jump-dispatch dispatch-branches
+    ] [
+        0 frame-required
+        %call-dispatch >r dispatch-branches r> %end-dispatch
+    ] if
+    init-templates iterate-next ;
 
 ! #call
 : define-intrinsics ( word intrinsics -- )

core/inference/class/class-tests.factor

@@ -3,7 +3,8 @@ USING: arrays math.private kernel math compiler inference
 inference.dataflow optimizer tools.test kernel.private generic
 sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
-slots.private combinators definitions compiler.units ;
+slots.private combinators definitions compiler.units
+system ;
 
 ! Make sure these compile even though this is invalid code
 [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@@ -251,12 +252,14 @@ M: fixnum annotate-entry-test-1 drop ;
     \ fixnum-shift inlined?
 ] unit-test
 
-[ t ] [
+cell-bits 32 = [
-    [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+    [ t ] [
-    \ shift inlined?
+        [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
-] unit-test
+        \ shift inlined?
+    ] unit-test
 
-[ f ] [
+    [ f ] [
-    [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+        [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
-    \ fixnum-shift inlined?
+        \ fixnum-shift inlined?
-] unit-test
+    ] unit-test
+] when

core/optimizer/known-words/known-words.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer.known-words
 USING: alien arrays generic hashtables inference.dataflow
@@ -149,6 +149,10 @@ float-arrays combinators.private combinators ;
 
 \ >array { { string vector } } "specializer" set-word-prop
 
+\ >vector { { array vector } } "specializer" set-word-prop
+
+\ >sbuf { string } "specializer" set-word-prop
+
 \ crc32 { string } "specializer" set-word-prop
 
 \ split, { string string } "specializer" set-word-prop

vm/code_heap.c

@@ -52,6 +52,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
 		return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
+	case RT_HERE:
+		return rel->offset + code_start;
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:

vm/code_heap.h

@@ -9,8 +9,8 @@ typedef enum {
 	RT_DISPATCH,
 	/* a compiled word reference */
 	RT_XT,
-	/* reserved */
+	/* current offset */
-	RT_RESERVED,
+	RT_HERE,
 	/* a local label */
 	RT_LABEL
 } F_RELTYPE;