1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 #include "config.h"
28
29 /* This file contains the fixnum multiplication procedure. Returns
30 SHARP_F if the result does not fit in a fixnum. Note: The portable
31 version has only been tried on machines with long = 32 bits. This
32 file is included in the appropriate os file. */
33
34 #if (TYPE_CODE_LENGTH == 8)
35
36 #if defined(vax) && defined(__unix__)
37
38 #define MUL_HANDLED
39
40 /* Note that "register" is used here (not "fast") since the
41 assembly code requires knowledge of the location of
42 the variables and they therefore must be in registers.
43 This is a kludge. It depends on what register variables
44 get assigned to what registers. It should be entirely
45 coded in assembly language. -- JINX
46
47 With gcc, we do have a half-way decent interface to assembly
48 code, so the register-assignment dependency is removed. -- KR
49 */
50
51 SCHEME_OBJECT
Mul(SCHEME_OBJECT Arg1,SCHEME_OBJECT Arg2)52 Mul (SCHEME_OBJECT Arg1,
53 SCHEME_OBJECT Arg2)
54 {
55 long A = (FIXNUM_TO_LONG (Arg1));
56 long B = (FIXNUM_TO_LONG (Arg2));
57 #if __GNUC__
58 #if FALSE
59 /* GCC isn't yet efficient enough with `long long' -- KR. */
60 {
61 long long X;
62 asm ("emul %1,%2,$0,%0" : "=g" (X) : "g" (A), "g" (B));
63 return
64 ((((X & (-1 << 23)) == 0) ||
65 ((X & (-1 << 23)) == (-1 << 23)))
66 ? (LONG_TO_FIXNUM ((long) X))
67 : SHARP_F);
68 }
69 #else
70 /* non-long-long version: */
71 {
72 struct
73 {
74 long low;
75 long high;
76 } X;
77 asm ("emul %1,%2,$0,%0" : "=g" (X) : "g" (A), "g" (B));
78 B = (X . low);
79 A = (X . high);
80 }
81 #endif
82 #else /* not __GNUC__ */
83 asm(" emul r11,r10,$0,r10"); /* A is in 11, B in 10 */
84 #endif
85 /* A should have high order result, B low order */
86 return
87 ((((A == 0) && (B & (-1 << 23)) == 0) ||
88 ((A == -1) && (B & (-1 << 23)) == (-1 << 23)))
89 ? (LONG_TO_FIXNUM (B))
90 : SHARP_F);
91 }
92
93 #endif /* vax and __unix__ */
94
95 /* 68k family code. Uses hp9000s300 conventions for the new compiler. */
96
97 #if (defined(hp9000s300) || defined(__hp9000s300)) && !defined(old_cc) && !defined(__GNUC__)
98 #define MUL_HANDLED
99
100 /* The following constants are hard coded in the assembly language
101 * code below. The code assumes that d0 and d1 are scratch registers
102 * for the compiler.
103 */
104
105 #if (SHARP_F != 0) || (TC_FIXNUM != 0x1A)
106 #include "Error: types changed. Change assembly language appropriately"
107 #endif
108
109 #ifndef MC68010 /* MC68020, MC68030, or MC68040 */
110
111 static long Fixnum_Range[2] = {SMALLEST_FIXNUM , BIGGEST_FIXNUM};
112
113 asm(" text");
114 asm(" global _Mul");
115 asm("_Mul:");
116 asm(" bfexts 4(%sp){&8:&24},%d0");
117 asm(" bfexts 8(%sp){&8:&24},%d1");
118 asm(" muls.l %d1,%d0");
119 asm(" bvs.b result_is_nil");
120 asm(" cmp2.l %d0,_Fixnum_Range");
121 asm(" bcs.b result_is_nil");
122 asm(" moveq &0x1A,%d1");
123 asm(" bfins %d1,%d0{&0:&8}");
124 asm(" rts");
125 asm("result_is_nil:");
126 asm(" clr.l %d0");
127 asm(" rts");
128 asm(" data");
129
130 #else /* MC68010 */
131
132 /* 20(sp) = arg0; 24(sp) = arg1 because of movem */
133
134 asm(" text");
135 asm(" global _Mul");
136 asm("_Mul:");
137 asm(" movem.l %d2-%d5,-(%sp)");
138 asm(" clr.b %d5");
139 asm(" tst.b 21(%sp)");
140 asm(" slt 20(%sp)");
141 asm(" bge.b coerce_1");
142 asm(" moveq &1,%d5");
143 asm(" neg.l 20(%sp)");
144
145 asm("coerce_1:");
146 asm(" tst.b 25(%sp)");
147 asm(" slt 24(%sp)");
148 asm(" bge.b after_coerce");
149 asm(" eori.b &1,%d5");
150 asm(" neg.l 24(%sp)");
151 asm("after_coerce:");
152 asm(" move.l 20(%sp),%d0");
153 asm(" move.l 24(%sp),%d1");
154 asm(" move.w %d0,%d2");
155 asm(" mulu %d1,%d2");
156 asm(" move.w %d1,%d4");
157 asm(" swap %d1");
158 asm(" move.w %d1,%d3");
159 asm(" mulu %d0,%d3");
160 asm(" swap %d0");
161 asm(" mulu %d0,%d4");
162 asm(" add.l %d4,%d3");
163 asm(" bcs.b result_is_nil");
164 asm(" mulu %d0,%d1");
165 asm(" bne.b result_is_nil");
166 asm(" swap %d2");
167 asm(" add.w %d3,%d2");
168 asm(" bcs.b result_is_nil");
169 asm(" swap %d3");
170 asm(" tst.w %d3");
171 asm(" bne.b result_is_nil");
172 asm(" cmpi.w %d2,&0x7F");
173 asm(" bgt.b result_is_nil");
174 asm(" swap %d2");
175 asm(" tst.b %d5");
176 asm(" beq.b sign_is_right");
177 asm(" neg.l %d2");
178 asm("sign_is_right:");
179 asm(" move.l %d2,-(%sp)");
180 asm(" move.b &0x1A,(%sp)");
181 asm(" move.l (%sp)+,%d0");
182 asm(" movem.l (%sp)+,%d2-%d5");
183 asm(" rts");
184 asm("result_is_nil:");
185 asm(" clr.l %d0");
186 asm(" movem.l (%sp)+,%d2-%d5");
187 asm(" rts");
188 asm(" data");
189
190 #endif /* MC68010 */
191 #endif /* hp9000s300 */
192
193 #endif /* (TYPE_CODE_LENGTH == 8) */
194
195 #ifndef MUL_HANDLED
196
197 #define ONE ((unsigned long) 1)
198
199 #define HALF_WORD_SIZE (((sizeof (long)) * CHAR_BIT) / 2)
200 #define HALF_WORD_MASK ((ONE << HALF_WORD_SIZE) - 1)
201 #define MAX_MIDDLE (ONE << ((DATUM_LENGTH - 1) - HALF_WORD_SIZE))
202 #define MAX_FIXNUM (ONE << DATUM_LENGTH)
203 #define ABS(x) (((x) < 0) ? -(x) : (x))
204
205 SCHEME_OBJECT
Mul(SCHEME_OBJECT Arg1,SCHEME_OBJECT Arg2)206 Mul (SCHEME_OBJECT Arg1,
207 SCHEME_OBJECT Arg2)
208 {
209 long A, B, C;
210 unsigned long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
211 bool Sign;
212
213 A = (FIXNUM_TO_LONG (Arg1));
214 B = (FIXNUM_TO_LONG (Arg2));
215 Sign = ((A < 0) == (B < 0));
216 A = ABS(A);
217 B = ABS(B);
218 Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
219 Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
220 if ((Hi_A > 0) && (Hi_B > 0))
221 return (SHARP_F);
222 Lo_A = (A & HALF_WORD_MASK);
223 Lo_B = (B & HALF_WORD_MASK);
224 Lo_C = (Lo_A * Lo_B);
225 if (Lo_C >= FIXNUM_SIGN_BIT)
226 return (SHARP_F);
227 Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
228 if (Middle_C >= MAX_MIDDLE)
229 return (SHARP_F);
230 C = Lo_C + (Middle_C << HALF_WORD_SIZE);
231 if (LONG_TO_FIXNUM_P(C))
232 {
233 if (Sign || (C == 0))
234 return (LONG_TO_UNSIGNED_FIXNUM(C));
235 else
236 return (LONG_TO_UNSIGNED_FIXNUM(MAX_FIXNUM - C));
237 }
238 return (SHARP_F);
239 }
240
241 #endif /* not MUL_HANDLED */
242