steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Faster compilation of dispatch primitive

db4
Slava Pestov 2008-01-13 17:07:59 -05:00
parent 4a350d1ccb
commit 952c559b52
10 changed files with 129 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/compiler/test/simple.factor
View File

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

15
core/cpu/architecture/architecture.factor
View File

@ -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 ( word-table# -- )
HOOK: %call-dispatch compiler-backend ( -- label )
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 ( -- )

55
core/cpu/ppc/architecture/architecture.factor
View File

@ -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-template ( word-table# quot -- )
[
>r
"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
: (%dispatch) ( len -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup rot cells LWZ ;
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# -- )
[ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %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

38
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -23,8 +23,8 @@ IN: cpu.ppc.intrinsics
: %slot-any
"obj" operand "scratch" operand %untag
"n" operand dup 1 SRAWI
"scratch" operand "val" operand "n" operand ;
"offset" operand "n" operand 1 SRAWI
"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" } } }
{ +clobber+ { "val" "n" } }
{ +scratch+ { { f "scratch" } { f "offset" } } }
{ +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
"n" operand dup 2 SRAWI
"n" operand "obj" operand "n" operand ADD
"out" operand "n" operand string-offset LHZ
(%char-slot)
"out" operand "offset" 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
"slot" operand dup "obj" operand ADD
"val" operand "slot" operand string-offset STH
"val" operand "offset" operand string-offset STH
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
{ +clobber+ { "val" "slot" } }
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +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

7
core/generator/fixup/fixup.factor
View File

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

47
core/generator/generator.factor
View File

@ -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
] [
%epilogue-later %jump-label
] if ;
{
{ [ dup compiling-label get eq? ] [
drop current-label-start get %jump-label
] }
{ [ 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 )
node-children
[ compiling-word get dispatch-branch ] map
word-table get push-all ;
: %dispatch ( word-table# -- )
tail-call? [
%jump-dispatch
] [
0 frame-required
%call-dispatch
] if ;
: dispatch-branches ( node -- )
node-children [
compiling-word get dispatch-branch %dispatch-label
] each ;
M: #dispatch generate-node
word-table get length %dispatch
dispatch-branches init-templates iterate-next ;
#! The order here is important, dispatch-branches must
#! 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 -- )

21
core/inference/class/class-tests.factor
View File

@ -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 ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
] when

6
core/optimizer/known-words/known-words.factor
View File

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

2
vm/code_heap.c
View File

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

4
vm/code_heap.h
View File

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