\ ========== 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 \ conditions are met: \ \ - 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 \ any nuclear facility. \ \ ========== Copyright Header End ============================================ id: @(#)extra.fth 3.15 03/12/08 13:22:13 purpose: 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 \ "run-time" version. hex \ Execute a Forth word given a pointer to a code field address code perform ( addr-of-acf -- ) tos 0 scr rtget sp tos get scr base %g0 jmpl sp ainc end-code \ 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. headerless 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 sp scr pop scr 1 scr ldub bubble scr 3 scr and \t16 scr 1 scr sll \t32 scr 2 scr sll tos scr tos add c; headers \ 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 field: \ 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 \ Registers: \t32 \ tos alf of word being tested \t32 \ scr string \t32 \ sc1 name being tested \t32 \ sc2 # of characters left to test \t32 \ string is kept on the top of the external stack \t32 \t32 begin \t32 tos base cmp 0<> \ Test for end of list \t32 while \t32 tos /token sc1 add \ Get name address of word to test \t32 sp scr get \ Get string address \t32 bubble \t32 scr 0 sc2 ldub \ get the name field length \t32 begin \t32 scr 0 sc3 ldub \ Compare 2 characters \t32 sc1 0 sc4 ldub \t32 bubble \t32 sc3 sc4 cmp \t32 0= while \ Keep looking as long as characters match \t32 nop \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 \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 \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 \t32 tos 20 %g0 andcc \ Test the alias flag \t32 0<> if \t32 nop \t32 sc1 0 sc1 rtget \ Get acf \t32 sc1 base sc1 add \ Relocate \t32 \itc else \t32 \itc nop \t32 \itc sc1 0 sc2 lduh \ Is is a realigned code word? \t32 \itc sc2 0 cmp \t32 \itc = if nop \t32 \itc sc1 2 sc1 add \ Align to 4 byte boundary \t32 \itc then \t32 \t32 then \t32 \t32 sc1 sp put \ Replace string on stack with acf \t32 tos 40 %g0 andcc \ Test the immediate flag \t32 0<> if \t32 -1 tos move \ Not immediate \ Delay slot \t32 ( else ) \t32 1 tos move \ Immediate \t32 then \t32 inhibit-delay \t32 next \t32 then \t32 repeat \t32 nop \t32 \t32 \ The names did not match, so check the next name in the list \t32 tos 0 tos rtget \ Fetch next link \t32 tos base tos add \t32 repeat \t32 nop \t32 \t32 \ If we get here, we've checked all the names with no luck \t32 0 tos move \t32 c; code ($find-next) ( adr len link -- adr len alf true | adr len false ) \ Registers: \ tos alf of word being tested \ scr string \ sc1 anf of word being tested \ sc2 # of characters left to test \ sc3 character from string \ sc4 character from name \ sc5 string length \ 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 ahead scr sc5 scr add \ Point to end of string begin 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 begin sc1 sc2 sc4 ldub \ Get character from name field scr sc2 sc3 ldub \ Get character from search string sc3 sc4 cmp \ Compare 2 characters <> until 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 = if nop tos sp push \ Push alf above str$ -1 tos move \ True on top of stack means "found" next then then but then \ 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 = until tos base tos add \ Relocate \ If we get here, we've checked all the names with no luck 0 tos move c; headers : ?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 c; code toggle ( addr byte-mask -- ) sp 0 /n* scr nget bubble scr 0 sc1 ldub bubble sc1 tos sc1 xor sc1 scr 0 stb sp 1 /n* tos nget sp 2 /n* sp add c; code log2 ( n -- log2-of-n ) %g0 1 scr sub \ result -> scr Init'l = -1; return -1 if N was zero. begin tos %g0 %g0 subcc 0<> while tos 1 tos srln repeat scr 1 scr add scr tos move c; \ \ 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' 1 sc2 set sc2 tos tos slln tos 1 tos sub \ tos <= lowbits scr tos tos and \ tos <= bits sc1 %g0 sp nput \ mask' => next-on-stack c; 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; headerless code /t* ( n -- n*/t ) tos 2 tos sll c; headers \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 ; \ headerless : linkalign ( -- ) #linkalign (align) ; headers : u* ( un1 un2 -- product ) um* drop ;