From b4e485bb9a3bd042dc6e980e5094c53f027bc94b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 26 Oct 1989 07:50:01 +0000 Subject: [PATCH] * Change generic arithmetic primitives to be trampolines into some procedures that are stored in the fixed objects vector. This permits some upwards compatibility of new R4RS arithmetic and gives the compiler a method for invoking the binary arithmetic operators which are normally not available in the global environment. It also provides a solution to the problem of making generic arithmetic available during the cold load. The compiled-code interface bypasses the primitive interface and directly applies these trampolines, thus avoiding the overhead of the interface when the trampoline is also compiled. * Increase the default constant size of the regular band to 400, and the heap size of the compiler band to 1000. --- v7/src/microcode/boot.c | 75 +++- v7/src/microcode/config.h | 6 +- v7/src/microcode/fixobj.h | 26 +- v7/src/microcode/generic.c | 685 ++---------------------------------- v7/src/microcode/intprm.c | 12 +- v7/src/microcode/utabmd.scm | 16 +- v7/src/microcode/version.h | 6 +- v8/src/microcode/fixobj.h | 26 +- v8/src/microcode/utabmd.scm | 16 +- v8/src/microcode/version.h | 6 +- 10 files changed, 184 insertions(+), 690 deletions(-) diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 4b27339eb..dbf6346b6 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.58 1989/09/24 15:12:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.59 1989/10/26 07:49:17 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -339,37 +339,90 @@ SCHEME_OBJECT make_fixed_objects_vector () { extern SCHEME_OBJECT initialize_history (); + extern SCHEME_OBJECT make_primitive (); /* Create the fixed objects vector, with 4 extra slots for expansion and debugging. */ fast SCHEME_OBJECT fixed_objects_vector = (make_vector ((NFixed_Objects + 4), SHARP_F, false)); - VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector); - VECTOR_SET (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_TRUE, 2))); - VECTOR_SET + FAST_VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector); + FAST_VECTOR_SET + (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_TRUE, 2))); + FAST_VECTOR_SET (fixed_objects_vector, System_Interrupt_Vector, (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false))); /* Error vector is not needed at boot time */ - VECTOR_SET (fixed_objects_vector, System_Error_Vector, SHARP_F); - VECTOR_SET + FAST_VECTOR_SET (fixed_objects_vector, System_Error_Vector, SHARP_F); + FAST_VECTOR_SET (fixed_objects_vector, OBArray, (make_vector (OBARRAY_SIZE, EMPTY_LIST, false))); - VECTOR_SET (fixed_objects_vector, Dummy_History, (initialize_history ())); - VECTOR_SET (fixed_objects_vector, State_Space_Tag, SHARP_T); - VECTOR_SET (fixed_objects_vector, Bignum_One, (long_to_bignum (1))); + FAST_VECTOR_SET + (fixed_objects_vector, Dummy_History, (initialize_history ())); + FAST_VECTOR_SET (fixed_objects_vector, State_Space_Tag, SHARP_T); + FAST_VECTOR_SET (fixed_objects_vector, Bignum_One, (long_to_bignum (1))); (*Free++) = EMPTY_LIST; (*Free++) = EMPTY_LIST; - VECTOR_SET + FAST_VECTOR_SET (fixed_objects_vector, The_Work_Queue, (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)))); - VECTOR_SET + FAST_VECTOR_SET (fixed_objects_vector, Utilities_Vector, (make_vector (0, SHARP_F, false))); + + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_ZERO_P, + (make_primitive ("INTEGER-ZERO?"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_POSITIVE_P, + (make_primitive ("INTEGER-POSITIVE?"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_NEGATIVE_P, + (make_primitive ("INTEGER-NEGATIVE?"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_SUCCESSOR, + (make_primitive ("INTEGER-ADD-1"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_PREDECESSOR, + (make_primitive ("INTEGER-SUBTRACT-1"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_EQUAL_P, + (make_primitive ("INTEGER-EQUAL?"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_LESS_P, + (make_primitive ("INTEGER-LESS?"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_GREATER_P, + (make_primitive ("INTEGER-GREATER?"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_ADD, + (make_primitive ("INTEGER-ADD"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_SUBTRACT, + (make_primitive ("INTEGER-SUBTRACT"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_MULTIPLY, + (make_primitive ("INTEGER-MULTIPLY"))); + FAST_VECTOR_SET + (fixed_objects_vector, + GENERIC_TRAMPOLINE_DIVIDE, + SHARP_F); + return (fixed_objects_vector); } diff --git a/v7/src/microcode/config.h b/v7/src/microcode/config.h index 4439e1fa8..e3edfe8e7 100644 --- a/v7/src/microcode/config.h +++ b/v7/src/microcode/config.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.49 1989/09/24 15:12:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.50 1989/10/26 07:49:33 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -588,7 +588,7 @@ longjmp(Exit_Point, NORMAL_EXIT) #endif #ifndef CONSTANT_SIZE -#define CONSTANT_SIZE 360 /* Default Kcells for constant */ +#define CONSTANT_SIZE 400 /* Default Kcells for constant */ #endif #ifndef HEAP_SIZE @@ -600,7 +600,7 @@ longjmp(Exit_Point, NORMAL_EXIT) #endif #ifndef COMPILER_HEAP_SIZE -#define COMPILER_HEAP_SIZE 500 +#define COMPILER_HEAP_SIZE 1000 #endif #ifndef COMPILER_CONSTANT_SIZE diff --git a/v7/src/microcode/fixobj.h b/v7/src/microcode/fixobj.h index 2a559bdc9..e12bcf37b 100644 --- a/v7/src/microcode/fixobj.h +++ b/v7/src/microcode/fixobj.h @@ -1,5 +1,7 @@ /* -*-C-*- +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.28 1989/10/26 07:49:43 cph Rel $ + Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts @@ -30,11 +32,8 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.27 1989/03/27 23:15:06 jinx Rel $ - * - * Declarations of user offsets into the Fixed Objects Vector. - * This should correspond to the file UTABMD.SCM - */ +/* Declarations of user offsets into the Fixed Objects Vector. + This should correspond to the file "utabmd.scm". */ #define Non_Object 0x00 /* Used for unassigned variables. */ #define System_Interrupt_Vector 0x01 /* Handlers for interrups. */ @@ -81,5 +80,20 @@ MIT in each case. */ #define Primitive_Profiling_Table 0x23 /* Table of profile counts for primitives. */ -#define NFixed_Objects 0x24 +/* Trampolines for various generic arithmetic operations. + These facilitate upwards compatibility and simplify compilation. */ +#define GENERIC_TRAMPOLINE_ZERO_P 0x24 +#define GENERIC_TRAMPOLINE_POSITIVE_P 0x25 +#define GENERIC_TRAMPOLINE_NEGATIVE_P 0x26 +#define GENERIC_TRAMPOLINE_SUCCESSOR 0x27 +#define GENERIC_TRAMPOLINE_PREDECESSOR 0x28 +#define GENERIC_TRAMPOLINE_EQUAL_P 0x29 +#define GENERIC_TRAMPOLINE_LESS_P 0x2A +#define GENERIC_TRAMPOLINE_GREATER_P 0x2B +#define GENERIC_TRAMPOLINE_ADD 0x2C +#define GENERIC_TRAMPOLINE_SUBTRACT 0x2D +#define GENERIC_TRAMPOLINE_MULTIPLY 0x2E +#define GENERIC_TRAMPOLINE_DIVIDE 0x2F + +#define NFixed_Objects 0x30 diff --git a/v7/src/microcode/generic.c b/v7/src/microcode/generic.c index 2c0b1e618..ebd7c9a16 100644 --- a/v7/src/microcode/generic.c +++ b/v7/src/microcode/generic.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.31 1989/10/11 15:30:29 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.32 1989/10/26 07:49:47 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -34,674 +34,53 @@ MIT in each case. */ #include "scheme.h" #include "prims.h" -#include "zones.h" -/* Complex Number Macros. Should have its own file. */ - -#define REAL_PART(arg) (MEMORY_REF ((arg), COMPLEX_REAL)) -#define IMAG_PART(arg) (MEMORY_REF ((arg), COMPLEX_IMAG)) - -#define COERCE_REAL_PART(arg) \ - ((COMPLEX_P (arg)) ? (REAL_PART (arg)) : (arg)) - -#define COERCE_IMAG_PART(arg) \ - ((COMPLEX_P (arg)) ? (IMAG_PART (arg)) : FIXNUM_ZERO) - -#define RETURN_COMPLEX(real, imag) \ -{ \ - SCHEME_OBJECT _real_value = (real); \ - SCHEME_OBJECT _imag_value = (imag); \ - PRIMITIVE_RETURN \ - ((real_zero_p (_imag_value)) \ - ? _real_value \ - : (system_pair_cons (TC_COMPLEX, _real_value, _imag_value))); \ -} - -static double -bignum_to_double_1 (bignum) - SCHEME_OBJECT bignum; -{ - if (! (BIGNUM_TO_DOUBLE_P (bignum))) - signal_error_from_primitive (ERR_ARG_1_FAILED_COERCION); - return (bignum_to_double (bignum)); -} - -static double -bignum_to_double_2 (bignum) - SCHEME_OBJECT bignum; -{ - if (! (BIGNUM_TO_DOUBLE_P (bignum))) - signal_error_from_primitive (ERR_ARG_2_FAILED_COERCION); - return (bignum_to_double (bignum)); -} - -static Boolean -real_zero_p (number) - fast SCHEME_OBJECT number; -{ - switch (OBJECT_TYPE (number)) - { - case TC_FIXNUM: - return (FIXNUM_ZERO_P (number)); - case TC_BIG_FLONUM: - return ((FLONUM_TO_DOUBLE (number)) == 0); - case TC_BIG_FIXNUM: - return (BIGNUM_ZERO_P (number)); - default: - error_wrong_type_arg (1); - } - /*NOTREACHED*/ -} - -DEFINE_PRIMITIVE ("ZERO?", Prim_zero, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); - { - fast SCHEME_OBJECT number = (ARG_REF (1)); - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT - ((COMPLEX_P (number)) - ? ((real_zero_p (REAL_PART (number))) && - (real_zero_p (IMAG_PART (number)))) - : (real_zero_p (number)))); - } -} - -#define SIGN_CHECK(operator, bignum_operator) \ +#define INDIRECT_1(slot) \ { \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ - { \ - fast SCHEME_OBJECT number = (ARG_REF (1)); \ - switch (OBJECT_TYPE (number)) \ - { \ - case TC_FIXNUM: \ - PRIMITIVE_RETURN \ - (BOOLEAN_TO_OBJECT ((FIXNUM_TO_LONG (number)) operator 0)); \ - \ - case TC_BIG_FLONUM: \ - PRIMITIVE_RETURN \ - (BOOLEAN_TO_OBJECT \ - ((FLONUM_TO_DOUBLE (number)) operator 0)); \ - \ - case TC_BIG_FIXNUM: \ - PRIMITIVE_RETURN \ - (BOOLEAN_TO_OBJECT (bignum_operator (number))); \ - \ - default: \ - error_wrong_type_arg (1); \ - } \ - } \ + PRIMITIVE_CANONICALIZE_CONTEXT (); \ + Will_Push (STACK_ENV_EXTRA_SLOTS + 1); \ + Push (Get_Fixed_Obj_Slot (slot)); \ + Push (STACK_FRAME_HEADER + 1); \ + Pushed (); \ + PRIMITIVE_ABORT (PRIM_APPLY); \ + /*NOTREACHED*/ \ } +DEFINE_PRIMITIVE ("ZERO?", Prim_zero, 1, 1, 0) + INDIRECT_1 (GENERIC_TRAMPOLINE_ZERO_P) DEFINE_PRIMITIVE ("POSITIVE?", Prim_positive, 1, 1, 0) - SIGN_CHECK (>, BIGNUM_POSITIVE_P) - + INDIRECT_1 (GENERIC_TRAMPOLINE_POSITIVE_P) DEFINE_PRIMITIVE ("NEGATIVE?", Prim_negative, 1, 1, 0) - SIGN_CHECK (<, BIGNUM_NEGATIVE_P) - -static SCHEME_OBJECT -real_add_constant (number, offset) - fast SCHEME_OBJECT number; - fast long offset; -{ - return - ((FIXNUM_P (number)) - ? (long_to_integer ((FIXNUM_TO_LONG (number)) + offset)) - : (BIGNUM_P (number)) - ? (bignum_to_integer (bignum_add (number, (long_to_bignum (offset))))) - : (double_to_flonum ((FLONUM_TO_DOUBLE (number)) + ((double) offset)))); -} - + INDIRECT_1 (GENERIC_TRAMPOLINE_NEGATIVE_P) DEFINE_PRIMITIVE ("1+", Prim_add_one, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - fast SCHEME_OBJECT number = (ARG_REF (1)); - PRIMITIVE_RETURN - ((REAL_P (number)) - ? (real_add_constant (number, 1)) - : (COMPLEX_P (number)) - ? (system_pair_cons - (TC_COMPLEX, - (real_add_constant ((REAL_PART (number)), 1)), - (IMAG_PART (number)))) - : ((error_wrong_type_arg (1)), ((SCHEME_OBJECT) 0))); - } -} - + INDIRECT_1 (GENERIC_TRAMPOLINE_SUCCESSOR) DEFINE_PRIMITIVE ("-1+", Prim_subtract_one, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - fast SCHEME_OBJECT number = (ARG_REF (1)); - PRIMITIVE_RETURN - ((REAL_P (number)) - ? (real_add_constant (number, -1)) - : (COMPLEX_P (number)) - ? (system_pair_cons - (TC_COMPLEX, - (real_add_constant ((REAL_PART (number)), -1)), - (IMAG_PART (number)))) - : ((error_wrong_type_arg (1)), ((SCHEME_OBJECT) 0))); - } -} - -#define TWO_OP_COMPARATOR(GENERAL_OP, BIGNUM_OP) \ -{ \ - switch (OBJECT_TYPE (Arg1)) \ - { \ - case TC_FIXNUM: \ - { \ - switch (OBJECT_TYPE (Arg2)) \ - { \ - case TC_FIXNUM: \ - return \ - ((FIXNUM_TO_LONG (Arg1)) GENERAL_OP \ - (FIXNUM_TO_LONG (Arg2))); \ - case TC_BIG_FLONUM: \ - return \ - ((FIXNUM_TO_DOUBLE (Arg1)) GENERAL_OP \ - (FLONUM_TO_DOUBLE (Arg2))); \ - case TC_BIG_FIXNUM: \ - return (BIGNUM_OP ((FIXNUM_TO_BIGNUM (Arg1)), Arg2)); \ - default: \ - error_wrong_type_arg (2); \ - } \ - } \ - case TC_BIG_FLONUM: \ - { \ - switch (OBJECT_TYPE (Arg2)) \ - { \ - case TC_FIXNUM: \ - return \ - ((FLONUM_TO_DOUBLE (Arg1)) GENERAL_OP \ - (FIXNUM_TO_DOUBLE (Arg2))); \ - case TC_BIG_FLONUM: \ - return \ - ((FLONUM_TO_DOUBLE (Arg1)) GENERAL_OP \ - (FLONUM_TO_DOUBLE (Arg2))); \ - case TC_BIG_FIXNUM: \ - return \ - ((FLONUM_TO_DOUBLE (Arg1)) GENERAL_OP \ - (bignum_to_double_2 (Arg2))); \ - default: \ - error_wrong_type_arg (2); \ - } \ - } \ - case TC_BIG_FIXNUM: \ - { \ - switch (OBJECT_TYPE (Arg2)) \ - { \ - case TC_FIXNUM: \ - return (BIGNUM_OP (Arg1, (FIXNUM_TO_BIGNUM (Arg2)))); \ - case TC_BIG_FLONUM: \ - return \ - ((bignum_to_double_1 (Arg1)) GENERAL_OP \ - (FLONUM_TO_DOUBLE (Arg2))); \ - case TC_BIG_FIXNUM: \ - return (BIGNUM_OP (Arg1, Arg2)); \ - default: \ - error_wrong_type_arg (2); \ - } \ - } \ - default: \ - error_wrong_type_arg (1); \ - } \ -} - -static Boolean -real_equal_p (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - TWO_OP_COMPARATOR (==, bignum_equal_p); -} - -static Boolean -real_less_p (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - TWO_OP_COMPARATOR (<, BIGNUM_LESS_P); -} + INDIRECT_1 (GENERIC_TRAMPOLINE_PREDECESSOR) -#define BIGNUM_GREATER_P(x, y) (BIGNUM_LESS_P((y), (x))) - -static Boolean -real_greater_p (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - TWO_OP_COMPARATOR (>, BIGNUM_GREATER_P); +#define INDIRECT_2(slot) \ +{ \ + PRIMITIVE_HEADER (2); \ + PRIMITIVE_CANONICALIZE_CONTEXT (); \ + Will_Push (STACK_ENV_EXTRA_SLOTS + 1); \ + Push (Get_Fixed_Obj_Slot (slot)); \ + Push (STACK_FRAME_HEADER + 2); \ + Pushed (); \ + PRIMITIVE_ABORT (PRIM_APPLY); \ + /*NOTREACHED*/ \ } DEFINE_PRIMITIVE ("&=", Prim_equal_number, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - { - fast SCHEME_OBJECT Arg1 = (ARG_REF (1)); - fast SCHEME_OBJECT Arg2 = (ARG_REF (2)); - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT - ((COMPLEX_P (Arg1)) - ? ((COMPLEX_P (Arg2)) && - (real_equal_p ((REAL_PART (Arg1)), (REAL_PART (Arg2)))) && - (real_equal_p ((IMAG_PART (Arg1)), (IMAG_PART (Arg2))))) - : ((! (COMPLEX_P (Arg2))) && - (real_equal_p (Arg1, Arg2))))); - } -} - + INDIRECT_2 (GENERIC_TRAMPOLINE_EQUAL_P) DEFINE_PRIMITIVE ("&<", Prim_less, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT (real_less_p ((ARG_REF (1)), (ARG_REF (2))))); -} - + INDIRECT_2 (GENERIC_TRAMPOLINE_LESS_P) DEFINE_PRIMITIVE ("&>", Prim_greater, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT (real_greater_p ((ARG_REF (1)), (ARG_REF (2))))); -} - -#define TWO_OP_OPERATOR(FIXNUM_OP, FLONUM_OP, BIGNUM_OP) \ -{ \ - switch (OBJECT_TYPE (Arg1)) \ - { \ - case TC_FIXNUM: \ - { \ - switch (OBJECT_TYPE (Arg2)) \ - { \ - case TC_FIXNUM: \ - return (FIXNUM_OP (Arg1, Arg2)); \ - case TC_BIG_FLONUM: \ - return \ - (double_to_flonum \ - ((FIXNUM_TO_DOUBLE (Arg1)) FLONUM_OP \ - (FLONUM_TO_DOUBLE (Arg2)))); \ - case TC_BIG_FIXNUM: \ - return \ - (bignum_to_integer \ - (BIGNUM_OP ((FIXNUM_TO_BIGNUM (Arg1)), Arg2))); \ - default: \ - error_wrong_type_arg (2); \ - } \ - } \ - case TC_BIG_FLONUM: \ - { \ - switch (OBJECT_TYPE (Arg2)) \ - { \ - case TC_FIXNUM: \ - return \ - (double_to_flonum \ - ((FLONUM_TO_DOUBLE (Arg1)) FLONUM_OP \ - (FIXNUM_TO_DOUBLE (Arg2)))); \ - case TC_BIG_FLONUM: \ - return \ - (double_to_flonum \ - ((FLONUM_TO_DOUBLE (Arg1)) FLONUM_OP \ - (FLONUM_TO_DOUBLE (Arg2)))); \ - case TC_BIG_FIXNUM: \ - return \ - (double_to_flonum \ - ((FLONUM_TO_DOUBLE (Arg1)) FLONUM_OP \ - (bignum_to_double_2 (Arg2)))); \ - default: \ - error_wrong_type_arg (2); \ - } \ - } \ - case TC_BIG_FIXNUM: \ - { \ - switch (OBJECT_TYPE (Arg2)) \ - { \ - case TC_FIXNUM: \ - return \ - (bignum_to_integer \ - (BIGNUM_OP (Arg1, (FIXNUM_TO_BIGNUM (Arg2))))); \ - case TC_BIG_FLONUM: \ - return \ - (double_to_flonum \ - ((bignum_to_double_1 (Arg1)) FLONUM_OP \ - (FLONUM_TO_DOUBLE (Arg2)))); \ - case TC_BIG_FIXNUM: \ - return (bignum_to_integer (BIGNUM_OP (Arg1, Arg2))); \ - default: \ - error_wrong_type_arg (2); \ - } \ - } \ - default: \ - error_wrong_type_arg (1); \ - } \ -} - -#define FIXNUM_ADD(x, y) \ - (long_to_integer ((FIXNUM_TO_LONG (x)) + (FIXNUM_TO_LONG (y)))) - -#define FIXNUM_SUBTRACT(x, y) \ - (long_to_integer ((FIXNUM_TO_LONG (x)) - (FIXNUM_TO_LONG (y)))) - -static SCHEME_OBJECT -fixnum_multiply (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - extern SCHEME_OBJECT Mul (); - fast SCHEME_OBJECT result = (Mul (Arg1, Arg2)); - return - ((result == SHARP_F) - ? (bignum_multiply ((FIXNUM_TO_BIGNUM (Arg1)), (FIXNUM_TO_BIGNUM (Arg2)))) - : result); -} - -static SCHEME_OBJECT -real_add (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - TWO_OP_OPERATOR (FIXNUM_ADD, +, bignum_add); -} - -static SCHEME_OBJECT -real_subtract (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - TWO_OP_OPERATOR (FIXNUM_SUBTRACT, -, bignum_subtract); -} - -static SCHEME_OBJECT -real_multiply (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - TWO_OP_OPERATOR (fixnum_multiply, *, bignum_multiply); -} - + INDIRECT_2 (GENERIC_TRAMPOLINE_GREATER_P) DEFINE_PRIMITIVE ("&+", Prim_add, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - { - fast SCHEME_OBJECT Arg1 = (ARG_REF (1)); - fast SCHEME_OBJECT Arg2 = (ARG_REF (2)); - if ((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2))) - RETURN_COMPLEX - ((real_add ((COERCE_REAL_PART (Arg1)), (COERCE_REAL_PART (Arg2)))), - (real_add ((COERCE_IMAG_PART (Arg1)), (COERCE_IMAG_PART (Arg2))))); - PRIMITIVE_RETURN (real_add (Arg1, Arg2)); - } -} - + INDIRECT_2 (GENERIC_TRAMPOLINE_ADD) DEFINE_PRIMITIVE ("&-", Prim_subtract, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - { - fast SCHEME_OBJECT Arg1 = (ARG_REF (1)); - fast SCHEME_OBJECT Arg2 = (ARG_REF (2)); - if ((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2))) - RETURN_COMPLEX - ((real_subtract ((COERCE_REAL_PART (Arg1)), - (COERCE_REAL_PART (Arg2)))), - (real_subtract ((COERCE_IMAG_PART (Arg1)), - (COERCE_IMAG_PART (Arg2))))); - PRIMITIVE_RETURN (real_subtract (Arg1, Arg2)); - } -} - -static SCHEME_OBJECT -complex_multiply (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - RETURN_COMPLEX - ((real_subtract ((real_multiply ((COERCE_REAL_PART (Arg1)), - (COERCE_REAL_PART (Arg2)))), - (real_multiply ((COERCE_IMAG_PART (Arg1)), - (COERCE_IMAG_PART (Arg2)))))), - (real_add ((real_multiply ((COERCE_REAL_PART (Arg1)), - (COERCE_IMAG_PART (Arg2)))), - (real_multiply ((COERCE_REAL_PART (Arg2)), - (COERCE_IMAG_PART (Arg1))))))); -} - + INDIRECT_2 (GENERIC_TRAMPOLINE_SUBTRACT) DEFINE_PRIMITIVE ("&*", Prim_multiply, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - { - fast SCHEME_OBJECT Arg1 = (ARG_REF (1)); - fast SCHEME_OBJECT Arg2 = (ARG_REF (2)); - PRIMITIVE_RETURN - (((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2))) - ? (complex_multiply (Arg1, Arg2)) - : (real_multiply (Arg1, Arg2))); - } -} - -#define FLONUM_DIVIDE(numerator, denominator) \ -{ \ - fast double _denominator = (denominator); \ - if (_denominator == 0) \ - error_bad_range_arg (2); \ - return (double_to_flonum ((numerator) / _denominator)); \ -} - -static SCHEME_OBJECT -bignum_real_divide (numerator, denominator) - fast SCHEME_OBJECT numerator; - fast SCHEME_OBJECT denominator; -{ - SCHEME_OBJECT quotient; - SCHEME_OBJECT remainder; - if (bignum_divide (numerator, denominator, ("ient), (&remainder))) - error_bad_range_arg (2); - return - ((BIGNUM_ZERO_P (remainder)) - ? (bignum_to_integer (quotient)) - : (double_to_flonum - ((bignum_to_double_1 (numerator)) / - (bignum_to_double_2 (denominator))))); -} - -static SCHEME_OBJECT -real_divide (Arg1, Arg2) - fast SCHEME_OBJECT Arg1; - fast SCHEME_OBJECT Arg2; -{ - switch (OBJECT_TYPE (Arg1)) - { - case TC_FIXNUM: - { - switch (OBJECT_TYPE (Arg2)) - { - case TC_FIXNUM: - { - fast long A = (FIXNUM_TO_LONG (Arg1)); - fast long B = (FIXNUM_TO_LONG (Arg2)); - if (B == 0) - error_bad_range_arg (2); - return - (((A % B) == 0) - ? (long_to_integer ((long) (A / B))) - : (double_to_flonum (((double) A) / ((double) B)))); - } - case TC_BIG_FLONUM: - FLONUM_DIVIDE - ((FIXNUM_TO_DOUBLE (Arg1)), (FLONUM_TO_DOUBLE (Arg2))); - case TC_BIG_FIXNUM: - return (bignum_real_divide ((FIXNUM_TO_BIGNUM (Arg1)), Arg2)); - default: - error_wrong_type_arg (2); - } - /*NOTREACHED*/ - } - case TC_BIG_FLONUM: - { - switch (OBJECT_TYPE (Arg2)) - { - case TC_FIXNUM: - FLONUM_DIVIDE - ((FLONUM_TO_DOUBLE (Arg1)), (FIXNUM_TO_DOUBLE (Arg2))); - case TC_BIG_FLONUM: - FLONUM_DIVIDE - ((FLONUM_TO_DOUBLE (Arg1)), (FLONUM_TO_DOUBLE (Arg2))); - case TC_BIG_FIXNUM: - FLONUM_DIVIDE - ((FLONUM_TO_DOUBLE (Arg1)), (bignum_to_double_2 (Arg2))); - default: - error_wrong_type_arg (2); - } - /*NOTREACHED*/ - } - case TC_BIG_FIXNUM: - { - switch (OBJECT_TYPE (Arg2)) - { - case TC_FIXNUM: - return (bignum_real_divide (Arg1, (FIXNUM_TO_BIGNUM (Arg2)))); - case TC_BIG_FLONUM: - FLONUM_DIVIDE - ((bignum_to_double_1 (Arg1)), (FLONUM_TO_DOUBLE (Arg2))); - case TC_BIG_FIXNUM: - return (bignum_real_divide (Arg1, Arg2)); - default: - error_wrong_type_arg (2); - } - /*NOTREACHED*/ - } - default: - error_wrong_type_arg (1); - } - /*NOTREACHED*/ -} - -static SCHEME_OBJECT -complex_divide (Arg1, Arg2) - SCHEME_OBJECT Arg1, Arg2; -{ - fast SCHEME_OBJECT real1 = (COERCE_REAL_PART (Arg1)); - fast SCHEME_OBJECT real2 = (COERCE_REAL_PART (Arg2)); - fast SCHEME_OBJECT imag1 = (COERCE_IMAG_PART (Arg1)); - fast SCHEME_OBJECT imag2 = (COERCE_IMAG_PART (Arg2)); - fast SCHEME_OBJECT temp = - (real_divide ((LONG_TO_UNSIGNED_FIXNUM (1)), - (real_add ((real_multiply (real2, real2)), - (real_multiply (imag2, imag2)))))); - RETURN_COMPLEX - ((real_multiply ((real_add ((real_multiply (real1, real2)), - (real_multiply (imag1, imag2)))), - temp)), - (real_multiply ((real_subtract ((real_multiply (real2, imag1)), - (real_multiply (real1, imag2)))), - temp))); -} - + INDIRECT_2 (GENERIC_TRAMPOLINE_MULTIPLY) DEFINE_PRIMITIVE ("&/", Prim_divide, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); - { - fast SCHEME_OBJECT Arg1 = (ARG_REF (1)); - fast SCHEME_OBJECT Arg2 = (ARG_REF (2)); - PRIMITIVE_RETURN - (((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2))) - ? (complex_divide (Arg1, Arg2)) - : (real_divide (Arg1, Arg2))); - } -} - -/* Generic sqrt and transcendental functions are created by generalizing - their floating point counterparts. */ - -static double -scheme_sqrt (x) - fast double x; -{ - extern double sqrt (); - if (x < 0) - error_bad_range_arg (1); - return (sqrt (x)); -} - -static double -scheme_ln (x) - fast double x; -{ - extern double log (); - if (x < 0) - error_bad_range_arg (1); - return (log (x)); -} - -extern double exp (); -extern double sin (); -extern double cos (); -extern double atan (); - -#define GENERIC_FUNCTION(fun) \ -{ \ - PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ - { \ - fast SCHEME_OBJECT number = (ARG_REF (1)); \ - switch (OBJECT_TYPE (number)) \ - { \ - case TC_FIXNUM: \ - PRIMITIVE_RETURN \ - (double_to_flonum (fun (FIXNUM_TO_DOUBLE (number)))); \ - case TC_BIG_FLONUM: \ - PRIMITIVE_RETURN \ - (double_to_flonum (fun (FLONUM_TO_DOUBLE (number)))); \ - case TC_BIG_FIXNUM: \ - PRIMITIVE_RETURN \ - (double_to_flonum (fun (bignum_to_double_1 (number)))); \ - default: \ - error_wrong_type_arg (1); \ - } \ - } \ -} - -DEFINE_PRIMITIVE ("SQRT", Prim_sqrt, 1, 1, 0) - GENERIC_FUNCTION (scheme_sqrt) -DEFINE_PRIMITIVE ("EXP", Prim_exp, 1, 1, 0) - GENERIC_FUNCTION (exp) -DEFINE_PRIMITIVE ("LOG", Prim_log, 1, 1, 0) - GENERIC_FUNCTION (scheme_ln) -DEFINE_PRIMITIVE ("SIN", Prim_sin, 1, 1, 0) - GENERIC_FUNCTION (sin); -DEFINE_PRIMITIVE ("COS", Prim_cos, 1, 1, 0) - GENERIC_FUNCTION (cos) -DEFINE_PRIMITIVE ("&ATAN", Prim_arctan, 1, 1, 0) - GENERIC_FUNCTION (atan) - -#define FLONUM_TO_INTEGER_PRIMITIVE(mapping) \ -{ \ - PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ - { \ - fast SCHEME_OBJECT number = (ARG_REF (1)); \ - PRIMITIVE_RETURN \ - ((FLONUM_P (number)) \ - ? (FLONUM_TO_INTEGER (mapping (number))) \ - : (INTEGER_P (number)) \ - ? number \ - : ((error_wrong_type_arg (1)), ((SCHEME_OBJECT) 0))); \ - } \ -} - -DEFINE_PRIMITIVE ("TRUNCATE", Prim_truncate, 1, 1, 0) - FLONUM_TO_INTEGER_PRIMITIVE (FLONUM_TRUNCATE) -DEFINE_PRIMITIVE ("ROUND", Prim_round, 1, 1, 0) - FLONUM_TO_INTEGER_PRIMITIVE (flonum_round) -DEFINE_PRIMITIVE ("FLOOR", Prim_floor, 1, 1, 0) - FLONUM_TO_INTEGER_PRIMITIVE (flonum_floor) -DEFINE_PRIMITIVE ("CEILING", Prim_ceiling, 1, 1, 0) - FLONUM_TO_INTEGER_PRIMITIVE (flonum_ceiling) + INDIRECT_2 (GENERIC_TRAMPOLINE_DIVIDE) diff --git a/v7/src/microcode/intprm.c b/v7/src/microcode/intprm.c index e0a6ecd04..329f1b0ac 100644 --- a/v7/src/microcode/intprm.c +++ b/v7/src/microcode/intprm.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intprm.c,v 1.2 1989/09/24 15:13:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intprm.c,v 1.3 1989/10/26 07:49:52 cph Rel $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -68,6 +68,16 @@ DEFINE_PRIMITIVE ("INTEGER-EQUAL?", Prim_integer_equal_p, 2, 2, 0) DEFINE_PRIMITIVE ("INTEGER-LESS?", Prim_integer_less_p, 2, 2, 0) INTEGER_COMPARISON (integer_less_p) +DEFINE_PRIMITIVE ("INTEGER-GREATER?", Prim_integer_greater_p, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + Set_Time_Zone (Zone_Math); + CHECK_ARG (1, INTEGER_P); + CHECK_ARG (2, INTEGER_P); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (integer_less_p ((ARG_REF (2)), (ARG_REF (1))))); +} + #define INTEGER_BINARY_OPERATION(operator) \ { \ PRIMITIVE_HEADER (2); \ diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index 0f35df9cc..141c1aa72 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -37,7 +37,7 @@ ;;;; Machine Dependent Type Tables -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.49 1989/09/24 14:47:35 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.50 1989/10/26 07:49:55 cph Exp $ (declare (usual-integrations)) @@ -90,6 +90,18 @@ LOST-OBJECT-BASE ;21 STATE-SPACE-ROOT ;22 PRIMITIVE-PROFILING-TABLE ;23 + GENERIC-TRAMPOLINE-ZERO? ;24 + GENERIC-TRAMPOLINE-POSITIVE? ;25 + GENERIC-TRAMPOLINE-NEGATIVE? ;26 + GENERIC-TRAMPOLINE-ADD-1 ;27 + GENERIC-TRAMPOLINE-SUBTRACT-1 ;28 + GENERIC-TRAMPOLINE-EQUAL? ;29 + GENERIC-TRAMPOLINE-LESS? ;2A + GENERIC-TRAMPOLINE-GREATER? ;2B + GENERIC-TRAMPOLINE-ADD ;2C + GENERIC-TRAMPOLINE-SUBTRACT ;2D + GENERIC-TRAMPOLINE-MULTIPLY ;2E + GENERIC-TRAMPOLINE-DIVIDE ;2F )) ;;; [] Types @@ -574,4 +586,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.49 1989/09/24 14:47:35 cph Exp $" \ No newline at end of file +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.50 1989/10/26 07:49:55 cph Exp $" \ No newline at end of file diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index b832cbc5d..3976dc604 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.5 1989/10/11 15:30:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.6 1989/10/26 07:50:01 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -37,7 +37,7 @@ MIT in each case. */ /* Scheme system release version */ #ifndef RELEASE -#define RELEASE "7.1.0" +#define RELEASE "7.1.0 (alpha)" #endif /* Microcode release version */ @@ -46,7 +46,7 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 5 +#define SUBVERSION 6 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v8/src/microcode/fixobj.h b/v8/src/microcode/fixobj.h index 17db147a8..6457672c8 100644 --- a/v8/src/microcode/fixobj.h +++ b/v8/src/microcode/fixobj.h @@ -1,5 +1,7 @@ /* -*-C-*- +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.28 1989/10/26 07:49:43 cph Rel $ + Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts @@ -30,11 +32,8 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.27 1989/03/27 23:15:06 jinx Rel $ - * - * Declarations of user offsets into the Fixed Objects Vector. - * This should correspond to the file UTABMD.SCM - */ +/* Declarations of user offsets into the Fixed Objects Vector. + This should correspond to the file "utabmd.scm". */ #define Non_Object 0x00 /* Used for unassigned variables. */ #define System_Interrupt_Vector 0x01 /* Handlers for interrups. */ @@ -81,5 +80,20 @@ MIT in each case. */ #define Primitive_Profiling_Table 0x23 /* Table of profile counts for primitives. */ -#define NFixed_Objects 0x24 +/* Trampolines for various generic arithmetic operations. + These facilitate upwards compatibility and simplify compilation. */ +#define GENERIC_TRAMPOLINE_ZERO_P 0x24 +#define GENERIC_TRAMPOLINE_POSITIVE_P 0x25 +#define GENERIC_TRAMPOLINE_NEGATIVE_P 0x26 +#define GENERIC_TRAMPOLINE_SUCCESSOR 0x27 +#define GENERIC_TRAMPOLINE_PREDECESSOR 0x28 +#define GENERIC_TRAMPOLINE_EQUAL_P 0x29 +#define GENERIC_TRAMPOLINE_LESS_P 0x2A +#define GENERIC_TRAMPOLINE_GREATER_P 0x2B +#define GENERIC_TRAMPOLINE_ADD 0x2C +#define GENERIC_TRAMPOLINE_SUBTRACT 0x2D +#define GENERIC_TRAMPOLINE_MULTIPLY 0x2E +#define GENERIC_TRAMPOLINE_DIVIDE 0x2F + +#define NFixed_Objects 0x30 diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm index 37dfcdd70..bb531cda2 100644 --- a/v8/src/microcode/utabmd.scm +++ b/v8/src/microcode/utabmd.scm @@ -37,7 +37,7 @@ ;;;; Machine Dependent Type Tables -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.49 1989/09/24 14:47:35 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.50 1989/10/26 07:49:55 cph Exp $ (declare (usual-integrations)) @@ -90,6 +90,18 @@ LOST-OBJECT-BASE ;21 STATE-SPACE-ROOT ;22 PRIMITIVE-PROFILING-TABLE ;23 + GENERIC-TRAMPOLINE-ZERO? ;24 + GENERIC-TRAMPOLINE-POSITIVE? ;25 + GENERIC-TRAMPOLINE-NEGATIVE? ;26 + GENERIC-TRAMPOLINE-ADD-1 ;27 + GENERIC-TRAMPOLINE-SUBTRACT-1 ;28 + GENERIC-TRAMPOLINE-EQUAL? ;29 + GENERIC-TRAMPOLINE-LESS? ;2A + GENERIC-TRAMPOLINE-GREATER? ;2B + GENERIC-TRAMPOLINE-ADD ;2C + GENERIC-TRAMPOLINE-SUBTRACT ;2D + GENERIC-TRAMPOLINE-MULTIPLY ;2E + GENERIC-TRAMPOLINE-DIVIDE ;2F )) ;;; [] Types @@ -574,4 +586,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.49 1989/09/24 14:47:35 cph Exp $" \ No newline at end of file +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.50 1989/10/26 07:49:55 cph Exp $" \ No newline at end of file diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index a3fb81bb2..2464a96e2 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.5 1989/10/11 15:30:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.6 1989/10/26 07:50:01 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -37,7 +37,7 @@ MIT in each case. */ /* Scheme system release version */ #ifndef RELEASE -#define RELEASE "7.1.0" +#define RELEASE "7.1.0 (alpha)" #endif /* Microcode release version */ @@ -46,7 +46,7 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 5 +#define SUBVERSION 6 #endif #ifndef UCODE_TABLES_FILENAME -- 2.25.1