[openfirmware] [commit] r3781 - cpu/arm cpu/x86 forth/kernel forth/lib forth/wrapper/zip
repository service
svn at openfirmware.info
Thu Sep 17 08:22:34 CET 2015
Author: quozl
Date: Thu Sep 17 08:22:33 2015
New Revision: 3781
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/3781
Log:
Preparations for a 64-bit implementation
Modified:
cpu/arm/debugm.fth
cpu/x86/debugm.fth
cpu/x86/kerncode.fth
forth/kernel/forward.fth
forth/kernel/kernel.fth
forth/kernel/metacompile.fth
forth/lib/debug.fth
forth/lib/loadcomm.fth
forth/lib/strcase.fth
forth/wrapper/zip/inflate.c
Modified: cpu/arm/debugm.fth
==============================================================================
--- cpu/arm/debugm.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ cpu/arm/debugm.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -13,7 +13,7 @@
nuser 'debug \ code field for high level trace
nuser <ip \ lower limit of ip
nuser ip> \ upper limit of ip
-nuser cnt \ how many times thru debug next
+nuser cntx \ how many times thru debug next
\ Since we use a shared "next" routine, slow-next and fast-next are no-op's
alias slow-next 2drop ( high low -- )
@@ -30,13 +30,13 @@
ldr r0,'user ip>
cmp ip,r0
u< if
- ldr r0,'user cnt
+ ldr r0,'user cntx
inc r0,#1
- str r0,'user cnt
+ str r0,'user cntx
cmp r0,#2
= if
mov r0,#0
- str r0,'user cnt
+ str r0,'user cntx
adr r0,'body normal-next
str r0,'user debug-next
ldr pc,'user 'debug
Modified: cpu/x86/debugm.fth
==============================================================================
--- cpu/x86/debugm.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ cpu/x86/debugm.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -9,7 +9,7 @@
nuser 'debug \ code field for high level trace
nuser <ip \ lower limit of ip
nuser ip> \ upper limit of ip
-nuser cnt \ how many times thru debug next
+nuser cntx \ how many times thru debug next
label _flush_cache ( -- )
ret
@@ -58,13 +58,13 @@
u>= if
'user ip> ip cmp
u< if
- 'user cnt ax mov
+ 'user cntx ax mov
ax inc
- ax 'user cnt mov
+ ax 'user cntx mov
2 # ax cmp
= if
ax ax sub
- ax 'user cnt mov
+ ax 'user cntx mov
\ normal-next #) ax lea
make-even \ word-align address
\- rel normal-next dup #) ax lea
Modified: cpu/x86/kerncode.fth
==============================================================================
--- cpu/x86/kerncode.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ cpu/x86/kerncode.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -470,6 +470,8 @@
code 0> (s n -- f ) > unary-test c;
code 0>= (s n -- f ) 0>= unary-test c;
+: ?exit (s flag -- ) 0<> if exit then ;
+
assembler definitions
:-h compare
ax pop bx pop ax bx cmp
Modified: forth/kernel/forward.fth
==============================================================================
--- forth/kernel/forward.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/kernel/forward.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -80,6 +80,13 @@
: resolved? ( acf -- flag ) \ true if already resolved
resolution@ origin-t u>
;
+: defined?-t \ name ( -- flag )
+ safe-parse-word $sfind if
+ resolved?
+ else
+ 2drop false
+ then
+;
\ Words to manipulate the symbol table vocabulary at the end of compilation.
Modified: forth/kernel/kernel.fth
==============================================================================
--- forth/kernel/kernel.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/kernel/kernel.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -395,7 +395,9 @@
: "move (s from-pstr to-pstr -- to-pstr ) >r count r> pack ;
\ : count (s adr -- adr+1 len ) dup 1+ swap c@ ;
+[ifndef]-t /string
: /string ( adr len cnt -- adr' len' ) tuck - -rot + swap ;
+[then]
: printable? ( n -- flag ) \ true if n is a printable ascii character
dup bl th 7f within swap th 80 th ff between or
@@ -415,8 +417,12 @@
dup 0 ?do 2dup + 1- c@ white-space? 0= ?leave 1- loop
;
+[ifndef]-t upper
: upper (s adr len -- ) bounds ?do i dup c@ upc swap c! loop ;
+[then]
+[ifndef]-t lower
: lower (s adr len -- ) bounds ?do i dup c@ lcc swap c! loop ;
+[then]
nuser caps
: f83-compare (s adr adr2 len -- -1 | 0 | 1 )
@@ -523,9 +529,12 @@
cmove> drop
;
+[ifndef]-t 2rot
: 2rot (s a b c d e f -- c d e f a b ) 5 roll 5 roll ;
-
+[then]
+[ifndef]-t ?dup
: ?dup (s n -- [n] n ) dup if dup then ;
+[then]
: between (s n min max -- f ) >r over <= swap r> <= and ;
: within (s n1 min max+1 -- f ) over - >r - r> u< ;
@@ -628,7 +637,7 @@
\ needs to temporarily contain odd byte offset because of c,
: here (s -- addr ) dp @ ;
-fffffffc value limit
+-4 value limit
: unused ( -- #bytes ) limit here - ;
defer allot-error
@@ -709,7 +718,7 @@
\t16 compile (lit) ,
\t16 then
-64\ \t32 dup -1 h# 0.ffff.fffe n->l between if
+64\ \t32 dup 1+ d# 32 >> 0= if
64\ \t32 compile (llit) 1+ l,
64\ \t32 else
\t32 compile (lit) ,
@@ -926,14 +935,17 @@
: numdelim? ( char -- flag ) dup ascii . = swap ascii , = or ;
: $dnumber? ( adr len -- [ n .. ] #cells )
0 0 2swap ( ud $ )
- dup 0= if 4drop 0 exit then ( ud $ )
+ dup 0= if 4drop 0 exit then ( ud $ )
over c@ ascii - = ( ud $ neg? )
dup >r negate /string ( ud $' ) ( r: neg? )
+ base @ >r ( ud $' ) ( r: neg? base )
+ \ Recognize leading "0x"
+ over 2 " 0x" $= if hex 2 /string then
\ Convert groups of digits possibly separated by periods or commas
begin >number dup 1 > while ( ud' $' )
over c@ numdelim? 0= if ( ud' $' )
- r> 5drop 0 exit ( ud' $' )
+ 2r> base ! 5drop 0 exit ( ud' $' )
then ( ud' $' )
1 /string ( ud' $' )
repeat ( ud' $' )
@@ -944,12 +956,13 @@
c@ ascii . = if ( ud )
true ( ud dbl? )
else ( ud )
- r> 3drop 0 exit
+ 2r> base ! 3drop 0 exit
then ( ud dbl? )
else ( ud adr )
drop false ( ud dbl? )
then ( ud dbl? )
+ r> base !
over or if ( ud )
r> if dnegate then 2
else
@@ -1142,7 +1155,8 @@
64\ : 16\ [compile] \ ; immediate
64\ : 32\ [compile] \ ; immediate
64\ : 64\ ; immediate
-[then]
+
+[then] \ run-time
\ From definers.fth
@@ -1170,7 +1184,9 @@
: ?csp (s -- ) sp@ csp @ <> ( -22 ) abort" Stack Changed " ;
: (;code) (s -- ) ip> aligned acf-aligned used ;
-: (does>) (s -- ) ip> acf-aligned used ;
+64\ : (does>) (s -- ) ip> aligned used ;
+32\ : (does>) (s -- ) ip> acf-aligned used ;
+16\ : (does>) (s -- ) ip> acf-aligned used ;
defer do-entercode
' noop is do-entercode
@@ -1188,7 +1204,11 @@
: c; ( -- ) next end-code ;
: ;code (s -- )
- ?csp compile (;code) align acf-align place-;code
+ ?csp compile (;code)
+16\ align acf-align
+32\ align acf-align
+64\ acf-align
+ place-;code
[compile] [ reveal do-entercode
; immediate
@@ -1196,9 +1216,13 @@
state @ if
compile (does>)
else
- here aligned acf-aligned used !csp not-hidden ]
+16\ here aligned acf-aligned used !csp not-hidden ]
+32\ here aligned acf-aligned used !csp not-hidden ]
+64\ here aligned used !csp not-hidden ]
then
- align acf-align place-does
+16\ align acf-align place-does
+32\ align acf-align place-does
+64\ align place-does
; immediate
: : (s -- ) ?exec !csp header hide ] colon-cf ;
@@ -1279,14 +1303,13 @@
headers
: do-buffer ( apf -- adr )
- dup >user @ if ( apf )
- >user @ ( adr )
- else ( apf )
- dup /user# + @ ( apf size )
- dup alloc-mem ( apf size adr )
- dup rot erase ( apf adr )
- dup rot >user ! ( adr )
- then
+ dup >user @ ?dup ( apf adr adr | apf 0 )
+ if nip exit then ( apf )
+ \ Must use unaligned-@ here, since /user# != /n on all machines.
+ dup /user# + unaligned-@ ( apf size )
+ dup alloc-mem ( apf size adr )
+ dup rot erase ( apf adr )
+ dup rot >user ! ( adr )
;
: (buffer:) ( size -- )
create-cf make-buffer does> do-buffer
@@ -1474,6 +1497,27 @@
: vocabulary ( "name" -- ) header (wordlist) ;
defer $find-next
+
+[ifndef]-t ($find-next)
+\ Generic colon definition version of ($find-next). This is guaranteed
+\ to be suboptimal in almost all cases, but it's useful before you start
+\ writing and debugging accelerated versions.
+\ 'link' is an address in a vocaulary containing the token (of the
+\ acf) of the newest definition
+: ($find-next) ( adr len link -- adr len alf true | adr len false )
+ begin
+ link@ dup origin <> ( adr len acf more? )
+ while
+ >link >r r@ l>name name>string ( target$ this$ R:alf )
+ 2over $= if
+ r> true exit
+ then
+ r>
+ repeat
+ drop false
+;
+[then]
+
' ($find-next) is $find-next
\ : insert-after ( new-node old-node -- )
@@ -2000,9 +2044,8 @@
: line-delimiter file @ 17 na+ ; \ The last delimiter at the end of each line
: pre-delimiter file @ 18 na+ ; \ The first line delimiter (if any)
: (file-name) file @ 19 na+ ; \ The name of the file
-/n round-up
headers
-20 /n-t * d# 68 + constant /fd
+d# 20 /n-t * d# 68 + /n-t round-up constant /fd
: set-name ( adr len -- )
\ If the name is too long, cut off initial characters (because the
Modified: forth/kernel/metacompile.fth
==============================================================================
--- forth/kernel/metacompile.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/kernel/metacompile.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -9,7 +9,7 @@
\ Non-immediate version which is compiled inside several
\ meta and transition words
-: literal-t ( n -- ) n->l-t compile-t (lit) ,-t ;
+: literal-t ( n -- ) n->n-t compile-t (lit) ,-t ;
\ vocabularies:
\ transition
@@ -401,7 +401,7 @@
\ Automatic allocation of space in the user area
variable #user-t
-/n constant #ualign-t
+/n-t constant #ualign-t
: ualigned-t ( n -- n' ) #ualign-t 1- + #ualign-t negate and ;
: ualloc-t ( n -- next-user-# ) \ allocate n bytes and leave a user number
@@ -415,7 +415,9 @@
: isconstant ( acf -- n ) >body-t @-t ;
: constant \ name ( n -- )
safe-parse-word 3dup $equ
- " constant-cf" $header-t s->l-t ,-t
+64\ " constant-cf" $header-t n->n-t ,-t
+32\ " constant-cf" $header-t s->l-t ,-t
+16\ " constant-cf" $header-t s->l-t ,-t
['] isconstant setaction ?debug
;
@@ -425,7 +427,9 @@
['] iscreate setaction ?debug
;
-: isvariable ( n acf -- ) >body-t !-t ;
+64\ : isvariable ( n acf -- ) >body-t >r n->n-t r> !-t ;
+32\ : isvariable ( n acf -- ) >body-t !-t ;
+16\ : isvariable ( n acf -- ) >body-t !-t ;
: variable \ name ( -- )
" variable-cf" header-t 0 n->n-t ,-t
['] isvariable setaction ?debug
@@ -489,7 +493,10 @@
\ of defining the label.
: mlabel \ name ( -- ) ( Later: -- adr-t )
- safe-parse-word align-t acf-align-t $label
+ safe-parse-word align-t
+32\ acf-align-t
+16\ acf-align-t
+ $label
;
: mloclabel \ name ( -- ) ( Later: -- adr-t )
safe-parse-word $label
@@ -568,14 +575,20 @@
\ XXX the alignment should be done in startdoes; it is incorrect
\ to assume that acf alignment is sufficient (code alignment might
\ be stricter).
- align-t acf-align-t here-t doestarget !
+64\ align-t here-t doestarget !
+32\ align-t acf-align-t here-t doestarget !
+16\ align-t acf-align-t here-t doestarget !
" startdoes" $meta-execute
target
; immediate
: ;code (s -- )
host
- ?csp compile-t (;code) align-t acf-align-t here-t doestarget !
+ ?csp compile-t (;code)
+64\ acf-align-t
+32\ align-t acf-align-t
+16\ align-t acf-align-t
+ here-t doestarget !
" start;code" $meta-execute
[compile] [ reveal-t entercode
target
@@ -669,6 +682,9 @@
;
meta definitions
+: [ifdef]-t defined?-t [compile] [if] ; immediate-h
+: [ifndef]-t defined?-t 0= [compile] [if] ; immediate-h
+
alias : :-t
alias ] ]-t
alias /n /n-t
Modified: forth/lib/debug.fth
==============================================================================
--- forth/lib/debug.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/lib/debug.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -42,7 +42,7 @@
: force-redisplay ( -- ) -1 to displayed-xt ;
: (debug) (s low-adr hi-adr -- )
- unbug 1 cnt ! ip> ! <ip ! pnext
+ unbug 1 cntx ! ip> ! <ip ! pnext
slow-next? @ 0= if
here low-dictionary-adr slow-next
slow-next? on
@@ -294,8 +294,8 @@
ascii $ of space 2dup type cr to-cmd-column false endof \ String
ascii Q of cr ." unbug" abort true endof \ Quit
ascii ( of the-ip set-<ip false endof
- ascii < of the-ip ta1+ set-<ip 1 cnt ! false endof
- ascii ) of the-ip ip> ! 1 cnt ! false endof
+ ascii < of the-ip ta1+ set-<ip 1 cntx ! false endof
+ ascii ) of the-ip ip> ! 1 cntx ! false endof
ascii * of the-ip find-cfa dup <ip ! 'unnest ip> ! false endof
ascii \ of show-rstack @ 0= show-rstack ! false endof \ toggle return stack display
ascii X of hex-stack @ 0= hex-stack ! false endof \ toggle heX stack display
Modified: forth/lib/loadcomm.fth
==============================================================================
--- forth/lib/loadcomm.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/lib/loadcomm.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -24,6 +24,7 @@
fload ${BP}/forth/lib/strings.fth
fload ${BP}/forth/lib/stringop.fth
+fload ${BP}/forth/lib/string-tools.fth
fload ${BP}/forth/lib/fastspac.fth
Modified: forth/lib/strcase.fth
==============================================================================
--- forth/lib/strcase.fth Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/lib/strcase.fth Thu Sep 17 08:22:33 2015 (r3781)
@@ -9,7 +9,7 @@
\ " abc" $of ." The string starts with abc" $endof
\ " xyz" $of ." Oh, it's an xyz string" $endof
\ ( $ ) ." **** It was " 2dup type
-\ $endcase ( $ )
+\ $endcase
\ The default clause is optional.
\ When an $of clause is executed, the remaining selector string (past
@@ -28,15 +28,36 @@
\needs substring? fload ${BP}/forth/lib/substrin.fth
-: ($of) ( arg$ sel$ -- arg$' )
- 4dup 2swap substring? if
- nip /string
- r> cell+ >r \ Return to next word in $of clause
+\ Copying standard words here so they can be case insensitive:
+: u$= (s adr1 len1 adr2 len2 -- same? )
+ rot tuck <> if 3drop false exit then ( adr1 adr2 len1 )
+ caps-comp 0=
+;
+
+: usubstring? ( adr1 len1 adr2 len2 -- flag )
+ rot tuck ( adr1 adr2 len1 len2 len1 )
+ < if 3drop false else tuck u$= then
+;
+
+: ($of) ( $selector $test -- [$selector] )
+ 2over $= if
+ 2drop
+ r> /token + >r \ Return to next word in $of clause
else
+ r> dup branch@ + >r \ Skip to matching $endof
+ then
+;
+: ($sub) ( $selector $test -- $selector | $rest )
+ 4dup 2swap usubstring? if ( $selector $test )
+ nip /string ( $rest )
+ r> /token + >r \ Return to next word in $sub clause
+ else ( $selector $test )
2drop
- r> dup @ + >r \ Skip to matching $endof
+ r> dup branch@ + >r \ Skip to matching $endof
then
;
+: $sub ( -- >m ) ['] ($sub) +>mark ; immediate
+: $endsub ( >m -- ) ['] ($endof) +>mark but ->resolve ; immediate
: $case ( -- 0 ) +level 0 ; immediate
: $of ( -- >m ) ['] ($of) +>mark ; immediate
Modified: forth/wrapper/zip/inflate.c
==============================================================================
--- forth/wrapper/zip/inflate.c Wed Jul 15 23:07:22 2015 (r3780)
+++ forth/wrapper/zip/inflate.c Thu Sep 17 08:22:33 2015 (r3781)
@@ -269,7 +269,7 @@
}
} else {
- int i; /* temporary variables */
+ int i = 0; /* temporary variables */
struct huft *tl; /* literal/length code table */
struct huft *td; /* distance code table */
int bl; /* lookup bits for tl */
More information about the openfirmware
mailing list