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 */
openfirmware@openfirmware.info
-
repository service