\ \ Last change: KS 30.09.2015 14:21:54 \ \ uCore Floating Point Package \ Polynomial approximations of math functions are 23 bits precise \ \ >float, float> and normalize are realised as uCore instructions, see uCore.vhd \ In case of overflow, the largest possible number will be returned and the ovfl bit will be set \ In case of underflow, + or - zero will be returned and the unfl bit will be set \ The floating point -zero is a zero with the sign bit set, i.e. $80000000 for a 32 bit system \ \ cell_width = word width of the host system \ data_width = word width of the target system \ exp_width = width of the exponent field Host cell_width data_width - Constant delta_width \ cell width >= data width data_width 1- 2** Constant #signbit exp_width 2** 1- Constant #exp_mask #exp_mask invert Constant #man_mask #exp_mask 2/ invert Constant #exp_min #exp_mask #exp_min and Constant #exp_sign #signbit Constant #fzero_neg 0 Constant #fzero_pos #signbit #exp_mask or Constant #fmax_neg #signbit invert Constant #fmax_pos -1 delta_width negate shift Constant #data_mask Variable underflow 0 underflow ! Variable overflow 0 overflow ! Variable Scale \ used for optimal scaling of a set of polynomial coefficients : scaled ( n -- n' ) s>d data_width 1 - 0 DO d2* LOOP Scale @ fm/mod nip ; : scale_factor ( n -- ) Scale ! ; : round ( dm -- m' ) over 0< 0= IF nip EXIT THEN \ < 0.5 swap 2* IF 1+ EXIT THEN \ > 0.5 dup 1 and + \ = 0.5, round to even ; : *. ( n1 u -- n2 ) over 0< IF swap negate um* round negate EXIT THEN um* round ; Target data_width 1- 2** Constant #signbit exp_width 2** 1- Constant #exp_mask #exp_mask invert Constant #man_mask #exp_mask 2/ invert Constant #exp_min #exp_mask 2/ #exp_mask xor Constant #exp_sign 0 Constant #fzero_pos #signbit Constant #fzero_neg #signbit #exp_mask or Constant #fmax_neg #signbit invert Constant #fmax_pos Host: scaled ( n -- n' ) scaled ; Host: scale_factor ( n -- ) scale_factor ; : int.frac ( r -- frac int ) \ split float number into integer and fractional part float> [ data_width 2 - ] Literal + dup 0< IF 1+ shift 2* 0 EXIT THEN 0 swap 2 + dshift ; Host : normalized? ( m -- f ) dup #signbit and swap #signbit u2/ and 2* xor ; : normalize ( m e -- m' e' ) over normalized? ?EXIT over 0= IF drop #exp_min EXIT THEN BEGIN dup #exp_min = ?EXIT 1 - swap 2* swap over normalized? UNTIL ; : >float ( m e -- r ) overflow off underflow off normalize swap #man_mask and swap over #fzero_neg = over #exp_min = and >r over #fzero_pos = r> or IF drop #exp_mask invert and EXIT THEN \ leave floating +/-zero. For +zero irrespective of exponent dup #man_mask 2/ and dup 0< IF #man_mask 2/ xor THEN \ exponent over/underflow? IF 0< IF underflow on 0< IF #fzero_neg EXIT THEN #fzero_pos EXIT THEN overflow on 0< IF #fmax_neg EXIT THEN #fmax_pos EXIT THEN dup #exp_min = IF drop #man_mask and EXIT THEN \ smallest exponent => denormalized #exp_mask and #exp_sign xor swap \ flip sign of exponent => bias = #exp_min dup 2* [ #signbit invert #exp_mask invert and ] Literal and swap 0< IF #signbit or THEN or ; : float> ( r -- m e ) dup #exp_mask and ?dup 0= IF #exp_min EXIT THEN \ de-normalized dup #exp_sign and IF #exp_mask 2/ and ELSE #exp_mask 2/ invert or THEN swap \ flip sign and extend dup 0< IF #exp_mask 2/ or 2/ [ #signbit #exp_sign or u2/ invert ] Literal and \ add 0.5 for better rounding ELSE #man_mask and u2/ [ #signbit #exp_sign or u2/ ] Literal or \ add 0.5 for better rounding THEN swap ; : int.frac ( r -- frac int ) \ split float number into integer and fractional part float> [ data_width 2 - ] Literal + dup 0< IF invert 0 ?DO u2/ LOOP 2* 0 EXIT THEN 0 swap [ delta_width 2 + ] Literal + 0 DO d2* LOOP ; data_width &32 = [IF] : >ieee ( r -- ieee ) \ only valid for 32-bit data_width float> $80 xor $7F + $FF and \ exponent over 0< IF $100 or THEN &23 shift swap \ sign abs -&7 shift $7FFFFF and or \ mantissa ; : ieee> ( ieee -- r ) \ only valid for 32-bit data_width dup dup 0< IF negate $7FFFFF and $1000000 or ELSE $7FFFFF and $800000 or THEN 7 shift swap -&23 shift $7F - dup $80 and IF $7F and ELSE $7F invert or THEN >float ; [THEN] Host : f+ ( r1 r2 -- r3 ) float> rot float> rot 2dup - \ m2 m1 e1 e2 e1-e2 dup 0< IF swap >r nip ELSE rot >r nip >r swap r> negate THEN \ m> m< diff_e1-e2 1- dup [ data_width exp_width - negate ] Literal u< IF drop 0 swap THEN over IF ashift ELSE drop THEN swap 2/ + r> 1+ >float ; Target : f+ ( r1 r2 -- r3 ) float> rot float> rot 2dup - \ m2 m1 e1 e2 e1-e2 dup 0< IF swap >r nip ELSE rot >r nip >r swap r> negate THEN \ m> m< diff_e1-e2 1- dup [ data_width exp_width - negate ] Literal u< IF drop 0 swap THEN over IF ashift ELSE drop THEN swap 2/ + r> 1+ >float ; Host: f+ ( r1 r2 -- r3 ) dbg? IF t> t> f+ >t EXIT THEN exec? IF f+ EXIT THEN T f+ H ; immediate Host : f* ( r1 r2 -- r3 ) float> rot float> \ m2 exp2 m1 exp1 rot + data_width + -rot \ exp3 m2 m1 m* delta_width 0 ?DO d2* LOOP nip swap >float ; Target : f* ( r1 r2 -- r3 ) float> rot float> \ m2 exp2 m1 exp1 rot + data_width + -rot \ m2 m1 R: exp3 m* nip swap >float ; Host: f* ( r1 r2 -- r3 ) dbg? IF t> t> f* >t EXIT THEN exec? IF f* EXIT THEN T f* H ; immediate Host : f/ ( r1 r2 -- r3 ) overflow off dup 2* 0= IF invert xor #signbit and invert overflow on EXIT THEN \ leave +/- largest number on / by zero float> rot float> data_width - rot - -rot 0 swap delta_width 2 + 0 ?DO d2/ LOOP rot m/mod nip swap 2 + >float ; Target : f/ ( r1 r2 -- r3 ) #ovfl st_reset dup 2* 0= IF invert xor #signbit and invert #ovfl st_set EXIT THEN \ leave +/- largest number on / by zero float> rot float> data_width - rot - -rot 2/ 2/ swap 0 -rot m/mod nip swap 2 + >float ; Host: f/ ( r1 r2 -- r3 ) dbg? IF t> t> swap f/ >t EXIT THEN exec? IF f/ EXIT THEN T f/ H ; immediate Host : fnegate ( r -- -r ) dup 2* IF float> 1+ swap 2/ invert #exp_sign 2/ + swap >float EXIT THEN 0< IF 0 EXIT THEN #signbit \ handle + and - zero ; : fabs ( r -- |r| ) dup 0< IF fnegate THEN ; : f- ( r1 r2 -- r3 ) fnegate f+ ; : f< ( r1 r2 -- f ) f- 0< ; : f> ( r1 r2 -- f ) swap f- 0< ; : f<= ( r1 r2 -- f ) f> 0= ; : f>= ( r1 r2 -- f ) f< 0= ; : f0= ( r -- f ) 2* 0= ; : f0< ( r -- f ) 0< ; : f2* ( r1 -- r2 ) float> 1+ >float ; : f2/ ( r1 -- r2 ) float> swap 2/ swap >float ; : float ( n -- r ) 0 >float ; : integer ( r -- n ) dup 2* #data_mask and 0= IF 2* EXIT THEN \ +/- zero 1 float f2/ f+ \ add 0.5 for rounding float> ashift ; : 1/f ( r1 -- r2 ) 1 float swap f/ ; : fscale ( r1 n -- f2 ) dup 0< IF abs float f/ EXIT THEN float f* ; : milli ( r1 -- r2 ) -&1000 fscale ; : micro ( r1 -- r2 ) -&1000000 fscale ; : kilo ( r1 -- r2 ) &1000 fscale ; : mega ( r1 -- r2 ) &1000000 fscale ; Target : fnegate ( r -- -r ) dup 2* IF float> 1+ swap 2/ invert [ #exp_sign u2/ ] Literal + swap >float EXIT THEN 0< IF 0 EXIT THEN #signbit \ handle + and - zero ; : fabs ( r -- |r| ) dup 0< IF fnegate THEN ; : f- ( r1 r2 -- r3 ) fnegate f+ ; : f< ( r1 r2 -- f ) f- 0< ; : f> ( r1 r2 -- f ) swap f- 0< ; : f<= ( r1 r2 -- f ) f> 0= ; : f>= ( r1 r2 -- f ) f< 0= ; : f0= ( r -- f ) 2* 0= ; Macro: f0< ( r -- f ) T 0< H ; : f2* ( r1 -- r2 ) float> 1+ >float ; : f2/ ( r1 -- r2 ) float> swap 2/ swap >float ; Macro: float ( n -- r ) 0 lit, T >float H ; : integer ( r -- n ) dup 2* 0= IF 2* EXIT THEN 1 float f2/ f+ float> ashift ; : 1/f ( r1 -- r2 ) 1 float swap f/ ; : fscale ( r1 n -- f2 ) dup 0< IF abs float f/ EXIT THEN float f* ; : milli ( r1 -- r2 ) -&1000 fscale ; : micro ( r1 -- r2 ) milli milli ; : kilo ( r1 -- r2 ) &1000 fscale ; : mega ( r1 -- r2 ) kilo kilo ; Host: fnegate ( r -- -r ) dbg? IF t> fnegate >t EXIT THEN exec? IF fnegate EXIT THEN T fnegate H ; immediate Host: fabs ( r -- |r| ) dbg? IF t> fabs >t EXIT THEN exec? IF fabs EXIT THEN T fabs H ; immediate Host: f2* ( r1 -- r2 ) dbg? IF t> f2* >t EXIT THEN exec? IF f2* EXIT THEN T f2* H ; immediate Host: f2/ ( r1 -- r2 ) dbg? IF t> f2/ >t EXIT THEN exec? IF f2/ EXIT THEN T f2/ H ; immediate Host: float ( n -- r ) dbg? IF t> float >t EXIT THEN exec? IF float EXIT THEN T float H ; immediate Host: integer ( r -- n ) dbg? IF t> integer >t EXIT THEN exec? IF integer EXIT THEN T integer H ; immediate Host: 1/f ( r1 -- r2 ) dbg? IF t> 1/f >t EXIT THEN exec? IF 1/f EXIT THEN T 1/f H ; immediate Host: milli ( r1 -- r2 ) dbg? IF t> milli >t EXIT THEN exec? IF milli EXIT THEN T milli H ; immediate Host: micro ( r1 -- r2 ) dbg? IF t> micro >t EXIT THEN exec? IF micro EXIT THEN T micro H ; immediate Host: kilo ( r1 -- r2 ) dbg? IF t> kilo >t EXIT THEN exec? IF kilo EXIT THEN T kilo H ; immediate Host: mega ( r1 -- r2 ) dbg? IF t> mega >t EXIT THEN exec? IF mega EXIT THEN T mega H ; immediate include f_exp_log.fs \ float with log/exp consumes 500 instructions \ include f_trigonometry.fs