1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PXU:MULS.SL
4% Description:  support for BIGNUM package with double INUM operations
5%               lap source for MIPS processor
6% Author:       H. Melenk, W. Neun
7% Created:      25 January 1989
8% Modified:
9% Mode:         Lisp
10% Package:      Utilities
11% Status:       Experimental
12%
13% (c) Copyright 1989, Konrad-Zuse-Zentrum, all rights reserved.
14%
15%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
16% Mac G4 version by W. Neun, ZIB Berlin
17%
18%  this file is needed compiletime only
19%
20% Double length multiply and divide for the 68020 processor.
21% These are the open codes which embed the extended arithmetic
22% operations such that they are accessible from compiled LISP top level.
23% They map the 2*30 bit operations needed by BIG to the 2*32 bit operations
24% of the processor by shifting etc.
25
26(compiletime (load inum))
27
28(fluid '(*second-value*))
29
30(bothtimes
31(put 'wdivide 'opencode
32		'((divd (reg 3) (reg 1) (reg 2))
33                  (mulld (reg 4) (reg 3) (reg 2))
34                  (subf  (reg 4) (reg 4) (reg 1))
35		  (*move (reg 3) (reg 1))
36		  (*move (reg 4) ($fluid *second-value*))))
37)
38
39(put 'wtimesdouble 'opencode
40     % Called with two parameters of maximum bbase size
41     % the return value are the low order bits of the product.
42     % The high order bits are placed in fluid variable.
43     '(% double length unsigned mutiply;
44       (mulhd (reg 3) (reg 1) (reg 2))
45       (mulld (reg 1) (reg 1) (reg 2))
46       (*WSHIFT (reg 3) 2)
47       (*MOVE (reg 1) (reg 2))
48       (*WSHIFT (reg 2) -62)
49       (*WOR (reg 3)(reg 2))
50       (*MOVE (reg 3)($FLUID *second-value*))
51       (*WSHIFT (reg 1) 2)
52       (*WSHIFT (reg 1) -2) ))
53
54
55(put 'wxtimes2 'opencode % different version for $pxu/mbarith
56     '((MULhd (reg 4) (reg 1) (reg 2))
57       (mulld (reg 1) (reg 1) (reg 2))
58      (*move (reg 4) ($FLUID *second-value*))))
59
60
61(de wquotientdouble (arg1 arg2 arg3)
62
63   (prog (quot rem carrybit i)
64
65             % first divide the uper 30 bits by divisor and put the
66             % quotient into the result and continue with the remainder
67
68     (setq quot (wdivide arg1 arg3))
69     (setq rem *second-value*)
70
71     (setq arg2 (wshift arg2 2))  %initial shift
72
73     (ifor (from i 0 61 1) (do
74
75            % now shift the remainder left by 1 and add the most significant
76            % bit of arg2. shift arg2 left one bit
77            % if sum is greater or equal divisor, add a bit '1' to remainder
78            % else add a '0'.
79            % do it until arg2 is eaten up. quot is the result (quotient),
80            %          rem is the remainder (in *second-value*)
81
82            (progn
83             (setq quot (wshift quot 1))
84             (setq carrybit (wshift arg2 -63))
85             (setq arg2 (wshift arg2 1))
86             (setq rem (wplus2 (wshift rem 1) carrybit))
87             (when (wgeq rem arg3) (setq rem (wdifference rem arg3))
88                                   (setq quot (wplus2 quot 1)))
89      )     )              )
90     (setq *second-value* rem)
91     (return quot)))
92)
93
94(commentoutcode
95(put 'wquotientdouble 'opencode
96      % called with a double length number in params 1 and 2
97      % and a single length number in par 3.
98      % Result is the single length quotient.
99      % the remainder is placed in a fluid variable.
100      '(  % adjusting the words first
101        (*MOVE (reg 1) (reg 4))
102        (*WSHIFT (reg 1) -2)
103        (*WSHIFT (reg 4) 30)
104        (*WOR (reg 2) (reg 4))
105        (mtspr (reg mq) (reg 2))
106          % now we can divide and spread the results
107       %% (DIV (reg 1) (reg 1) (reg 3))
108        (mfspr (reg 2) (reg mq))
109        (*MOVE (reg 2) ($FLUID *second-value*)))))
110
111(fluid '(*second-value*))
112
113(put 'addcarry 'opencode
114       '((*MOVE ($FLUID carry*) (reg 2))
115         (*WPLUS2 (reg 1)(reg 2))
116         (rldicl (reg 3) (reg 1) 2 62)
117         (*MOVE (reg 3) ($FLUID carry*))
118         (*WSHIFT (reg 1) 2)
119         (*WSHIFT (reg 1) -2)))
120
121(put 'subcarry 'opencode
122       '((*MOVE ($FLUID carry*) (reg 2))
123         (*WDIFFERENCE (reg 1)(reg 2))
124         %(*MOVE (reg 1) (reg 2))
125         %(*WSHIFT (reg 2) -31)
126         (rldicl (reg 2) (reg 1) 1 63)
127         (*MOVE (reg 2) ($FLUID carry*))
128         (*WSHIFT (reg 2) 62)
129         (*WPLUS2 (reg 1) (reg 2))
130       ))
131
132
133%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
134%
135%   functions supporting word arithmetic with bbase*
136%   bbase* is too large to be stored in a fluid cell;
137%   so we perform operations with bbase* by shift and mask
138%   instructions.
139
140%   get the value for bbase* into a register
141(put 'bbase** 'opencode
142     '((*MOVE 1 (reg 1))
143       (*WSHIFT (reg 1) 62)))
144
145%   get the value for logicalbits* into a register
146(put 'logicalbits** 'opencode
147      '((*MOVE -1 (reg 1))
148        (*WSHIFT (reg 1) -2)))
149
150%   calculate (remainder x bbase*)
151(put 'remainder-bbase 'opencode
152      '((*WSHIFT (reg 1) 2)
153        (*WSHIFT (reg 1) -2)))
154
155%   calculate (quotient x bbase*)
156(put 'quotient-bbase 'opencode
157      '((*WSHIFT (reg 1) -62)))
158
159(put 'bbase** 'destroys '((reg 1)))
160(put 'logicalbits** 'destroys '((reg 1)))
161(put 'remainder-bbase 'destroys '((reg 1)))
162(put 'quotient-bbase 'destroys '((reg 1)))
163
164
165