\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: extra.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)extra.fth 3.15 03/12/08 13:22:13
copyright: Copyright 1994-2003 Sun Microsystems, Inc. All Rights Reserved
copyright: Copyright 1985-1994 Bradley Forthware
copyright: Use is subject to license terms.
\ Definitions originally from kerncode.fth which are not used in the
\ Execute a Forth word given a pointer to a code field address
code perform ( addr-of-acf -- )
\ Select a vocabulary thread by hashing the lookup name.
\ Hashing function: Use the lower 2 bits of the first character in
\ the name to select one of 4 threads in the array pointed-to by voc-ptr.
code hash ( str-addr voc-apf -- thread )
\ The next 2 lines are equivalent to ">threads", which in this
\ implementation happens to be the same as ">body >user"
\t32 tos 8 tos ld \ Get the user number
\t16 tos 2 tos lduh \ Get the user number
up tos tos add \ Find the address of the threads
\ Search a vocabulary thread (link) for a name matching string.
\ If found, return its code field address and -1 if immediate, 1 if not
\ immediate. If not found, return the string and 0.
\ name: forth-style packed string, no tag bits
\ flag: 40 bit is immediate bit
\ Padding is optionally inserted between the name and the flags
\ so that the byte after the flag byte is on an even boundary.
\t32 code search-thread ( string link origin -- acf -1 | acf 1 | string 0 )
\t32 sp tos pop \ Discard origin; we already have it in a register
\t32 \ tos alf of word being tested
\t32 \ sc1 name being tested
\t32 \ sc2 # of characters left to test
\t32 \ string is kept on the top of the external stack
\t32 tos base cmp 0<> \ Test for end of list
\t32 tos /token sc1 add \ Get name address of word to test
\t32 sp scr get \ Get string address
\t32 scr 0 sc2 ldub \ get the name field length
\t32 scr 0 sc3 ldub \ Compare 2 characters
\t32 0= while \ Keep looking as long as characters match
\t32 scr 1 scr add \ Increment byte pointers
\t32 sc2 1 sc2 subcc \ Decrement byte counter
\t32 0< if \ If we've tested all chars, the names match.
\t32 sc1 1 sc1 add \ Delay slot
\t32 sc1 0 tos ldub \ Get flags byte into tos register
\t32 \dtc sc1 4 sc1 add \ Now find the code field by
\t32 \dtc sc1 -4 sc1 and \ aligning to the next 4 byte boundary
\t32 \itc sc1 2 sc1 add \ Now find the code field by
\t32 \itc sc1 -2 sc1 and \ aligning to the next 2 byte boundary
\t32 tos 20 %g0 andcc \ Test the alias flag
\t32 sc1 0 sc1 rtget \ Get acf
\t32 sc1 base sc1 add \ Relocate
\t32 \itc sc1 0 sc2 lduh \ Is is a realigned code word?
\t32 \itc sc1 2 sc1 add \ Align to 4 byte boundary
\t32 sc1 sp put \ Replace string on stack with acf
\t32 tos 40 %g0 andcc \ Test the immediate flag
\t32 -1 tos move \ Not immediate \ Delay slot
\t32 1 tos move \ Immediate
\t32 \ The names did not match, so check the next name in the list
\t32 tos 0 tos rtget \ Fetch next link
\t32 \ If we get here, we've checked all the names with no luck
code ($find-next) ( adr len link -- adr len alf true | adr len false )
\ tos alf of word being tested
\ sc1 anf of word being tested
\ sc2 # of characters left to test
\ sc3 character from string
\ sc4 character from name
\ string is kept on the top of the external stack
sp 1 /n* scr nget \ Get string address
sp 0 /n* sc5 nget \ get the name field length
scr sc5 scr add \ Point to end of string
tos /token tos sub \ >link
tos 1 sc1 sub \ sc1 points to count byte at *end* of string
%g0 sc5 sc2 subcc \ Set starting loop index and cond. codes
sc1 sc2 sc4 ldub \ Get character from name field
scr sc2 sc3 ldub \ Get character from search string
sc3 sc4 cmp \ Compare 2 characters
sc2 1 sc2 addcc \ Increment loop index
0> if \ If we've tested all name chars, we
sc1 0 sc4 ldub \ get the count byte from the name field
sc4 h# 1f sc4 and \ may have a match; check the count byte
sc4 sc5 cmp \ Compare count bytes
tos sp push \ Push alf above str$
-1 tos move \ True on top of stack means "found"
\ The names did not match, so check the next name in the list
tos 0 tos rtget \ Fetch next link ( next acf )
tos 0 cmp \ Test for end of list
tos base tos add \ Relocate
\ If we get here, we've checked all the names with no luck
: ?negate ( n1 n2 -- n3 ) if negate then ;
code wflip ( l1 -- l2 ) \ word-swap the low two words; clear the rest.
tos /n 2 - 8 * scr slln \ lowest word to upper word of scr
64\ tos /n 4 - 8 * tos slln \ second word to upper word of tos
tos d# 16 tos srln \ second word to 2nd-from-upper word of tos
tos scr tos or \ Join with lowest word (the rest is cleared).
64\ tos /n 4 - 8 * tos srln \ and back into place
code toggle ( addr byte-mask -- )
code log2 ( n -- log2-of-n )
%g0 1 scr sub \ result -> scr Init'l = -1; return -1 if N was zero.
\ Extract some of the rightmost bits from a cell
code bits ( mask #bits -- mask' bits )
sp %g0 scr nget \ scr <= mask
scr tos sc1 srln \ sc1 <= mask'
tos 1 tos sub \ tos <= lowbits
scr tos tos and \ tos <= bits
sc1 %g0 sp nput \ mask' => next-on-stack
code s->l ( n.signed -- l ) inhibit-delay c;
32\ code l->n ( l -- n ) inhibit-delay c;
64\ code l->n ( l -- n ) tos 0 tos sra c;
code n->a ( n -- a ) inhibit-delay c;
32\ code l->w ( l -- w ) tos d# 16 tos sll tos d# 16 tos srl c;
64\ code l->w ( l -- w ) tos d# 48 tos sllx tos d# 48 tos srlx c;
32\ code n->w ( n -- w ) tos d# 16 tos sll tos d# 16 tos srl c;
64\ code n->w ( n -- w ) tos d# 48 tos sllx tos d# 48 tos srlx c;
code l>r ( l -- ) tos rp push sp tos pop c;
code lr> ( -- l ) tos sp push rp tos pop c;
code lr@ ( -- l ) tos sp push rp tos get c;
code /t* ( n -- n*/t ) tos 2 tos sll c;
\t16 tshift-t constant tshift \ Shift factor for offset tokens
#talign-t constant #talign \ Alignment of tokens compiled in colon defs.
#linkalign-t constant #linkalign
/l constant #align \ Hardware alignment: instruction, word fetches
\t16 1 tshift-t << constant #acf-align \ Code field alignment
\t32 #acf-align-t constant #acf-align
: align ( -- ) #align (align) ;
: talign ( -- ) #talign (align) ;
: taligned ( adr -- adr' ) #talign round-up ;
: linkalign ( -- ) #linkalign (align) ;
: u* ( un1 un2 -- product ) um* drop ;
projects / OpenSPARC-T2-SAM / blob