[openfirmware] [commit] r2112 - cpu/arm cpu/mips cpu/ppc cpu/x86 forth/kernel forth/lib
repository service
svn at openfirmware.info
Tue Jan 18 21:25:31 CET 2011
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
;
More information about the openfirmware
mailing list