← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/microcode/mul.c

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

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