\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: fcode32.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: @(#)fcode32.fth 1.15 06/10/26
copyright: Copyright 2006 Sun Microsystems, Inc. All rights reserved.
copyright: Use is subject to license terms.
code 2l->n ( l1 l2 -- x1 x2 )
: l-$number ( adr len -- true | n false ) swap n->l swap $number ;
: l-move ( adr1 adr2 cnt -- ) rot n->l rot n->l rot n->l move ;
: l-fill ( adr cnt byte -- ) rot n->l rot n->l rot fill ;
: lcpeek ( adr -- { byte true } | false ) n->l cpeek ;
: lwpeek ( adr -- { byte true } | false ) n->l wpeek ;
: llpeek ( adr -- { byte true } | false ) n->l lpeek ;
: lcpoke ( byte adr -- ok? ) n->l cpoke ;
: lwpoke ( byte adr -- ok? ) n->l wpoke ;
: llpoke ( byte adr -- ok? ) n->l lpoke ;
: lb?branch ( [ <mark ] -- [ >mark ] )
\ New feature of IEEE 1275
l->n if get-offset drop else skip-bytes then
\ The get-backward-mark is needed in case of the following valid
\ ANS Forth construct: BEGIN .. WHILE .. UNTIL .. THEN
get-backward-mark [compile] until
code l>>a ( n1 cnt -- n2 )
code lrshift ( n1 cnt -- n2 )
: lb(of) ( marks -- marks )
drop-offset +level compile 2l->n -level [compile] of
drop-offset +level compile 2l->n -level [compile] do
drop-offset +level compile 2l->n -level [compile] ?do
drop-offset +level compile l->n -level [compile] +loop
also assembler definitions
: leaveflag ( condition -- )
\ macro to assemble code to leave a flag on the stack
\ Note: l0= and l= clash with the link defs in kernport.fth
code l0= ( n -- f ) tos test 0= leaveflag c;
code l0<> ( n -- f ) tos test 0<> leaveflag c;
code l0< ( n -- f ) tos test 0< leaveflag c;
code l0<= ( n -- f ) tos test <= leaveflag c;
code l0> ( n -- f ) tos test > leaveflag c;
code l0>= ( n -- f ) tos test 0>= leaveflag c;
code l< ( n1 n2 -- f ) compare < leaveflag c;
code l> ( n1 n2 -- f ) compare > leaveflag c;
code l= ( n1 n2 -- f ) compare 0= leaveflag c;
code l<> ( n1 n2 -- f ) compare <> leaveflag c;
code lu> ( n1 n2 -- f ) compare u> leaveflag c;
code lu<= ( n1 n2 -- f ) compare u<= leaveflag c;
code lu< ( n1 n2 -- f ) compare u< leaveflag c;
code lu>= ( n1 n2 -- f ) compare u>= leaveflag c;
code l>= ( n1 n2 -- f ) compare >= leaveflag c;
code l<= ( n1 n2 -- f ) compare <= leaveflag c;
: l-between ( n1 n2 n3 -- flag ) >r over l<= swap r> l<= and ;
: l-within ( n1 n2 n3 -- flag ) over - >r - r> lu< ;
: l-max ( n1 n2 -- max ) 2dup l< if swap then drop ;
: l-min ( n1 n2 -- min ) 2dup l> if swap then drop ;
: l-abs ( n -- |n| ) dup l0< if negate then ;
\itc tos 2 scr lduh tos 0 tos lduh
\itc tos h# 10 tos sll scr tos tos add
tos /n 2 + scr lduh sc1 10 sc1 sll scr sc1 sc1 add
tos /n 4 + scr lduh sc1 10 sc1 sllx scr sc1 sc1 add
tos /n 6 + scr lduh sc1 10 sc1 sllx scr sc1 scr add
tos 2 scr lduh sc1 10 sc1 sll scr sc1 sc1 add
tos 4 scr lduh sc1 10 sc1 sllx scr sc1 sc1 add
tos 6 scr lduh sc1 10 sc1 sllx
scr tos 6 sth scr 10 scr srlx
scr tos 4 sth scr 10 scr srlx
scr tos 2 sth scr 10 scr srl
scr tos /n 6 + sth scr 10 scr srlx
scr tos /n 4 + sth scr 10 scr srlx
scr tos /n 2 + sth scr 10 scr srl
code ll@ ( addr -- l ) \ longword aligned
code lw@ ( addr -- w ) \ 16-bit word aligned
: lbase ( -- adr ) +level compile base compile la1+ -level ; immediate
: l#out ( -- adr ) +level compile #out compile la1+ -level ; immediate
: l#line ( -- adr ) +level compile #line compile la1+ -level ; immediate
: lspan ( -- adr ) +level compile span compile la1+ -level ; immediate
code lrl@ ( addr -- l ) \ longword aligned
code lrw@ ( addr -- w ) \ 16-bit word aligned
\ Double word stuff we need to implement with 32-bit only math.
sp 0 /n* sc1 nget \ x2.low
sp 2 /n* sc3 nget \ x1.low
sp 1 /n* sc2 nget \ x1.high
sp 2 /n* sp add \ Pop args
sc3 sc1 sc1 addcc \ x3.low
sc2 tos tos addc \ x3.high
sc1 sp 0 nput \ Push result (x3.high already in tos)
sp 0 /n* sc1 nget \ x2.low
sp 2 /n* sc3 nget \ x1.low
sp 1 /n* sc2 nget \ x1.high
sp 2 /n* sp add \ Pop args
sc3 sc1 sc1 subcc \ x3.low
sc2 tos tos subc \ x3.high
sc1 sp 0 nput \ Push result (x3.high already in tos)
: l-u/mod ( u1 u2 -- u.rem u.quot ) n->l swap n->l swap u/mod ;
: l-/mod ( n1 n2 -- n.rem n.quot ) l->n swap l->n swap /mod ;
\ The following is from obp/fm/kernel/dmuldiv.fth and obp/fm/kernel/dmul.fth:
/l 4 * constant bits/half-l
: l-scale-up ( n -- h ) bits/half-l << ;
: l-scale-down ( n -- h ) bits/half-l >> ;
alias l-split-halves lwsplit
: l-half* ( h1 h2 -- low<< high ) * l-split-halves swap l-scale-up swap ;
\ AB * CD = BD + (BC + DA)<<bits/half-cell + AC<<bits/cell
\ Where A, B, C, D are half "l" (or 16 bit in this case) values.
: lum* ( n1 n2 -- xlo xhi )
l-split-halves rot l-split-halves ( b a d c )
\ Easy case - high halves are both 0, so result is just BD
2 pick over or 0= if drop nip * 0 exit then
3 pick 2 pick * 0 2>r ( b a d c ) ( r: d.low )
\ Check for C = 0 and optimize if so
dup if ( b a d c ) ( r: d.low )
\ C is not zero, so compute and add BC<<
2r> ld+ 2>r ( b a d c ) ( r: d.intermed )
\ Check for A = 0 and optimize if so
\ A is not zero, so compute and add DA<< and AC<<<
rot over l-half* ( c a da.low da.high )
2r> ld+ 2>r ( c a ) ( r: d.intermed' )
\ A is zero, so we are finished
\ C is zero, so all we have to do is compute and add DA<<
drop rot drop ( a d ) ( r: d.low )
\ This is the elementary school long-division algorithm, base 2^^16 (on a
\ 32-bit system) or 2^32 (on a 64-bit system).
\ It depends on the assumption that "/" can accurately divide a single-cell
\ (i.e. 32 or 64 bit) number by a half-cell (i.e. 16 or 32 bit) number.
\ Each "digit" is a half-cell number; thus the dividend is a 4-digit
\ number "ABCD" and the divisor is a 2-digit number "EF".
\ It would be interesting to compare the performance of this to a
\ "bit-banging" non-restoring division loop.
: l-um/mod ( ud u -- urem uquot )
2dup u>= if \ Overflow; return max-uint for quotient
0= if 0 / then \ Force divide by zero trap
2drop 0 -1 n->l exit ( 0 max-u )
\ Split the divisor into two 16-bit "digits"
dup l-split-halves ( ud u ulow uhigh )
\ If the high "digit" of the divisor is zero, we can skip a lot
\ of the steps. In this case, we only have to worry about the
\ middle two digits of the dividend in developing the quotient.
\ Approximate the high digit of the quotient by dividing the "BC"
\ digits by the "F" digit. The answer could by low by one, but if
\ so it will be fixed in the next step.
2over swap l-scale-down swap l-scale-up + over / l-scale-up
\ Multiply the trial quotient by the divisor
rot over lum* ( ud ulow guess<< udtemp )
\ Subtract the trial product from the dividend, giving the remainder
2swap >r >r ld- drop ( error ) ( r: guess<< ulow )
\ Divide the remainder by the divisor, giving the rest of the
dup r@ l-u/mod nip ( error guess1 )
r> r> ( error guess1 ulow guess<< )
\ Merge the two halves of the quotient
2 pick + >r ( error guess1 ulow ) ( r: uquot )
\ Calculate the remainder
\ The high divisor digit is non-zero, so we have to deal with
\ both digits, dividing "ABCD" by "EF".
\ Approximate the high digit of the quotient.
3 pick over l-u/mod nip ( ud u ulow uhigh guess )
\ Reduce guess by one if "E" = "A"
dup 1 l-scale-up = if 1- then ( ud u ulow uhigh guess' )
\ Multiply the trial quotient by the divisor
3 pick over l-scale-up lum* ( ud u ulow uhigh guess' ud.temp )
\ Subtract the trial product from the dividend, giving the remainder
>r >r 2rot r> r> ld- ( u ulow uhigh guess' d.resid )
\ If the remainder is negative, add the divisor and reduce the trial
\ quotient by one. The following loop executes at most twice.
begin dup 0< while ( u ulow uhigh guess' d.resid )
rot 1- -rot ( u ulow uhigh guess+ d.resid )
4 pick l-scale-up 4 pick ld+ ( u ulow uhigh guess+ d.resid' )
repeat ( u ulow uhigh guess+ +d.resid )
\ Now we have the correct high quotient digit; save it for later
rot l-scale-up >r ( u ulow uhigh +d.resid ) ( r: q.high )
\ Repeat the above process, using the partial remainder as the
\ dividend. Ulow is no longer needed
3 roll drop ( u uhigh +d.resid )
\ Trial quotient digit...
2dup l-scale-up swap l-scale-down + 3 roll l-u/mod nip
( u +d.resid guess1 ) ( r: q.high )
dup 1 l-scale-up = if 1- then ( u +d.resid guess1' )
3 pick over lum* ( u +d.resid guess1' d.err )
rot >r ld- ( u d.resid' ) ( r: q.high guess1' )
\ Adjust quotient digit until partial remainder is positive
begin dup 0< while ( u d.resid' ) ( r: q.high guess1' )
r> 1- >r ( u d.resid' ) ( r: q.high guess1' )
\ There is no l-m+, so use "0< ld+" instead
2 pick dup 0< ld+ ( u d.resid'' ) ( r: q.high guess1' )
repeat ( u +d.resid ) ( r: q.high guess1' )
\ Discard divisior and high cell of quotient (which must be zero)
: l-mu/mod (s d n1 -- rem d.quot )
>r 0 r@ l-um/mod r> swap >r l-um/mod r>
base @ l-mu/mod ( nrem ud2 )
: l-#s (s ud -- 0 0 ) begin l-# 2dup or 0= until ;
token-tables 0 ta+ token@ token-table0-64 token!
token-tables 0 ta+ !null-token
token-tables 2 ta+ token@ token-table2-64 token!
token-tables 2 ta+ !null-token
fload ${BP}/pkg/fcode/primlist.fth \ Codes for kernel primitives
fload ${BP}/pkg/fcode/sysprims-nofb.fth \ Codes for system primitives
fload ${BP}/pkg/fcode/obsfcod2.fth
fload ${BP}/pkg/fcode/sysprm64.fth
fload ${BP}/pkg/fcode/regcodes.fth
token-tables 0 ta+ token@ token-table0-32 token!
token-tables 2 ta+ token@ token-table2-32 token!
token-table0-32 token@ token-tables 0 ta+ token!
token-table2-32 token@ token-tables 2 ta+ token!
token-table0-64 token@ token-tables 0 ta+ token!
token-table2-64 token@ token-tables 2 ta+ token!
stand-init: Chose fcode32 mode
projects / OpenSPARC-T2-SAM / blob