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% IBM RS 6000 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(fluid '(*second-value*))
26
27(bothtimes
28(put 'wdivide 'opencode
29		'((divs (reg 1) (reg 1) (reg 2))
30                  (mfspr (reg 3) (reg mq))
31		  (*move (reg 3) ($fluid *second-value*))))
32)
33
34(put 'wtimesdouble 'opencode
35     % Called with two parameters of maximum bbase size
36     % the return value are the low order bits of the product.
37     % The high order bits are placed in fluid variable.
38     '(% double length unsigned mutiply;
39       (MUL (reg 3) (reg 1) (reg 2))
40       (Mfspr (reg 1) (reg mq))
41       (*WSHIFT (reg 3) 2)
42       (*MOVE (reg 1) (reg 2))
43       (*WSHIFT (reg 2) -30)
44       (*WOR (reg 3)(reg 2))
45       (*MOVE (reg 3)($FLUID *second-value*))
46       (*WSHIFT (reg 1) 2)
47       (*WSHIFT (reg 1) -2) ))
48
49
50(put 'wxtimes2 'opencode % different version for $pxu/mbarith
51     '((MUL (reg 4) (reg 1) (reg 2))
52      (Mfspr (reg 1) (reg mq))
53      (*move (reg 4) ($FLUID *second-value*))))
54
55
56(put 'wquotientdouble 'opencode
57      % called with a double length number in params 1 and 2
58      % and a single length number in par 3.
59      % Result is the single length quotient.
60      % the remainder is placed in a fluid variable.
61      '(  % adjusting the words first
62        (*MOVE (reg 1) (reg 4))
63        (*WSHIFT (reg 1) -2)
64        (*WSHIFT (reg 4) 30)
65        (*WOR (reg 2) (reg 4))
66        (mtspr (reg mq) (reg 2))
67          % now we can divide and spread the results
68        (DIV (reg 1) (reg 1) (reg 3))
69        (mfspr (reg 2) (reg mq))
70        (*MOVE (reg 2) ($FLUID *second-value*))))
71
72(fluid '(*second-value*))
73
74(put 'addcarry 'opencode
75       '((*MOVE ($FLUID carry*) (reg 2))
76         (*WPLUS2 (reg 1)(reg 2))
77         (sriq (reg 3) (reg 1) 30)
78         (*MOVE (reg 3) ($FLUID carry*))
79         (*WSHIFT (reg 1) 2)
80         (*WSHIFT (reg 1) -2)))
81
82(put 'subcarry 'opencode
83       '((*MOVE ($FLUID carry*) (reg 2))
84         (*WDIFFERENCE (reg 1)(reg 2))
85         %(*MOVE (reg 1) (reg 2))
86         %(*WSHIFT (reg 2) -31)
87         (sriq (reg 2) (reg 1) 31)
88         (*MOVE (reg 2) ($FLUID carry*))
89         (*WSHIFT (reg 2) 30)
90         (*WPLUS2 (reg 1) (reg 2))
91       ))
92
93
94%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
95%
96%   functions supporting word arithmetic with bbase*
97%   bbase* is too large to be stored in a fluid cell;
98%   so we perform operations with bbase* by shift and mask
99%   instructions.
100
101%   get the value for bbase* into a register
102(put 'bbase** 'opencode
103%     '((*MOVE 1 (reg 1))
104%       (*WSHIFT (reg 1) 30)))
105      '((cau (reg 1) (reg 0) 16#4000 )))
106
107%   get the value for logicalbits* into a register
108(put 'logicalbits** 'opencode
109      '((*MOVE -1 (reg 1))
110        (*WSHIFT (reg 1) -2)))
111
112%   calculate (remainder x bbase*)
113(put 'remainder-bbase 'opencode
114      '((*WSHIFT (reg 1) 2)
115        (*WSHIFT (reg 1) -2)))
116
117%   calculate (quotient x bbase*)
118(put 'quotient-bbase 'opencode
119      '((*WSHIFT (reg 1) -30)))
120
121(put 'bbase** 'destroys '((reg 1)))
122(put 'logicalbits** 'destroys '((reg 1)))
123(put 'remainder-bbase 'destroys '((reg 1)))
124(put 'quotient-bbase 'destroys '((reg 1)))
125
126
127