home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / mul.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  7KB  |  242 lines
  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 */
  242.