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% Redistribution and use in source and binary forms, with or without
13% modification, are permitted provided that the following conditions are met:
14%
15%    * Redistributions of source code must retain the relevant copyright
16%      notice, this list of conditions and the following disclaimer.
17%    * Redistributions in binary form must reproduce the above copyright
18%      notice, this list of conditions and the following disclaimer in the
19%      documentation and/or other materials provided with the distribution.
20%
21% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
22% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
25% CONTRIBUTORS
26% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
28% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
29% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
30% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32% POSSIBILITY OF SUCH DAMAGE.
33%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
34%
35% Double length multiply and divide for the  processor.
36% These are the open codes which embed the extended arithmetic
37% operations such that they are accessible from compiled LISP top level.
38%
39% Full 32 bit version : 28-June 1993 (H. Melenk)
40
41(fluid '(*second-value* carry*))
42
43
44(put 'wtimesdouble 'opencode
45     % Called with two parameters of maximum bbase size
46     % the return value are the low order bits of the product.
47     % The high order bits are placed in fluid variable.
48     '(% double length unsigned mutiply;
49       % EDX:EAX <- EAX * reg
50       (*move (reg 4)(reg t1))  % save this reg
51       (MUL (reg 2))
52      % now we have 32 low bits in REG1, 32 high bits in REG4(=EDX)
53       (*MOVE (reg EDX) ($FLUID *second-value*))
54       (*move (reg t1)(reg 4))  % restore
55     ))
56(put 'addAndSetCarry 'destroys '((reg 1)(reg 3)))
57
58
59(put 'wxtimes2 'opencode % different version for $pxu/mbarith
60     '((IMUL (reg 2))
61      (*MOVE (reg 4)($FLUID *second-value*))
62      ))
63
64(put 'wquotientdouble 'opencode
65      % called with a double length number in params 1 and 2
66      % and a single length number in par 3.
67      % Result is the single length quotient.
68      % the remainder is placed in a fluid variable.
69      '(  % adjusting the words first
70        (*MOVE (reg 1) (reg edx)) % high word
71        (*MOVE (reg 2) (reg eax)) % low word
72        (DIV (reg 3))
73        (*MOVE (reg EDX) ($FLUID *second-value*))
74      ))
75
76% add and set carry
77%
78%   (a + b) -> (carry*,result)
79
80(put 'addAndSetCarry 'opencode
81       '(
82         (ADD (reg 2)(reg 1))
83           % move cf to carry*
84         (SETC ($FLUID carry*))
85       ))
86(put 'addAndSetCarry 'destroys '((reg 1)))
87
88
89% add with carry
90%
91%   (a + b + carry*) -> (carry*,result)
92
93(put 'addwithcarry 'opencode
94       '(
95           % move carry* to register CF
96         (*MOVE (wconst 0)(reg t1))
97         (SUB ($fluid carry*)(reg t1))
98           % add with carry
99         (ADC (reg 2)(reg 1))
100           % move cf to carry*
101         (SETC ($FLUID carry*))
102       ))
103(put 'addWithCarry 'destroys '((reg 1)))
104
105% add and add carry
106%
107%   (a + b) -> result,  (*second-value* + carry) -> *second-value*
108
109(put 'addAndAddCarry 'opencode
110       '(
111         (ADD (reg 2)(reg 1))
112         (*move ($FLUID *second-value*) (reg 2))
113         (ADC (wconst 0)(reg 2))
114         (*move (reg 2) ($FLUID *second-value*))
115       ))
116(put 'addAndAddCarry 'destroys '((reg 1)(reg 2)))
117
118% subtract with borrow
119%
120%  (a - (b + carry!*)) -> result, carry*=1 if borrow
121
122(put 'subtractwithborrow 'opencode
123       '(
124           % move carry* to cf
125         (*MOVE (wconst 0)(reg t1))
126         (SUB ($fluid carry*)(reg t1))
127           % subtract with borrow
128         (sbb (reg 2)(reg 1))
129           % move new borrow to carry*
130         (SETC ($FLUID carry*))
131       ))
132(put 'subtractwithborrow 'destroys '((reg 1)))
133
134
135%------------------- unsigned greaterp ---------------------
136
137% code based on integer carry;
138
139(put 'ugreaterp* 'opencode
140   % returns 1 if arg1 > arg2 unsigned.
141'( (sub (reg 1)(reg 2))        % compare, setting carry if r1>r2
142   (setc (reg 1))              % move carry to low byte
143   (*wand (reg 1) (wconst 1))  % clear leading bits
144))
145(ds ugreaterp(a b)(eq 1 (ugreaterp* a b)))
146
147
148