Changeset 2112

Timestamp:

Jan 18, 2011 9:25:30 PM (2 years ago)

Author:

wmb

Message:

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

Files:

• cpu/arm/kerncode.fth (modified) (1 diff)
• cpu/arm/kernel.bth (modified) (1 diff)
• cpu/mips/kerncode.fth (modified) (1 diff)
• cpu/ppc/kerncode.fth (modified) (1 diff)
• cpu/x86/kerncode.fth (modified) (1 diff)
• forth/kernel/kernel.fth (modified) (2 diffs)
• forth/lib/decomp.fth (modified) (5 diffs)

cpu/arm/kerncode.fth

@@ -133 +133 @@
 
 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 )

cpu/arm/kernel.bth

@@ -32 +32 @@
 
 [ifndef] arm-assembler          \ Make sure we have the ARM assembler
-order cr
 only forth also definitions
 

cpu/mips/kerncode.fth

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

cpu/ppc/kerncode.fth

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

cpu/x86/kerncode.fth

@@ -161 +161 @@
 
 \ ---- 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 )

forth/kernel/kernel.fth

@@ -1913 +1913 @@
    ' !      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 )
@@ -1958 +1965 @@
 
 : 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

forth/lib/decomp.fth

@@ -301 +301 @@
 : 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"  ;
@@ -323 +323 @@
 
 \  Common constant for sizing the three classes:
-d# 30 constant #decomp-classes
+d# 36 constant #decomp-classes
 
 #decomp-classes tassociative: execution-class  ( token -- index )
@@ -338 +338 @@
    ( 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
@@ -356 +359 @@
    ( 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
 ;
@@ -377 +383 @@
    ( 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
 ;