1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PXC/MULS32.SL 4% Description: support for BIGNUM package with double INUM operations 5% lap source for 80386 processor 6% Author: H. Melenk 7% Created: 11 Sept 1989 8% Modified: 9% Mode: Lisp 10% Status: Open Source: BSD License 11% 12%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13% 14% Redistribution and use in source and binary forms, with or without 15% modification, are permitted provided that the following conditions are met: 16% 17% * Redistributions of source code must retain the relevant copyright 18% notice, this list of conditions and the following disclaimer. 19% * Redistributions in binary form must reproduce the above copyright 20% notice, this list of conditions and the following disclaimer in the 21% documentation and/or other materials provided with the distribution. 22% 23% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 24% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 25% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 26% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 27% CONTRIBUTORS 28% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 29% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 30% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 31% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 32% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 33% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34% POSSIBILITY OF SUCH DAMAGE. 35% 36%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 37% 38% Double length multiply and divide for the processor. 39% These are the open codes which embed the extended arithmetic 40% operations such that they are accessible from compiled LISP top level. 41% 42% Full 32 bit version : 28-June 1993 (H. Melenk) 43 44(fluid '(*second-value* carry*)) 45 46 47(put 'wtimesdouble 'opencode 48 % Called with two parameters of maximum bbase size 49 % the return value are the low order bits of the product. 50 % The high order bits are placed in fluid variable. 51 '(% double length unsigned mutiply; 52 % reg1:reg2 <- reg1 * reg2 53 (UMULL (reg 1) (reg 2) (reg 1) (reg 2)) 54 % now we have 32 low bits in REG1, 32 high bits in REG2 55 (*MOVE (reg 2) ($FLUID *second-value*)) 56 )) 57(put 'wtimesdouble 'destroys '((reg 1)(reg 2))) 58 59 60(put 'wxtimes2 'opencode % different version for $pxu/mbarith 61 '((SMULL (reg 1) (reg 2) (reg 1) (reg 2)) 62 (*MOVE (reg 2)($FLUID *second-value*)) 63 )) 64 65(put 'wquotientdouble 'opencode 66 % called with a double length number in params 1 and 2 67 % (high word in (reg 1), low word in (reg 2)) 68 % and a single length number in par 3. 69 % Result is the single length quotient. 70 % the remainder is placed in a fluid variable. 71 '(% to pass a 64 bit number, load high word in (reg 2) and low word in (reg 1) 72 (*Move (reg 1) (reg 4)) 73 (*Move (reg 2) (reg 1)) 74 (*Move (reg 4) (reg 2)) 75 % load address of fluid variable in (reg 4) 76 (*Move (idloc *second-value*) (reg 4)) 77 (ADD (reg 4) (reg symval) (regshifted 4 LSL 2)) 78 (*Call wxquotientdouble) 79 )) 80 81% add and set carry 82% 83% (a + b) -> (carry*,result) 84 85(put 'addAndSetCarry 'opencode 86 '( 87 (ADDS (reg 1) (reg 2) (reg 1)) 88 % move cf to carry* 89 (MOVCC (reg t1) 0) 90 (MOVCS (reg t1) 1) 91 (*Move (reg t1) ($FLUID carry*)) 92 )) 93(put 'addAndSetCarry 'destroys '((reg 1))) 94 95 96% add with carry 97% 98% (a + b + carry*) -> (carry*,result) 99 100(put 'addwithcarry 'opencode 101 '( 102 % move carry* to register CF 103 (*Move ($fluid carry*) (reg t1)) 104 (MOVS (reg t1) (regshifted t1 LSR 1)) % shifted out bit goes into carry flag 105 % add with carry 106 (ADCS (reg 1) (reg 2) (reg 1)) 107 % move cf to carry* 108 (MOVCC (reg t1) 0) 109 (MOVCS (reg t1) 1) 110 (*Move (reg t1) ($FLUID carry*)) 111 )) 112(put 'addWithCarry 'destroys '((reg 1))) 113 114% add and add carry 115% 116% (a + b) -> result, (*second-value* + carry) -> *second-value* 117 118(put 'addAndAddCarry 'opencode 119 '( 120 (ADDS (reg 1) (reg 2) (reg 1)) 121 (*move ($FLUID *second-value*) (reg 2)) 122 (ADC (reg 2) (reg 2) (wconst 0)) 123 (*move (reg 2) ($FLUID *second-value*)) 124 )) 125(put 'addAndAddCarry 'destroys '((reg 1)(reg 2))) 126 127% subtract with borrow 128% 129% (a - (b + carry!*)) -> result, carry*=1 if borrow 130 131(put 'subtractwithborrow 'opencode 132 '( 133 % move carry* to cf 134 (*Move ($fluid carry*) (reg t1)) 135 (RSBS (reg t1) (reg t1) (wconst 0)) 136 % subtract with borrow 137 (SBCS (reg 1) (reg 1) (reg 2)) 138 % move new borrow to carry* 139 (MOVHS (reg t1) 0) 140 (MOVLO (reg t1) 1) 141 (*Move (reg t1) ($FLUID carry*)) 142 )) 143(put 'subtractwithborrow 'destroys '((reg 1))) 144 145 146%------------------- unsigned greaterp --------------------- 147 148% code based on integer carry; 149 150(put 'ugreaterp* 'opencode 151 % returns 1 if arg1 > arg2 unsigned. 152'( (RSBS (reg 1) (reg 1) (reg 2)) % compare, setting carry if r1>r2 153 % move carry to lowest bit 154 (MOVHS (reg 1) 0) 155 (MOVLO (reg 1) 1) 156)) 157(ds ugreaterp(a b)(eq 1 (ugreaterp* a b))) 158 159(commentoutcode 160(put 'ugreaterp 'opencode 161 % returns 1 if arg1 > arg2 unsigned. 162'( (RSBS (reg 1) (reg 1) (reg 2)) % compare, setting carry if r1>r2 163 % load nil or t depending on carry 164 (MOVHI (reg 1) (reg nil)) 165 (SUBLS (reg 1) (reg nil) (wconst nil-t-diff*)) 166)) 167 168 ) 169 170 171