Author: wmb Date: Tue Jan 18 21:25:30 2011 New Revision: 2112 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2112
Log: Kernel - fixed a longstanding inefficiency in the code that handles "is" / "to" for basic datatypes like value and defer. "to <value>" is now much faster, comparable in speed to "<variable> @".
Modified: cpu/arm/kerncode.fth cpu/arm/kernel.bth cpu/mips/kerncode.fth cpu/ppc/kerncode.fth cpu/x86/kerncode.fth forth/kernel/kernel.fth forth/lib/decomp.fth
Modified: cpu/arm/kerncode.fth ============================================================================== --- cpu/arm/kerncode.fth Mon Jan 17 22:58:06 2011 (r2111) +++ cpu/arm/kerncode.fth Tue Jan 18 21:25:30 2011 (r2112) @@ -133,6 +133,35 @@
meta definitions
+code isdefer ( xt -- ) + ldr r0,[ip],1cell \ Get CFA of target word + ldr r0,[r0,1cell] \ Get user number + str tos,[r0,up] \ Store value + pop tos,sp \ Fix stack +c; +code isvalue ( n -- ) + ldr r0,[ip],1cell \ Get CFA of target word + ldr r0,[r0,1cell] \ Get user number + str tos,[r0,up] \ Store value + pop tos,sp \ Fix stack +c; +code isuser ( n -- ) + ldr r0,[ip],1cell \ Get CFA of target word + ldr r0,[r0,1cell] \ Get user number + str tos,[r0,up] \ Store value + pop tos,sp \ Fix stack +c; +code isconstant ( n -- ) + ldr r0,[ip],1cell \ Get CFA of target word + str tos,[r0,1cell] \ Store value + pop tos,sp \ Fix stack +c; +code isvariable ( n -- ) + ldr r0,[ip],1cell \ Get CFA of target word + str tos,[r0,1cell] \ Store value + pop tos,sp \ Fix stack +c; + code (lit) ( -- lit ) psh tos,sp ldr tos,[ip],1cell
Modified: cpu/arm/kernel.bth ============================================================================== --- cpu/arm/kernel.bth Mon Jan 17 22:58:06 2011 (r2111) +++ cpu/arm/kernel.bth Tue Jan 18 21:25:30 2011 (r2112) @@ -31,7 +31,6 @@
[ifndef] arm-assembler \ Make sure we have the ARM assembler -order cr only forth also definitions
fload ${BP}/forth/lib/bitops.fth
Modified: cpu/mips/kerncode.fth ============================================================================== --- cpu/mips/kerncode.fth Mon Jan 17 22:58:06 2011 (r2111) +++ cpu/mips/kerncode.fth Tue Jan 18 21:25:30 2011 (r2112) @@ -207,6 +207,53 @@
meta definitions
+code isdefer ( xt -- ) + ip t0 get + ip ainc + + t0 4 t0 lw \ Get user number + t0 up t0 addu \ User area address + tos base tos subu \ relocate xt + tos t0 0 sw \ Store value + sp ainc \ finish popping stack +c; + +code isuser ( xt -- ) + ip t0 get + ip ainc + + t0 4 t0 lw \ Get user number + t0 up t0 addu \ User area address + tos t0 0 sw \ Store value + sp ainc \ finish popping stack +c; + +code isvalue ( xt -- ) + ip t0 get + ip ainc + + t0 4 t0 lw \ Get user number + t0 up t0 addu \ User area address + tos t0 0 sw \ Store value + sp ainc \ finish popping stack +c; + +code isconstant ( xt -- ) + ip t0 get + ip ainc + + tos t0 4 sw \ Store value + sp ainc \ finish popping stack +c; + +code isvariable ( xt -- ) + ip t0 get + ip ainc + + tos t0 4 sw \ Store value + sp ainc \ finish popping stack +c; + \ dovariable constant dovariable \ dodoes constant dodoes
Modified: cpu/ppc/kerncode.fth ============================================================================== --- cpu/ppc/kerncode.fth Mon Jan 17 22:58:06 2011 (r2111) +++ cpu/ppc/kerncode.fth Tue Jan 18 21:25:30 2011 (r2112) @@ -190,6 +190,39 @@
meta definitions
+code isdefer ( xt -- ) + literal-to-t0 + lwz t0,/cf(t0) \ User number in t0 + stwx tos,t0,up + pop-tos +c; + +code isvalue ( n -- ) + literal-to-t0 + lwz t0,/cf(t0) \ User number in t0 + stwx tos,t0,up + pop-tos +c; + +code isuser ( n -- ) + literal-to-t0 + lwz t0,/cf(t0) \ User number in t0 + stwx tos,t0,up + pop-tos +c; + +code isconstant ( n -- ) + literal-to-t0 + stw tos,/cf(t0) + pop-tos +c; + +code isvariable ( n -- ) + literal-to-t0 + stw tos,/cf(t0) + pop-tos +c; + \ dovariable constant dovariable \ dodoes constant dodoes
Modified: cpu/x86/kerncode.fth ============================================================================== --- cpu/x86/kerncode.fth Mon Jan 17 22:58:06 2011 (r2111) +++ cpu/x86/kerncode.fth Tue Jan 18 21:25:30 2011 (r2112) @@ -161,6 +161,39 @@
\ ---- Run-time words compiled by compiling words.
+code isdefer ( xt -- ) + 0 [ip] ax mov ip ainc /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax +[ifdef] big-endian-t + ax bx mov ax pop ?bswap-ax ax 0 [bx] mov +[else] + bx pop bx 0 [ax] mov +[then] +c; +code isvalue ( n -- ) + 0 [ip] ax mov ip ainc /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax +[ifdef] big-endian-t + ax bx mov ax pop ?bswap-ax ax 0 [bx] mov +[else] + bx pop bx 0 [ax] mov +[then] +c; +code isuser ( n -- ) + 0 [ip] ax mov ip ainc /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax +[ifdef] big-endian-t + ax bx mov ax pop ?bswap-ax ax 0 [bx] mov +[else] + bx pop bx 0 [ax] mov +[then] +c; +code isconstant ( n -- ) + 0 [ip] bx mov ip ainc + ax pop ?bswap-ax ax /cf [bx] mov +c; +code isvariable ( n -- ) + 0 [ip] bx mov ip ainc + ax pop ?bswap-ax ax /cf [bx] mov +c; + code bswap (s n1 -- n2 ) ax pop
Modified: forth/kernel/kernel.fth ============================================================================== --- forth/kernel/kernel.fth Mon Jan 17 22:58:06 2011 (r2111) +++ forth/kernel/kernel.fth Tue Jan 18 21:25:30 2011 (r2112) @@ -1912,6 +1912,13 @@ ' ! token,-t \ constant ' ! token,-t \ variable
+create is-ops + ' isdefer token,-t \ defer + ' isuser token,-t \ user variable + ' isvalue token,-t \ value + ' isconstant token,-t \ constant + ' isvariable token,-t \ variable + : associate ( acf -- true | index false ) word-type ( n ) word-types begin ( n adr ) @@ -1957,11 +1964,17 @@ [ifndef] run-time
: do-is ( data acf -- ) - dup kerntype? if ( [data] acf ) - state @ if compile (is) token, else (is then - else ( [data] acf ) + dup associate if ( [data] acf ) to-hook - then + else ( [data] acf index ) + state @ if ( acf index ) + is-ops swap ta+ token@ ( acf is-token ) + token, token, ( ) + else ( data acf index ) + tuck data-locs +execute ( data index data-adr ) + swap !ops +execute ( ) + then ( ) + then ( ) ; \ is is the word that is actually used by applications : is \ name ( data -- )
Modified: forth/lib/decomp.fth ============================================================================== --- forth/lib/decomp.fth Mon Jan 17 22:58:06 2011 (r2111) +++ forth/lib/decomp.fth Tue Jan 18 21:25:30 2011 (r2112) @@ -300,7 +300,7 @@ headers : skip-(') ( ip -- ip' ) ta1+ ta1+ ; headerless -: .is ( ip -- ip' ) .cword dup token@ .name ta1+ ; +: .is ( ip -- ip' ) ." to " ta1+ dup token@ .name ta1+ ; : .string-tail ( ip -- ip' ) dup count type +str ; : .string ( ip -- ip' ) .cword .string-tail put" ; : .pstring ( ip -- ip' ) ?cr ." p" put" ta1+ .string-tail put" ; @@ -322,7 +322,7 @@ \ classify each word in a definition
\ Common constant for sizing the three classes: -d# 30 constant #decomp-classes +d# 36 constant #decomp-classes
#decomp-classes tassociative: execution-class ( token -- index ) ( 0 ) [compile] (lit) ( 1 ) [compile] ?branch @@ -337,9 +337,12 @@ ( 18 ) [compile] (endof) ( 19 ) [compile] (endcase) ( 20 ) [compile] ("s) ( 21 ) [compile] (is) ( 22 ) [compile] (dlit) ( 23 ) [compile] (llit) - ( 24 ) [compile] (n") ( 25 ) [compile] dummy - ( 26 ) [compile] dummy ( 27 ) [compile] dummy - ( 28 ) [compile] dummy ( 29 ) [compile] dummy + ( 24 ) [compile] (n") ( 25 ) [compile] isdefer + ( 26 ) [compile] isuser ( 27 ) [compile] isvalue + ( 28 ) [compile] isconstant ( 29 ) [compile] isvariable + ( 30 ) [compile] dummy ( 31 ) [compile] dummy + ( 32 ) [compile] dummy ( 33 ) [compile] dummy + ( 34 ) [compile] dummy ( 35 ) [compile] dummy
\ Print a word which has been classified by execution-class #decomp-classes 1+ case: .execution-class ( ip index -- ip' ) @@ -355,9 +358,12 @@ ( 18 ) .endof ( 19 ) .endcase ( 20 ) .pstring ( 21 ) .is ( 22 ) .dlit ( 23 ) .llit - ( 24 ) .nstring ( 25 ) dummy - ( 26 ) dummy ( 27 ) dummy - ( 28 ) dummy ( 29 ) dummy + ( 24 ) .nstring ( 25 ) .is + ( 26 ) .is ( 27 ) .is + ( 28 ) .is ( 29 ) .is + ( 30 ) dummy ( 31 ) dummy + ( 32 ) dummy ( 32 ) dummy + ( 34 ) dummy ( 35 ) dummy ( default ) .word ;
@@ -376,9 +382,12 @@ ( 18 ) skip-branch ( 19 ) skip-word ( 20 ) skip-string ( 21 ) skip-word ( 22 ) skip-dlit ( 23 ) skip-llit - ( 24 ) skip-nstring ( 25 ) dummy - ( 26 ) dummy ( 27 ) dummy - ( 28 ) dummy ( 29 ) dummy + ( 24 ) skip-nstring ( 25 ) skip-word + ( 26 ) skip-word ( 27 ) skip-word + ( 28 ) skip-word ( 29 ) skip-word + ( 30 ) dummy ( 31 ) dummy + ( 32 ) dummy ( 32 ) dummy + ( 34 ) dummy ( 35 ) dummy ( default ) skip-word ;