From: Chris Hanson Date: Sun, 22 Apr 2007 16:31:24 +0000 (+0000) Subject: Final merge from pre-v15 branch. X-Git-Tag: 20090517-FFI~637 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6bce93cc94f21de0eacf00f184932b8efb51d4fe;p=mit-scheme.git Final merge from pre-v15 branch. --- diff --git a/v7/src/microcode/ansidecl.h b/v7/src/microcode/ansidecl.h deleted file mode 100644 index 8a6a309f3..000000000 --- a/v7/src/microcode/ansidecl.h +++ /dev/null @@ -1,107 +0,0 @@ -/* Copyright (C) 1990 Free Software Foundation, Inc. -This file is part of the GNU C Library. - -$Id: ansidecl.h,v 1.9 2007/01/05 15:33:06 cph Exp $ - -The GNU C Library is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 1, or (at your option) -any later version. - -The GNU C Library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* ANSI and traditional C compatibility macros - - ANSI C is assumed if STDC_HEADERS is #defined. - - Macros - PTR - Generic pointer type - LONG_DOUBLE - `long double' type - CONST - `const' keyword - VOLATILE - `volatile' keyword - SIGNED - `signed' keyword - PTRCONST - Generic const pointer (void *const) - - EXFUN(name, prototype) - declare external function NAME - with prototype PROTOTYPE - DEFUN(name, arglist, args) - define function NAME with - args ARGLIST of types in ARGS - DEFUN_VOID(name) - define function NAME with no args - AND - argument separator for ARGS - NOARGS - null arglist - DOTS - `...' in args - - For example: - extern int EXFUN(printf, (CONST char *format DOTS)); - int DEFUN(fprintf, (stream, format), - FILE *stream AND CONST char *format DOTS) { ... } - void DEFUN_VOID(abort) { ... } -*/ - -#ifndef _ANSIDECL_H -#define _ANSIDECL_H 1 - - -/* Every source file includes this file, - so they will all get the switch for lint. */ -/* LINTLIBRARY */ - -#if defined(__STDC__) || defined(STDC_HEADERS) -#define HAVE_STDC - -#define PTR void * -#define PTRCONST void *CONST -#define LONG_DOUBLE long double - -#define AND , -#define NOARGS void -#define VOLATILE volatile -#define SIGNED signed -#define DOTS , ... - -/* Some systems don't declare their libraries correctly, making CONST - impossible to have. */ -#ifdef CONST -#undef CONST -#endif - -#ifdef NO_CONST -#define CONST -#else -#define CONST const -#endif - -#define EXFUN(name, proto) name proto -#define DEFUN(name, arglist, args) name(args) -#define DEFUN_VOID(name) name(NOARGS) - -#else /* not (__STDC__ || STDC_HEADERS) */ - -#define PTR char * -#define PTRCONST PTR -#define LONG_DOUBLE double - -#define AND ; -#define NOARGS -#define CONST -#define VOLATILE -#define SIGNED -#define DOTS - -#define EXFUN(name, proto) name() -#define DEFUN(name, arglist, args) name arglist args; -#define DEFUN_VOID(name) name() - -#endif /* not (__STDC__ || STDC_HEADERS) */ - -#endif /* _ANSIDECL_H */ diff --git a/v7/src/microcode/array.c b/v7/src/microcode/array.c deleted file mode 100644 index 19aee116f..000000000 --- a/v7/src/microcode/array.c +++ /dev/null @@ -1,2255 +0,0 @@ -/* -*-C-*- - -$Id: array.c,v 9.50 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -#include "scheme.h" -#include "prims.h" -#include "array.h" -#include -#include -/* contains some math constants */ - -/* ARRAY (as a scheme object) - is a usual array (in C) containing REAL numbers (float/double) - and tagged as a non-marked vector. - - Basic contents: - constructors, selectors, arithmetic operations, - conversion routines between C_Array, and Scheme_Vector - - see array.h for macros, NM_VECTOR, and extern */ - -/* mathematical constants */ -#ifdef PI -#undef PI -#endif -#define PI 3.141592653589793238462643 -#define PI_OVER_2 1.570796326794896619231322 -#define TWOPI 6.283185307179586476925287 -#define SQRT_2 1.4142135623730950488 -#define ONE_OVER_SQRT_2 .7071067811865475244 -/* Abramowitz and Stegun p.3 */ - -REAL -flonum_to_real (argument, arg_number) - fast SCHEME_OBJECT argument; - int arg_number; -{ - switch (OBJECT_TYPE (argument)) - { - case TC_FIXNUM: - return ((REAL) (FIXNUM_TO_DOUBLE (argument))); - - case TC_BIG_FIXNUM: - if (! (BIGNUM_TO_DOUBLE_P (argument))) - error_bad_range_arg (arg_number); - return ((REAL) (bignum_to_double (argument))); - - case TC_BIG_FLONUM: - return ((REAL) (FLONUM_TO_DOUBLE (argument))); - - default: - error_wrong_type_arg (arg_number); - /* NOTREACHED */ - } -} - -SCHEME_OBJECT -allocate_array (length) - long length; -{ -#if (REAL_IS_DEFINED_DOUBLE == 0) - - fast SCHEME_OBJECT result = - (allocate_non_marked_vector - (TC_NON_MARKED_VECTOR, ((length * REAL_SIZE) + 1), true)); - FAST_MEMORY_SET (result, 1, length); - return (result); - -#else /* (REAL_IS_DEFINED_DOUBLE != 0) */ - - long n_words = (length * DOUBLE_SIZE); - ALIGN_FLOAT (Free); - Primitive_GC_If_Needed (n_words + 1); - { - SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (Free))); - (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n_words)); - Free += n_words; - return (result); - } - -#endif /* (REAL_IS_DEFINED_DOUBLE != 0) */ -} - -DEFINE_PRIMITIVE ("VECTOR->ARRAY", Prim_vector_to_array, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - CHECK_ARG (1, VECTOR_P); - { - SCHEME_OBJECT vector = (ARG_REF (1)); - long length = (VECTOR_LENGTH (vector)); - SCHEME_OBJECT result = (allocate_array (length)); - fast SCHEME_OBJECT * scan_source = (& (VECTOR_REF (vector, 0))); - fast SCHEME_OBJECT * end_source = (scan_source + length); - fast REAL * scan_target = (ARRAY_CONTENTS (result)); - while (scan_source < end_source) - (*scan_target++) = (flonum_to_real ((*scan_source++), 1)); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("ARRAY->VECTOR", Prim_array_to_vector, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - CHECK_ARG (1, ARRAY_P); - { - SCHEME_OBJECT array = (ARG_REF (1)); - long length = (ARRAY_LENGTH (array)); - fast REAL * scan_source = (ARRAY_CONTENTS (array)); - fast REAL * end_source = (scan_source + length); - SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, length, true)); - fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1)); - while (scan_source < end_source) - (*scan_result++) = (double_to_flonum ((double) (*scan_source++))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("ARRAY-ALLOCATE", Prim_array_allocate, 1,1, 0) -{ - fast REAL * scan; - long length; - SCHEME_OBJECT result; - PRIMITIVE_HEADER (1); - - length = (arg_nonnegative_integer (1)); - result = (allocate_array (length)); - for (scan = (ARRAY_CONTENTS (result)); --length >= 0; ) - *scan++ = ((REAL) 0.0); - PRIMITIVE_RETURN (result); -} - -DEFINE_PRIMITIVE ("ARRAY-CONS-REALS", Prim_array_cons_reals, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - fast double from = (arg_real_number (1)); - fast double dt = (arg_real_number (2)); - long length = (arg_nonnegative_integer (3)); - SCHEME_OBJECT result = (allocate_array (length)); - fast REAL * scan_result = (ARRAY_CONTENTS (result)); - fast int i; - for (i = 0; (i < length); i += 1) - { - (*scan_result++) = ((REAL) from); - from += dt; - } - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("ARRAY-LENGTH", Prim_array_length, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - CHECK_ARG (1, ARRAY_P); - PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (ARRAY_LENGTH (ARG_REF (1)))); -} - -DEFINE_PRIMITIVE ("ARRAY-REF", Prim_array_ref, 2, 2, 0) -{ - SCHEME_OBJECT array; - PRIMITIVE_HEADER (2); - CHECK_ARG (1, ARRAY_P); - array = (ARG_REF (1)); - PRIMITIVE_RETURN - (double_to_flonum - ((double) - ((ARRAY_CONTENTS (array)) - [arg_index_integer (2, (ARRAY_LENGTH (array)))]))); -} - -DEFINE_PRIMITIVE ("ARRAY-SET!", Prim_array_set, 3, 3, 0) -{ - SCHEME_OBJECT array; - REAL * array_ptr; - double old_value, new_value; - PRIMITIVE_HEADER (3); - CHECK_ARG (1, ARRAY_P); - array = (ARG_REF (1)); - array_ptr = - (& ((ARRAY_CONTENTS (array)) - [arg_index_integer (2, (ARRAY_LENGTH (array)))])); - old_value = (*array_ptr); - new_value = (arg_real_number (3)); -#if (REAL_IS_DEFINED_DOUBLE == 0) - if ((new_value >= 0.0) - ? (new_value < ((double) FLT_MIN)) - : (new_value > (0.0 - ((double) FLT_MIN)))) - new_value = ((REAL) 0.0); -#endif - (*array_ptr) = ((REAL) new_value); - PRIMITIVE_RETURN (double_to_flonum (old_value)); -} - -/*____________________ file readers ___________ - ascii and 2bint formats - ______________________________________________*/ - -/* Reading data from files - To read REAL numbers, use "lf" for double, "%f" for float - */ -#if (REAL_IS_DEFINED_DOUBLE == 1) -#define REALREAD "%lf" -#define REALREAD2 "%lf %lf" -#else -#define REALREAD "%f" -#define REALREAD2 "%f %f" -#endif - -static void -C_Array_Read_Ascii_File (a, N, fp) /* 16 ascii decimal digits */ - REAL * a; - long N; - FILE * fp; -{ - fast long i; - for (i = 0; (i < N); i += 1) - { - if ((fscanf (fp, REALREAD, (&(a[i])))) != 1) - { printf("Not enough values read ---\n last value a[%d] = % .16e \n", (i-1), a[i-1]); - error_external_return (); } - } - return; -} - -/* 2BINT FORMAT = integer stored in 2 consecutive bytes. - On many machines, "putw" and "getw" use 4 byte integers (C int) - so use "putc" "getc" as shown below. - */ - -static void -C_Array_Read_2bint_File (a, N, fp) - REAL * a; - long N; - FILE * fp; -{ - fast long i; - fast int msd; - for (i = 0; (i < N); i += 1) - { - if (feof (fp)) - error_external_return (); - msd = (getc (fp)); - (a [i]) = ((REAL) ((msd << 8) | (getc (fp)))); - } - return; -} - -DEFINE_PRIMITIVE ("ARRAY-READ-FROM-FILE", Prim_array_read_from_file, 3,3, 0) -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (1, STRING_P); /* 1 = filename */ - /* 2 = length of data */ - CHECK_ARG (3, FIXNUM_P); /* 3 = format of data 0=ascii 1=2bint */ - { - fast long length = (arg_nonnegative_integer (2)); - fast SCHEME_OBJECT result = (allocate_array (length)); - int format; - fast FILE * fp; - if ( (fp = fopen((STRING_ARG (1)), "r")) == NULL) - error_bad_range_arg (1); - - format = arg_nonnegative_integer(3); - if (format==0) - C_Array_Read_Ascii_File ((ARRAY_CONTENTS (result)), length, fp); - else if (format==1) - C_Array_Read_2bint_File ((ARRAY_CONTENTS (result)), length, fp); - else - error_bad_range_arg(3); /* illegal format code */ - - if ((fclose (fp)) != 0) - error_external_return (); - PRIMITIVE_RETURN (result); - } -} - -static void -C_Array_Write_Ascii_File (a, N, fp) /* 16 ascii decimal digits */ - REAL * a; - long N; - FILE * fp; -{ - fast long i; - for (i = 0; (i < N); i += 1) - { - if (feof (fp)) - error_external_return (); - fprintf (fp, "% .16e \n", a[i]); - } - return; -} - -DEFINE_PRIMITIVE ("ARRAY-WRITE-ASCII-FILE", Prim_array_write_ascii_file, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - CHECK_ARG (1, ARRAY_P); - CHECK_ARG (2, STRING_P); - { - fast SCHEME_OBJECT array = (ARG_REF (1)); - fast FILE * fp = (fopen((STRING_ARG (2)), "w")); - if (fp == ((FILE *) 0)) - error_bad_range_arg (2); - C_Array_Write_Ascii_File - ((ARRAY_CONTENTS (array)), - (ARRAY_LENGTH (array)), - fp); - if ((fclose (fp)) != 0) - error_external_return (); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - - - - -DEFINE_PRIMITIVE ("SUBARRAY-COPY!", Prim_subarray_copy, 5, 5, 0) -{ - PRIMITIVE_HEADER (5); - CHECK_ARG (1, ARRAY_P); /* source array */ - CHECK_ARG (2, ARRAY_P); /* destination array */ - { - REAL * source = (ARRAY_CONTENTS (ARG_REF (1))); - REAL * target = (ARRAY_CONTENTS (ARG_REF (2))); - long start_source = (arg_nonnegative_integer (3)); - long start_target = (arg_nonnegative_integer (4)); - long n_elements = (arg_nonnegative_integer (5)); - if ((start_source + n_elements) > (ARRAY_LENGTH (ARG_REF (1)))) - error_bad_range_arg (3); - if ((start_target + n_elements) > (ARRAY_LENGTH (ARG_REF (2)))) - error_bad_range_arg (4); - { - fast REAL * scan_source = (source + start_source); - fast REAL * end_source = (scan_source + n_elements); - fast REAL * scan_target = (target + start_target); - while (scan_source < end_source) - (*scan_target++) = (*scan_source++); - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("ARRAY-REVERSE!", Prim_array_reverse, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - CHECK_ARG (1, ARRAY_P); - { - SCHEME_OBJECT array = (ARG_REF (1)); - long length = (ARRAY_LENGTH (array)); - long half_length = (length / 2); - fast REAL * array_ptr = (ARRAY_CONTENTS (array)); - fast long i; - fast long j; - for (i = 0, j = (length - 1); (i < half_length); i += 1, j -= 1) - { - fast REAL Temp = (array_ptr [j]); - (array_ptr [j]) = (array_ptr [i]); - (array_ptr [i]) = Temp; - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("ARRAY-TIME-REVERSE!", Prim_array_time_reverse, 1, 1, 0) -{ - void C_Array_Time_Reverse (); - PRIMITIVE_HEADER (1); - CHECK_ARG (1, ARRAY_P); - C_Array_Time_Reverse - ((ARRAY_CONTENTS (ARG_REF (1))), (ARRAY_LENGTH (ARG_REF (1)))); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* time-reverse - x[0] remains fixed. (time=0) - x[i] swapped with x[n-i]. (mirror image around x[0]) */ - -void -C_Array_Time_Reverse (x,n) - REAL *x; - long n; -{ long i, ni, n2; - REAL xt; - if ((n % 2) == 0) /* even length */ - { n2 = (n/2); - for (i=1; i (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(3); - offset = (arg_real (4)); - scale = (arg_real (5)); - if ((offset == 0.0) && (scale == 1.0)) - ; /* be smart */ - else if (scale == 0.0) - for (i=at; i (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(4); - x = (arg_real_number (5)); - y = (arg_real_number (6)); - a = ARRAY_CONTENTS(ARG_REF(1)); - b = ARRAY_CONTENTS(ARG_REF(2)); - if ((ARRAY_LENGTH(ARG_REF(1))) != (ARRAY_LENGTH(ARG_REF(2)))) - error_bad_range_arg(2); - if (x==0.0) /* imaginary only */ - if (y==0.0) - for (i=at; i (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(5); - if (tc==1) - { x = 1.0; /* real part of accumulator */ - y = 0.0; /* imag part of accumulator */ - for (i=at;i= 0.0) /* It may be faster to look at the sign - of mantissa, and dispatch */ - modf( ((double) ((*a)+0.5)), &integral_part); - else - modf( ((double) ((*a)-0.5)), &integral_part); - (*b) = ( (REAL) integral_part); -} - -void -REALsquare (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) ((*a) * (*a)) ); -} - -void -REALsqrt (a,b) - REAL *a,*b; -{ - if ((*a) < 0.0) - error_bad_range_arg(1); /* sqrt(negative) */ - (*b) = ( (REAL) sqrt( (double) (*a)) ); -} - -void -REALsin (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) sin( (double) (*a)) ); -} - -void -REALcos (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) cos( (double) (*a)) ); -} - -void -REALtan (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) tan( (double) (*a)) ); -} - -void -REALasin (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) asin( (double) (*a)) ); -} - -void -REALacos (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) acos( (double) (*a)) ); -} - -void -REALatan (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) atan( (double) (*a)) ); -} - -void -REALgamma (a,b) - REAL *a,*b; -{ - fast double y; - if ((y = gamma(((double) (*a)))) > LN_MAXDOUBLE) - error_bad_range_arg(1); /* gamma( non-positive integer ) */ - (*b) = ((REAL) (signgam * exp(y))); /* see HPUX Section 3 */ -} - -void -REALerf (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) erf((double) (*a)) ); -} - -void -REALerfc (a,b) - REAL *a,*b; -{ - (*b) = ( (REAL) erfc((double) (*a)) ); -} - -void -REALbessel1 (order,a,b) /* Bessel of first kind */ - long order; - REAL *a,*b; -{ - if (order == 0) - (*b) = ( (REAL) j0((double) (*a)) ); - if (order == 1) - (*b) = ( (REAL) j1((double) (*a)) ); - else - (*b) = ( (REAL) jn(((int) order), ((double) (*a))) ); -} - -void -REALbessel2 (order,a,b) /* Bessel of second kind */ - long order; - REAL *a,*b; -{ - if ((*a) <= 0.0) - error_bad_range_arg(1); /* Blows Up */ - if (order == 0) - (*b) = ( (REAL) y0((double) (*a)) ); - if (order == 1) - (*b) = ( (REAL) y1((double) (*a)) ); - else - (*b) = ( (REAL) yn(((int) order), ((double) (*a))) ); -} - -/* Table to store the available unary-functions. - Also some binary functions at the end -- not available right now. - The (1 and 2)s denote the numofargs (1 for unary 2 for binary) */ - -struct array_func_table -{ - long numofargs; - void (*func)(); -} -Array_Function_Table [] = -{ - 1, REALabs, /*0*/ - 1, REALexp, /*1*/ - 1, REALlog, /*2*/ - 1, REALtruncate, /*3*/ - 1, REALround, /*4*/ - 1, REALsquare, /*5*/ - 1, REALsqrt, /*6*/ - 1, REALsin, /*7*/ - 1, REALcos, /*8*/ - 1, REALtan, /*9*/ - 1, REALasin, /*10*/ - 1, REALacos, /*11*/ - 1, REALatan, /*12*/ - 1, REALgamma, /*13*/ - 1, REALerf, /*14*/ - 1, REALerfc, /*15*/ - 2, REALbessel1, /*16*/ - 2, REALbessel2 /*17*/ - }; - -#define MAX_ARRAY_FUNCTC 17 - -/* array-unary-function! could be called array-operation-1! - following the naming convention for other similar procedures - but it is specialized to mappings only, so we have special name. */ - -DEFINE_PRIMITIVE ("ARRAY-UNARY-FUNCTION!", Prim_array_unary_function, 2,2, 0) -{ - long n, i; - REAL *a,*b; - long tc; - void (*f)(); - PRIMITIVE_HEADER (2); - CHECK_ARG (1, ARRAY_P); /* a = input (and output) array */ - CHECK_ARG (2, FIXNUM_P); /* tc = type code */ - tc = arg_nonnegative_integer(2); - if (tc > MAX_ARRAY_FUNCTC) error_bad_range_arg(2); - f = ((Array_Function_Table[tc]).func); - if (1 != (Array_Function_Table[tc]).numofargs) error_wrong_type_arg(2); - /* check it is a unary function */ - a = ARRAY_CONTENTS(ARG_REF(1)); - b = a; - n = ARRAY_LENGTH(ARG_REF(1)); - for (i=0; i (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(4); - if (tc == 0) - { - result = 0.0; - for (i=at;i= (fabs ((double) ((a [i]) - value)))) - PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (i)); - } - PRIMITIVE_RETURN (SHARP_F); -} - -DEFINE_PRIMITIVE ("SUBARRAY-MIN-MAX-INDEX", Prim_subarray_min_max_index, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (1, ARRAY_P); - { - REAL * a = (ARRAY_CONTENTS (ARG_REF (1))); - long at = (arg_nonnegative_integer (2)); /* starting index */ - long m = (arg_nonnegative_integer (3)); /* number of points to process */ - long mplus = (at + m); - long nmin; - long nmax; - if (mplus > (ARRAY_LENGTH (ARG_REF (1)))) - error_bad_range_arg (3); - - C_Array_Find_Min_Max ((& (a [at])), m, (&nmin), (&nmax)); - nmin = nmin + at; /* offset appropriately */ - nmax = nmax + at; - - PRIMITIVE_RETURN - (cons ((LONG_TO_FIXNUM (nmin)), - (cons ((LONG_TO_FIXNUM (nmax)), - EMPTY_LIST)))); - } -} - -void -C_Array_Find_Min_Max (x, n, nmin, nmax) - fast REAL * x; - fast long n; - long * nmin; - long * nmax; -{ REAL *xold = x; - register REAL xmin, xmax; - register long nnmin, nnmax; - register long count; - - nnmin = nnmax = 0; - xmin = xmax = *x++; - n--; - count = 1; - if(n>0) - { - do { - if(*x < xmin) { - nnmin = count++ ; - xmin = *x++ ; - } else if(*x > xmax) { - nnmax = count++ ; - xmax = *x++ ; - } else { - count++ ; - x++ ; - } - } while( --n > 0 ) ; - } - *nmin = nnmin ; - *nmax = nnmax ; -} - - -/* array-average - can be done with (array-reduce +) and division by array-length. - But there is also this C primitive. - Keep it around, may be useful someday. */ - -/* Computes the average in pieces, so as to reduce - roundoff smearing in cumulative sum. - example= first huge positive numbers, then small nums, - then huge negative numbers. */ - -static void -C_Array_Find_Average (Array, Length, pAverage) - long Length; - REAL * Array; - REAL * pAverage; -{ - long i; - long array_index; - REAL average_n, sum; - - average_n = 0.0; - array_index = 0; - while (array_index < Length) - { - sum = 0.0; - for (i=0;((array_index xmax) - error_bad_range_arg (3); - for (i = 0; (i < Length); i += 1) - { - if ((*From_Here) < xmin) - (*To_Here++) = xmin; - else if ((*From_Here) > xmax) - (*To_Here++) = xmax; - else - (*To_Here++) = (*From_Here); - From_Here += 1; - } - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* complex-array-operation-1! - groups together procedures that use 1 complex-array - and store the result in place */ - -DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1!", Prim_complex_array_operation_1, 3,3, 0) -{ long n, i, opcode; - REAL *a, *b; - void complex_array_to_polar(), complex_array_exp(), complex_array_sqrt(); - void complex_array_sin(), complex_array_cos(); - void complex_array_asin(), complex_array_acos(), complex_array_atan(); - PRIMITIVE_HEADER (3); - CHECK_ARG (1, FIXNUM_P); /* operation opcode */ - CHECK_ARG (2, ARRAY_P); /* input array -- n real part */ - CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */ - n = ARRAY_LENGTH(ARG_REF(2)); - if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3); - a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */ - b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */ - opcode = arg_nonnegative_integer(1); - if (opcode==1) - complex_array_to_polar(a,b,n); - else if (opcode==2) - complex_array_exp(a,b,n); - else if (opcode==3) - complex_array_sqrt(a,b,n); - - else if (opcode==4) - complex_array_sin(a,b,n); - else if (opcode==5) - complex_array_cos(a,b,n); - /* for tan(z) use sin(z)/cos(z) */ - - else if (opcode==6) - complex_array_asin(a,b,n); - else if (opcode==7) - complex_array_acos(a,b,n); - else if (opcode==8) - complex_array_atan(a,b,n); - - else - error_bad_range_arg(1); /* illegal opcode */ - PRIMITIVE_RETURN (UNSPECIFIC); -} - -void -complex_array_to_polar (a,b,n) - REAL *a,*b; - long n; -{ - long i; - double x,y, temp; - for (i=0; i=0.0) - b[i] = sqrt((r-x)/2.0); /* choose principal root */ - else /* see Abramowitz (p.17 3.7.27) */ - b[i] = -sqrt((r-x)/2.0); - } -} - -void -complex_array_sin (a,b,n) - REAL *a,*b; - long n; -{ - long i; - double x, ey,fy; - REAL temp; - - for (i=0; i=0.0) - imag = sqrt((r-x)/2.0); /* choose principal root */ - else /* see Abramowitz (p.17 3.7.27) */ - imag = -sqrt((r-x)/2.0); - - real = real - oldy; /* i*z + sqrt(...) */ - imag = imag + oldx; - - b[i] = (REAL) (- log (sqrt (real*real + imag*imag))); /* -i*log(...) */ - a[i] = (REAL) atan2( imag, real); /* chosen angle is okay - Also 0/0 doesnot occur */ - } -} - -void -complex_array_acos (a,b,n) - REAL *a,*b; - long n; -{ - long i; - - complex_array_asin (a,b,n); - - for (i=0; i0.0)) return(.08 + .46 * (1 - t_bar)); - else return (0); -} - -double -unit_square_wave (t) - double t; -{ - double twopi = 6.28318530717958; - double fmod(), fabs(); - double pi = twopi/2.; - double t_bar = ((REAL) fabs(fmod( ((double) t), twopi))); - if (t_bar < pi) return(1); - else return(-1); -} - -double -unit_triangle_wave (t) - double t; -{ - double twopi = 6.28318530717958; - double pi = twopi/2.; - double pi_half = pi/2.; - double three_pi_half = pi+pi_half; - double t_bar = ((double) fabs(fmod( ((double) t), twopi))); - if (t_bar0.0)) - return(.5 * (1 - t_bar)); - else - return (0.0); -} - -double -integer_power (a, n) - double a; - long n; -{ - double b; - double integer_power(); - - if (n<0) exit(-1); - else if (n==0) return(1.0); - else if (n==1) return(a); - else if ((n%2) == 0) - { - b = integer_power(a, n/2); - return(b*b); - } - else - return(a * integer_power(a, (n-1))); -} - -/* array-operation-1! - groups together procedures that use 1 array - and store the result in place (e.g. random) */ - -DEFINE_PRIMITIVE ("ARRAY-OPERATION-1!", Prim_array_operation_1, 2,2, 0) -{ - long n, opcode; - REAL *a; - void array_random(); - PRIMITIVE_HEADER (2); - CHECK_ARG (1, FIXNUM_P); /* operation opcode */ - CHECK_ARG (2, ARRAY_P); /* input array -- n */ - n = ARRAY_LENGTH(ARG_REF(2)); - a = ARRAY_CONTENTS(ARG_REF(2)); - opcode = arg_nonnegative_integer(1); - if (opcode==1) - array_random(a,n); - else if (opcode==2) - error_bad_range_arg(1); /* illegal opcode */ - else - error_bad_range_arg(1); /* illegal opcode */ - PRIMITIVE_RETURN (UNSPECIFIC); -} - -void -array_random (a,n) - REAL *a; - long n; -{ - long i; - /* HPUX 3: Rand uses a multiplicative congruential random-number generator - with period 2^32 that returns successive pseudo-random numbers in the - range from 0 to 2^15-1 */ - for (i=0;i fabs(*(a+m+(k-1)*n-1))) - m = i; - *(pvt+k-1) = m; - if (m != k) - *(pvt+n-1) = - *(pvt+n-1); - p = *(a+m+(k-1)*n-1); - *(a+m+(k-1)*n-1) = *(a+k+(k-1)*n-1); - *(a+k+(k-1)*n-1) = p; - if (p != 0.0) { - for (i=k+1; i<=n; i++) - *(a+i+(k-1)*n-1) = - *(a+i+(k-1)*n-1) / p; - for (j=k+1; j<=n; j++) { - t = *(a+m+(j-1)*n-1); - *(a+m+(j-1)*n-1) = *(a+k+(j-1)*n-1); - *(a+k+(j-1)*n-1) = t; - if (t != 0.0) - for (i=k+1; i<=n; i++) - *(a+i+(j-1)*n-1) = *(a+i+(j-1)*n-1) + *(a+i+(k-1)*n-1) * t; - } - } - } - for (k=1; k -#include "limits.h" /* Conversions between Scheme types and C types. */ long -DEFUN (fixnum_to_long, (fixnum), SCHEME_OBJECT fixnum) +fixnum_to_long (SCHEME_OBJECT fixnum) { return (FIXNUM_TO_LONG (fixnum)); } SCHEME_OBJECT -DEFUN (double_to_fixnum, (value), double value) +double_to_fixnum (double value) { #ifdef HAVE_DOUBLE_TO_LONG_BUG - fast long temp = ((long) value); + long temp = ((long) value); return (LONG_TO_FIXNUM (temp)); #else return (LONG_TO_FIXNUM ((long) value)); #endif } -Boolean -DEFUN (integer_to_long_p, (n), fast SCHEME_OBJECT n) +bool +integer_to_long_p (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) || (BIGNUM_TO_LONG_P (n))); } long -DEFUN (integer_to_long, - (n), - fast SCHEME_OBJECT n) +integer_to_long (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) ? (FIXNUM_TO_LONG (n)) : (bignum_to_long (n))); } SCHEME_OBJECT -DEFUN (long_to_integer, (number), long number) +long_to_integer (long number) { return ((LONG_TO_FIXNUM_P (number)) @@ -73,16 +69,14 @@ DEFUN (long_to_integer, (number), long number) : (long_to_bignum (number))); } -Boolean -DEFUN (integer_to_ulong_p, (n), fast SCHEME_OBJECT n) +bool +integer_to_ulong_p (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) || (BIGNUM_TO_ULONG_P (n))); } unsigned long -DEFUN (integer_to_ulong, - (n), - fast SCHEME_OBJECT n) +integer_to_ulong (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) ? ((unsigned long) (FIXNUM_TO_LONG (n))) @@ -90,7 +84,7 @@ DEFUN (integer_to_ulong, } SCHEME_OBJECT -DEFUN (ulong_to_integer, (number), unsigned long number) +ulong_to_integer (unsigned long number) { long s_number = ((long) number); if (s_number >= 0) @@ -102,20 +96,20 @@ DEFUN (ulong_to_integer, (number), unsigned long number) return (ulong_to_bignum (number)); } -Boolean -DEFUN (integer_to_double_p, (n), fast SCHEME_OBJECT n) +bool +integer_to_double_p (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) || (BIGNUM_TO_DOUBLE_P (n))); } double -DEFUN (integer_to_double, (n), fast SCHEME_OBJECT n) +integer_to_double (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) ? (FIXNUM_TO_DOUBLE (n)) : (bignum_to_double (n))); } SCHEME_OBJECT -DEFUN (double_to_integer, (x), fast double x) +double_to_integer (double x) { return ((DOUBLE_TO_FIXNUM_P (x)) @@ -124,17 +118,23 @@ DEFUN (double_to_integer, (x), fast double x) } double -DEFUN (double_truncate, (x), fast double x) +double_truncate (double x) { double iptr; (void) modf (x, (&iptr)); return (iptr); } + +double +double_round (double x) +{ + return (double_truncate ((x < 0) ? (x - 0.5) : (x + 0.5))); +} /* Conversions between Scheme types and Scheme types. */ SCHEME_OBJECT -DEFUN (bignum_to_fixnum, (bignum), fast SCHEME_OBJECT bignum) +bignum_to_fixnum (SCHEME_OBJECT bignum) { return ((BIGNUM_TO_FIXNUM_P (bignum)) @@ -143,7 +143,7 @@ DEFUN (bignum_to_fixnum, (bignum), fast SCHEME_OBJECT bignum) } SCHEME_OBJECT -DEFUN (bignum_to_integer, (bignum), fast SCHEME_OBJECT bignum) +bignum_to_integer (SCHEME_OBJECT bignum) { return ((BIGNUM_TO_FIXNUM_P (bignum)) @@ -152,7 +152,7 @@ DEFUN (bignum_to_integer, (bignum), fast SCHEME_OBJECT bignum) } SCHEME_OBJECT -DEFUN (bignum_to_flonum, (bignum), fast SCHEME_OBJECT bignum) +bignum_to_flonum (SCHEME_OBJECT bignum) { return ((BIGNUM_TO_FLONUM_P (bignum)) @@ -160,42 +160,34 @@ DEFUN (bignum_to_flonum, (bignum), fast SCHEME_OBJECT bignum) : SHARP_F); } -Boolean -DEFUN (flonum_integer_p, (x), SCHEME_OBJECT x) +bool +flonum_integer_p (SCHEME_OBJECT x) { - extern double EXFUN (modf, (double, double *)); double iptr; return ((modf ((FLONUM_TO_DOUBLE (x)), (&iptr))) == 0); } SCHEME_OBJECT -DEFUN (flonum_floor, (x), SCHEME_OBJECT x) +flonum_floor (SCHEME_OBJECT x) { - extern double EXFUN (floor, (double)); return (double_to_flonum (floor (FLONUM_TO_DOUBLE (x)))); } SCHEME_OBJECT -DEFUN (flonum_ceiling, (x), SCHEME_OBJECT x) +flonum_ceiling (SCHEME_OBJECT x) { - extern double EXFUN (ceil, (double)); return (double_to_flonum (ceil (FLONUM_TO_DOUBLE (x)))); } SCHEME_OBJECT -DEFUN (flonum_round, - (x), - SCHEME_OBJECT x) +flonum_round (SCHEME_OBJECT x) { - fast double dx = (FLONUM_TO_DOUBLE (x)); - return - (double_to_flonum (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5)))); + return (double_to_flonum (double_round (FLONUM_TO_DOUBLE (x)))); } SCHEME_OBJECT -DEFUN (flonum_normalize, (x), SCHEME_OBJECT x) +flonum_normalize (SCHEME_OBJECT x) { - extern double EXFUN (frexp, (double, int *)); int exponent; double significand = (frexp ((FLONUM_TO_DOUBLE (x)), (&exponent))); return (cons ((double_to_flonum (significand)), @@ -203,35 +195,34 @@ DEFUN (flonum_normalize, (x), SCHEME_OBJECT x) } SCHEME_OBJECT -DEFUN (flonum_denormalize, (x, e), SCHEME_OBJECT x AND SCHEME_OBJECT e) +flonum_denormalize (SCHEME_OBJECT x, SCHEME_OBJECT e) { - extern double EXFUN (ldexp, (double, int)); return (double_to_flonum (ldexp ((FLONUM_TO_DOUBLE (x)), ((int) (integer_to_long (e)))))); } /* Generic Integer Operations */ -Boolean -DEFUN (integer_zero_p, (n), SCHEME_OBJECT n) +bool +integer_zero_p (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) ? (FIXNUM_ZERO_P (n)) : (BIGNUM_ZERO_P (n))); } -Boolean -DEFUN (integer_negative_p, (n), SCHEME_OBJECT n) +bool +integer_negative_p (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) ? (FIXNUM_NEGATIVE_P (n)) : (BIGNUM_NEGATIVE_P (n))); } -Boolean -DEFUN (integer_positive_p, (n), SCHEME_OBJECT n) +bool +integer_positive_p (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) ? (FIXNUM_POSITIVE_P (n)) : (BIGNUM_POSITIVE_P (n))); } -Boolean -DEFUN (integer_equal_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) +bool +integer_equal_p (SCHEME_OBJECT n, SCHEME_OBJECT m) { return ((FIXNUM_P (n)) @@ -241,8 +232,8 @@ DEFUN (integer_equal_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) : (bignum_equal_p (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))); } -Boolean -DEFUN (integer_less_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) +bool +integer_less_p (SCHEME_OBJECT n, SCHEME_OBJECT m) { return ((FIXNUM_P (n)) @@ -253,7 +244,7 @@ DEFUN (integer_less_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) } SCHEME_OBJECT -DEFUN (integer_negate, (n), SCHEME_OBJECT n) +integer_negate (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) @@ -262,7 +253,7 @@ DEFUN (integer_negate, (n), SCHEME_OBJECT n) } SCHEME_OBJECT -DEFUN (integer_add, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) +integer_add (SCHEME_OBJECT n, SCHEME_OBJECT m) { return ((FIXNUM_P (n)) @@ -274,7 +265,7 @@ DEFUN (integer_add, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) } SCHEME_OBJECT -DEFUN (integer_add_1, (n), SCHEME_OBJECT n) +integer_add_1 (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) @@ -283,7 +274,7 @@ DEFUN (integer_add_1, (n), SCHEME_OBJECT n) } SCHEME_OBJECT -DEFUN (integer_subtract, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) +integer_subtract (SCHEME_OBJECT n, SCHEME_OBJECT m) { return ((FIXNUM_P (n)) @@ -295,7 +286,7 @@ DEFUN (integer_subtract, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) } SCHEME_OBJECT -DEFUN (integer_subtract_1, (n), SCHEME_OBJECT n) +integer_subtract_1 (SCHEME_OBJECT n) { return ((FIXNUM_P (n)) @@ -304,10 +295,9 @@ DEFUN (integer_subtract_1, (n), SCHEME_OBJECT n) } SCHEME_OBJECT -DEFUN (integer_multiply, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) +integer_multiply (SCHEME_OBJECT n, SCHEME_OBJECT m) { - extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT)); - fast SCHEME_OBJECT result; + SCHEME_OBJECT result; return ((FIXNUM_P (n)) ? ((FIXNUM_P (m)) @@ -322,10 +312,9 @@ DEFUN (integer_multiply, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m) (bignum_multiply (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))))); } -Boolean -DEFUN (integer_divide, (n, d, q, r), - SCHEME_OBJECT n AND SCHEME_OBJECT d - AND SCHEME_OBJECT * q AND SCHEME_OBJECT * r) +bool +integer_divide (SCHEME_OBJECT n, SCHEME_OBJECT d, + SCHEME_OBJECT * q, SCHEME_OBJECT * r) { if (FIXNUM_P (n)) { @@ -334,10 +323,10 @@ DEFUN (integer_divide, (n, d, q, r), /* Now, unbelievable hair because C doesn't fully specify / and % when their arguments are negative. We must get consistent answers for all valid arguments. */ - fast long lx = (FIXNUM_TO_LONG (n)); - fast long ly = (FIXNUM_TO_LONG (d)); - fast long quotient; - fast long remainder; + long lx = (FIXNUM_TO_LONG (n)); + long ly = (FIXNUM_TO_LONG (d)); + long quotient; + long remainder; if (ly == 0) return (true); if (lx < 0) @@ -386,14 +375,14 @@ DEFUN (integer_divide, (n, d, q, r), } SCHEME_OBJECT -DEFUN (integer_quotient, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d) +integer_quotient (SCHEME_OBJECT n, SCHEME_OBJECT d) { if (FIXNUM_P (n)) { if (FIXNUM_P (d)) { - fast long lx = (FIXNUM_TO_LONG (n)); - fast long ly = (FIXNUM_TO_LONG (d)); + long lx = (FIXNUM_TO_LONG (n)); + long ly = (FIXNUM_TO_LONG (d)); return ((ly == 0) ? SHARP_F @@ -423,14 +412,14 @@ DEFUN (integer_quotient, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d) } SCHEME_OBJECT -DEFUN (integer_remainder, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d) +integer_remainder (SCHEME_OBJECT n, SCHEME_OBJECT d) { if (FIXNUM_P (n)) { if (FIXNUM_P (d)) { - fast long lx = (FIXNUM_TO_LONG (n)); - fast long ly = (FIXNUM_TO_LONG (d)); + long lx = (FIXNUM_TO_LONG (n)); + long ly = (FIXNUM_TO_LONG (d)); return ((ly == 0) ? SHARP_F @@ -456,7 +445,7 @@ DEFUN (integer_remainder, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d) } static unsigned long -DEFUN (unsigned_long_length_in_bits, (n), unsigned long n) +unsigned_long_length_in_bits (unsigned long n) { unsigned long result = 0; while (n > 0) @@ -468,7 +457,7 @@ DEFUN (unsigned_long_length_in_bits, (n), unsigned long n) } SCHEME_OBJECT -DEFUN (integer_length_in_bits, (n), SCHEME_OBJECT n) +integer_length_in_bits (SCHEME_OBJECT n) { if (FIXNUM_P (n)) { @@ -481,7 +470,7 @@ DEFUN (integer_length_in_bits, (n), SCHEME_OBJECT n) } SCHEME_OBJECT -DEFUN (integer_shift_left, (n, m), SCHEME_OBJECT n AND unsigned long m) +integer_shift_left (SCHEME_OBJECT n, unsigned long m) { if ((m == 0) || (!integer_positive_p (n))) return (n); diff --git a/v7/src/microcode/avltree.c b/v7/src/microcode/avltree.c index 17bd1b878..57d93e517 100644 --- a/v7/src/microcode/avltree.c +++ b/v7/src/microcode/avltree.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: avltree.c,v 1.10 2007/01/05 21:19:25 cph Exp $ +$Id: avltree.c,v 1.11 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -27,22 +27,17 @@ USA. /* This file contains the code for a simple AVL tree library. It is used by the MIT/GNU Scheme microcode to quickly map - names to indices into various tables. - */ + names to indices into various tables. */ #include "avltree.h" -extern int EXFUN (strcmp_ci, (CONST char * s1, CONST char * s2)); -extern PTR EXFUN (malloc, (unsigned long)); -extern void EXFUN (free, (PTR)); +extern int strcmp_ci (const char *, const char *); -CONST char * tree_error_message = 0; -CONST char * tree_error_noise = 0; +const char * tree_error_message = 0; +const char * tree_error_noise = 0; static void -DEFUN (tree_error, (message, noise), - CONST char * message AND - CONST char * noise) +tree_error (const char * message, const char * noise) { tree_error_message = message; tree_error_noise = noise; @@ -57,25 +52,23 @@ DEFUN (tree_error, (message, noise), With random insertion (or when created as below), they are better, approaching log base 2. - This version does not allow duplicate entries. */ + This version does not allow duplicate entries. */ -#define BRANCH_HEIGHT(tree) (((tree) == 0) ? 0 : (tree)->height) +#define BRANCH_HEIGHT(tree) (((tree) == 0) ? 0 : ((tree) -> height)) #ifndef MAX # define MAX(a,b) (((a) >= (b)) ? (a) : (b)) #endif static void -DEFUN (update_height, (tree), tree_node tree) +update_height (tree_node tree) { - tree->height = (1 + (MAX ((BRANCH_HEIGHT (tree->left)), + (tree->height) = (1 + (MAX ((BRANCH_HEIGHT (tree->left)), (BRANCH_HEIGHT (tree->rite))))); } static tree_node -DEFUN (leaf_make, (name, value), - CONST char * name AND - unsigned long value) +leaf_make (const char * name, unsigned long value) { tree_node leaf = ((tree_node) (malloc (sizeof (struct tree_node_s)))); if (leaf == 0) @@ -83,40 +76,40 @@ DEFUN (leaf_make, (name, value), tree_error ("leaf_make: malloc failed.\n", 0); return (leaf); } - leaf->name = name; - leaf->value = value; - leaf->height = 1; - leaf->left = 0; - leaf->rite = 0; + (leaf->name) = name; + (leaf->value) = value; + (leaf->height) = 1; + (leaf->left) = 0; + (leaf->rite) = 0; return (leaf); } static tree_node -DEFUN (rotate_left, (tree), tree_node tree) +rotate_left (tree_node tree) { - tree_node rite = tree->rite; - tree_node beta = rite->left; - tree->rite = beta; - rite->left = tree; + tree_node rite = (tree->rite); + tree_node beta = (rite->left); + (tree->rite) = beta; + (rite->left) = tree; update_height (tree); update_height (rite); return (rite); } static tree_node -DEFUN (rotate_rite, (tree), tree_node tree) +rotate_rite (tree_node tree) { - tree_node left = tree->left; - tree_node beta = left->rite; - tree->left = beta; - left->rite = tree; + tree_node left = (tree->left); + tree_node beta = (left->rite); + (tree->left) = beta; + (left->rite) = tree; update_height (tree); update_height (left); return (left); } static tree_node -DEFUN (rebalance_left, (tree), tree_node tree) +rebalance_left (tree_node tree) { if ((1 + (BRANCH_HEIGHT (tree->rite))) >= (BRANCH_HEIGHT (tree->left))) { @@ -125,15 +118,15 @@ DEFUN (rebalance_left, (tree), tree_node tree) } else { - tree_node q = tree->left; + tree_node q = (tree->left); if ((BRANCH_HEIGHT (q->rite)) > (BRANCH_HEIGHT (q->left))) - tree->left = (rotate_left (q)); + (tree->left) = (rotate_left (q)); return (rotate_rite (tree)); } } static tree_node -DEFUN (rebalance_rite, (tree), tree_node tree) +rebalance_rite (tree_node tree) { if ((1 + (BRANCH_HEIGHT (tree->left))) >= (BRANCH_HEIGHT (tree->rite))) { @@ -142,38 +135,33 @@ DEFUN (rebalance_rite, (tree), tree_node tree) } else { - tree_node q = tree->rite; + tree_node q = (tree->rite); if ((BRANCH_HEIGHT (q->left)) > (BRANCH_HEIGHT (q->rite))) - tree->rite = (rotate_rite (q)); + (tree->rite) = (rotate_rite (q)); return (rotate_left (tree)); } } tree_node -DEFUN (tree_insert, (tree, name, value), - tree_node tree AND - CONST char * name AND - unsigned long value) +tree_insert (tree_node tree, const char * name, unsigned long value) { if (tree == 0) return (leaf_make (name, value)); - switch (strcmp_ci (name, tree->name)) + switch (strcmp_ci (name, (tree->name))) { case 0: tree_error ("tree_insert: Duplicate entry %s.\n", name); return (tree); - - case -1: + + case (-1): { - /* To the left */ - tree->left = (tree_insert (tree->left, name, value)); + (tree->left) = (tree_insert ((tree->left), name, value)); return (rebalance_left (tree)); } case 1: { - /* To the right */ - tree->rite = (tree_insert (tree->rite, name, value)); + (tree->rite) = (tree_insert ((tree->rite), name, value)); return (rebalance_rite (tree)); } } @@ -182,30 +170,27 @@ DEFUN (tree_insert, (tree, name, value), } tree_node -DEFUN (tree_lookup, (tree, name), tree_node tree AND CONST char * name) +tree_lookup (tree_node tree, const char * name) { while (tree != 0) - switch (strcmp_ci (name, tree->name)) + switch (strcmp_ci (name, (tree->name))) { case 0: return (tree); - case -1: - tree = tree->left; + case (-1): + tree = (tree->left); break; case 1: - tree = tree->rite; + tree = (tree->rite); break; } return (tree); } tree_node -DEFUN (tree_build, (high, names, value), - unsigned long high AND - CONST char ** names AND - unsigned long value) +tree_build (unsigned long high, const char ** names, unsigned long value) { static long bias = 0; if (high > 1) @@ -220,20 +205,18 @@ DEFUN (tree_build, (high, names, value), bias = (1 - bias); } next = (middle + 1); - tree = (leaf_make (names[middle], (value + middle))); - tree->left = (tree_build (middle, names, value)); - tree->rite = (tree_build ((high - next), &names[next], (value + next))); + tree = (leaf_make ((names[middle]), (value + middle))); + (tree->left) = (tree_build (middle, names, value)); + (tree->rite) + = (tree_build ((high - next), (& (names[next])), (value + next))); update_height (tree); return (tree); } - else if (high == 1) - return (leaf_make (* names, value)); - else - return (0); + return ((high == 1) ? (leaf_make ((*names), value)) : 0); } void -DEFUN (tree_free, (tree), tree_node tree) +tree_free (tree_node tree) { if (tree != 0) { diff --git a/v7/src/microcode/avltree.h b/v7/src/microcode/avltree.h index 954fc45e7..25f638c33 100644 --- a/v7/src/microcode/avltree.h +++ b/v7/src/microcode/avltree.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: avltree.h,v 1.9 2007/01/05 21:19:25 cph Exp $ +$Id: avltree.h,v 1.10 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -35,8 +35,8 @@ USA. #include "config.h" -extern CONST char * tree_error_message; -extern CONST char * tree_error_noise; +extern const char * tree_error_message; +extern const char * tree_error_noise; typedef struct tree_node_s * tree_node; @@ -45,14 +45,13 @@ struct tree_node_s int height; tree_node left; tree_node rite; - CONST char * name; + const char * name; unsigned long value; }; -extern tree_node EXFUN - (tree_build, (unsigned long, CONST char **, unsigned long)); -extern tree_node EXFUN (tree_lookup, (tree_node, CONST char *)); -extern tree_node EXFUN (tree_insert, (tree_node, CONST char *, unsigned long)); -extern void EXFUN (tree_free, (tree_node)); +extern tree_node tree_build (unsigned long, const char **, unsigned long); +extern tree_node tree_lookup (tree_node, const char *); +extern tree_node tree_insert (tree_node, const char *, unsigned long); +extern void tree_free (tree_node); #endif /* AVLTREE_H */ diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c deleted file mode 100644 index 69fd6926f..000000000 --- a/v7/src/microcode/bchdmp.c +++ /dev/null @@ -1,1110 +0,0 @@ -/* -*-C-*- - -$Id: bchdmp.c,v 9.94 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag, - purify, and fasdump, respectively, to provide garbage collection - and related utilities to disk. */ - -#include "scheme.h" -#include "prims.h" -#include "osfile.h" -#include "osfs.h" -#include "trap.h" -#include "lookup.h" /* UNCOMPILED_VARIABLE */ -#define In_Fasdump -#include "fasl.h" -#include "bchgcc.h" - -extern int EXFUN (OS_channel_copy, (off_t, Tchannel, Tchannel)); - -extern SCHEME_OBJECT EXFUN - (dump_renumber_primitive, (SCHEME_OBJECT)); -extern SCHEME_OBJECT * EXFUN - (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)); -extern SCHEME_OBJECT * EXFUN - (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); -extern SCHEME_OBJECT * EXFUN - (cons_whole_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -extern SCHEME_OBJECT compiler_utilities; -extern SCHEME_OBJECT * EXFUN - (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -#ifdef __unix__ -# include "ux.h" -# include "uxio.h" - static char FASDUMP_FILENAME[] = "fasdumpXXXXXX"; -#endif - -#ifdef __WIN32__ -# include "nt.h" -# include "ntio.h" - static char FASDUMP_FILENAME[] = "faXXXXXX"; -#endif - -#ifdef __OS2__ -# include "os2.h" - static char FASDUMP_FILENAME[] = "faXXXXXX"; -# ifdef __EMX__ -# include -# endif -# if defined(__IBMC__) || defined(__WATCOMC__) -# include -# include -# include -# ifndef F_OK -# define F_OK 0 -# define X_OK 1 -# define W_OK 2 -# define R_OK 4 -# endif -# endif -#endif - -static Tchannel dump_channel; -static CONST char * dump_file_name; -static int real_gc_file; -static int dump_file; -static SCHEME_OBJECT * saved_free; -static SCHEME_OBJECT * fixup_buffer = 0; -static SCHEME_OBJECT * fixup_buffer_end; -static SCHEME_OBJECT * fixup; -static int fixup_count = 0; -static Boolean compiled_code_present_p; - -#define Write_Data(size, buffer) \ - ((OS_channel_write_dump_file \ - (dump_channel, \ - ((char *) (buffer)), \ - ((size) * (sizeof (SCHEME_OBJECT))))) \ - / (sizeof (SCHEME_OBJECT))) - -#include "dump.c" - -static SCHEME_OBJECT EXFUN (dump_to_file, (SCHEME_OBJECT, CONST char *)); -static int EXFUN (fasdump_exit, (long length)); -static int EXFUN (reset_fixes, (void)); -static ssize_t EXFUN (eta_read, (int, char *, int)); -static ssize_t EXFUN (eta_write, (int, char *, int)); -static long EXFUN - (dump_loop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **)); - -/* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag) - - Dump an object into a file so that it can be loaded using - BINARY-FASLOAD. A spare heap is required for this operation. The - first argument is the object to be dumped. The second is the - filename or channel. The third argument, FLAG, is currently - ignored. The primitive returns #T or #F indicating whether it - successfully dumped the object (it can fail on an object that is - too large). It should signal an error rather than return false, - but ... some other time. - - This version of fasdump can only handle files (actually lseek-able - streams), since the header is written at the beginning of the - output but its contents are only know after the rest of the output - has been written. - - Thus, for arbitrary channels, a temporary file is allocated, and on - completion, the file is copied to the channel. */ - -DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - SCHEME_OBJECT root = (ARG_REF (1)); - if (STRING_P (ARG_REF (2))) - PRIMITIVE_RETURN (dump_to_file (root, (STRING_ARG (2)))); - { - Tchannel channel = (arg_channel (2)); - char * temp_name = (make_gc_file_name (FASDUMP_FILENAME)); - transaction_begin (); - protect_gc_file_name (temp_name); - if (!allocate_gc_file (temp_name)) - signal_error_from_primitive (ERR_EXTERNAL_RETURN); - { - SCHEME_OBJECT fasdump_result = (dump_to_file (root, temp_name)); - if (fasdump_result == SHARP_T) - { - Tchannel temp_channel = (OS_open_input_file (temp_name)); - int copy_result - = (OS_channel_copy ((OS_file_length (temp_channel)), - temp_channel, - channel)); - OS_channel_close (temp_channel); - OS_file_remove (temp_name); - transaction_commit (); - if (copy_result < 0) - signal_error_from_primitive (ERR_IO_ERROR); - } - PRIMITIVE_RETURN (fasdump_result); - } - } - } -} - -/* (DUMP-BAND PROCEDURE FILE-NAME) - Saves all of the heap and pure space on FILE-NAME. When the - file is loaded back using BAND_LOAD, PROCEDURE is called with an - argument of #F. */ - -DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) -{ - SCHEME_OBJECT * saved_free; - SCHEME_OBJECT * prim_table_start; - SCHEME_OBJECT * prim_table_end; - SCHEME_OBJECT * c_table_start; - SCHEME_OBJECT * c_table_end; - long prim_table_length; - long c_table_length; - int result = 0; - PRIMITIVE_HEADER (2); - - Band_Dump_Permitted (); - CHECK_ARG (1, INTERPRETER_APPLICABLE_P); - CHECK_ARG (2, STRING_P); - if (Unused_Heap_Bottom < Heap_Bottom) - /* Cause the image to be in the low heap, to increase - the probability that no relocation is needed on reload. */ - Primitive_GC (0); - Primitive_GC_If_Needed (5); - - saved_free = Free; - - { - SCHEME_OBJECT Combination; - Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free)); - (Free[COMB_1_FN]) = (ARG_REF (1)); - (Free[COMB_1_ARG_1]) = SHARP_F; - Free += 2; - { - SCHEME_OBJECT p = (MAKE_POINTER_OBJECT (TC_LIST, Free)); - (*Free++) = Combination; - (*Free++) = compiler_utilities; - (*Free++) = p; - } - } - - prim_table_start = Free; - prim_table_end - = (cons_whole_primitive_table (prim_table_start, Heap_Top, - (&prim_table_length))); - if (prim_table_end >= Heap_Top) - goto done; - - c_table_start = prim_table_end; - c_table_end - = (cons_c_code_table (c_table_start, Heap_Top, - (&c_table_length))); - if (c_table_end >= Heap_Top) - goto done; - - { - CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0))); - SCHEME_OBJECT * faligned_heap = Heap_Bottom; - SCHEME_OBJECT * faligned_constant = Constant_Space; - - BCH_ALIGN_FLOAT_ADDRESS (faligned_heap); - BCH_ALIGN_FLOAT_ADDRESS (faligned_constant); - - OS_file_remove_link (filename); - dump_channel = (OS_open_dump_file (filename)); - if (dump_channel == NO_CHANNEL) - error_bad_range_arg (2); - - result - = (Write_File ((Free - 1), - ((long) (Free - faligned_heap)), - faligned_heap, - ((long) (Free_Constant - faligned_constant)), - faligned_constant, - prim_table_start, - prim_table_length, - ((long) (prim_table_end - prim_table_start)), - c_table_start, - c_table_length, - ((long) (c_table_end - c_table_start)), - (compiler_utilities != SHARP_F), - 1)); - - OS_channel_close_noerror (dump_channel); - if (!result) - OS_file_remove (filename); - } - - done: - Band_Dump_Exit_Hook (); - Free = saved_free; - PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result)); -} - -static SCHEME_OBJECT -DEFUN (dump_to_file, (root, fname), - SCHEME_OBJECT root AND - CONST char * fname) -{ - Boolean success = 1; - long value; - long length; - long hlength; - long tlength; - long tsize; - SCHEME_OBJECT * dumped_object; - SCHEME_OBJECT * free_buffer; - SCHEME_OBJECT * dummy; - SCHEME_OBJECT * table_start; - SCHEME_OBJECT * table_end; - SCHEME_OBJECT * table_top; - SCHEME_OBJECT header [FASL_HEADER_LENGTH]; - - if (fixup_buffer == 0) - { - fixup_buffer = ((SCHEME_OBJECT *) (malloc (gc_buffer_bytes))); - if (fixup_buffer == 0) - error_system_call (errno, syscall_malloc); - fixup_buffer_end = (fixup_buffer + gc_buffer_size); - } - - dump_file_name = fname; - dump_file = (open (dump_file_name, GC_FILE_FLAGS, 0666)); - if (dump_file < 0) - error_bad_range_arg (2); - - compiled_code_present_p = 0; - real_gc_file = (swap_gc_file (dump_file)); - saved_free = Free; - fixup = fixup_buffer_end; - fixup_count = -1; - - table_top = (& (saved_free [Space_Before_GC ()])); - table_start = (initialize_primitive_table (saved_free, table_top)); - if (table_start >= table_top) - { - fasdump_exit (0); - Primitive_GC (table_start - saved_free); - } - - free_buffer = (initialize_free_buffer ()); - Free = 0; - free_buffer += FASL_HEADER_LENGTH; - - dummy = free_buffer; - BCH_ALIGN_FLOAT (Free, dummy); - - (*free_buffer++) = root; - dumped_object = (Free++); - - value - = dump_loop (((initialize_scan_buffer (0)) + FASL_HEADER_LENGTH), - (&free_buffer), (&Free)); - if (value != PRIM_DONE) - { - fasdump_exit (0); - if (value == PRIM_INTERRUPT) - return (SHARP_F); - else - signal_error_from_primitive (value); - } - end_transport (&success); - if (!success) - { - fasdump_exit (0); - return (SHARP_F); - } - - length = (Free - dumped_object); - - table_end = (cons_primitive_table (table_start, table_top, &tlength)); - if (table_end >= table_top) - { - fasdump_exit (0); - Primitive_GC (table_end - saved_free); - } - -#ifdef NATIVE_CODE_IS_C - /* Cannot dump C compiled code. */ - if (compiled_code_present_p) - { - fasdump_exit (0); - signal_error_from_primitive (ERR_COMPILED_CODE_ERROR); - } -#endif - - tsize = (table_end - table_start); - hlength = ((sizeof (SCHEME_OBJECT)) * tsize); - if (((lseek (dump_file, - ((sizeof (SCHEME_OBJECT)) * (length + FASL_HEADER_LENGTH)), - 0)) - == -1) - || ((write (dump_file, ((char *) (&table_start[0])), hlength)) - != hlength)) - { - fasdump_exit (0); - return (SHARP_F); - } - - hlength = ((sizeof (SCHEME_OBJECT)) * FASL_HEADER_LENGTH); - prepare_dump_header - (header, dumped_object, length, dumped_object, - 0, Constant_Space, tlength, tsize, 0, 0, - compiled_code_present_p, 0); - if (((lseek (dump_file, 0, 0)) == -1) - || ((write (dump_file, ((char *) &header[0]), hlength)) != hlength)) - { - fasdump_exit (0); - return (SHARP_F); - } - return - (BOOLEAN_TO_OBJECT - (fasdump_exit (((sizeof (SCHEME_OBJECT)) * (length + tsize)) + hlength))); -} - -static int -DEFUN (fasdump_exit, (length), long length) -{ - SCHEME_OBJECT * fixes, * fix_address; - int result; - - Free = saved_free; - restore_gc_file (); - -#ifdef HAVE_FTRUNCATE - ftruncate (dump_file, length); -#endif - result = ((close (dump_file)) == 0); -#if defined(HAVE_TRUNCATE) && !defined(HAVE_FTRUNCATE) - truncate (dump_file_name, length); -#endif - - if (length == 0) - unlink (dump_file_name); - dump_file_name = 0; - - fixes = fixup; - - next_buffer: - - while (fixes != fixup_buffer_end) - { - fix_address = ((SCHEME_OBJECT *) (*fixes++)); - (*fix_address) = (*fixes++); - } - - if (fixup_count >= 0) - { - if ((retrying_file_operation - (eta_read, - real_gc_file, - ((char *) fixup_buffer), - (gc_file_start_position + (fixup_count << gc_buffer_byte_shift)), - gc_buffer_bytes, - "read", - "the fixup buffer", - (&gc_file_current_position), - io_error_retry_p)) - != ((long) gc_buffer_bytes)) - { - gc_death - (TERM_EXIT, - "fasdump: Could not read back the fasdump fixup information", - 0, 0); - /*NOTREACHED*/ - } - fixup_count -= 1; - fixes = fixup_buffer; - goto next_buffer; - } - - fixup = fixes; - Fasdump_Exit_Hook (); - return (result); -} - -static int -DEFUN_VOID (reset_fixes) -{ - long start; - - fixup_count += 1; - start = (gc_file_start_position + (fixup_count << gc_buffer_byte_shift)); - - if (((start + ((long) gc_buffer_bytes)) > gc_file_end_position) - || ((retrying_file_operation - (eta_write, - real_gc_file, - ((char *) fixup_buffer), - start, - gc_buffer_bytes, - "write", - "the fixup buffer", - (&gc_file_current_position), - io_error_always_abort)) - != ((long) gc_buffer_bytes))) - return (0); - fixup = fixup_buffer_end; - return (1); -} - -static ssize_t -DEFUN (eta_read, (fid, buffer, size), - int fid AND - char * buffer AND - int size) -{ - return (read (fid, buffer, size)); -} - -static ssize_t -DEFUN (eta_write, (fid, buffer, size), - int fid AND - char * buffer AND - int size) -{ - return (write (fid, buffer, size)); -} - -#define MAYBE_DUMP_FREE(free) \ -{ \ - if (free >= free_buffer_top) \ - DUMP_FREE (free); \ -} - -#define DUMP_FREE(free) do \ -{ \ - Boolean _s = 1; \ - free = (dump_and_reset_free_buffer (free, (&_s))); \ - if (!_s) \ - return (PRIM_INTERRUPT); \ -} while (0) - -#define MAYBE_DUMP_SCAN(scan) \ -{ \ - if (scan >= scan_buffer_top) \ - DUMP_SCAN (scan); \ -} - -#define DUMP_SCAN(scan) do \ -{ \ - Boolean _s = 1; \ - scan = (dump_and_reload_scan_buffer (scan, (&_s))); \ - if (!_s) \ - return (PRIM_INTERRUPT); \ -} while (0) - -#define PUSH_FIXUP_DATA(ptr) \ -{ \ - if ((fixup == fixup_buffer) && (!reset_fixes ())) \ - return (PRIM_INTERRUPT); \ - (*--fixup) = (* (ptr)); \ - (*--fixup) = ((SCHEME_OBJECT) ptr); \ -} - -#define TRANSPORT_VECTOR(new_address, free, old_start, n_words) \ -{ \ - SCHEME_OBJECT * old_ptr = old_start; \ - SCHEME_OBJECT * free_end = (free + n_words); \ - if (free_end < free_buffer_top) \ - while (free < free_end) \ - (*free++) = (*old_ptr++); \ - else \ - { \ - while (free < free_buffer_top) \ - (*free++) = (*old_ptr++); \ - free = (transport_vector_tail (free, free_end, old_ptr)); \ - if (free == 0) \ - return (PRIM_INTERRUPT); \ - } \ -} - -static SCHEME_OBJECT * -DEFUN (transport_vector_tail, (free, free_end, tail), - SCHEME_OBJECT * free AND - SCHEME_OBJECT * free_end AND - SCHEME_OBJECT * tail) -{ - unsigned long n_words = (free_end - free); - { - Boolean success = 1; - free = (dump_and_reset_free_buffer (free, (&success))); - if (!success) - return (0); - } - { - unsigned long n_blocks = (n_words >> gc_buffer_shift); - if (n_blocks > 0) - { - Boolean success = 1; - free = (dump_free_directly (tail, n_blocks, (&success))); - if (!success) - return (0); - tail += (n_blocks << gc_buffer_shift); - } - } - { - SCHEME_OBJECT * free_end = (free + (n_words & gc_buffer_mask)); - while (free < free_end) - (*free++) = (*tail++); - } - return (free); -} - -/* A copy of gc_loop, with minor modifications. */ - -static long -DEFUN (dump_loop, (scan, free_ptr, new_address_ptr), - SCHEME_OBJECT * scan AND - SCHEME_OBJECT ** free_ptr AND - SCHEME_OBJECT ** new_address_ptr) -{ - SCHEME_OBJECT * free = (*free_ptr); - SCHEME_OBJECT * new_address = (*new_address_ptr); - while (scan != free) - { - SCHEME_OBJECT object; - if (scan >= scan_buffer_top) - { - if (scan == scan_buffer_top) - DUMP_SCAN (scan); - else - { - sprintf - (gc_death_message_buffer, - "dump_loop: scan (0x%lx) > scan_buffer_top (0x%lx)", - ((unsigned long) scan), - ((unsigned long) scan_buffer_top)); - gc_death (TERM_EXIT, gc_death_message_buffer, scan, free); - /*NOTREACHED*/ - } - } - object = (*scan); - switch (OBJECT_TYPE (object)) - { - case TC_BROKEN_HEART: - if ((OBJECT_DATUM (object)) == 0) - { - scan += 1; - break; - } - if (object == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan))) - /* Does this ever happen? */ - goto end_dump_loop; - sprintf (gc_death_message_buffer, - "dump_loop: broken heart (0x%lx) in scan", - object); - gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, free); - /*NOTREACHED*/ - break; - - case TC_CHARACTER: - case TC_CONSTANT: - case TC_FIXNUM: - case TC_NULL: - case TC_RETURN_CODE: - case TC_STACK_ENVIRONMENT: - case TC_THE_ENVIRONMENT: - scan += 1; - break; - - case TC_PCOMB0: - case TC_PRIMITIVE: - (*scan++) = (dump_renumber_primitive (object)); - break; - - case TC_CELL: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - PUSH_FIXUP_DATA (old_start); - (*free++) = (old_start[0]); - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 1; - } - } - break; - - case TC_ACCESS: - case TC_ASSIGNMENT: - case TC_COMBINATION_1: - case TC_COMMENT: - case TC_COMPLEX: - case TC_DEFINITION: - case TC_DELAY: - case TC_DELAYED: - case TC_DISJUNCTION: - case TC_ENTITY: - case TC_EXTENDED_PROCEDURE: - case TC_INTERNED_SYMBOL: - case TC_IN_PACKAGE: - case TC_LAMBDA: - case TC_LEXPR: - case TC_LIST: - case TC_PCOMB1: - case TC_PROCEDURE: - case TC_RATNUM: - case TC_SCODE_QUOTE: - case TC_SEQUENCE_2: - case TC_UNINTERNED_SYMBOL: - case TC_WEAK_CONS: - transport_pair: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - PUSH_FIXUP_DATA (old_start); - (*free++) = (old_start[0]); - switch (OBJECT_TYPE (object)) - { - case TC_INTERNED_SYMBOL: - (*free++) = BROKEN_HEART_ZERO; - break; - case TC_UNINTERNED_SYMBOL: - (*free++) = UNBOUND_OBJECT; - break; - default: - (*free++) = (old_start[1]); - break; - } - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 2; - } - } - break; - - case TC_COMBINATION_2: - case TC_CONDITIONAL: - case TC_EXTENDED_LAMBDA: - case TC_HUNK3_A: - case TC_HUNK3_B: - case TC_PCOMB2: - case TC_SEQUENCE_3: - case TC_VARIABLE: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - PUSH_FIXUP_DATA (old_start); - (*free++) = (old_start[0]); - switch (OBJECT_TYPE (object)) - { - case TC_VARIABLE: - (*free++) = UNCOMPILED_VARIABLE; - (*free++) = SHARP_F; - break; - default: - (*free++) = (old_start[1]); - (*free++) = (old_start[2]); - break; - } - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 3; - } - } - break; - - case TC_QUAD: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - PUSH_FIXUP_DATA (old_start); - (*free++) = (old_start[0]); - (*free++) = (old_start[1]); - (*free++) = (old_start[2]); - (*free++) = (old_start[3]); - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 4; - } - } - break; - - case TC_BIG_FIXNUM: - case TC_CHARACTER_STRING: - case TC_COMBINATION: - case TC_CONTROL_POINT: - case TC_NON_MARKED_VECTOR: - case TC_PCOMB3: - case TC_RECORD: - case TC_VECTOR: - case TC_VECTOR_16B: - case TC_VECTOR_1B: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - PUSH_FIXUP_DATA (old_start); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - case TC_BIG_FLONUM: - case TC_COMPILED_CODE_BLOCK: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - PUSH_FIXUP_DATA (old_start); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - scan += (1 + (OBJECT_DATUM (object))); - MAYBE_DUMP_SCAN (scan); - break; - - case TC_REFERENCE_TRAP: - if ((OBJECT_DATUM (object)) > TRAP_MAX_IMMEDIATE) - goto transport_pair; - /* Otherwise it's a non-pointer. */ - scan += 1; - break; - - case TC_COMPILED_ENTRY: - compiled_code_present_p = true; - { - SCHEME_OBJECT * old_start; - Get_Compiled_Block (old_start, (OBJECT_ADDRESS (object))); - if (BROKEN_HEART_P (*old_start)) - (*scan++) - = (RELOCATE_COMPILED (object, - (OBJECT_ADDRESS (*old_start)), - old_start)); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - PUSH_FIXUP_DATA (old_start); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) - = (RELOCATE_COMPILED (object, new_address, old_start)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - case TC_LINKAGE_SECTION: - switch (READ_LINKAGE_KIND (object)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - /* `count' typeless pointers to hunk3s follow. */ - unsigned long count = (READ_CACHE_LINKAGE_COUNT (object)); - scan += 1; - while (count > 0) - { - SCHEME_OBJECT * old_start; - MAYBE_DUMP_SCAN (scan); - old_start = (SCHEME_ADDR_TO_ADDR (*scan)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) - = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (*old_start))); - else - { - PUSH_FIXUP_DATA (old_start); - (*free++) = (old_start[0]); - (*free++) = (old_start[1]); - (*free++) = (old_start[2]); - MAYBE_DUMP_FREE (free); - (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 3; - } - count -= 1; - } - } - break; - - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: - { - unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object)); - char * entry = (FIRST_OPERATOR_LINKAGE_ENTRY (scan)); - long delta; - - if (count > 0) - compiled_code_present_p = true; - - { - int extend_p = (entry >= ((char *) scan_buffer_top)); - long delta1 = (((char *) scan) - entry); - if (extend_p) - extend_scan_buffer (entry, free); - BCH_START_OPERATOR_RELOCATION (scan); - if (extend_p) - { - entry = (end_scan_buffer_extension (entry)); - scan = ((SCHEME_OBJECT *) (entry + delta1)); - } - } - - /* END_OPERATOR_LINKAGE_AREA assumes that we will add - one to the result, so do that now. */ - delta - = (((END_OPERATOR_LINKAGE_AREA (scan, count)) + 1) - - scan_buffer_top); - - /* The operator entries are copied sequentially, but - extra hair is required because the entry addresses - are encoded. */ - while (count > 0) - { - char * next_entry = (NEXT_LINKAGE_OPERATOR_ENTRY (entry)); - int extend_p = (next_entry >= ((char *) scan_buffer_top)); - SCHEME_OBJECT esaddr; - SCHEME_OBJECT * old_start; - - /* Guarantee that the scan buffer is large enough - to hold the entry. */ - if (extend_p) - extend_scan_buffer (next_entry, free); - - /* Get the entry address. */ - BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS (esaddr, entry); - - /* Get the code-block pointer for this entry. */ - Get_Compiled_Block - (old_start, (SCHEME_ADDR_TO_ADDR (esaddr))); - - /* Copy the block. */ - if (BROKEN_HEART_P (*old_start)) - { - BCH_STORE_OPERATOR_LINKAGE_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, - (OBJECT_ADDRESS (*old_start)), - old_start)), - entry); - } - else - { - unsigned long n_words - = (1 + (OBJECT_DATUM (*old_start))); - PUSH_FIXUP_DATA (old_start); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR - (new_address, free, old_start, n_words); - BCH_STORE_OPERATOR_LINKAGE_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, new_address, old_start)), - entry); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - - if (extend_p) - { - entry = (end_scan_buffer_extension (next_entry)); - delta -= gc_buffer_size; - } - else - entry = next_entry; - - count -= 1; - } - scan = (scan_buffer_top + delta); - MAYBE_DUMP_SCAN (scan); - BCH_END_OPERATOR_RELOCATION (scan); - } - break; - - case CLOSURE_PATTERN_LINKAGE_KIND: - scan += (1 + (READ_CACHE_LINKAGE_COUNT (object))); - MAYBE_DUMP_SCAN (scan); - break; - - default: - gc_death (TERM_EXIT, "dump_loop: Unknown compiler linkage kind.", - scan, free); - /*NOTREACHED*/ - scan += 1; - break; - } - break; - - case TC_MANIFEST_CLOSURE: - { - unsigned long count; - char * entry; - char * closure_end; - - { - unsigned long delta = (2 * (sizeof (format_word))); - char * count_end = (((char *) (scan + 1)) + delta); - int extend_p = (count_end >= ((char *) scan_buffer_top)); - - /* Guarantee that the scan buffer is large enough to - hold the count field. */ - if (extend_p) - extend_scan_buffer (count_end, free); - - BCH_START_CLOSURE_RELOCATION (scan); - count = (MANIFEST_CLOSURE_COUNT (scan + 1)); - entry = (FIRST_MANIFEST_CLOSURE_ENTRY (scan + 1)); - - if (extend_p) - { - long dw = (entry - count_end); - count_end = (end_scan_buffer_extension (count_end)); - entry = (count_end + dw); - } - scan = ((SCHEME_OBJECT *) (count_end - delta)); - } - - if (count > 0) - compiled_code_present_p = true; - - closure_end = ((char *) (MANIFEST_CLOSURE_END (scan, count))); - - /* The closures are copied sequentially, but extra hair is - required because the code-entry pointers are encoded as - machine instructions. */ - while (count > 0) - { - char * entry_end = (CLOSURE_ENTRY_END (entry)); - int extend_p = (entry_end >= ((char *) scan_buffer_top)); - SCHEME_OBJECT esaddr; - SCHEME_OBJECT * old_start; - long delta1 = (entry - entry_end); - long delta2 = (closure_end - entry_end); - - /* If the closure overflows the scan buffer, extend - the buffer to the end of the closure. */ - if (extend_p) - extend_scan_buffer (entry_end, free); - - /* Extract the code-entry pointer and convert it to a - C pointer. */ - BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS (esaddr, entry); - Get_Compiled_Block (old_start, (SCHEME_ADDR_TO_ADDR (esaddr))); - - /* Copy the code entry. Use machine-specific macro to - update the pointer. */ - if (BROKEN_HEART_P (*old_start)) - BCH_STORE_CLOSURE_ENTRY_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, (OBJECT_ADDRESS (*old_start)), old_start)), - entry); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - PUSH_FIXUP_DATA (old_start); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - BCH_STORE_CLOSURE_ENTRY_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, new_address, old_start)), - entry); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - - if (extend_p) - { - entry_end = (end_scan_buffer_extension (entry_end)); - entry = (entry_end + delta1); - closure_end = (entry_end + delta2); - } - - entry = (NEXT_MANIFEST_CLOSURE_ENTRY (entry)); - count -= 1; - } - scan = ((SCHEME_OBJECT *) closure_end); - MAYBE_DUMP_SCAN (scan); - BCH_END_CLOSURE_RELOCATION (scan); - } - break; - - case TC_ENVIRONMENT: - /* Make fasdump fail */ - return (ERR_FASDUMP_ENVIRONMENT); - - case TC_FUTURE: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else if (Future_Spliceable (object)) - (*scan) = (Future_Value (object)); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - PUSH_FIXUP_DATA (old_start); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - default: - GC_BAD_TYPE ("dump_loop", object); - scan += 1; - break; - } - } - - end_dump_loop: - (*free_ptr) = free; - (*new_address_ptr) = new_address; - return (PRIM_DONE); -} diff --git a/v7/src/microcode/bchdrn.c b/v7/src/microcode/bchdrn.c deleted file mode 100644 index f80e3b04e..000000000 --- a/v7/src/microcode/bchdrn.c +++ /dev/null @@ -1,551 +0,0 @@ -/* -*- C -*- - -$Id: bchdrn.c,v 1.14 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Drone program for overlapped I/O in bchscheme. */ - -#include "ux.h" -#include "bchdrn.h" -#if 0 -/* ux.h includes indirectly */ -# include -#endif - -#define DEBUG -/* #define DEBUG_1 */ -/* #define DEBUG_2 */ - -extern char * EXFUN (error_name, (int)); -extern int EXFUN (retrying_file_operation, - (ssize_t EXFUN ((*), (int, char *, int)), - int, char *, long, long, char *, char *, long *, - int EXFUN ((*), (char *, char *)))); - -#ifdef USE_SYSV_SHARED_MEMORY - -static struct -{ - char * program_name; - char * file_name; /* gc file name */ - int shmid; /* shared memory descriptor */ - int tdron; /* total number of drones */ - int nbuf; /* total number of buffers */ - long bufsiz; /* size of each buffer in bytes */ - int sdron; /* index of first drone to start */ - int ndron; /* number of drones to start */ - int keep_p; /* keep the gc file if Scheme dies? */ -} arguments; - -struct argdesc -{ - char * name; - char * format; - PTR location; -}; - -static char string_a[] = "%s"; -#define STRING_FMT &string_a[0] - -static char decimal_int_a[] = "%d"; -#define DECIMAL_INT_FMT &decimal_int_a[0] - -static char decimal_long_a[] = "%ld"; -#define DECIMAL_LONG_FMT &decimal_long_a[0] - -static struct argdesc command_line[] = -{ - { "program_name", STRING_FMT, &arguments.program_name }, - { "file_name", STRING_FMT, &arguments.file_name }, - { "shmid", DECIMAL_INT_FMT, &arguments.shmid }, - { "tdron", DECIMAL_INT_FMT, &arguments.tdron }, - { "nbuf", DECIMAL_INT_FMT, &arguments.nbuf }, - { "bufsiz", DECIMAL_LONG_FMT, &arguments.bufsiz }, - { "sdron", DECIMAL_INT_FMT, &arguments.sdron }, - { "ndron", DECIMAL_INT_FMT, &arguments.ndron }, - { "keep_gc_file", DECIMAL_INT_FMT, &arguments.keep_p } -}; - -static int gc_fid = -1; -static char * shared_memory; -static struct buffer_info * gc_buffers; -static struct drone_info * myself; -static unsigned long * drone_version, * wait_mask; -static jmp_buf abort_point; -static pid_t boss_pid; - -static void EXFUN (kill_program, (int sig)); - -static void -DEFUN (posix_signal, (signum, handler), - int signum AND void EXFUN ((*handler), ())) -{ - struct sigaction new; - - new.sa_handler = handler; - UX_sigemptyset (&new.sa_mask); - UX_sigaddset ((&new.sa_mask), SIGCONT); - UX_sigaddset ((&new.sa_mask), SIGQUIT); - new.sa_flags = SA_NOCLDSTOP; - - if ((UX_sigaction (signum, &new, 0)) == -1) - { - fprintf (stderr, "%s (%d, posix_signal): sigaction failed. errno = %s.\n", - arguments.program_name, myself->index, (error_name (errno))); - fflush (stderr); - kill_program (0); - /*NOTREACHED*/ - } - return; -} - -static void -DEFUN (kill_program, (sig), int sig) -{ - myself->state = drone_dead; - if (gc_fid != -1) - close (gc_fid); - shmdt (shared_memory); - if (sig == -1) - { - shmctl (arguments.shmid, IPC_RMID, ((struct shmid_ds *) 0)); - if (!arguments.keep_p) - unlink (arguments.file_name); - } - exit (0); - /*NOTREACHED*/ -} - -static void -DEFUN (abort_operation, (sig), int sig) -{ - RE_INSTALL_HANDLER (SIGQUIT, abort_operation); - myself->state = drone_aborting; - longjmp (abort_point, 1); - /*NOTREACHED*/ -} - -static void -DEFUN (continue_running, (sig), int sig) -{ - RE_INSTALL_HANDLER (SIGCONT, continue_running); - longjmp (abort_point, 1); - /*NOTREACHED*/ -} - -static int -DEFUN (always_one, (operation_name, noise), - char * operation_name AND char * noise) -{ - return (1); -} - -static void -DEFUN (process_requests, (drone), struct drone_info * drone) -{ - sigset_t non_blocking_signal_mask, blocking_signal_mask; - int result, count, buffer_index, flags; - long current_position = -1; - struct timeval timeout; - struct stat file_info; - unsigned long read_mask, my_mask; - - myself = drone; - my_mask = (((unsigned long) 1) << drone->index); - drone->DRONE_PID = (getpid ()); - gc_fid = (open (arguments.file_name, O_RDWR, 0644)); - if (gc_fid == -1) - { - fprintf (stderr, - "%s (%d, process_requests): open failed. errno = %s.\n", - arguments.program_name, drone->index, (error_name (errno))); - fflush (stderr); - if (drone->DRONE_PPID == boss_pid) - (void) (kill (boss_pid, SIGCONT)); - kill_program (0); - /*NOTREACHED*/ - } -#ifdef DEBUG_1 - printf ("%s (%d, process_requests): Starting (pid = %d, ppid = %d).\n", - arguments.program_name, drone->index, - drone->DRONE_PID, drone->DRONE_PPID); - fflush (stdout); -#endif - if ((result = (fstat (gc_fid, &file_info))) == -1) - { - fprintf (stderr, - "%s (%d, process_requests): fstat failed. errno = %s.\n", - arguments.program_name, drone->index, (error_name (errno))); - fflush (stderr); - } - /* Force O_SYNC only if we are dealing with a raw device. */ - - if ((result == -1) || ((file_info.st_mode & S_IFMT) == S_IFCHR)) - { - if ((flags = (fcntl (gc_fid, F_GETFL, 0))) == -1) - { - fprintf - (stderr, - "%s (%d, process_requests): fcntl (F_GETFL) failed. errno = %s.\n", - arguments.program_name, drone->index, (error_name (errno))); - fflush (stderr); - } - else - { - flags |= O_SYNC; - if ((fcntl (gc_fid, F_SETFL, flags)) == -1) - { - fprintf - (stderr, - "%s (%d, process_requests): fcntl (F_SETFL) failed. errno = %s.\n", - arguments.program_name, drone->index, (error_name (errno))); - fflush (stderr); - } - } - } - - UX_sigemptyset (&non_blocking_signal_mask); - UX_sigemptyset (&blocking_signal_mask); - UX_sigaddset ((&blocking_signal_mask), SIGCONT); - UX_sigaddset ((&blocking_signal_mask), SIGQUIT); - UX_sigprocmask (SIG_SETMASK, (&blocking_signal_mask), 0); - posix_signal (SIGQUIT, abort_operation); - posix_signal (SIGCONT, continue_running); - - if ((setjmp (abort_point)) == 0) - { - count = drone->index; - drone->state = drone_idle; - if (drone->DRONE_PPID == boss_pid) - (void) (kill (boss_pid, SIGCONT)); - } - else - goto redo_dispatch; - - for (; 1; count++) - { - timeout.tv_sec = 6; - timeout.tv_usec = 0; - - UX_sigprocmask (SIG_SETMASK, (&non_blocking_signal_mask), 0); - result = (select (0, 0, 0, 0, &timeout)); - UX_sigprocmask (SIG_SETMASK, (&blocking_signal_mask), 0); - - if ((drone->state != drone_idle) - || ((result == -1) && (errno == EINTR))) - { - if (result != -1) - { - fprintf (stderr, - "\n%s (%d, process_requests): request after timeout %d.\n", - arguments.program_name, drone->index, drone->state); - fflush (stderr); - } -redo_dispatch: - switch (drone->state) - { - default: - fprintf (stderr, - "\n%s (%d, process_requests): Unknown/bad operation %d.\n", - arguments.program_name, drone->index, drone->state); - fflush (stderr); - kill_program (0); - /*NOTREACHED*/ - - case drone_idle: - break; - - case drone_aborting: -#ifdef DEBUG_1 - printf ("\n%s (%d, process_requests): Aborting.", - arguments.program_name, drone->index); - fflush (stdout); -#endif - drone->buffer_index = -1; - current_position = -1; - break; - - case drone_reading: - case drone_writing: - { - /* Can't use buffer->bottom because the shared memory may be - attached at a different address! - */ - - int saved_errno; - enum drone_state operation; - char * operation_name, * buffer_address; - struct buffer_info * buffer; - struct gc_queue_entry * entry; - - operation = drone->state; - buffer_index = (drone->buffer_index); - buffer = (gc_buffers + buffer_index); - - entry = ((struct gc_queue_entry *) - (((char *) drone) + (drone->entry_offset))); - entry->error_code = 0; - - operation_name = ((operation == drone_reading) ? "read" : "write"); - buffer_address = (shared_memory + (arguments.bufsiz * buffer_index)); -#ifdef DEBUG_1 - printf ("\n%s (%d, process_requests %s): Buffer index = %d.\n", - arguments.program_name, drone->index, operation_name, - buffer_index); - printf ("\tBuffer address = 0x%lx; Position = 0x%lx; Size = 0x%lx.", - buffer_address, buffer->position, buffer->size); - fflush (stdout); -#endif - - UX_sigprocmask (SIG_SETMASK, (&non_blocking_signal_mask), 0); - result = (retrying_file_operation - (((operation == drone_reading) ? read : write), - gc_fid, buffer_address, - buffer->position, buffer->size, operation_name, NULL, - ¤t_position, always_one)); - saved_errno = errno; - UX_sigprocmask (SIG_SETMASK, (&blocking_signal_mask), 0); - - if (result == -1) - { - buffer->state = ((operation == drone_reading) - ? buffer_read_error - : buffer_write_error); - drone->buffer_index = -1; - entry->drone_index = -1; - entry->error_code = saved_errno; - entry->state = entry_error; - current_position = -1; -#ifdef DEBUG - printf ("\n%s (%d, process_requests): %s error (errno = %s).\n", - arguments.program_name, drone->index, operation_name, - (error_name (saved_errno))); - fflush (stdout); -#endif - } - - else - { - buffer->state = ((operation == drone_reading) - ? buffer_ready - : buffer_idle); - drone->buffer_index = -1; - entry->drone_index = -1; - if (operation == drone_writing) - { - entry->retry_count = 0; - entry->state = entry_idle; - } - -#ifdef DEBUG_1 - printf ("\n%s (%d, process_requests %s): Done.", - arguments.program_name, drone->index, operation_name); - fflush (stdout); -#endif - } - } - } - - count = 0; - drone->state = drone_idle; - read_mask = (* wait_mask); - if ((read_mask & my_mask) == my_mask) - (void) (kill (boss_pid, SIGCONT)); - } - else if (result == 0) - { - if (count == arguments.tdron) - { - count = 0; - if ((kill (boss_pid, 0)) == -1) - kill_program (-1); - } - read_mask = (* wait_mask); - if ((read_mask & my_mask) == my_mask) - { - fprintf (stderr, - "\n%s (%d, process_requests): signal deadlock (%s)!\n", - arguments.program_name, drone->index, - ((read_mask == ((unsigned long) -1)) ? "any" : "me")); - fflush (stderr); - drone->state = drone_idle; /* !! */ - (void) (kill (boss_pid, SIGCONT)); - } - } - } -} - -static void -DEFUN_VOID (start_drones) -{ - pid_t my_pid; - int counter, cpid; - struct drone_info *gc_drones, *drone; - - my_pid = (getpid ()); - - shared_memory = (shmat (arguments.shmid, ((char *) 0), 0)); - if (shared_memory == ((char *) -1)) - { - fprintf (stderr, - "\ -%s (start_drones): Unable to attach shared memory segment %d (errno = %s).\n", - arguments.program_name, arguments.shmid, (error_name (errno))); - fflush (stderr); - sleep (10); - kill (boss_pid, SIGCONT); - exit (1); - } -#ifdef DEBUG_1 - printf ("%s (start_drones): Attached shared memory at address = 0x%lx.\n", - arguments.program_name, ((long) shared_memory)); - fflush (stdout); -#endif - posix_signal (SIGINT, SIG_IGN); - posix_signal (SIGQUIT, SIG_IGN); - posix_signal (SIGHUP, kill_program); - posix_signal (SIGTERM, kill_program); - - gc_buffers = ((struct buffer_info *) - (shared_memory + (arguments.nbuf * arguments.bufsiz))); - gc_drones = ((struct drone_info *) (gc_buffers + arguments.nbuf)); - drone_version = ((unsigned long *) (gc_drones + arguments.tdron)); - wait_mask = (drone_version + 1); - if ((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER)) - { - fprintf (stderr, - "%s (start_drones): stored drone version != drone version.\n", - arguments.program_name); - fprintf (stderr, "\t*drone_version = %ld; DRONE_VERSION_NUMBER = %ld.\n", - (* drone_version), ((unsigned long) DRONE_VERSION_NUMBER)); - fflush (stderr); - kill (boss_pid, SIGCONT); - exit (1); - } - - for (counter = 1, drone = (gc_drones + (arguments.sdron + 1)); - counter < arguments.ndron; - counter++, drone ++) - { - if ((cpid = (fork ())) == 0) - { - drone->DRONE_PPID = my_pid; - process_requests (drone); - /*NOTREACHED*/ - } - else if (cpid == -1) - { - fprintf (stderr, - "%s (start_drones): fork failed; errno = %s.\n", - arguments.program_name, (error_name (errno))); - fflush (stderr); - } - } - drone = (gc_drones + arguments.sdron); - drone->DRONE_PPID = boss_pid; - /* This is non-portable behavior to prevent zombies from being created. */ - if (arguments.ndron != 1) - posix_signal (SIGCHLD, SIG_IGN); - process_requests (drone); - /*NOTREACHED*/ -} - -int -DEFUN (main, (argc, argv), int argc AND char ** argv) -{ - int count, nargs; - static char err_buf[1024]; -#if defined(DEBUG) || defined(DEBUG_1) || defined(DEBUG_2) - static char out_buf[1024]; - - setvbuf (stdout, &out_buf[0], _IOFBF, (sizeof (out_buf))); -#endif - setvbuf (stderr, &err_buf[0], _IOFBF, (sizeof (err_buf))); - -#ifdef DEBUG_2 - printf ("%s (main): Arguments =\n", argv[0]); - for (count = 1; count < argc; count++) - printf ("\t%s\n", argv[count]); - fflush (stdout); -#endif - - nargs = ((sizeof (command_line)) / (sizeof (struct argdesc))); - boss_pid = (getppid ()); - if (argc != nargs) - { - fprintf (stderr, - "%s (main): Wrong number of arguments (got %d, expected %d).\n", - argv[0], (argc - 1), (nargs - 1)); - fflush (stderr); - kill (boss_pid, SIGCONT); - exit (1); - } - for (count = 0; count < nargs; count++) - { - if (command_line[count].format == STRING_FMT) - (* ((char **) command_line[count].location)) = argv[count]; - else - sscanf (argv[count], - command_line[count].format, - command_line[count].location); - } - -#ifdef DEBUG_2 - printf ("%s (main): Parsed arguments =\n", argv[0]); - for (count = 0; count < nargs; count++) - { - if (command_line[count].format == STRING_FMT) - printf ("\t%s\t= %s\n", - command_line[count].name, - (* ((char **) (command_line[count].location)))); - else - printf ("\t%s\t= %d\n", - command_line[count].name, - (* ((int *) (command_line[count].location)))); - } - fflush (stdout); -#endif - - start_drones (); - /*NOTREACHED*/ - return (0); -} - -#define MAIN main - -#endif /* USE_SYSV_SHARED_MEMORY */ - -#ifndef MAIN - -int -DEFUN (main, (argc, argv), int argc AND char ** argv) -{ - fprintf (stderr, "%s: Not implemented.\n", (argv[0])); - fflush (stderr); - exit (1); - return (1); -} - -#endif /* MAIN */ diff --git a/v7/src/microcode/bchdrn.h b/v7/src/microcode/bchdrn.h deleted file mode 100644 index 370af2196..000000000 --- a/v7/src/microcode/bchdrn.h +++ /dev/null @@ -1,178 +0,0 @@ -/* -*-C-*- - -$Id: bchdrn.h,v 1.14 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Header file for overlapped I/O in bchscheme. */ - -#ifndef _BCHDRN_H_INCLUDED -#define _BCHDRN_H_INCLUDED - -#include "config.h" -#include -#include - -#ifdef HAVE_UNISTD_H -# include -#else -# ifdef __unix__ - extern ssize_t EXFUN (read, (int, PTR, size_t)); - extern ssize_t EXFUN (write, (int, PTR, size_t)); -# endif -#endif - -#ifdef HAVE_POSIX_SIGNALS -# define RE_INSTALL_HANDLER(signum,handler) do { } while (0) -#else -# define RE_INSTALL_HANDLER(signum,handler) signal (signum, handler) -#endif - -/* Doesn't work on GNU/Linux or on FreeBSD. Disable until we can - figure out what is going on. */ -#define AVOID_SYSV_SHARED_MEMORY - -#if !defined(AVOID_SYSV_SHARED_MEMORY) && defined(HAVE_SHMAT) -# define USE_SYSV_SHARED_MEMORY -#endif - -#if defined(__HPUX__) - -# define HAVE_PREALLOC - -# include -# if defined(SHL_MAGIC) -# define hpux8 1 -# endif - -/* Page tables can have no gaps in HP-UX < 8.0, leave a gap for malloc. */ - -# if defined(hp9000s300) || defined(__hp9000s300) -# ifdef hpux8 -# define ATTACH_POINT 0x60000000 -# else /* not hpux8 */ -# define MALLOC_SPACE (2 << 20) /* 2 Meg */ -# endif /* hpux8 */ -# endif /* hp9000s300 */ - -#endif /* __HPUX__ */ - -#ifdef USE_SYSV_SHARED_MEMORY - -#define DRONE_VERSION_NUMBER ((1 << 8) | 2) - -#include -#include -#include -#include -#include -#include - -#ifndef MALLOC_SPACE -# define MALLOC_SPACE 0 -#endif - -#ifndef ATTACH_POINT -# define ATTACH_POINT 0 -#endif - -#define DRONE_EXTRA_T - -struct drone_extra_s -{ - pid_t my_pid; - pid_t my_ppid; -}; - -typedef struct drone_extra_s drone_extra_t; - -#define DRONE_PID drone_extra.my_pid -#define DRONE_PPID drone_extra.my_ppid - -#endif /* USE_SYSV_SHARED_MEMORY */ - -/* Shared definitions for all versions */ - -enum buffer_state -{ - buffer_idle, /* 0 */ - buffer_busy, /* 1, used for scan or free */ - buffer_ready, /* 2, after being read */ - buffer_queued, /* 3, never written, use as if read */ - buffer_being_read, /* 4 */ - buffer_read_error, /* 5 */ - buffer_being_written, /* 6 */ - buffer_write_error /* 7 */ -}; - -struct buffer_info -{ - int index; - enum buffer_state state; - long position; - long size; - PTR bottom; - PTR top; - PTR end; -}; - -enum drone_state -{ - drone_dead, /* 0 */ - drone_not_ready, /* 1 */ - drone_idle, /* 2 */ - drone_reading, /* 3 */ - drone_writing, /* 4 */ - drone_aborting /* 5 */ -}; - -struct drone_info -{ - int index; -#ifdef DRONE_EXTRA_T - drone_extra_t drone_extra; -#endif - enum drone_state state; - int buffer_index; - long entry_offset; -}; - -enum queue_entry_state -{ - entry_idle, /* 0 */ - entry_busy, /* 1 */ - entry_error /* 2 */ -}; - -struct gc_queue_entry -{ - int index; - enum queue_entry_state state; - struct buffer_info * buffer; - int drone_index; - int error_code; - int retry_count; -}; - -#endif /* _BCHDRN_H_INCLUDED */ diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h deleted file mode 100644 index 5c83724ea..000000000 --- a/v7/src/microcode/bchgcc.h +++ /dev/null @@ -1,254 +0,0 @@ -/* -*-C-*- - -$Id: bchgcc.h,v 9.67 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -#ifndef SCM_BCHGCC_H -#define SCM_BCHGCC_H - -#include "config.h" -#include "gccode.h" - -#ifdef HAVE_SYS_FILE_H -# include -#endif -#ifdef HAVE_FCNTL_H -# include -#endif - -#ifdef __WIN32__ -# define IO_PAGE_SIZE 4096 -#endif -#ifdef __OS2__ -# define IO_PAGE_SIZE 4096 -#endif -#ifndef IO_PAGE_SIZE -# include -#endif - -#ifndef BCH_START_CLOSURE_RELOCATION -# define BCH_START_CLOSURE_RELOCATION(scan) do { } while (0) -#endif - -#ifndef BCH_END_CLOSURE_RELOCATION -# define BCH_END_CLOSURE_RELOCATION(scan) do { } while (0) -#endif - -#ifndef BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS -# define BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS EXTRACT_CLOSURE_ENTRY_ADDRESS -#endif - -#ifndef BCH_STORE_CLOSURE_ENTRY_ADDRESS -# define BCH_STORE_CLOSURE_ENTRY_ADDRESS STORE_CLOSURE_ENTRY_ADDRESS -#endif - - -#ifndef BCH_START_OPERATOR_RELOCATION -# define BCH_START_OPERATOR_RELOCATION(scan) do { } while (0) -#endif - -#ifndef BCH_END_OPERATOR_RELOCATION -# define BCH_END_OPERATOR_RELOCATION(scan) do { } while (0) -#endif - -#ifndef BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS -# define BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS EXTRACT_OPERATOR_LINKAGE_ADDRESS -#endif - -#ifndef BCH_STORE_OPERATOR_LINKAGE_ADDRESS -# define BCH_STORE_OPERATOR_LINKAGE_ADDRESS STORE_OPERATOR_LINKAGE_ADDRESS -#endif - -extern char * EXFUN (error_name, (int)); - -typedef ssize_t EXFUN (file_operation_t, (int, char *, int)); - -extern int EXFUN (retrying_file_operation, - (file_operation_t *, - int, char *, long, long, char *, char *, long *, - int EXFUN ((*), (char *, char *)))); - -extern int EXFUN (io_error_retry_p, (char *, char *)); -extern int EXFUN (io_error_always_abort, (char *, char *)); - -extern char * EXFUN (make_gc_file_name, (CONST char *)); -extern int EXFUN (allocate_gc_file, (char *)); -extern void EXFUN (protect_gc_file_name, (CONST char *)); - -struct saved_scan_state -{ - SCHEME_OBJECT * virtual_scan_pointer; - unsigned long scan_position; - unsigned long scan_offset; -}; - -extern void EXFUN - (save_scan_state, (struct saved_scan_state * state, SCHEME_OBJECT * scan)); -extern SCHEME_OBJECT * EXFUN - (restore_scan_state, (struct saved_scan_state * state)); -extern void EXFUN - (set_fixed_scan_area, (SCHEME_OBJECT * bottom, SCHEME_OBJECT * top)); - -#ifndef O_BINARY -# define O_BINARY 0 -#endif - -#define GC_FILE_FLAGS (O_RDWR | O_CREAT | O_BINARY) /* O_SYNCIO removed */ -#define GC_FILE_MASK 0644 /* Everyone reads, owner writes */ - -/* IO_PAGE_SIZE must be a power of 2! */ - -#ifndef IO_PAGE_SIZE -# ifdef DEV_BSIZE -# define IO_PAGE_SIZE DEV_BSIZE -# else -# define IO_PAGE_SIZE 8192 -# endif -#endif - -#define ALIGN_DOWN_TO_IO_PAGE(addr) \ - (((unsigned long) (addr)) & (~(IO_PAGE_SIZE - 1))) - -#define ALIGN_UP_TO_IO_PAGE(addr) \ - (ALIGN_DOWN_TO_IO_PAGE (((unsigned long) (addr)) + (IO_PAGE_SIZE - 1))) - -#define ALIGNED_TO_IO_PAGE_P(addr) \ - (((unsigned long) (addr)) == (ALIGN_DOWN_TO_IO_PAGE (addr))) - -extern long - gc_file_end_position, - gc_file_current_position, - gc_file_start_position; - -extern unsigned long - gc_buffer_size, - gc_buffer_bytes, - gc_buffer_shift, - gc_buffer_mask, - gc_buffer_byte_shift; - -extern char - gc_death_message_buffer[]; - -extern SCHEME_OBJECT - * scan_buffer_top, - * scan_buffer_bottom, - * free_buffer_top, - * free_buffer_bottom, - * weak_pair_stack_ptr, - * weak_pair_stack_limit, - * virtual_scan_pointer; - -typedef enum { NORMAL_GC, PURE_COPY, CONSTANT_COPY } gc_mode_t; - -extern SCHEME_OBJECT * EXFUN - (gc_loop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **, - SCHEME_OBJECT *, gc_mode_t, int)); - -extern SCHEME_OBJECT - * EXFUN (dump_and_reload_scan_buffer, (SCHEME_OBJECT *, Boolean *)), - * EXFUN (dump_and_reset_free_buffer, (SCHEME_OBJECT *, Boolean *)), - * EXFUN (dump_free_directly, (SCHEME_OBJECT *, long, Boolean *)), - * EXFUN (initialize_free_buffer, (void)), - * EXFUN (initialize_scan_buffer, (SCHEME_OBJECT *)), - EXFUN (read_newspace_address, (SCHEME_OBJECT *)); - -extern void - EXFUN (GC, (int)), - EXFUN (end_transport, (Boolean *)), - EXFUN (final_reload, (SCHEME_OBJECT *, unsigned long, char *)), - EXFUN (extend_scan_buffer, (char *, SCHEME_OBJECT *)), - EXFUN (gc_death, (long, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)), - EXFUN (restore_gc_file, (void)), - EXFUN (initialize_weak_pair_transport, (SCHEME_OBJECT *)), - EXFUN (fix_weak_chain_1, (SCHEME_OBJECT *)), - EXFUN (fix_weak_chain_2, (void)), - EXFUN (GC_end_root_relocation, (SCHEME_OBJECT *, SCHEME_OBJECT *)); - -extern long - EXFUN (GC_relocate_root, (SCHEME_OBJECT **)); - -extern char - * EXFUN (end_scan_buffer_extension, (char *)); - -extern int - EXFUN (swap_gc_file, (int)); - -extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); -extern void EXFUN (reset_allocator_parameters, (void)); - -/* Some utility macros */ - -/* These work even when scan/addr point to constant space - because initialize_free_buffer (in bchmmg.c) cleverly initializes - scan_buffer_bottom, scan_buffer_top, and virtual_scan_pointer - so that the operations below do the right thing. - - These depend on (scan) and (addr) always pointing past the current - Scan pointer! - */ - -#define SCAN_POINTER_TO_NEWSPACE_ADDRESS(scan) \ - (((char *) virtual_scan_pointer) \ - + (((char *) (scan)) - ((char *) scan_buffer_bottom))) - -#define READ_NEWSPACE_ADDRESS(loc, addr) do \ -{ \ - SCHEME_OBJECT * _addr, * _scaddr; \ - \ - _addr = (addr); \ - _scaddr = (scan_buffer_bottom + ((_addr) - virtual_scan_pointer)); \ - \ - if ((_scaddr >= scan_buffer_bottom) && (_scaddr < scan_buffer_top)) \ - (loc) = (* _scaddr); \ - else if ((_addr >= Constant_Space) && (_addr < Free_Constant)) \ - (loc) = (* _addr); \ - else \ - (loc) = (read_newspace_address (_addr)); \ -} while (0) - -#ifdef FLOATING_ALIGNMENT - -#define BCH_ALIGN_FLOAT(address, pointer) \ -{ \ - while (!FLOATING_ALIGNED_P (address)) \ - { \ - (address) += 1; \ - (* ((pointer)++)) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \ - } \ -} - -#define BCH_ALIGN_FLOAT_ADDRESS(address) \ -{ \ - while (!FLOATING_ALIGNED_P (address)) \ - (address) += 1; \ -} - -#else -#define BCH_ALIGN_FLOAT(address, pointer) -#define BCH_ALIGN_FLOAT_ADDRESS(address) -#endif - -#endif /* SCM_BCHGCC_H */ diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c deleted file mode 100644 index f7f8b1b44..000000000 --- a/v7/src/microcode/bchgcl.c +++ /dev/null @@ -1,739 +0,0 @@ -/* -*-C-*- - -$Id: bchgcl.c,v 9.58 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This is the main GC loop for bchscheme. */ - -#include "scheme.h" -#include "bchgcc.h" - -#define MAYBE_DUMP_FREE(free) \ -{ \ - if (free >= free_buffer_top) \ - DUMP_FREE (free); \ -} - -#define DUMP_FREE(free) \ - free = (dump_and_reset_free_buffer (free, 0)) - -#define MAYBE_DUMP_SCAN(scan) \ -{ \ - if (scan >= scan_buffer_top) \ - DUMP_SCAN (scan); \ -} - -#define DUMP_SCAN(scan) \ - scan = (dump_and_reload_scan_buffer (scan, 0)) - -#define TRANSPORT_VECTOR(new_address, free, old_start, n_words) \ -{ \ - SCHEME_OBJECT * old_ptr = old_start; \ - SCHEME_OBJECT * free_end = (free + n_words); \ - if (free_end < free_buffer_top) \ - while (free < free_end) \ - (*free++) = (*old_ptr++); \ - else \ - { \ - while (free < free_buffer_top) \ - (*free++) = (*old_ptr++); \ - free = (transport_vector_tail (free, free_end, old_ptr)); \ - } \ -} - -static SCHEME_OBJECT * -DEFUN (transport_vector_tail, (free, free_end, tail), - SCHEME_OBJECT * free AND - SCHEME_OBJECT * free_end AND - SCHEME_OBJECT * tail) -{ - unsigned long n_words = (free_end - free); - DUMP_FREE (free); - { - unsigned long n_blocks = (n_words >> gc_buffer_shift); - if (n_blocks > 0) - { - free = (dump_free_directly (tail, n_blocks, 0)); - tail += (n_blocks << gc_buffer_shift); - } - } - { - SCHEME_OBJECT * free_end = (free + (n_words & gc_buffer_mask)); - while (free < free_end) - (*free++) = (*tail++); - } - return (free); -} - -SCHEME_OBJECT * -DEFUN (gc_loop, - (scan, free_ptr, new_address_ptr, low_heap, gc_mode, - require_normal_end), - SCHEME_OBJECT * scan AND - SCHEME_OBJECT ** free_ptr AND - SCHEME_OBJECT ** new_address_ptr AND - SCHEME_OBJECT * low_heap AND - gc_mode_t gc_mode AND - int require_normal_end) -{ - SCHEME_OBJECT * free = (*free_ptr); - SCHEME_OBJECT * new_address = (*new_address_ptr); - while (scan != free) - { - SCHEME_OBJECT object; - if (scan >= scan_buffer_top) - { - if (scan == scan_buffer_top) - DUMP_SCAN (scan); - else - { - sprintf - (gc_death_message_buffer, - "gc_loop: scan (0x%lx) > scan_buffer_top (0x%lx)", - ((unsigned long) scan), - ((unsigned long) scan_buffer_top)); - gc_death (TERM_EXIT, gc_death_message_buffer, scan, free); - /*NOTREACHED*/ - } - } - object = (*scan); - switch (OBJECT_TYPE (object)) - { - case TC_BROKEN_HEART: - if (gc_mode != NORMAL_GC) - goto end_gc_loop; - if (object == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan))) - /* Does this ever happen? */ - goto end_gc_loop; - sprintf (gc_death_message_buffer, - "gc_loop: broken heart (0x%lx) in scan", - object); - gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, free); - /*NOTREACHED*/ - break; - - case TC_CHARACTER: - case TC_CONSTANT: - case TC_FIXNUM: - case TC_NULL: - case TC_PCOMB0: - case TC_PRIMITIVE: - case TC_RETURN_CODE: - case TC_STACK_ENVIRONMENT: - case TC_THE_ENVIRONMENT: - scan += 1; - break; - - case TC_CELL: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - (*free++) = (old_start[0]); - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 1; - } - } - break; - - case TC_ACCESS: - case TC_ASSIGNMENT: - case TC_COMBINATION_1: - case TC_COMMENT: - case TC_COMPLEX: - case TC_DEFINITION: - case TC_DELAY: - case TC_DELAYED: - case TC_DISJUNCTION: - case TC_ENTITY: - case TC_EXTENDED_PROCEDURE: - case TC_IN_PACKAGE: - case TC_LAMBDA: - case TC_LEXPR: - case TC_LIST: - case TC_PCOMB1: - case TC_PROCEDURE: - case TC_RATNUM: - case TC_SCODE_QUOTE: - case TC_SEQUENCE_2: - transport_pair: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - goto really_transport_pair; - - case TC_INTERNED_SYMBOL: - case TC_UNINTERNED_SYMBOL: - if (gc_mode == PURE_COPY) - { - SCHEME_OBJECT name = (MEMORY_REF (object, SYMBOL_NAME)); - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (name)); - if ((old_start < low_heap) - || (BROKEN_HEART_P (*old_start))) - scan += 1; - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (name, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - break; - } - really_transport_pair: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - (*free++) = (old_start[0]); - (*free++) = (old_start[1]); - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 2; - } - } - break; - - case TC_COMBINATION_2: - case TC_CONDITIONAL: - case TC_EXTENDED_LAMBDA: - case TC_HUNK3_A: - case TC_HUNK3_B: - case TC_PCOMB2: - case TC_SEQUENCE_3: - case TC_VARIABLE: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - (*free++) = (old_start[0]); - (*free++) = (old_start[1]); - (*free++) = (old_start[2]); - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 3; - } - } - break; - - case TC_QUAD: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - (*free++) = (old_start[0]); - (*free++) = (old_start[1]); - (*free++) = (old_start[2]); - (*free++) = (old_start[3]); - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 4; - } - } - break; - - case TC_BIG_FIXNUM: - case TC_CHARACTER_STRING: - case TC_COMBINATION: - case TC_CONTROL_POINT: - case TC_NON_MARKED_VECTOR: - case TC_PCOMB3: - case TC_RECORD: - case TC_VECTOR: - case TC_VECTOR_16B: - case TC_VECTOR_1B: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - goto transport_vector; - - case TC_ENVIRONMENT: - if (gc_mode == PURE_COPY) - { - scan += 1; - break; - } - transport_vector: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - case TC_BIG_FLONUM: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - goto transport_aligned_vector; - - case TC_COMPILED_CODE_BLOCK: - if (gc_mode == PURE_COPY) - { - scan += 1; - break; - } - transport_aligned_vector: - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - case TC_WEAK_CONS: - if (gc_mode == PURE_COPY) - { - scan += 1; - break; - } - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else - { - SCHEME_OBJECT weak_car = (old_start[0]); - if (((OBJECT_TYPE (weak_car)) == TC_NULL) - || ((OBJECT_ADDRESS (weak_car)) < low_heap)) - { - (*free++) = weak_car; - (*free++) = (old_start[1]); - } - else if (weak_pair_stack_ptr > weak_pair_stack_limit) - { - (*--weak_pair_stack_ptr) = ((SCHEME_OBJECT) new_address); - (*--weak_pair_stack_ptr) = weak_car; - (*free++) = SHARP_F; - (*free++) = (old_start[1]); - } - else - { - (*free++) = (OBJECT_NEW_TYPE (TC_NULL, weak_car)); - (*free++) = (old_start[1]); - (old_start[1]) - = (MAKE_OBJECT_FROM_OBJECTS (weak_car, Weak_Chain)); - Weak_Chain = object; - } - MAYBE_DUMP_FREE (free); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 2; - } - } - break; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - scan += (1 + (OBJECT_DATUM (object))); - MAYBE_DUMP_SCAN (scan); - break; - - case TC_REFERENCE_TRAP: - if ((OBJECT_DATUM (object)) > TRAP_MAX_IMMEDIATE) - goto transport_pair; - /* Otherwise it's a non-pointer. */ - scan += 1; - break; - - case TC_COMPILED_ENTRY: - if (gc_mode == PURE_COPY) - { - scan += 1; - break; - } - { - SCHEME_OBJECT * old_start; - Get_Compiled_Block (old_start, (OBJECT_ADDRESS (object))); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) - = (RELOCATE_COMPILED (object, - (OBJECT_ADDRESS (*old_start)), - old_start)); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) - = (RELOCATE_COMPILED (object, new_address, old_start)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - case TC_LINKAGE_SECTION: - if (gc_mode == PURE_COPY) - { - gc_death (TERM_COMPILER_DEATH, - "gc_loop: linkage section in pure area", - scan, free); - /*NOTREACHED*/ - } - switch (READ_LINKAGE_KIND (object)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - /* `count' typeless pointers to hunk3s follow. */ - unsigned long count = (READ_CACHE_LINKAGE_COUNT (object)); - scan += 1; - while (count > 0) - { - SCHEME_OBJECT * old_start; - MAYBE_DUMP_SCAN (scan); - old_start = (SCHEME_ADDR_TO_ADDR (*scan)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) - = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (*old_start))); - else - { - (*free++) = (old_start[0]); - (*free++) = (old_start[1]); - (*free++) = (old_start[2]); - MAYBE_DUMP_FREE (free); - (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += 3; - } - count -= 1; - } - } - break; - - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: - { - unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object)); - char * entry = (FIRST_OPERATOR_LINKAGE_ENTRY (scan)); - long delta; - - { - int extend_p = (entry >= ((char *) scan_buffer_top)); - long delta1 = (((char *) scan) - entry); - if (extend_p) - extend_scan_buffer (entry, free); - BCH_START_OPERATOR_RELOCATION (scan); - if (extend_p) - { - entry = (end_scan_buffer_extension (entry)); - scan = ((SCHEME_OBJECT *) (entry + delta1)); - } - } - - /* END_OPERATOR_LINKAGE_AREA assumes that we will add - one to the result, so do that now. */ - delta - = (((END_OPERATOR_LINKAGE_AREA (scan, count)) + 1) - - scan_buffer_top); - - /* The operator entries are copied sequentially, but - extra hair is required because the entry addresses - are encoded. */ - while (count > 0) - { - char * next_entry = (NEXT_LINKAGE_OPERATOR_ENTRY (entry)); - int extend_p = (next_entry >= ((char *) scan_buffer_top)); - SCHEME_OBJECT esaddr; - SCHEME_OBJECT * old_start; - - /* Guarantee that the scan buffer is large enough - to hold the entry. */ - if (extend_p) - extend_scan_buffer (next_entry, free); - - /* Get the entry address. */ - BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS (esaddr, entry); - - /* Get the code-block pointer for this entry. */ - Get_Compiled_Block - (old_start, (SCHEME_ADDR_TO_ADDR (esaddr))); - - /* Copy the block. */ - if (old_start < low_heap) - ; - else if (BROKEN_HEART_P (*old_start)) - { - BCH_STORE_OPERATOR_LINKAGE_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, - (OBJECT_ADDRESS (*old_start)), - old_start)), - entry); - } - else - { - unsigned long n_words - = (1 + (OBJECT_DATUM (*old_start))); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR - (new_address, free, old_start, n_words); - BCH_STORE_OPERATOR_LINKAGE_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, new_address, old_start)), - entry); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - - if (extend_p) - { - entry = (end_scan_buffer_extension (next_entry)); - delta -= gc_buffer_size; - } - else - entry = next_entry; - - count -= 1; - } - scan = (scan_buffer_top + delta); - MAYBE_DUMP_SCAN (scan); - BCH_END_OPERATOR_RELOCATION (scan); - } - break; - - case CLOSURE_PATTERN_LINKAGE_KIND: - scan += (1 + (READ_CACHE_LINKAGE_COUNT (object))); - MAYBE_DUMP_SCAN (scan); - break; - - default: - gc_death (TERM_EXIT, "gc_loop: Unknown compiler linkage kind.", - scan, free); - /*NOTREACHED*/ - break; - } - break; - - case TC_MANIFEST_CLOSURE: - if (gc_mode == PURE_COPY) - { - gc_death (TERM_COMPILER_DEATH, - "gc_loop: manifest closure in pure area", - scan, free); - /*NOTREACHED*/ - } - { - unsigned long count; - char * entry; - char * closure_end; - - { - unsigned long delta = (2 * (sizeof (format_word))); - char * count_end = (((char *) (scan + 1)) + delta); - int extend_p = (count_end >= ((char *) scan_buffer_top)); - - /* Guarantee that the scan buffer is large enough to - hold the count field. */ - if (extend_p) - extend_scan_buffer (count_end, free); - - BCH_START_CLOSURE_RELOCATION (scan); - count = (MANIFEST_CLOSURE_COUNT (scan + 1)); - entry = (FIRST_MANIFEST_CLOSURE_ENTRY (scan + 1)); - - if (extend_p) - { - long dw = (entry - count_end); - count_end = (end_scan_buffer_extension (count_end)); - entry = (count_end + dw); - } - scan = ((SCHEME_OBJECT *) (count_end - delta)); - } - - closure_end = ((char *) (MANIFEST_CLOSURE_END (scan, count))); - - /* The closures are copied sequentially, but extra hair is - required because the code-entry pointers are encoded as - machine instructions. */ - while (count > 0) - { - char * entry_end = (CLOSURE_ENTRY_END (entry)); - int extend_p = (entry_end >= ((char *) scan_buffer_top)); - SCHEME_OBJECT esaddr; - SCHEME_OBJECT * old_start; - long delta1 = (entry - entry_end); - long delta2 = (closure_end - entry_end); - - /* If the closure overflows the scan buffer, extend - the buffer to the end of the closure. */ - if (extend_p) - extend_scan_buffer (entry_end, free); - - /* Extract the code-entry pointer and convert it to a - C pointer. */ - BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS (esaddr, entry); - Get_Compiled_Block (old_start, (SCHEME_ADDR_TO_ADDR (esaddr))); - - /* Copy the code entry. Use machine-specific macro to - update the pointer. */ - if (old_start < low_heap) - ; - else if (BROKEN_HEART_P (*old_start)) - BCH_STORE_CLOSURE_ENTRY_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, (OBJECT_ADDRESS (*old_start)), old_start)), - entry); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - BCH_ALIGN_FLOAT (new_address, free); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - BCH_STORE_CLOSURE_ENTRY_ADDRESS - ((RELOCATE_COMPILED_RAW_ADDRESS - (esaddr, new_address, old_start)), - entry); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - - if (extend_p) - { - entry_end = (end_scan_buffer_extension (entry_end)); - entry = (entry_end + delta1); - closure_end = (entry_end + delta2); - } - - entry = (NEXT_MANIFEST_CLOSURE_ENTRY (entry)); - count -= 1; - } - scan = ((SCHEME_OBJECT *) closure_end); - MAYBE_DUMP_SCAN (scan); - BCH_END_CLOSURE_RELOCATION (scan); - } - break; - - case TC_FUTURE: - if (gc_mode == CONSTANT_COPY) - { - scan += 1; - break; - } - { - SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object)); - if (old_start < low_heap) - scan += 1; - else if (BROKEN_HEART_P (*old_start)) - (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start))); - else if (Future_Spliceable (object)) - (*scan) = (Future_Value (object)); - else - { - unsigned long n_words = (1 + (OBJECT_DATUM (*old_start))); - TRANSPORT_VECTOR (new_address, free, old_start, n_words); - (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address)); - (*old_start) = (MAKE_BROKEN_HEART (new_address)); - new_address += n_words; - } - } - break; - - default: - GC_BAD_TYPE ("gc_loop", object); - scan += 1; - break; - } - } - end_gc_loop: - (*free_ptr) = free; - (*new_address_ptr) = new_address; - if (require_normal_end && (scan != free)) - { - gc_death (TERM_BROKEN_HEART, "gc_loop ended too early", scan, free); - /*NOTREACHED*/ - } - return (scan); -} diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c deleted file mode 100644 index 89303f0ff..000000000 --- a/v7/src/microcode/bchmmg.c +++ /dev/null @@ -1,3684 +0,0 @@ -/* -*-C-*- - -$Id: bchmmg.c,v 9.109 2007/02/10 19:22:13 riastradh Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Memory management top level. Garbage collection to disk. */ - -#include "scheme.h" -#include "prims.h" -#include "memmag.h" -#include "option.h" -#include "osenv.h" -#include "osfs.h" - -#ifdef __unix__ -# include "ux.h" -# define SUB_DIRECTORY_DELIMITER '/' -/* This makes for surprising behavior: */ -/* # define UNLINK_BEFORE_CLOSE */ -#endif - -#ifdef __WIN32__ -# include "nt.h" -# define SUB_DIRECTORY_DELIMITER '\\' -#endif - -#ifdef __OS2__ -# include "os2.h" -# define SUB_DIRECTORY_DELIMITER '\\' -# if defined(__IBMC__) || defined(__WATCOMC__) || defined(__EMX__) -# include -# include -# endif -# ifndef F_OK -# define F_OK 0 -# define X_OK 1 -# define W_OK 2 -# define R_OK 4 -# endif -#endif - -#include "bchgcc.h" -#include "bchdrn.h" - -#ifndef SEEK_SET -# define SEEK_SET 0 -#endif - -#ifdef USE_SYSV_SHARED_MEMORY -# define RECORD_GC_STATISTICS -#endif -#define MILLISEC * 1000 - -#define FLOOR(value,quant) ((quant) * ((value) / (quant))) -#define CEILING(value,quant) (FLOOR (((value) + ((quant) - 1)), (quant))) - -/* Memory management top level. Garbage collection to disk. - - The algorithm is basically the same as for the 2 space collector, - except that new space is on the disk, and there are two windows to - it (the scan and free buffers). The two windows are physically the - same whent they correspond to the same section of the address space. - There may be additional windows used to overlap I/O. - - For information on the 2 space collector, read the comments in the - replaced files. - - The memory management code is spread over the following files: - - bchgcc.h: shared header file for bchscheme. - - bchmmg.c: top level, initialization and I/O. Replaces memmag.c - - bchgcl.c: main garbage collector loop. Replaces gcloop.c - - bchpur.c: constant/pure space hacking. Replaces purify.c - - bchdmp.c: object & world image dumping. Replaces fasdump.c - - bchdrn.h: header file for bchmmg.c and the bchdrn.c. - - bchdrn.c: stand-alone program used as an overlapped I/O drone. - - bchutl.c: utilities common to bchmmg.c and bchdrn.c. - - Problems with this implementation right now: - - It only works on Unix (or systems which support Unix I/O calls). - - Dumpworld does not work because the file is not closed at dump time or - reopened at restart time. - - Command-line specified gc files are only locked on versions of Unix - that have lockf(2). If your system does not have lockf, two - processes can try to share the file and get very confused. - -oo - ------------------------------------------ - | GC Buffer Space | (not always contiguous) - | | - ------------------------------------------ <- fixed boundary (currently) - | Heap Space | - | | - ------------------------------------------ <- boundary moved by purify - | Constant + Pure Space /\ | - | || | - ------------------------------------------ <- fixed boundary (currently) - | Control Stack || | - | \/ | - ------------------------------------------ <- fixed boundary (currently) -0 - - Each area has a pointer to its starting address and a pointer to - the next free cell (for the stack, it is a pointer to the last cell - in use). The GC buffer space contains two (or more) buffers used - during the garbage collection process. One is the scan buffer and - the other is the free buffer, and they are dumped and loaded from - disk as necessary. At the beginning and at the end a single buffer - is used, since transporting will occur into the area being scanned. -*/ - -/* Exports */ - -extern void EXFUN (Clear_Memory, (int, int, int)); -extern void EXFUN (Setup_Memory, (int, int, int)); -extern void EXFUN (Reset_Memory, (void)); - -long - absolute_gc_file_end_position, - gc_file_end_position, - gc_file_current_position, - gc_file_start_position; - -unsigned long - gc_buffer_size, - gc_buffer_bytes, - gc_buffer_shift, - gc_buffer_mask, - gc_buffer_byte_shift; - -static unsigned long - gc_extra_buffer_size, - gc_buffer_overlap_bytes, - gc_buffer_remainder_bytes, - gc_total_buffer_size; - -SCHEME_OBJECT - * scan_buffer_top, * scan_buffer_bottom, - * free_buffer_top, * free_buffer_bottom, - * virtual_scan_pointer; - -static SCHEME_OBJECT - * virtual_scan_base; - -static char - * gc_file_name = 0; - -CONST char - * drone_file_name = 0; - -static int - keep_gc_file_p = 0, - gc_file = -1, - read_overlap = 0, - write_overlap = 0; - -static SCHEME_OBJECT - * aligned_heap; - -static Boolean - can_dump_directly_p, - extension_overlap_p, - scan_buffer_extended_p; - -static long - scan_position, - free_position, - pre_read_position, - extension_overlap_length; - -static long - saved_heap_size, - saved_constant_size, - saved_stack_size; - -static unsigned long - read_queue_bitmask; /* Change MAX_READ_OVERLAP if you change this. */ - -static struct buffer_info - * free_buffer, - * scan_buffer, - * next_scan_buffer; - -int -DEFUN (io_error_always_abort, (operation_name, noise), - char * operation_name AND char * noise) -{ - return (1); -} - -#ifdef __WIN32__ -#include - -int -DEFUN (io_error_retry_p, (operation_name, noise), - char * operation_name AND char * noise) -{ - char buf[512]; - extern HANDLE master_tty_window; - - sprintf (&buf[0], - "%s: GC file error (code = %d) when manipulating %s.\n" - "Choose an option (Cancel = Exit Scheme)", - operation_name, (GetLastError ()), noise); - switch (MessageBox (master_tty_window, - &buf[0], - "MIT/GNU Scheme garbage-collection problem description", - (MB_ICONSTOP | MB_ABORTRETRYIGNORE | MB_APPLMODAL))) - { - case IDABORT: - return (1); - - case IDRETRY: - return (0); - - case IDIGNORE: - Microcode_Termination (TERM_EXIT); - } - /*NOTREACHED*/ - return (0); -} - -#else /* not __WIN32__ */ -#ifdef __OS2__ - -int -io_error_retry_p (char * operation_name, char * noise) -{ - char buf [512]; - sprintf ((&buf[0]), - "%s: GC file error (code = %d) when manipulating %s.\n" - "Choose an option (Cancel = Exit Scheme)", - operation_name, errno, noise); - switch - (WinMessageBox (HWND_DESKTOP, - NULLHANDLE, - (&buf[0]), - "MIT/GNU Scheme garbage-collection problem description", - 0, - (MB_ICONHAND | MB_ABORTRETRYIGNORE | MB_APPLMODAL))) - { - case MBID_ABORT: return (1); - case MBID_RETRY: return (0); - case MBID_IGNORE: Microcode_Termination (TERM_EXIT); - } -} - -#else /* not __OS2__ */ - -extern char EXFUN (userio_choose_option, - (CONST char *, CONST char *, CONST char **)); -extern int EXFUN (userio_confirm, (CONST char *)); - -int -DEFUN (io_error_retry_p, (operation_name, noise), - char * operation_name AND char * noise) -{ - static CONST char * retry_choices [] = - { - "A = abort the operation", - "E = exit scheme", - "K = kill scheme", - "Q = quit scheme", - "R = retry the operation", - "S = sleep for 1 minute and retry the operation", - "X = exit scheme", - 0}; - - outf_error ("\n%s (%s): GC file error (errno = %s) when manipulating %s.\n", - scheme_program_name, operation_name, (error_name (errno)), - noise); - - while (1) - { - switch (userio_choose_option - ("Choose one of the following actions:", - "Action -> ", retry_choices)) - { - case 'A': - return (1); - - case '\0': - /* IO problems, assume everything is scrod. */ - outf_fatal - ("%s (io_error_retry_p): Problems reading the keyboard; Exitting.\n", - scheme_program_name); - termination_eof (); - /*NOTREACHED*/ - - case 'E': case 'K': case 'Q': case 'X': - if (!(userio_confirm ("Kill Scheme (Y/N)? "))) - continue; - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - - case 'S': - sleep (60); - /* fall through */ - - case 'R': - default: - return (0); - } - } -} - -#endif /* not __OS2__ */ -#endif /* not __WIN32__ */ - -static int -DEFUN (verify_write, (position, size, success), - long position AND long size AND Boolean * success) -{ - if ((position >= gc_file_start_position) - && ((position + size) <= gc_file_end_position)) - return (0); - outf_error ( - "\n%s (verify_write): attempting to write outside allowed area.\n", - scheme_program_name); - outf_error("\tlow position = 0x%lx; high position = 0x%lx.\n", - gc_file_start_position, gc_file_end_position); - outf_error("\twrite position = 0x%lx; size = 0x%lx = %d bytes.\n", - position, size, size); - outf_flush_error(); - if (success == ((Boolean *) NULL)) - { - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - } - *success = ((Boolean) false); - return (-1); -} - -static void -DEFUN (write_data, (from, position, nbytes, noise, success), - char * from AND long position AND long nbytes - AND char * noise AND Boolean * success) -{ - if (((verify_write (position, nbytes, success)) != -1) - && ((retrying_file_operation (((file_operation_t *) write), - gc_file, - from, - position, - nbytes, - "write", - noise, - &gc_file_current_position, - ((success == ((Boolean *) NULL)) - ? io_error_retry_p - : io_error_always_abort))) - == -1) - && (success != ((Boolean *) NULL))) - *success = false; - return; -} - -static void -DEFUN (load_data, (position, to, nbytes, noise, success), - long position AND char * to AND long nbytes - AND char * noise AND Boolean * success) -{ - (void) (retrying_file_operation (((file_operation_t *) read), - gc_file, - to, - position, - nbytes, - "read", - noise, - &gc_file_current_position, - ((success == ((Boolean *) NULL)) - ? io_error_retry_p - : io_error_always_abort))); -} - -static int -DEFUN (parameterization_termination, (kill_p, init_p), - int kill_p AND int init_p) -{ - fflush (stderr); - if (init_p) - termination_init_error (); /*NOTREACHED*/ - if (kill_p) - Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ - return (-1); -} - -struct bch_GC_statistic -{ - char * name; - long * counter; -}; - -#ifdef RECORD_GC_STATISTICS - -static void EXFUN (statistics_clear, (void)); -static void EXFUN (statistics_print, (int, char *)); - -# define STATISTICS_INCR(name) name += 1 -# define STATISTICS_CLEAR() statistics_clear () -# define STATISTICS_PRINT(level, noise) statistics_print (level, noise) - -#else - -static struct bch_GC_statistic all_gc_statistics[] = -{ { "invalid last statistic", ((long *) NULL) } }; - -# define STATISTICS_INCR(name) do { } while (0) -# define STATISTICS_CLEAR() do { } while (0) -# define STATISTICS_PRINT(level, noise) do { } while (0) - -#endif - -#ifdef USE_SYSV_SHARED_MEMORY - -#ifdef RECORD_GC_STATISTICS - -static long - reads_not_overlapped, - reads_overlapped, - reads_ready, - reads_queued, - reads_pending, - reads_overlapped_aborted, - reads_found_in_write_queue, - reads_found_ready, - read_wait_cycles, - writes_not_overlapped, - writes_overlapped, - writes_not_deferred, - writes_restarted, - writes_retried, - writes_pending, - write_wait_cycles, - pre_reads_aborted, - pre_reads_ignored, - pre_reads_found_in_write_queue, - pre_reads_found_ready, - pre_reads_not_started, - pre_reads_started, - pre_reads_deferred, - pre_reads_restarted, - pre_reads_retried, - pre_reads_not_retried, - pre_reads_requeued_as_writes, - ready_buffers_enqueued, - ready_buffers_not_enqueued, - drone_wait_cycles, - drone_request_failures, - drones_found_dead, - sleeps_interrupted, - await_io_cycles, - gc_start_time, - gc_end_transport_time, - gc_end_weak_update_time, - gc_start_reload_time, - gc_end_time; - -#define START_TRANSPORT_HOOK() \ - gc_start_time = ((long) (OS_real_time_clock ())) - -#define END_TRANSPORT_HOOK() \ - gc_end_transport_time = ((long) (OS_real_time_clock ())) - -#define END_WEAK_UPDATE_HOOK() \ - gc_end_weak_update_time = ((long) (OS_real_time_clock ())) - -#define START_RELOAD_HOOK() \ - gc_start_reload_time = ((long) (OS_real_time_clock ())) - -#define END_GC_HOOK() \ - gc_end_time = ((long) (OS_real_time_clock ())) - -static struct bch_GC_statistic all_gc_statistics[] = -{ - { "reads not overlapped", &reads_not_overlapped }, - { "reads overlapped", &reads_overlapped }, - { "reads ready", &reads_ready }, - { "reads queued", &reads_queued }, - { "reads pending", &reads_pending }, - { "reads overlapped aborted", &reads_overlapped_aborted }, - { "reads found in write queue", &reads_found_in_write_queue }, - { "reads found ready", &reads_found_ready }, - { "read wait cycles", &read_wait_cycles }, - { "writes not overlapped", &writes_not_overlapped }, - { "writes overlapped", &writes_overlapped }, - { "writes retried", &writes_retried }, - { "writes not deferred", &writes_not_deferred }, - { "writes restarted", &writes_restarted }, - { "writes retried", &writes_retried }, - { "writes pending", &writes_pending }, - { "write wait cycles", &write_wait_cycles }, - { "pre-reads aborted", &pre_reads_aborted }, - { "pre-reads ignored", &pre_reads_ignored }, - { "pre-reads found in write queue", &pre_reads_found_in_write_queue }, - { "pre-reads found ready", &pre_reads_found_ready }, - { "pre-reads not started", &pre_reads_not_started }, - { "pre-reads started", &pre_reads_started }, - { "pre-reads deferred", &pre_reads_deferred }, - { "pre-reads restarted", &pre_reads_restarted }, - { "pre-reads retried", &pre_reads_retried }, - { "pre-reads not retried", &pre_reads_not_retried }, - { "pre-reads requeued as writes", &pre_reads_requeued_as_writes }, - { "ready buffers enqueued", &ready_buffers_enqueued }, - { "ready buffers not enqueued", &ready_buffers_not_enqueued }, - { "drone wait cycles", &drone_wait_cycles }, - { "drone request failures", &drone_request_failures }, - { "drones found dead", &drones_found_dead }, - { "sleeps interrupted", &sleeps_interrupted }, - { "cycles awaiting I/O completion", &await_io_cycles }, - { "time at gc start", &gc_start_time }, - { "time at end of transport", &gc_end_transport_time }, - { "time at end of weak update", &gc_end_weak_update_time }, - { "time at start of reload", &gc_start_reload_time }, - { "time at gc end", &gc_end_time }, - { "invalid last statistic", ((long *) NULL) } -}; - -#endif /* RECORD_GC_STATISTICS */ - -/* The limit on MAX_READ_OVERLAP is the number of bits in read_queue_bitmask. - The limit on MAX_GC_DRONES is the number of bits in (* wait_mask). - There is no direct limit on MAX_WRITE_OVERLAP. - On the other hand, the explicit searches through the queues - will become slower as the numbers are increased. - */ - -#define MAX_READ_OVERLAP ((sizeof (long)) * CHAR_BIT) -#define MAX_WRITE_OVERLAP MAX_READ_OVERLAP -#define MAX_GC_DRONES ((sizeof (long)) * CHAR_BIT) -#define MAX_OVERLAPPED_RETRIES 2 - -static char * shared_memory = ((char *) -1); -static char * malloc_memory = ((char *) NULL); -static int drones_initialized_p = 0; -static int shmid = -1; -static int n_gc_buffers, n_gc_drones, gc_next_buffer, gc_next_drone; -static struct gc_queue_entry * gc_read_queue, * gc_write_queue; -static struct drone_info * gc_drones; -static struct buffer_info * gc_buffers; -static unsigned long * wait_mask, * drone_version; - -static long default_sleep_period = 20 MILLISEC; - -#define GET_SLEEP_DELTA() default_sleep_period -#define SET_SLEEP_DELTA(value) default_sleep_period = (value) - -static void -DEFUN (sleep_awaiting_drones, (microsec, mask), - unsigned int microsec AND unsigned long mask) -{ - int saved_errno; - int retval; - - *wait_mask = mask; -#ifdef HAVE_POLL - retval = (poll (0, 0, (microsec / 1000))); -#else - { - int dummy = 0; - struct timeval timeout; - timeout.tv_sec = 0; - timeout.tv_usec = microsec; - retval - = (select (0, - ((SELECT_TYPE *) &dummy), - ((SELECT_TYPE *) &dummy), - ((SELECT_TYPE *) &dummy), - &timeout)); - } -#endif - *wait_mask = ((unsigned long) 0); - saved_errno = errno; - - if ((retval == -1) && (saved_errno == EINTR)) - STATISTICS_INCR (sleeps_interrupted); -} - -#ifndef _SUNOS4 -# define SYSV_SPRINTF sprintf -#else -/* Losing SunOS sprintf */ - -# define SYSV_SPRINTF sysV_sprintf - -static int -DEFUN (sysV_sprintf, (string, format, value), - char * string AND char * format AND long value) -{ - sprintf (string, format, value); - return (strlen (string)); -} - -#endif /* _SUNOS4 */ - -#ifdef SIGCONT -static void -DEFUN (continue_running, (sig), int sig) -{ - RE_INSTALL_HANDLER (SIGCONT, continue_running); -} -#endif - -static void -DEFUN (start_gc_drones, (first_drone, how_many, restarting), - int first_drone AND int how_many AND int restarting) -{ - pid_t pid; - char arguments[512]; - struct drone_info *drone; - char - * shmid_string, /* shared memory handle */ - * tdron_string, /* total number of drones */ - * nbuf_string, /* total number of buffers */ - * bufsiz_string, /* size of each buffer in bytes */ - * sdron_string, /* index of first drone to start */ - * ndron_string; /* number of drones to start */ - - shmid_string = &arguments[0]; - tdron_string = - (shmid_string + (1 + (SYSV_SPRINTF (shmid_string, "%d", shmid)))); - nbuf_string = - (tdron_string + (1 + (SYSV_SPRINTF (tdron_string, "%d", n_gc_drones)))); - bufsiz_string = - (nbuf_string + (1 + (SYSV_SPRINTF (nbuf_string, "%d", n_gc_buffers)))); - sdron_string = - (bufsiz_string - + (1 + (SYSV_SPRINTF (bufsiz_string, "%ld", - (gc_total_buffer_size - * (sizeof (SCHEME_OBJECT))))))); - ndron_string = - (sdron_string + (1 + (SYSV_SPRINTF (sdron_string, "%d", first_drone)))); - (void) (SYSV_SPRINTF (ndron_string, "%d", how_many)); - - drone = (gc_drones + first_drone); - if (restarting && (drone->state != drone_dead)) - (void) (kill (drone->DRONE_PID, SIGTERM)); - drone->state = drone_not_ready; - (* drone_version) = ((unsigned long) DRONE_VERSION_NUMBER); - - if ((pid = (vfork ())) == 0) - { - execlp (drone_file_name, drone_file_name, gc_file_name, shmid_string, - tdron_string, nbuf_string, bufsiz_string, - sdron_string, ndron_string, (keep_gc_file_p ? "1" : "0"), - ((char *) 0)); - outf_error ("\n%s (start_gc_drones): execlp (%s) failed (errno = %s).\n", - scheme_program_name, drone_file_name, (error_name (errno))); - drone->state = drone_dead; - (void) (kill ((getppid ()), SIGCONT)); - _exit (1); - } - else if (pid == -1) - { - outf_error ("\n%s (start_gc_drones): vfork failed (errno = %s).\n", - scheme_program_name, (error_name (errno))); - drone->state = drone_dead; - } - else - { - sigset_t old_mask, new_mask; - - UX_sigemptyset (&new_mask); - UX_sigaddset ((&new_mask), SIGCONT); - UX_sigprocmask (SIG_BLOCK, (&new_mask), (&old_mask)); - if (drone->state == drone_not_ready) - UX_sigsuspend (&old_mask); - UX_sigprocmask (SIG_SETMASK, (&old_mask), 0); - - if ((drone->state != drone_idle) && !restarting) - { - /* Do the wait only at startup since Scheme handles SIGCHLD - for all children. */ - ((void) (waitpid (pid, ((int *) 0), WNOHANG))); - drone->state = drone_dead; - } - } - return; -} - -static int -DEFUN (invoke_gc_drone, - (entry, operation, buffer, position, size), - struct gc_queue_entry * entry - AND enum drone_state operation - AND struct buffer_info * buffer - AND long position - AND long size) -{ - int result, drone_index; - struct drone_info * drone; - enum buffer_state old_state; - - drone_index = (entry->drone_index); - drone = (gc_drones + drone_index); - drone->buffer_index = buffer->index; - drone->entry_offset = (((char *) entry) - ((char *) drone)); - - old_state = buffer->state; - buffer->state = ((operation == drone_reading) - ? buffer_being_read - : buffer_being_written); - buffer->position = position; - buffer->size = size; - entry->buffer = buffer; - entry->state = entry_busy; - - drone->state = operation; /* Previously drone_idle */ - if ((result = (kill (drone->DRONE_PID, SIGCONT))) == -1) - { - entry->state = entry_idle; - buffer->state = old_state; - drone->state = drone_dead; - if (errno != ESRCH) - outf_error - ("\n%s (invoke_gc_drone): kill (%d, SIGCONT) failed; errno = %s.\n", - scheme_program_name, drone->DRONE_PID, (error_name (errno))); - start_gc_drones (drone_index, 1, 1); - } - return (result != -1); -} - -/* The following don't do a wait/waitpid because Scheme handles SIGCHLD. */ - -static void -DEFUN_VOID (kill_all_gc_drones) -{ - int count; - struct drone_info * drone; - - for (count = 0, drone = gc_drones; count < n_gc_drones; count++, drone++) - (void) (kill (drone->DRONE_PID, SIGTERM)); - return; -} - -static int -DEFUN (probe_gc_drone, (drone), struct drone_info * drone) -{ - int result; - - if ((result = (kill ((drone->DRONE_PID), 0))) == -1) - { - if (errno != ESRCH) - (void) (kill ((drone->DRONE_PID), SIGTERM)); - drone->state = drone_dead; - } - return (result == 0); -} - -static void EXFUN (handle_drone_death, (struct drone_info *)); - -static void -DEFUN (probe_all_gc_drones, (wait_p), int wait_p) -{ - int count; - unsigned long running; - struct drone_info * drone; - - do { - for (count = 0, drone = gc_drones, running = ((unsigned long) 0); - count < n_gc_drones; - count++, drone++) - { - if (drone->state != drone_idle) - { - running |= (((unsigned long) 1) << drone->index); - if ((kill (drone->DRONE_PID, 0)) == -1) - { - if (errno != ESRCH) - (void) (kill (drone->DRONE_PID, SIGTERM)); - drone->state = drone_dead; - start_gc_drones (drone->index, 1, 1); - handle_drone_death (drone); - } - } - } - if (wait_p && (running != ((unsigned long) 0))) - { - sleep_awaiting_drones (default_sleep_period, running); - STATISTICS_INCR (await_io_cycles); - } - } while (wait_p && (running != ((unsigned long) 0))); - return; -} - -static void EXFUN (open_gc_file, (long, int)); - -static int -DEFUN (sysV_initialize, (first_time_p, size, r_overlap, w_overlap, drfnam), - int first_time_p - AND long size AND int r_overlap AND int w_overlap - AND CONST char * drfnam) -{ - SCHEME_OBJECT * bufptr; - int cntr; - long buffer_space, shared_size, malloc_size; - struct buffer_info * buffer; - - if (r_overlap < 0) - r_overlap = 0; - else if (r_overlap > MAX_READ_OVERLAP) - r_overlap = MAX_READ_OVERLAP; - read_overlap = r_overlap; - - if (w_overlap < 0) - w_overlap = 0; - else if (w_overlap > MAX_WRITE_OVERLAP) - w_overlap = MAX_WRITE_OVERLAP; - write_overlap = w_overlap; - - if ((n_gc_drones = (read_overlap + write_overlap)) > MAX_GC_DRONES) - { - read_overlap = ((read_overlap * MAX_GC_DRONES) / n_gc_drones); - write_overlap = ((write_overlap * MAX_GC_DRONES) / n_gc_drones); - n_gc_drones = (read_overlap + write_overlap); - } - n_gc_buffers = (2 + n_gc_drones); - - /* The second argument to open_gc_file should be (n_gc_drones == 0), - but we can't do this since we can change the number of drones. - */ - - if (first_time_p) - { - open_gc_file (size, 0); -#ifdef F_SETFD - /* Set the close on exec flag, the drones re-open it to get a - different file pointer so that all the processes can independently - lseek without clobbering each other. - */ - (void) (fcntl (gc_file, F_SETFD, 1)); -#endif - } - - buffer_space = (n_gc_buffers - * (gc_total_buffer_size * (sizeof (SCHEME_OBJECT)))); - shared_size = - (ALIGN_UP_TO_IO_PAGE (buffer_space - + (n_gc_buffers * (sizeof (struct buffer_info))) - + (n_gc_drones * (sizeof (struct drone_info))) - + (sizeof (long)) - + (sizeof (long)) - + (r_overlap * (sizeof (struct gc_queue_entry))) - + (w_overlap * (sizeof (struct gc_queue_entry))) - + IO_PAGE_SIZE)); - - malloc_size = ((n_gc_drones == 0) - ? shared_size - : (first_time_p ? MALLOC_SPACE : 0)); - - if (malloc_size > 0) - { - malloc_memory = ((char *) (malloc (malloc_size))); - if (malloc_memory == ((char *) NULL)) - { - outf_error - ("%s (sysV_initialize): Unable to allocate %d bytes (errno = %s).\n", - scheme_program_name, malloc_size, (error_name (errno))); - return (parameterization_termination (1, first_time_p)); - } - } - - if (n_gc_drones == 0) - shared_memory = ((char *) (ALIGN_UP_TO_IO_PAGE (malloc_memory))); - else - { - if ((shmid = (shmget (IPC_PRIVATE, shared_size, 0600))) == -1) - { - outf_error - ("%s (sysV_initialize): shmget (-, %d, -) failed (errno = %s).\n\ - \tUnable to allocate shared memory for drone processes.\n", - scheme_program_name, shared_size, (error_name (errno))); - return (parameterization_termination (0, first_time_p)); - } - shared_memory = (shmat (shmid, ATTACH_POINT, 0)); - if (shared_memory == ((char *) -1)) - { - int saved_errno = errno; - - (void) (shmctl (shmid, IPC_RMID, 0)); - shmid = -1; - outf_error - ("%s (sysV_initialize): shmat (%d, 0x%lx, 0) failed. (errno = %s).\n\ - \tUnable to attach shared memory for drone processes.\n", - scheme_program_name, shmid, shared_size, (error_name (saved_errno))); - return (parameterization_termination (0, first_time_p)); - } - signal (SIGCONT, continue_running); - } - - if (!(ALIGNED_TO_IO_PAGE_P (shared_memory))) - { - outf_error - ("%s (sysV_initialize): buffer space is not aligned properly.\n\ - \taddress = 0x%lx; IO_PAGE_SIZE = 0x%lx.\n", - ((long) shared_memory), ((long) IO_PAGE_SIZE)); - return (parameterization_termination (0, first_time_p)); - } - - if ((n_gc_drones != 0) && (malloc_size > 0) - && (malloc_memory != ((char *) NULL))) - { - free (malloc_memory); - malloc_memory = ((char *) NULL); - } - - gc_buffers = ((struct buffer_info *) (shared_memory + buffer_space)); - gc_drones = ((struct drone_info *) (gc_buffers + n_gc_buffers)); - drone_version = ((unsigned long *) (gc_drones + n_gc_drones)); - wait_mask = (drone_version + 1); - gc_read_queue = ((struct gc_queue_entry *) (drone_version + 2)); - gc_write_queue = (gc_read_queue + r_overlap); - - /* Initialize structures. */ - - *wait_mask = ((unsigned long) 0); - gc_next_drone = 0; - gc_next_buffer = 0; - - drone_file_name = ((char *) drfnam); - if ((drfnam != ((char *) NULL)) && (drfnam[0] != SUB_DIRECTORY_DELIMITER)) - { - CONST char * temp = (search_for_library_file (drfnam)); - - if (temp != ((char *) NULL)) - { - drone_file_name = temp; - if (drfnam != option_gc_drone) - free ((PTR) drfnam); - } - } - - for (bufptr = ((SCHEME_OBJECT *) shared_memory), cntr = 0, - buffer = gc_buffers; - (cntr < n_gc_buffers); - bufptr = buffer->end, cntr++, buffer++) - { - buffer->index = cntr; - buffer->state = buffer_idle; - buffer->position = -1; - buffer->bottom = ((PTR) bufptr); - buffer->top = ((PTR) (bufptr + gc_buffer_size)); - buffer->end = ((PTR) (bufptr + gc_total_buffer_size)); - } - - if (n_gc_drones == 0) - shared_memory = ((char *) -1); - else - { - struct gc_queue_entry * entry; - struct drone_info * drone; - - /* Make sure that SIGCONT is enabled. */ - { - sigset_t mask; - - UX_sigemptyset (&mask); - UX_sigaddset ((&mask), SIGCONT); - UX_sigprocmask (SIG_UNBLOCK, (&mask), 0); - } - - for (cntr = 0, entry = gc_read_queue; - cntr < read_overlap; - cntr++, entry++) - { - entry->index = cntr; - entry->state = entry_idle; - entry->retry_count = 0; - } - - for (cntr = 0, entry = gc_write_queue; - cntr < write_overlap; - cntr++, entry++) - { - entry->index = cntr; - entry->state = entry_idle; - entry->retry_count = 0; - } - - for (cntr = 0, drone = gc_drones; - cntr < n_gc_drones; - cntr++, drone++) - { - drone->index = cntr; - drone->state = drone_not_ready; - } - - start_gc_drones (0, n_gc_drones, 0); - if (gc_drones->state != drone_idle) - { - outf_error - ("%s (sysV_initialize): Problems starting up the GC drones%s.\n", - scheme_program_name, - (((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER)) - ? " (wrong drone version)" - : "")); - return (parameterization_termination (0, first_time_p)); - } - drones_initialized_p = 1; - } - return (0); -} - -static void EXFUN (close_gc_file, (int)); - -static void -DEFUN (sysV_shutdown, (final_time_p), int final_time_p) -{ - /* arg should be (n_gc_drones > 0), see sysV_initialize */ - if (final_time_p) - close_gc_file (1); - - if (malloc_memory != ((char *) NULL)) - { - free (malloc_memory); - malloc_memory = ((char *) NULL); - } - - if ((n_gc_drones != 0) && (drones_initialized_p)) - { - kill_all_gc_drones (); - drones_initialized_p = 0; - } - - if ((shared_memory != ((char *) -1)) && ((shmdt (shared_memory)) == -1)) - outf_error ("\n%s (sysV_shutdown): shmdt failed. errno = %s.\n", - scheme_program_name, (error_name (errno))); - shared_memory = ((char *) -1); - - if ((shmid != -1) - && (shmctl (shmid, IPC_RMID, ((struct shmid_ds *) 0))) == -1) - outf_error ("\n%s (sysV_shutdown): shmctl failed. errno = %s.\n", - scheme_program_name, (error_name (errno))); - shmid = -1; - - return; -} - -static int -DEFUN (find_idle_drone, (wait_p), int wait_p) -{ - int drone_index, next_drone_index, count = 0; - struct drone_info * drone; - - drone_index = gc_next_drone; - while (1) - { - count += 1; - do - { - next_drone_index = (drone_index + 1); - if (next_drone_index >= n_gc_drones) - next_drone_index = 0; - - drone = (gc_drones + drone_index); - switch (drone->state) - { - case drone_idle: - gc_next_drone = next_drone_index; - return (drone_index); - - case drone_dead: - start_gc_drones (drone_index, 1, 1); - /* fall through, look at it on next pass. */ - - default: - break; - } - drone_index = next_drone_index; - } while (drone_index != gc_next_drone); - - /* All the drones are busy... */ - - if (!wait_p) - { - STATISTICS_INCR (drone_request_failures); - return (-1); - } - - if (count == 10) - { - probe_all_gc_drones (0); - count = 0; - } - else - { - /* Use -1 as the mask to awaken when any drone becomes idle. */ - - sleep_awaiting_drones (default_sleep_period, ((unsigned long) -1)); - STATISTICS_INCR (drone_wait_cycles); - } - } -} - -static void -DEFUN (abort_gc_drone, (drone), struct drone_info * drone) -{ - int restart_p = 0; - sigset_t block_mask, signal_mask; - - UX_sigemptyset (&block_mask); - UX_sigaddset ((&block_mask), SIGCONT); - UX_sigprocmask (SIG_BLOCK, (&block_mask), (&signal_mask)); - - *wait_mask = (((unsigned long) 1) << drone->index); - if (drone->state != drone_idle) - { - if ((kill (drone->DRONE_PID, SIGQUIT)) == -1) - restart_p = 1; - else if (drone->state != drone_idle) - UX_sigsuspend (&signal_mask); - } - *wait_mask = ((unsigned long) 0); - UX_sigprocmask (SIG_SETMASK, (&signal_mask), 0); - if (restart_p) - start_gc_drones (drone->index, 1, 1); - return; -} - -static struct gc_queue_entry * -DEFUN (find_queue_entry, (queue, queue_size, position, drone_index), - struct gc_queue_entry * queue AND int queue_size - AND long position AND int drone_index) -{ - struct gc_queue_entry * entry; - int cntr; - - for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++) - { - if ((entry->state != entry_idle) - && (((entry->buffer)->position == position) - || (entry->drone_index == drone_index))) - return (entry); - } - return ((struct gc_queue_entry *) NULL); -} - -enum allocate_request -{ - request_read, - request_write, - request_ready -}; - -static struct gc_queue_entry * -DEFUN (allocate_queue_entry, (queue, queue_size, position, request, mask), - struct gc_queue_entry * queue AND int queue_size AND long position - AND enum allocate_request request AND unsigned long * mask) -{ - struct gc_queue_entry * entry; - int cntr, queue_index, drone_index; - unsigned long drone_mask; - - /* Examine all entries for duplicates, ergo no `break' */ - - queue_index = -1; - drone_mask = ((unsigned long) 0); - for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++) - { - if (entry->state == entry_idle) - queue_index = cntr; - else if ((entry->buffer)->position == position) - return (entry); - else if (entry->state == entry_error) - { - struct buffer_info * buffer = entry->buffer; - - entry->retry_count += 1; - if (entry->retry_count <= MAX_OVERLAPPED_RETRIES) - { - if (request == request_write) - { - /* This was done when originally queued, but we are paranoid. */ - (void) (verify_write (buffer->position, buffer->size, - ((Boolean *) NULL))); - do - entry->drone_index = (find_idle_drone (1)); - while (!(invoke_gc_drone (entry, drone_writing, entry->buffer, - buffer->position, buffer->size))); - STATISTICS_INCR (writes_retried); - } - else - { - entry->drone_index = (find_idle_drone (0)); - if ((entry->drone_index != -1) - && (invoke_gc_drone (entry, drone_reading, entry->buffer, - buffer->position, buffer->size))) - STATISTICS_INCR (pre_reads_retried); - else - STATISTICS_INCR (pre_reads_not_retried); - } - } - else if (request == request_write) - { - STATISTICS_INCR (writes_not_deferred); - write_data (((char *) (buffer->bottom)), - buffer->position, buffer->size, - "a queued buffer", ((Boolean *) NULL)); - buffer->state = buffer_idle; - entry->state = entry_idle; - entry->retry_count = 0; - queue_index = cntr; - } - else - /* If pre-reading, it will be taken care of later. */ - STATISTICS_INCR (pre_reads_deferred); - } - else if ((drone_index = (entry->drone_index)) != -1) - drone_mask |= (((unsigned long) 1) << drone_index); - } - - if (queue_index == -1) - { - probe_all_gc_drones (0); - if (mask != ((unsigned long *) NULL)) - (* mask) = drone_mask; - return ((struct gc_queue_entry *) NULL); - } - - entry = (queue + queue_index); - entry->buffer = ((struct buffer_info *) NULL); - return (entry); -} - -static struct buffer_info * -DEFUN_VOID (find_idle_buffer) -{ - int next_buffer, new_next_buffer; - struct buffer_info *buffer; - - next_buffer = gc_next_buffer; - do - { - new_next_buffer = (next_buffer + 1); - if (new_next_buffer >= n_gc_buffers) - new_next_buffer = 0; - buffer = (gc_buffers + next_buffer); - if (buffer->state == buffer_idle) - { - gc_next_buffer = new_next_buffer; - return (buffer); - } - next_buffer = new_next_buffer; - } while (next_buffer != gc_next_buffer); - - outf_fatal ("\n%s (find_idle_buffer): All buffers are in use!\n", - scheme_program_name); - Microcode_Termination (TERM_GC_OUT_OF_SPACE); - /*NOTREACHED*/ - return (0); -} - -static struct buffer_info * -DEFUN (find_ready_buffer, (position, size), long position AND long size) -{ - int next_buffer, new_next_buffer; - struct buffer_info *buffer; - - next_buffer = gc_next_buffer; - do - { - new_next_buffer = (next_buffer + 1); - if (new_next_buffer >= n_gc_buffers) - new_next_buffer = 0; - buffer = (gc_buffers + next_buffer); - if ((buffer->state == buffer_idle) /* && (buffer->size == size) */ - && (buffer->position == position)) - { - gc_next_buffer = new_next_buffer; - return (buffer); - } - next_buffer = new_next_buffer; - } while (next_buffer != gc_next_buffer); - return ((struct buffer_info *) NULL); -} - -static struct buffer_info * -DEFUN_VOID (get_gc_buffer) -{ - struct buffer_info * buffer; - - buffer = (find_idle_buffer ()); - buffer->state = buffer_busy; - return (buffer); -} - -static struct buffer_info * -DEFUN (read_buffer, (posn, size, noise), - long posn AND long size AND char * noise) -{ - struct gc_queue_entry * entry; - struct buffer_info * buffer; - - if ((read_overlap > 0) - && ((entry = (find_queue_entry (gc_read_queue, read_overlap, posn, -2))) - != ((struct gc_queue_entry *) NULL)) - && ((buffer = entry->buffer) != ((struct buffer_info *) NULL))) - { - switch (buffer->state) - { - default: - outf_error - ("\n%s (read_buffer %s): invalid state.\n\ - \tindex = %d; state = %d; position = 0x%lx.\n", - scheme_program_name, noise, buffer->index, buffer->state, posn); - /* fall through */ - - case buffer_read_error: - /* Try synchronously, and complain then if the condition persists. */ - break; - - case buffer_being_read: - { - int count; - struct drone_info * drone = (gc_drones + entry->drone_index); - - for (count = 1; (buffer->state == buffer_being_read) ; count++) - { - if (count == 10) - { - if (probe_gc_drone (drone)) - count = 0; - else - { - start_gc_drones (drone->index, 1, 1); - goto buffer_failed; - } - } - else - sleep_awaiting_drones (default_sleep_period, - (((unsigned long) 1) << drone->index)); - STATISTICS_INCR (read_wait_cycles); - } - - if (buffer->state != buffer_ready) - { -buffer_failed: - entry->state = entry_idle; - entry->retry_count = 0; - buffer->state = buffer_idle; - buffer->position = -1; - STATISTICS_INCR (reads_overlapped_aborted); - break; - } - STATISTICS_INCR (reads_pending); - goto buffer_available; - } - - case buffer_queued: - STATISTICS_INCR (reads_queued); - goto buffer_available; - - case buffer_ready: - STATISTICS_INCR (reads_ready); - -buffer_available: - /* This should check size, but they are all the same. */ - entry->state = entry_idle; - entry->retry_count = 0; - buffer->state = buffer_busy; - STATISTICS_INCR (reads_overlapped); - return (buffer); - } - } - else if ((write_overlap > 0) - && ((entry = (find_queue_entry (gc_write_queue, write_overlap, - posn, -2))) - != ((struct gc_queue_entry *) NULL))) - { - int index; - - /* This should check size, but they are all the same. */ - - entry->state = entry_idle; - entry->retry_count = 0; - buffer = entry->buffer; - index = entry->drone_index; - if (index != -1) - abort_gc_drone (gc_drones + index); - buffer->state = buffer_busy; - STATISTICS_INCR (reads_found_in_write_queue); - return (buffer); - } - else if ((buffer = (find_ready_buffer (posn, size))) - != ((struct buffer_info *) NULL)) - { - /* This should check size, but they are all the same. */ - - buffer->state = buffer_busy; - STATISTICS_INCR (reads_found_ready); - return (buffer); - } - - /* (read_overlap == 0) or not pre-read. */ - { - buffer = (find_idle_buffer ()); - - load_data (posn, ((char *) buffer->bottom), size, - noise, ((Boolean *) NULL)); - buffer->state = buffer_busy; - STATISTICS_INCR (reads_not_overlapped); - return (buffer); - } -} - -static void -DEFUN (write_buffer, (buffer, position, size, success, noise), - struct buffer_info * buffer AND long position - AND long size AND Boolean * success AND char * noise) -{ - if ((write_overlap > 0) && ((verify_write (position, size, success)) != -1)) - { - unsigned long drone_mask; - struct gc_queue_entry * entry = - (allocate_queue_entry (gc_write_queue, write_overlap, - position, request_write, (& drone_mask))); - - if (entry == ((struct gc_queue_entry *) NULL)) - { - STATISTICS_INCR (writes_pending); - do - { - sleep_awaiting_drones (default_sleep_period, drone_mask); - entry = - (allocate_queue_entry (gc_write_queue, write_overlap, - position, request_write, (& drone_mask))); - STATISTICS_INCR (write_wait_cycles); - } while (entry == ((struct gc_queue_entry *) NULL)); - } - else if (entry->buffer != NULL) - { - int index = entry->drone_index; - struct buffer_info * old_buffer; - - if (index != -1) - abort_gc_drone (gc_drones + index); - old_buffer = entry->buffer; - old_buffer->state = buffer_idle; - entry->buffer = buffer; - outf_error ("\n%s (write_buffer %s): duplicate write at 0x%lx.\n", - scheme_program_name, noise, position); - } - do - entry->drone_index = (find_idle_drone (1)); - while (!(invoke_gc_drone (entry, drone_writing, buffer, position, size))); - STATISTICS_INCR (writes_overlapped); - return; - } - - STATISTICS_INCR (writes_not_overlapped); - write_data (((char *) buffer->bottom), position, size, noise, success); - buffer->state = buffer_idle; - return; -} - -static void -DEFUN (enqueue_buffer, (entry, buffer, position, size, state), - struct gc_queue_entry * entry AND struct buffer_info * buffer - AND long position AND long size AND enum buffer_state state) -{ - buffer->state = state; - buffer->position = position; - buffer->size = size; - entry->buffer = buffer; - entry->drone_index = -1; - entry->state = entry_busy; - return; -} - -static void -DEFUN (enqueue_ready_buffer, (buffer, position, size), - struct buffer_info * buffer AND long position AND long size) -{ - struct gc_queue_entry * entry; - - if ((read_overlap == 0) - || ((entry = (allocate_queue_entry (gc_read_queue, read_overlap, - position, request_ready, - ((unsigned long *) NULL)))) - == ((struct gc_queue_entry *) NULL))) - { - write_buffer (buffer, position, size, ((char *) NULL), "a ready buffer"); - STATISTICS_INCR (ready_buffers_not_enqueued); - return; - } - if (entry->buffer != NULL) - { - int index = entry->drone_index; - struct buffer_info * old_buffer = entry->buffer; - - if (index != -1) - abort_gc_drone (gc_drones + index); - old_buffer->state = buffer_idle; - outf_error ("\n%s (enqueue_ready_buffer): Duplicate pre-read at 0x%lx.\n", - scheme_program_name, old_buffer->position); - } - enqueue_buffer (entry, buffer, position, size, buffer_queued); - STATISTICS_INCR (ready_buffers_enqueued); - return; -} - -static void -DEFUN (abort_pre_read, (position), long position) -{ - int index; - struct gc_queue_entry * entry; - struct buffer_info * buffer; - - entry = (find_queue_entry (gc_read_queue, read_overlap, position, -2)); - if (entry == ((struct gc_queue_entry *) NULL)) - return; - buffer = entry->buffer; - if (buffer->state == buffer_queued) - { - entry->state = entry_idle; - entry->retry_count = 0; - write_buffer (buffer, buffer->position, buffer->size, - ((Boolean *) NULL), "a queued buffer"); - STATISTICS_INCR (pre_reads_requeued_as_writes); - return; - } - index = entry->drone_index; - if (index != -1) - abort_gc_drone (gc_drones + index); - buffer->state = buffer_idle; - buffer->position = -1; - entry->state = entry_idle; - entry->retry_count = 0; - STATISTICS_INCR (pre_reads_aborted); - return; -} - -static int -DEFUN (pre_read_buffer, (position, size), long position AND long size) -{ - struct gc_queue_entry * rentry, * wentry; - struct buffer_info * buffer; - - if (read_overlap <= 0) - return (0); - - /* Do this first, to guarantee that we can insert it in the queue. - Otherwise there is no point in aborting a write, etc. - It is not really allocated until enqueue_buffer or invoke_gc_drone. - */ - - rentry = (allocate_queue_entry (gc_read_queue, read_overlap, - position, request_read, - ((unsigned long *) NULL))); - if (rentry == ((struct gc_queue_entry *) NULL)) - { - STATISTICS_INCR (pre_reads_ignored); - return (0); - } - else if (rentry->buffer != NULL) - /* Already being pre-read */ - return (1); - - if ((write_overlap > 0) - && ((wentry = (find_queue_entry (gc_write_queue, write_overlap, - position, -2))) - != ((struct gc_queue_entry *) NULL))) - { - int index = wentry->drone_index; - - buffer = wentry->buffer; - if (index != -1) - abort_gc_drone (gc_drones + index); - wentry->state = entry_idle; - wentry->retry_count = 0; - enqueue_buffer (rentry, buffer, position, size, buffer_queued); - STATISTICS_INCR (pre_reads_found_in_write_queue); - return (1); - } - else if ((buffer = (find_ready_buffer (position, size))) - != ((struct buffer_info *) NULL)) - { - enqueue_buffer (rentry, buffer, position, size, buffer_ready); - STATISTICS_INCR (pre_reads_found_ready); - return (1); - } - - if (((rentry->drone_index = (find_idle_drone (0))) == -1) - || (!(invoke_gc_drone (rentry, drone_reading, (find_idle_buffer ()), - position, size)))) - { - STATISTICS_INCR (pre_reads_not_started); - return (0); - } - STATISTICS_INCR (pre_reads_started); - return (1); -} - -static void -DEFUN (handle_drone_death, (drone), struct drone_info * drone) -{ - struct buffer_info * buffer; - struct gc_queue_entry * entry; - - STATISTICS_INCR (drones_found_dead); - if ((entry = (find_queue_entry (gc_write_queue, write_overlap, - -1, drone->index))) - != ((struct gc_queue_entry *) NULL)) - { - buffer = entry->buffer; - entry->state = entry_idle; - entry->retry_count = 0; - if (buffer->state != buffer_idle) - { - write_buffer (buffer, buffer->position, buffer->size, - ((Boolean *) NULL), "a queued buffer whose drone died"); - STATISTICS_INCR (writes_restarted); - } - } - else if ((entry = (find_queue_entry (gc_read_queue, read_overlap, - -1, drone->index))) - != ((struct gc_queue_entry *) NULL)) - { - buffer = entry->buffer; - if (buffer->state != buffer_ready) - { - entry->state = entry_idle; - entry->retry_count = 0; - buffer->state = buffer_idle; - STATISTICS_INCR (pre_reads_restarted); - (void) (pre_read_buffer (buffer->position, buffer->size)); - } - } - return; -} - -static void -DEFUN (await_io_completion, (start_p), int start_p) -{ - int cntr; - struct buffer_info * buffer; - struct gc_queue_entry * entry; - - if (n_gc_drones != 0) - probe_all_gc_drones (1); - if (start_p) - { - for (cntr = 0, buffer = gc_buffers; cntr < n_gc_buffers; cntr++, buffer++) - { - buffer->state = buffer_idle; - buffer->position = -1; - } - for (cntr = 0, entry = gc_read_queue; cntr < read_overlap; cntr++, entry++) - entry->state = entry_idle; - for (cntr = 0, entry = gc_write_queue; cntr < write_overlap; - cntr++, entry++) - entry->state = entry_idle; - } - return; -} - -#define CAN_RECONFIGURE_GC_BUFFERS 1 - -#define GC_BUFFER_ALLOCATION(space) 0 - -#define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd) \ - sysV_initialize (ft, size, ro, wo, gcd) - -#define RE_INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd) \ - sysV_initialize (ft, size, ro, wo, gcd) - -#define BUFFER_SHUTDOWN(lt) sysV_shutdown (lt) - -#define INITIALIZE_IO() await_io_completion (1) -#define AWAIT_IO_COMPLETION() await_io_completion (0) - -#define INITIAL_SCAN_BUFFER() free_buffer /* NOP */ -#define INITIAL_FREE_BUFFER() get_gc_buffer () -#define OTHER_BUFFER(buffer) get_gc_buffer () - -#define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) buffer->bottom) -#define GC_BUFFER_TOP(buffer) ((SCHEME_OBJECT *) buffer->top) - -#define READ_BUFFER read_buffer -#define DUMP_BUFFER write_buffer -#define PRE_READ_BUFFER pre_read_buffer -#define ABORT_PRE_READ abort_pre_read -#define ENQUEUE_READY_BUFFER enqueue_ready_buffer - -#define LOAD_BUFFER(buffer, position, size, noise) \ - buffer = (read_buffer (position, size, noise)) - -#else /* not USE_SYSV_SHARED_MEMORY */ - -static struct buffer_info - * gc_disk_buffer_1, - * gc_disk_buffer_2; - -#define CAN_RECONFIGURE_GC_BUFFERS 0 - -#define GC_BUFFER_ALLOCATION(space) space - -#define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd) \ -do { \ - SCHEME_OBJECT * ptr = (start); \ - \ - gc_disk_buffer_1 = ((struct buffer_info *) ptr); \ - gc_disk_buffer_2 = ((struct buffer_info *) \ - (ptr + gc_total_buffer_size)); \ - open_gc_file (size, 1); \ -} while (0) - -#define BUFFER_SHUTDOWN(lt) close_gc_file (lt) - -#define INITIALIZE_IO() do { } while (0) -#define AWAIT_IO_COMPLETION() do { } while (0) - -#define INITIAL_FREE_BUFFER() gc_disk_buffer_1 -#define INITIAL_SCAN_BUFFER() OTHER_BUFFER(free_buffer) - -/* (gc_disk_buffer_1 - (gc_disk_buffer_2 - (buffer))) does not work - because scan_buffer is not initialized until after scanning - constant space. */ - -#define OTHER_BUFFER(buffer) (((buffer) == gc_disk_buffer_1) \ - ? gc_disk_buffer_2 \ - : gc_disk_buffer_1) - -#define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) (buffer)) -#define GC_BUFFER_TOP(buffer) (((SCHEME_OBJECT *) (buffer)) + gc_buffer_size) - -static int -DEFUN (catastrophic_failure, (name), char * name) -{ - outf_fatal ("\n%s: Procedure %s should never be called!\n", - scheme_program_name, name); - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - return (0); -} - -#define GCDIE(m) catastrophic_failure (m) - -#define RE_INITIALIZE_GC_BUFFERS(f,s,z,r,w,g) \ - GCDIE ("RE_INITIALIZE_GC_BUFFERS") -#define READ_BUFFER(p,s,n) GCDIE ("read_buffer") -#define PRE_READ_BUFFER(p,s) GCDIE ("pre_read_buffer") -#define ABORT_PRE_READ(p) GCDIE ("abort_pre_read") -#define ENQUEUE_READY_BUFFER(b,p,s) GCDIE ("enqueue_ready_buffer") - -#define LOAD_BUFFER(buffer, position, size, noise) \ - load_data (position, ((char *) buffer), size, noise, ((Boolean *) NULL)) - -#define DUMP_BUFFER(buffer, position, size, successp, noise) \ - write_data (((char *) buffer), position, size, noise, successp) - -#endif /* not USE_SYSV_SHARED_MEMORY */ - -#define DUMP_SCAN_BUFFER(success) \ - DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes, \ - success, "the scan buffer") - -#define DUMP_FREE_BUFFER(success) \ - DUMP_BUFFER (free_buffer, free_position, gc_buffer_bytes, \ - success, "the free buffer") - -#define LOAD_SCAN_BUFFER() \ - LOAD_BUFFER (scan_buffer, scan_position, gc_buffer_bytes, \ - "the scan buffer") - -#define LOAD_FREE_BUFFER() \ - LOAD_BUFFER (free_buffer, free_position, gc_buffer_bytes, \ - "the free buffer") - -static int -DEFUN (next_exponent_of_two, (value), int value) -{ - unsigned int power; - int exponent; - - if (value < 0) - return (0); - - for (power = 1, exponent = 0; - power < ((unsigned int) value); - power = (power << 1), exponent += 1) - ; - return (exponent); -} - -/* Hacking the gc file */ - -static int - saved_gc_file = -1, - saved_read_overlap, - saved_write_overlap; - -static long - saved_start_position, - saved_end_position; - -int -DEFUN (swap_gc_file, (fid), int fid) -{ - /* Do not use overlapped I/O for fasdump because the drone processes - will continue writing to the same old file! - */ - saved_gc_file = gc_file; - saved_read_overlap = read_overlap; - saved_write_overlap = write_overlap; - saved_start_position = gc_file_start_position; - saved_end_position = gc_file_end_position; - gc_file = fid; - read_overlap = 0; - write_overlap = 0; - gc_file_end_position - = (absolute_gc_file_end_position - gc_file_start_position); - gc_file_start_position = 0L; - return (saved_gc_file); -} - -void -DEFUN_VOID (restore_gc_file) -{ - gc_file = saved_gc_file; - read_overlap = saved_read_overlap; - write_overlap = saved_write_overlap; - gc_file_start_position = saved_start_position; - gc_file_end_position = saved_end_position; - saved_gc_file = -1; - return; -} - -static void -DEFUN (close_gc_file, (unlink_p), int unlink_p) -{ -#ifdef HAVE_LOCKF - if (gc_file != -1) - { - if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0) - perror ("lseek"); - if ((lockf (gc_file, F_ULOCK, - (gc_file_end_position - gc_file_start_position))) - < 0) - perror ("lockf"); - } -#endif - if ((gc_file != -1) && ((close (gc_file)) == -1)) - outf_error ("\n%s (close_gc_file): error: GC file = \"%s\"; errno = %s.\n", - scheme_program_name, gc_file_name, (error_name (errno))); - gc_file = -1; - if (!keep_gc_file_p && unlink_p) - unlink (gc_file_name); - OS_free (gc_file_name); - gc_file_name = 0; - keep_gc_file_p = 0; -} - -#define EMPTY_STRING_P(string) \ - (((string) == ((char *) NULL)) || ((*(string)) == '\0')) - -static void -DEFUN (termination_open_gc_file, (operation, extra), - CONST char * operation AND CONST char * extra) -{ - if ((! (EMPTY_STRING_P (operation))) && (! (EMPTY_STRING_P (extra)))) - outf_fatal - ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n\t%s.\n", - scheme_program_name, operation, gc_file_name, (error_name (errno)), - extra); - else if (! (EMPTY_STRING_P (operation))) - outf_fatal - ("%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n", - scheme_program_name, operation, gc_file_name, (error_name (errno))); - else if (! (EMPTY_STRING_P (extra))) - outf_fatal ("\t%s.\n", extra); - termination_init_error (); - /*NOTREACHED*/ -} - -char * -DEFUN (make_gc_file_name, (suffix), CONST char * suffix) -{ - unsigned int s = (strlen (suffix)); - if ((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER) - { - unsigned int n - = (((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER)) - - option_gc_file) - + 1); - char * result = (OS_malloc (n + s + 1)); - strncpy (result, option_gc_file, n); - (result[n]) = '\0'; - strcat (result, suffix); - return (result); - } - { - unsigned int l = (strlen (option_gc_directory)); - if ((option_gc_directory [l - 1]) == SUB_DIRECTORY_DELIMITER) - { - unsigned int n = l; - char * result = (OS_malloc (n + s + 1)); - sprintf (result, "%s%s", option_gc_directory, suffix); - return (result); - } - else - { - unsigned int n = (l + 1); - char * result = (OS_malloc (n + s + 1)); - sprintf (result, "%s%c%s", - option_gc_directory, SUB_DIRECTORY_DELIMITER, suffix); - return (result); - } - } -} - -int -DEFUN (allocate_gc_file, (name), char * name) -{ - /* `name' must end in 6 `X' characters. */ - char * exxes = (name + ((strlen (name)) - 6)); - unsigned int n = 0; - - while (n < 1000000) - { - sprintf (exxes, "%06d", n); - if (OS_file_touch (name)) - return (1); - n += 1; - } - return (0); -} - -void -DEFUN (protect_gc_file_name, (name), CONST char * name) -{ - CONST char ** p = (dstack_alloc (sizeof (char *))); - (*p) = name; - transaction_record_action (tat_always, OS_free, p); -} - -#ifndef _POSIX_VERSION -extern off_t EXFUN (lseek, (int, off_t, int)); -#endif - -static void -DEFUN (open_gc_file, (size, unlink_p), - long size AND - int unlink_p) -{ - struct stat file_info; - int flags; - Boolean temp_p, exists_p; - - gc_file_name - = (make_gc_file_name - (((option_gc_file[0]) == SUB_DIRECTORY_DELIMITER) - ? ((strrchr (option_gc_file, SUB_DIRECTORY_DELIMITER)) + 1) - : option_gc_file)); - - { - unsigned int n = (strlen (option_gc_file)); - if ((n >= 6) && ((strcmp ((option_gc_file + (n - 6)), "XXXXXX")) == 0)) - { - if (!allocate_gc_file (gc_file_name)) - { - outf_fatal - ("%s: Unable to allocate a temporary file for the spare heap.\n", - scheme_program_name); - termination_open_gc_file (0, 0); - /*NOTREACHED*/ - } - temp_p = true; - } - else - temp_p = false; - } - - flags = GC_FILE_FLAGS; - gc_file_start_position = (ALIGN_UP_TO_IO_PAGE (option_gc_start_position)); - gc_file_end_position = option_gc_end_position; - if (gc_file_end_position == -1) - gc_file_end_position = (gc_file_start_position + size); - gc_file_end_position = (ALIGN_DOWN_TO_IO_PAGE (gc_file_end_position)); - if (gc_file_end_position < gc_file_start_position) - { - outf_fatal - ("%s (open_gc_file): file bounds are inconsistent.\n\ - \trequested start = 0x%lx;\taligned start = 0x%lx.\n\ - \trequested end = 0x%lx;\taligned end = 0x%lx.\n", - scheme_program_name, - option_gc_start_position, gc_file_start_position, - option_gc_end_position, gc_file_end_position); - termination_open_gc_file (0, 0); - } - - absolute_gc_file_end_position = gc_file_end_position; - - if ((stat (gc_file_name, &file_info)) == -1) - { - exists_p = false; - can_dump_directly_p = true; - flags |= O_EXCL; - } - else - { -#ifdef __unix__ - /* If it is S_IFCHR, it should determine the IO block - size and make sure that it will work. - I don't know how to do that. - ustat(2) will do that for a mounted file system, - but obviously, if a raw device file is used, - there better not be a file system on the device or partition. - Does st_blksize give the correct value? -- Apparently not. - */ - - exists_p = true; - if ((file_info.st_mode & S_IFMT) == S_IFCHR) - can_dump_directly_p = false; - - else if (((file_info.st_mode & S_IFMT) != S_IFREG) - && ((file_info.st_mode & S_IFMT) != S_IFBLK)) - { - outf_fatal - ("%s (open_gc_file): file \"%s\" has unknown/bad type 0x%x.\n\ - \tKnown types: S_IFREG (0x%x), S_IFBLK (0x%x), S_IFCHR (0x%x).\n", - scheme_program_name, gc_file_name, - ((int) (file_info.st_mode & S_IFMT)), - S_IFREG, S_IFBLK, S_IFCHR); - termination_open_gc_file (((char *) NULL), ((char *) NULL)); - } - else - can_dump_directly_p = true; -#else - /* Assume that it will be a normal file. */ - exists_p = true; - can_dump_directly_p = true; -#endif - } - - gc_file = (open (gc_file_name, flags, GC_FILE_MASK)); - if (gc_file == -1) - { -#ifndef __unix__ - /* errno does not give sufficient information except under unix. */ - - int saved_errno = errno; - char - directory_buffer[FILE_NAME_LENGTH], - * directory, * directory_end; - - directory = &directory_buffer[0]; - strcpy (directory, gc_file_name); - directory_end = (strrchr (directory, SUB_DIRECTORY_DELIMITER)); - if (directory_end != ((char *) NULL)) - * directory_end = '\0'; - if ((access (directory, F_OK)) != 0) - { - outf_fatal - ("\n%s (open_gc_file): GC directory \"%s\" does not exist.\n", - scheme_program_name, directory); - termination_open_gc_file (((char *) NULL), ((char *) NULL)); - } - else if ((access (directory, W_OK)) != 0) - { - outf_fatal - ("\n%s (open_gc_file): GC directory \"%s\" is read protected.\n", - scheme_program_name, directory); - termination_open_gc_file (((char *) NULL), ((char *) NULL)); - } - else - errno = saved_errno; -#endif /* not __unix__ */ - termination_open_gc_file ("open", ((char *) NULL)); - } - - keep_gc_file_p = (option_gc_keep || (exists_p && (!temp_p))); - -#ifdef UNLINK_BEFORE_CLOSE - if (!keep_gc_file_p && unlink_p) - unlink (gc_file_name); -#endif - -#ifdef HAVE_PREALLOC - if (!exists_p) - prealloc (gc_file, ((unsigned int) gc_file_end_position)); -#endif - -#ifdef HAVE_LOCKF - if (exists_p) - { - if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) < 0) - termination_open_gc_file ("lseek", ((char *) NULL)); - - if ((lockf (gc_file, F_TLOCK, size)) < 0) - termination_open_gc_file - ("lockf", - "The GC file is probably being used by another process"); - } -#endif - - gc_file_current_position = -1; /* Unknown position */ - -#ifdef __unix__ - /* Determine whether it is a seekable file. */ - if (exists_p && ((file_info.st_mode & S_IFMT) == S_IFCHR)) - { -#ifdef HAVE_FCNTL - int fcntl_flags; -#endif - Boolean ignore; - static char message[] = "This is a test message to the GC file.\n"; - char * buffer; - - buffer = ((char *) aligned_heap); - strcpy (buffer, &message[0]); - strncpy ((buffer + ((sizeof (message)) - 1)), - buffer, - (IO_PAGE_SIZE - (sizeof (message)))); - (* (buffer + (IO_PAGE_SIZE - 1))) = '\n'; - -#ifdef HAVE_FCNTL - fcntl_flags = (fcntl (gc_file, F_GETFL, 0)); - if (fcntl_flags != (-1)) - fcntl (gc_file, F_SETFL, (fcntl_flags | O_NONBLOCK)); -#endif - - write_data (buffer, - (gc_file_start_position + ((long) IO_PAGE_SIZE)), - ((long) IO_PAGE_SIZE), - "a test buffer (1)", - &ignore); - load_data (gc_file_start_position, - (buffer + IO_PAGE_SIZE), - ((long) (2 * IO_PAGE_SIZE)), - "a test buffer (2)", - &ignore); - if ((strncmp (buffer, (buffer + (2 * IO_PAGE_SIZE)), IO_PAGE_SIZE)) != 0) - { - outf_fatal ("\n%s (open_gc_file): \"%s\" is not a seek-able device.\n", - scheme_program_name, gc_file_name); - termination_open_gc_file (((char *) NULL), ((char *) NULL)); - } -#ifdef HAVE_FCNTL - if (fcntl_flags != (-1)) - fcntl (gc_file, F_SETFL, fcntl_flags); -#endif - } -#endif /* __unix__ */ -} - -#define CONSTANT_SPACE_FUDGE 128 - -Boolean -DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop) -{ - SCHEME_OBJECT * htop; - long new_end; - - /* buffer for impurify, etc. */ - ctop = ((SCHEME_OBJECT *) - (ALIGN_UP_TO_IO_PAGE (ctop + CONSTANT_SPACE_FUDGE))); - htop = ((SCHEME_OBJECT *) - (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address))); - if (ctop >= htop) - return (FALSE); - - new_end = (((char *) htop) - ((char *) ctop)); - new_end = (CEILING (new_end, gc_buffer_bytes)); - new_end += gc_file_start_position; - if ((new_end > absolute_gc_file_end_position) - && (! option_gc_end_position)) - return (FALSE); - - gc_file_end_position = new_end; - Constant_Top = ctop; - Heap_Bottom = Constant_Top; - Heap_Top = htop; - aligned_heap = Heap_Bottom; - Local_Heap_Base = Heap_Bottom; - Unused_Heap_Bottom = Heap_Top; - Unused_Heap_Top = Highest_Allocated_Address; - Free = Heap_Bottom; - SET_MEMTOP (Heap_Top - GC_Reserve); - return (TRUE); -} - -Boolean -DEFUN_VOID (recompute_gc_end_position) -{ - SCHEME_OBJECT * htop; - long new_end, delta; - - if ((((gc_file_end_position - gc_file_start_position) % gc_buffer_bytes) - == 0) - || option_gc_end_position) - return (TRUE); - - htop = ((SCHEME_OBJECT *) - (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address))); - new_end = (CEILING ((((char *) htop) - ((char *) Constant_Top)), - gc_buffer_bytes)); - new_end += gc_file_start_position; - if (new_end <= absolute_gc_file_end_position) - { - gc_file_end_position = new_end; - return (TRUE); - } - delta = (FLOOR ((absolute_gc_file_end_position - gc_file_start_position), - gc_buffer_bytes)); - if ((((char *) Constant_Top) + delta) <= (((char *) Free) + GC_Reserve)) - /* This should really GC and retry, but ... */ - return (FALSE); - Heap_Top = ((SCHEME_OBJECT *) (((char *) Constant_Top) + delta)); - SET_MEMTOP (Heap_Top - GC_Reserve); - return (TRUE); -} - -void -DEFUN_VOID (reset_allocator_parameters) -{ - GC_Reserve = 4500; - GC_Space_Needed = 0; - Stack_Bottom = ((SCHEME_OBJECT *) - (ALIGN_UP_TO_IO_PAGE (Lowest_Allocated_Address))); - Stack_Top = ((SCHEME_OBJECT *) - (ALIGN_DOWN_TO_IO_PAGE - (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size))))); - Constant_Space = Stack_Top; - Free_Constant = Constant_Space; - (void) update_allocator_parameters (Free_Constant); - SET_CONSTANT_TOP (); - ALIGN_FLOAT (Free); - INITIALIZE_STACK (); - STACK_RESET (); - return; -} - -void -DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size), - int heap_size - AND int stack_size - AND int constant_space_size) -{ - saved_heap_size = heap_size; - saved_constant_size = constant_space_size; - saved_stack_size = stack_size; - reset_allocator_parameters (); -} - -void -DEFUN_VOID (Reset_Memory) -{ - BUFFER_SHUTDOWN (1); - HEAP_FREE (Lowest_Allocated_Address); - DEALLOCATE_REGISTERS (); - return; -} - -#define BLOCK_TO_IO_SIZE(size) \ - ((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT)))) \ - / (sizeof (SCHEME_OBJECT))) - -static int -DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift) -{ - unsigned long - new_buffer_size, new_buffer_bytes, new_buffer_byte_shift, - new_buffer_overlap_bytes, new_extra_buffer_size; - - new_buffer_size = (1L << new_buffer_shift); - new_buffer_bytes = (new_buffer_size * (sizeof (SCHEME_OBJECT))); - if (! (ALIGNED_TO_IO_PAGE_P (new_buffer_bytes))) - { - outf_error - ("%s (Setup_Memory): improper new_buffer_size.\n\ - \tIO_PAGE_SIZE = 0x%lx bytes.\n\ - \tgc_buffer_size = 0x%lx bytes = 0x%lx objects.\n\ - \tIO_PAGE_SIZE should divide gc_buffer_size.\n", - scheme_program_name, - ((long) IO_PAGE_SIZE), - new_buffer_bytes, new_buffer_size); - return (-1); - } - - new_buffer_byte_shift = (next_exponent_of_two (new_buffer_bytes)); - if ((((unsigned long) 1L) << new_buffer_byte_shift) != new_buffer_bytes) - { - outf_error - ("%s (Setup_Memory): gc_buffer_bytes (0x%lx) is not a power of 2.\n", - scheme_program_name, new_buffer_bytes); - return (-1); - } - - new_buffer_overlap_bytes = IO_PAGE_SIZE; - new_extra_buffer_size - = (new_buffer_overlap_bytes / (sizeof (SCHEME_OBJECT))); - if ((new_extra_buffer_size * (sizeof (SCHEME_OBJECT))) - != new_buffer_overlap_bytes) - { - outf_error - (" %s (Setup_Memory): improper IO_PAGE_SIZE.\n\ - \tIO_PAGE_SIZE = 0x%lx; (sizeof (SCHEME_OBJECT)) = 0x%lx.\n\ - \t(sizeof (SCHEME_OBJECT)) should divide IO_PAGE_SIZE.\n", - scheme_program_name, - ((long) IO_PAGE_SIZE), ((long) (sizeof (SCHEME_OBJECT)))); - return (-1); - } - - gc_buffer_shift = new_buffer_shift; - gc_buffer_size = new_buffer_size; - gc_buffer_bytes = new_buffer_bytes; - gc_buffer_mask = (gc_buffer_size - 1); - gc_buffer_byte_shift = new_buffer_byte_shift; - gc_buffer_overlap_bytes = new_buffer_overlap_bytes; - gc_extra_buffer_size = new_extra_buffer_size; - gc_buffer_remainder_bytes = (gc_buffer_bytes - gc_buffer_overlap_bytes); - gc_total_buffer_size = (gc_buffer_size + gc_extra_buffer_size); - return (0); -} - -void -DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size), - int heap_size - AND int stack_size - AND int constant_space_size) -{ - SCHEME_OBJECT test_value; - int real_stack_size; - long gc_buffer_allocation; - - ALLOCATE_REGISTERS (); - - /* Consistency check 1 */ - if (heap_size == 0) - { - outf_fatal ("%s (Setup_Memory): Configuration won't hold initial data.\n", - scheme_program_name); - termination_init_error (); - /*NOTREACHED*/ - } - - real_stack_size = (STACK_ALLOCATION_SIZE (stack_size)); - - /* add log(1024)/log(2) to exponent */ - if ((set_gc_buffer_sizes (10 - + (next_exponent_of_two (option_gc_window_size)))) - != 0) - parameterization_termination (1, 1); - - /* Use multiples of IO_PAGE_SIZE. */ - - heap_size = (BLOCK_TO_IO_SIZE (heap_size)); - constant_space_size = (BLOCK_TO_IO_SIZE (constant_space_size)); - real_stack_size = (BLOCK_TO_IO_SIZE (real_stack_size)); - gc_buffer_allocation = (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size)); - - /* Allocate. */ - - ALLOCATE_HEAP_SPACE ((heap_size - + constant_space_size + real_stack_size - + gc_buffer_allocation - + (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT)))), - Lowest_Allocated_Address, - Highest_Allocated_Address); - - /* Consistency check 2 */ - if (Lowest_Allocated_Address == NULL) - { - outf_fatal - ("%s (Setup_Memory): Not enough memory for this configuration.\n", - scheme_program_name); - termination_init_error (); - /*NOTREACHED*/ - } - - Highest_Allocated_Address -= gc_buffer_allocation; - - /* Consistency check 3 */ - test_value = - (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address)); - - if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) || - ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address)) - { - outf_fatal - ("%s (Setup_Memory): \ - Largest address does not fit in datum field of object.\n\ - \tAllocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n", - scheme_program_name); - Reset_Memory (); - termination_init_error (); - /*NOTREACHED*/ - } - - Clear_Memory (heap_size, stack_size, constant_space_size); - INITIALIZE_GC_BUFFERS (1, - Highest_Allocated_Address, - ((sizeof (SCHEME_OBJECT)) - * (CEILING ((heap_size + constant_space_size), - gc_buffer_size))), - option_gc_read_overlap, - option_gc_write_overlap, - option_gc_drone); - return; -} - -/* Utilities for the GC proper. */ - -static void -DEFUN (enqueue_free_buffer, (success), Boolean * success) -{ - int diff; - - diff = ((free_position - pre_read_position) >> gc_buffer_byte_shift); - if (diff >= read_overlap) - DUMP_FREE_BUFFER (success); - else - { - ENQUEUE_READY_BUFFER (free_buffer, free_position, gc_buffer_bytes); - read_queue_bitmask |= (1L << diff); - } - return; -} - -static void -DEFUN_VOID (schedule_pre_reads) -{ - int cntr; - long position; - unsigned long bit; - - if (pre_read_position == scan_position) - { - read_queue_bitmask = (read_queue_bitmask >> 1); - pre_read_position += gc_buffer_bytes; - } - for (cntr = 0, bit = 1L, position = pre_read_position; - ((cntr < read_overlap) && (position < free_position)); - cntr++, bit = (bit << 1), position += gc_buffer_bytes) - { - if ((read_queue_bitmask & bit) != bit) - if (PRE_READ_BUFFER (position, gc_buffer_bytes)) - read_queue_bitmask |= bit; - } - return; -} - -static void -DEFUN_VOID (abort_pre_reads) -{ - while (scan_position > pre_read_position) - { - ABORT_PRE_READ (pre_read_position); - pre_read_position += gc_buffer_bytes; - read_queue_bitmask = (read_queue_bitmask >> 1); - } - schedule_pre_reads (); - return; -} - -static void -DEFUN (reload_scan_buffer, (skip), unsigned long skip) -{ - scan_position += (skip << gc_buffer_byte_shift); - virtual_scan_pointer += (skip << gc_buffer_shift); - - if ((read_overlap > 0) && (scan_position > pre_read_position)) - abort_pre_reads (); - - if (scan_position == free_position) - { - pre_read_position = (free_position + gc_buffer_bytes); - read_queue_bitmask = 0L; - scan_buffer = free_buffer; - scan_buffer_bottom = free_buffer_bottom; - scan_buffer_top = free_buffer_top; - return; - } - LOAD_SCAN_BUFFER (); - scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer)); - scan_buffer_top = (GC_BUFFER_TOP (scan_buffer)); - *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); - - if (read_overlap > 0) - schedule_pre_reads (); -} - -SCHEME_OBJECT * -DEFUN (dump_and_reload_scan_buffer, (end, success), - SCHEME_OBJECT * end AND - Boolean * success) -{ - unsigned long number_to_skip = (end - scan_buffer_top); - DUMP_SCAN_BUFFER (success); - reload_scan_buffer (1 + (number_to_skip >> gc_buffer_shift)); - return (scan_buffer_bottom + (number_to_skip & gc_buffer_mask)); -} - -SCHEME_OBJECT * -DEFUN (dump_and_reset_free_buffer, (current_free, success), - SCHEME_OBJECT * current_free AND - Boolean * success) -{ - unsigned long overflow = (current_free - free_buffer_top); - SCHEME_OBJECT * from = free_buffer_top; - Boolean buffer_overlap_p = extension_overlap_p; - Boolean same_buffer_p = (scan_buffer == free_buffer); - - if (read_overlap > 0) - { - if (buffer_overlap_p) - { - extension_overlap_p = false; - next_scan_buffer = free_buffer; - } - else if (!same_buffer_p) - enqueue_free_buffer (success); - } - else if (!same_buffer_p) - DUMP_FREE_BUFFER (success); - - /* Otherwise there is no need to dump now, it will be dumped - when scan is dumped. Note that the next buffer may be dumped - before this one, but there should be no problem lseeking past the - end of file. */ - free_position += gc_buffer_bytes; - free_buffer = (OTHER_BUFFER (scan_buffer)); - free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer)); - free_buffer_top = (GC_BUFFER_TOP (free_buffer)); - { - SCHEME_OBJECT * into = free_buffer_bottom; - SCHEME_OBJECT * end = (into + overflow); - while (into < end) - (*into++) = (*from++); - if (same_buffer_p && (!buffer_overlap_p)) - (*scan_buffer_top) - = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); - return (into); - } -} - -/* These utilities are needed when pointers fall accross window boundaries. - - Between both they effectively do a dump_and_reload_scan_buffer, in two - stages. -*/ - -void -DEFUN (extend_scan_buffer, (to_where, current_free), - char * to_where AND - SCHEME_OBJECT * current_free) -{ - fast char * source, * dest; - long new_scan_position = (scan_position + gc_buffer_bytes); - - /* Is there buffer overlap?, i.e. is the next bufferful the one cached - in the free pointer window? - */ - - scan_buffer_extended_p = true; - dest = ((char *) scan_buffer_top); - extension_overlap_length = (to_where - dest); - extension_overlap_p = (new_scan_position == free_position); - - if (extension_overlap_p) - { - long temp; - - source = ((char *) free_buffer_bottom); - temp = (((char *) current_free) - source); - if (temp < extension_overlap_length) - { - /* This should only happen when Scan and Free are very close. */ - extension_overlap_length = temp; - } - } - else if (read_overlap == 0) - { - load_data (new_scan_position, dest, gc_buffer_overlap_bytes, - "the next scan buffer", ((Boolean *) NULL)); - return; - } - else - { - LOAD_BUFFER (next_scan_buffer, new_scan_position, - gc_buffer_bytes, "the next scan buffer"); - source = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer))); - } - - while (dest < to_where) - *dest++ = *source++; - return; -} - -char * -DEFUN (end_scan_buffer_extension, (to_relocate), char * to_relocate) -{ - char * result; - if (extension_overlap_p) - { - /* There was overlap between the scan buffer and the free buffer, - there may no longer be, but dump_and_reload_scan_buffer will - get us the correct next buffer. - The old scan buffer may be written, but the while loop below - will read storage contiguous to it (in the buffer extension). - */ - SCHEME_OBJECT old, new; - fast char * source, * dest, * limit; - - extension_overlap_p = false; - source = ((char *) scan_buffer_top); - old = (* ((SCHEME_OBJECT *) source)); - limit = (source + extension_overlap_length); - dest = ((char *) (dump_and_reload_scan_buffer (scan_buffer_top, 0))); - /* The following is only necesary if we are reusing the scan buffer. */ - new = (* scan_buffer_top); - (* ((SCHEME_OBJECT *) source)) = old; - result = (dest + (to_relocate - source)); - while (source < limit) - *dest++ = *source++; - (* scan_buffer_top) = new; - } - else if (next_scan_buffer == ((struct buffer_info *) NULL)) - { - /* There was no buffer overlap and no read overlap */ - - fast SCHEME_OBJECT * source, * dest, * limit; - - source = scan_buffer_top; - limit = (source + gc_extra_buffer_size); - - DUMP_SCAN_BUFFER (0); - scan_position += gc_buffer_bytes; - virtual_scan_pointer += gc_buffer_size; - - scan_buffer = (OTHER_BUFFER (free_buffer)); - scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer)); - scan_buffer_top = (GC_BUFFER_TOP (scan_buffer)); - - dest = scan_buffer_bottom; - result = (((char *) dest) + (to_relocate - ((char *) source))); - - while (source < limit) - *dest++ = *source++; - - if (gc_buffer_remainder_bytes != 0) - load_data ((scan_position + gc_buffer_overlap_bytes), - ((char *) dest), gc_buffer_remainder_bytes, - "the scan buffer", ((Boolean *) NULL)); - - (* scan_buffer_top) = - (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); - } - else - { - /* There is overlap with the next bufferful (not the free bufferful). */ - - fast char * source, * dest, * limit; - - source = ((char *) scan_buffer_top); - limit = (source + extension_overlap_length); - dest = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer))); - result = (dest + (to_relocate - source)); - - while (source < limit) - *dest++ = *source++; - - DUMP_SCAN_BUFFER (0); - scan_position += gc_buffer_bytes; - virtual_scan_pointer += gc_buffer_size; - - scan_buffer = next_scan_buffer; - next_scan_buffer = NULL; - scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer)); - scan_buffer_top = (GC_BUFFER_TOP (scan_buffer)); - (* scan_buffer_top) = - (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); - schedule_pre_reads (); - } - scan_buffer_extended_p = false; - return (result); -} - -/* This is used to avoid unnecessary copying when copying a large - non-marked area. - */ - -SCHEME_OBJECT * -DEFUN (dump_free_directly, (from, nbuffers, success), - fast SCHEME_OBJECT * from - AND fast long nbuffers - AND Boolean * success) -{ - if (((read_overlap + write_overlap) == 0) - && (can_dump_directly_p || (ALIGNED_TO_IO_PAGE_P (from)))) - { - long byte_length = (nbuffers << gc_buffer_byte_shift); - - write_data (((char *) from), free_position, byte_length, - "free buffers", success); - free_position += byte_length; - } - else - { - /* This assumes that the free buffer has no valid data, so it can be - used as scratch. - This code is executed when there is I/O overlap, or when the - data is not aligned to be written to a raw (character) device. - */ - - while ((--nbuffers) >= 0) - { - fast SCHEME_OBJECT * to, * bufend; - - for (to = free_buffer_bottom, bufend = free_buffer_top; to != bufend; ) - *to++ = *from++; - - (void) (dump_and_reset_free_buffer (to, success)); - } - } - return (free_buffer_bottom); -} - -/* This code is needed by purify. After the purified object is - copied, the next step is to scan constant space. In order to do - this, it's necessary to save the current scan position, reset the - scan limit pointers to scan constant space, then restore the saved - scan position and finish scanning the heap. These procedures - provide the necessary functionality to do this. */ - -static void -DEFUN_VOID (reset_scan_buffer) -{ - virtual_scan_pointer = 0; - scan_position = (-1L); - scan_buffer = 0; - scan_buffer_bottom = 0; - scan_buffer_top = Highest_Allocated_Address; - next_scan_buffer = 0; - scan_buffer_extended_p = false; - extension_overlap_p = false; - extension_overlap_length = 0; -} - -void -DEFUN (save_scan_state, (state, scan), - struct saved_scan_state * state AND - SCHEME_OBJECT * scan) -{ - (state -> virtual_scan_pointer) = virtual_scan_pointer; - (state -> scan_position) = scan_position; - (state -> scan_offset) = (scan - scan_buffer_bottom); - if (scan_position != free_position) - DUMP_SCAN_BUFFER (0); - reset_scan_buffer (); -} - -SCHEME_OBJECT * -DEFUN (restore_scan_state, (state), struct saved_scan_state * state) -{ - virtual_scan_pointer = (state -> virtual_scan_pointer); - scan_position = (state -> scan_position); - if (scan_position == free_position) - { - scan_buffer = free_buffer; - scan_buffer_bottom = free_buffer_bottom; - scan_buffer_top = free_buffer_top; - } - else - { - scan_buffer = (OTHER_BUFFER (free_buffer)); - scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer)); - scan_buffer_top = (GC_BUFFER_TOP (scan_buffer)); - LOAD_SCAN_BUFFER (); - } - return (scan_buffer_bottom + (state -> scan_offset)); -} - -void -DEFUN (set_fixed_scan_area, (bottom, top), - SCHEME_OBJECT * bottom AND - SCHEME_OBJECT * top) -{ - virtual_scan_pointer = bottom; - scan_buffer_bottom = bottom; - scan_buffer_top = top; -} - -#ifndef START_TRANSPORT_HOOK -#define START_TRANSPORT_HOOK() do { } while (0) -#endif - -#ifndef END_TRANSPORT_HOOK -#define END_TRANSPORT_HOOK() do { } while (0) -#endif - -#ifndef END_WEAK_UPDATE_HOOK -#define END_WEAK_UPDATE_HOOK() do { } while (0) -#endif - -#ifndef START_RELOAD_HOOK -#define START_RELOAD_HOOK() do { } while (0) -#endif - -#ifndef END_GC_HOOK -#define END_GC_HOOK() do { } while (0) -#endif - -/* This hacks the scan buffer also so that Scan is always below - scan_buffer_top until the scan buffer is initialized. - Various parts of the garbage collector depend on scan_buffer_top - having an aligned value. -*/ - -SCHEME_OBJECT * -DEFUN_VOID (initialize_free_buffer) -{ - STATISTICS_CLEAR (); - START_TRANSPORT_HOOK (); - read_queue_bitmask = 0L; - pre_read_position = gc_file_start_position; - free_position = gc_file_start_position; - INITIALIZE_IO (); - free_buffer = (INITIAL_FREE_BUFFER ()); - free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer)); - free_buffer_top = (GC_BUFFER_TOP (free_buffer)); - reset_scan_buffer (); - /* Force first write to do an lseek. */ - gc_file_current_position = -1; - return (free_buffer_bottom); -} - -SCHEME_OBJECT * -DEFUN (initialize_scan_buffer, (block_start), SCHEME_OBJECT * block_start) -{ - virtual_scan_base = block_start; - virtual_scan_pointer = virtual_scan_base; - scan_position = gc_file_start_position; - scan_buffer = (INITIAL_SCAN_BUFFER ()); - scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer)); - scan_buffer_top = (GC_BUFFER_TOP (scan_buffer)); - reload_scan_buffer (0); - return (scan_buffer_bottom); -} - -void -DEFUN (end_transport, (success), Boolean * success) -{ - DUMP_SCAN_BUFFER (success); - scan_position += gc_buffer_bytes; - virtual_scan_pointer += gc_buffer_size; - free_position = scan_position; - END_TRANSPORT_HOOK (); - STATISTICS_PRINT (2, "after transport"); - return; -} - -void -DEFUN (final_reload, (to, length, noise), - SCHEME_OBJECT * to AND unsigned long length AND char * noise) -{ - unsigned long byte_length; - - byte_length = (ALIGN_UP_TO_IO_PAGE (length * (sizeof (SCHEME_OBJECT)))); - END_WEAK_UPDATE_HOOK (); - AWAIT_IO_COMPLETION (); - START_RELOAD_HOOK (); - load_data (gc_file_start_position, ((char *) to), byte_length, - noise, ((Boolean *) NULL)); - END_GC_HOOK (); - STATISTICS_PRINT (1, "after final reload"); - return; -} - -static int - weak_buffer_pre_read_count; - -static long - weak_pair_buffer_position; - -static struct buffer_info - * weak_pair_buffer; - -static SCHEME_OBJECT - weak_pair_break; - -/* This procedure is not very smart. - - It does not attempt to figure out whether the position being - requested is already being pre-read, nor does it look further down - the weak chain list for duplicate positions, to avoid early writes. - - On the other hand, pre_read_buffer will ignore the request if it is - a duplicate, and will abort a pending write if a read for the same - position is requested. - */ - -static void -DEFUN (pre_read_weak_pair_buffers, (low_heap), SCHEME_OBJECT * low_heap) -{ - SCHEME_OBJECT next, * pair_addr, * obj_addr; - long position, last_position; - - last_position = -1; - next = weak_pair_break; - while (next != EMPTY_WEAK_CHAIN) - { - pair_addr = (OBJECT_ADDRESS (next)); - obj_addr = (OBJECT_ADDRESS (*pair_addr++)); - if (! (obj_addr < low_heap)) - { - position = (obj_addr - aligned_heap); - position = (position >> gc_buffer_shift); - position = (position << gc_buffer_byte_shift); - position += gc_file_start_position; - - if ((position != last_position) - && (position != weak_pair_buffer_position)) - { - last_position = position; - if ((weak_buffer_pre_read_count >= read_overlap) - || (!(PRE_READ_BUFFER (position, gc_buffer_bytes)))) - break; - weak_buffer_pre_read_count += 1; - } - } - next = (OBJECT_NEW_TYPE (TC_NULL, (*pair_addr))); - } - weak_pair_break = next; - return; -} - -/* The following code depends on being called in between copying objects, - so that the "free" pointer points to the middle of the free buffer, - and thus the overlap area at the end of the free buffer is available - as temporary storage. In addition, because we have not yet moved free, - next_scan_buffer has not been set even if we are in the middle of a - scan buffer extension. - */ - -SCHEME_OBJECT -DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr) -{ - long position; - unsigned long offset; - SCHEME_OBJECT result; - - if ((addr >= Constant_Space) && (addr < Free_Constant)) - return (* addr); - - position = (addr - virtual_scan_base); - offset = (position & gc_buffer_mask); - position = (position >> gc_buffer_shift); - position = (position << gc_buffer_byte_shift); - position += gc_file_start_position; - - if (position > free_position) - { - outf_fatal - ("\n%s (read_newspace_address): Reading outside of GC window!\n\ - \t addr = 0x%lx;\t position = 0x%lx.\n\ - \tscan_position = 0x%lx;\tfree_position = 0x%lx.\n", - scheme_program_name, - addr, position, - scan_position, free_position); - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - } - if (position == scan_position) - result = (* (scan_buffer_bottom + offset)); - else if (position == free_position) - result = (* (free_buffer_bottom + offset)); - else if ((position == ((long) (scan_position + gc_buffer_bytes))) - && scan_buffer_extended_p - && ((read_overlap != 0) || (offset < gc_extra_buffer_size))) - { - /* Note: we need not worry about the state of extension_overlap_p, - because if there is overlap between the scan extension and the free - buffer, then (position == free_position) would be true, - and that case has already been taken care of. - */ - - result = ((read_overlap == 0) - ? (* (scan_buffer_top + offset)) - : (* ((GC_BUFFER_BOTTOM (next_scan_buffer)) + offset))); - } - else if ((read_overlap <= 0) || (position > pre_read_position)) - { - unsigned long position2; - - position = (((char *) addr) - ((char *) virtual_scan_base)); - position2 = (ALIGN_DOWN_TO_IO_PAGE (position)); - offset = (position - position2); - position2 += gc_file_start_position; - - load_data (position2, - ((char *) free_buffer_top), - IO_PAGE_SIZE, - "a buffer for read_newspace_address", - ((Boolean *) NULL)); - result = (* ((SCHEME_OBJECT *) (((char *) free_buffer_top) + offset))); - } - else - { - /* The buffer is pre-read or in the process of being pre-read. - Force completion of the read, fetch the location, - and re-queue the buffer as ready. - */ - - LOAD_BUFFER (next_scan_buffer, position, gc_buffer_bytes, - "a buffer for read_newspace_address"); - result = ((GC_BUFFER_BOTTOM (next_scan_buffer)) [offset]); - ENQUEUE_READY_BUFFER (next_scan_buffer, position, gc_buffer_bytes); - next_scan_buffer = ((struct buffer_info *) NULL); - } - return (result); -} - -static void -DEFUN (initialize_new_space_buffer, (chain, low_heap), - SCHEME_OBJECT chain AND - SCHEME_OBJECT * low_heap) -{ - if (read_overlap == 0) - { - weak_pair_break = EMPTY_WEAK_CHAIN; - weak_pair_buffer = (INITIAL_FREE_BUFFER ()); - weak_pair_buffer_position = -1; - } - else - { - weak_pair_break = chain; - weak_pair_buffer = ((struct buffer_info *) NULL); - weak_pair_buffer_position = -1; - weak_buffer_pre_read_count = 0; - pre_read_weak_pair_buffers (low_heap); - } -} - -static void -DEFUN_VOID (flush_new_space_buffer) -{ - if (weak_pair_buffer_position == -1) - return; - DUMP_BUFFER (weak_pair_buffer, weak_pair_buffer_position, - gc_buffer_bytes, ((Boolean *) NULL), - "the weak pair buffer"); - weak_pair_buffer_position = -1; - return; -} - -static SCHEME_OBJECT * -DEFUN (guarantee_in_memory, (addr, low_heap), - SCHEME_OBJECT * addr AND - SCHEME_OBJECT * low_heap) -{ - long position, offset; - - if (addr < low_heap) - return (addr); - - position = (addr - aligned_heap); - offset = (position & gc_buffer_mask); - position = (position >> gc_buffer_shift); - position = (position << gc_buffer_byte_shift); - position += gc_file_start_position; - - if (position != weak_pair_buffer_position) - { - flush_new_space_buffer (); - LOAD_BUFFER (weak_pair_buffer, position, gc_buffer_bytes, - "the weak pair buffer"); - weak_pair_buffer_position = position; - if (weak_pair_break != EMPTY_WEAK_CHAIN) - { - weak_buffer_pre_read_count -= 1; - pre_read_weak_pair_buffers (low_heap); - } - } - return ((GC_BUFFER_BOTTOM (weak_pair_buffer)) + offset); -} - -/* For a description of the algorithm, see memmag.c and gccode.h. - This has been modified only to account for the fact that new space - is on disk. Old space is in memory. - Note: Compiled_BH requires the names Temp and Old! -*/ - -static SCHEME_OBJECT -DEFUN (update_weak_pointer, (Temp, low_heap), - SCHEME_OBJECT Temp AND - SCHEME_OBJECT * low_heap) -{ - SCHEME_OBJECT * Old; - - switch (GC_Type (Temp)) - { - case GC_Non_Pointer: - return (Temp); - - case GC_Special: - if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP) - /* No other special type makes sense here. */ - goto fail; - if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) - return (Temp); - /* Otherwise, it is a pointer. Fall through */ - - /* Normal pointer types, the broken heart is in the first word. - Note that most special types are treated normally here. - The BH code updates *Scan if the object has been relocated. - Otherwise it falls through and we replace it with a full SHARP_F. - Eliminating this assignment would keep old data (pl. of datum). - */ - case GC_Cell: - case GC_Pair: - case GC_Triple: - case GC_Quadruple: - case GC_Vector: - Old = (OBJECT_ADDRESS (Temp)); - if (Old < low_heap) - return (Temp); - - if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) - return (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old)); - else - return (SHARP_F); - - case GC_Compiled: - Old = (OBJECT_ADDRESS (Temp)); - if (Old < low_heap) - return (Temp); - Compiled_BH (false, { return Temp; }); - return (SHARP_F); - - default: /* Non Marked Headers and Broken Hearts */ - case GC_Undefined: - fail: - outf_error ("\n%s (update_weak_pointer): Clearing bad object 0x%08lx.\n", - scheme_program_name, Temp); - return (SHARP_F); - } -} - -SCHEME_OBJECT - Weak_Chain, - * weak_pair_stack_ptr, - * weak_pair_stack_limit; - -void -DEFUN (initialize_weak_pair_transport, (limit), SCHEME_OBJECT * limit) -{ - Weak_Chain = EMPTY_WEAK_CHAIN; - weak_pair_stack_ptr = sp_register; - weak_pair_stack_limit = (limit + 1); /* in case it's odd */ - return; -} - -void -DEFUN (fix_weak_chain_1, (low_heap), SCHEME_OBJECT * low_heap) -{ - fast SCHEME_OBJECT chain, * old_weak_cell, * scan, * ptr, * limit; - - chain = Weak_Chain; - initialize_new_space_buffer (chain, low_heap); - - limit = sp_register; - for (ptr = weak_pair_stack_ptr; ptr < limit ; ptr += 2) - *ptr = (update_weak_pointer (*ptr, low_heap)); - - while (chain != EMPTY_WEAK_CHAIN) - { - old_weak_cell = (OBJECT_ADDRESS (Weak_Chain)); - scan - = (guarantee_in_memory ((OBJECT_ADDRESS (*old_weak_cell++)), low_heap)); - Weak_Chain = (* old_weak_cell); - *scan - = (update_weak_pointer - ((MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, (* scan))), low_heap)); - Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain)); - } - flush_new_space_buffer (); - Weak_Chain = chain; - return; -} - -void -DEFUN_VOID (fix_weak_chain_2) -{ - SCHEME_OBJECT * ptr, * limit, new_car, * addr; - - limit = sp_register; - for (ptr = weak_pair_stack_ptr; ptr < limit ; ) - { - new_car = *ptr++; - addr = ((SCHEME_OBJECT *) (*ptr++)); - if (new_car != SHARP_F) - *addr = new_car; - } - weak_pair_stack_ptr = limit; - return; -} - -long -DEFUN (GC_relocate_root, (free_buffer_ptr), SCHEME_OBJECT ** free_buffer_ptr) -{ - long skip; - SCHEME_OBJECT * initial_free_buffer, * free_buffer; - - free_buffer = * free_buffer_ptr; - initial_free_buffer = free_buffer; - SET_MEMTOP (Heap_Top - GC_Reserve); - - /* Save the microcode registers so that they can be relocated */ - - Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F); - Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F); - - *free_buffer++ = Fixed_Objects; - *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register)); - *free_buffer++ = (Get_Current_Stacklet ()); - *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? - SHARP_F : - (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, - Prev_Restore_History_Stacklet))); - - *free_buffer++ = Current_State_Point; - *free_buffer++ = Fluid_Bindings; - skip = (free_buffer - initial_free_buffer); - if (free_buffer >= free_buffer_top) - free_buffer = (dump_and_reset_free_buffer (free_buffer, 0)); - * free_buffer_ptr = free_buffer; - return (skip); -} - -void -DEFUN (GC_end_root_relocation, (root, root2), - SCHEME_OBJECT * root AND SCHEME_OBJECT * root2) -{ - /* Make the microcode registers point to the copies in new-space. */ - - Fixed_Objects = *root++; - Set_Fixed_Obj_Slot (Precious_Objects, *root2); - Set_Fixed_Obj_Slot - (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2)))); - - history_register = (OBJECT_ADDRESS (*root++)); - Set_Current_Stacklet (* root); - root += 1; - if ((* root) != SHARP_F) - Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++)); - else - { - Prev_Restore_History_Stacklet = NULL; - root += 1; - } - Current_State_Point = *root++; - Fluid_Bindings = *root++; - Free_Stacklets = NULL; - COMPILER_TRANSPORT_END (); - CLEAR_INTERRUPT (INT_GC); - return; -} - -/* Here is the set up for the full garbage collection: - - - First it makes the constant space and stack into one large area - by "hiding" the gap between them with a non-marked header. - - - Then it saves away all the relevant microcode registers into new - space, making this the root for garbage collection. - - - Then it does the actual garbage collection in 4 steps: - 1) Trace constant space. - 2) Trace objects pointed out by the root and constant space. - 3) Trace the precious objects, remembering where consing started. - 4) Update all weak pointers. - - - Load new space to memory. - - - Finally it restores the microcode registers from the copies in - new space. -*/ - -void -DEFUN (GC, (weak_pair_transport_initialized_p), - int weak_pair_transport_initialized_p) -{ - SCHEME_OBJECT * root; - SCHEME_OBJECT * end_of_constant_area; - SCHEME_OBJECT the_precious_objects; - SCHEME_OBJECT * root2; - SCHEME_OBJECT * free_buffer; - SCHEME_OBJECT * block_start; - SCHEME_OBJECT * saved_ctop; - long skip_length; - - saved_ctop = Constant_Top; - if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE) - && (update_allocator_parameters (Free_Constant))) - Constant_Top = saved_ctop; - - if (!weak_pair_transport_initialized_p) - initialize_weak_pair_transport (Stack_Bottom); - - free_buffer = (initialize_free_buffer ()); - Free = Heap_Bottom; - ALIGN_FLOAT (Free); - block_start = aligned_heap; - skip_length = (Free - block_start); - free_buffer += skip_length; - - Terminate_Old_Stacklet (); - SEAL_CONSTANT_SPACE (); - end_of_constant_area = (CONSTANT_AREA_END ()); - the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects)); - root = Free; - - /* The 4 step GC */ - - Free += (GC_relocate_root (&free_buffer)); - - { - SCHEME_OBJECT * new_scan - = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer), (&Free), - Constant_Top, NORMAL_GC, 0)); - if (new_scan != end_of_constant_area) - { - gc_death (TERM_EXIT, "gc_loop ended too early", new_scan, free_buffer); - /*NOTREACHED*/ - } - } - - { - SCHEME_OBJECT * scan - = (gc_loop (((initialize_scan_buffer (block_start)) + skip_length), - (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1)); - - root2 = Free; - (*free_buffer++) = the_precious_objects; - Free += 1; - if (free_buffer >= free_buffer_top) - free_buffer = (dump_and_reset_free_buffer (free_buffer, 0)); - - gc_loop (scan, (&free_buffer), (&Free), Constant_Top, NORMAL_GC, 1); - } - - end_transport (0); - fix_weak_chain_1 (Constant_Top); - - /* Load new space into memory. */ - final_reload (block_start, (Free - block_start), "new space"); - - fix_weak_chain_2 (); - GC_end_root_relocation (root, root2); - Constant_Top = saved_ctop; - SET_CONSTANT_TOP (); -} - -/* (GARBAGE-COLLECT SLACK) - Requests a garbage collection leaving the specified amount of slack - for the top of heap check on the next GC. The primitive ends by - invoking the GC daemon if there is one. -*/ - -DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) -{ - extern unsigned long gc_counter; - SCHEME_OBJECT daemon; - PRIMITIVE_HEADER (1); - PRIMITIVE_CANONICALIZE_CONTEXT (); - - STACK_SANITY_CHECK ("GC"); - if (Free > Heap_Top) - termination_gc_out_of_space (); - - GC_Reserve = (arg_nonnegative_integer (1)); - POP_PRIMITIVE_FRAME (1); - - ENTER_CRITICAL_SECTION ("garbage collector"); - run_pre_gc_hooks (); - gc_counter += 1; - GC (0); - run_post_gc_hooks (); - daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); - - Will_Push (CONTINUATION_SIZE); - Store_Return (RC_NORMAL_GC_DONE); - exp_register = (LONG_TO_FIXNUM (MemTop - Free - GC_Space_Needed)); - Save_Cont (); - Pushed (); - - RENAME_CRITICAL_SECTION ("garbage collector daemon"); - if (daemon == SHARP_F) - PRIMITIVE_ABORT (PRIM_POP_RETURN); - /*NOTREACHED*/ - - Will_Push (2); - STACK_PUSH (daemon); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed (); - PRIMITIVE_ABORT (PRIM_APPLY); - /*NOTREACHED*/ - return (0); -} - -#ifdef RECORD_GC_STATISTICS - -static void -DEFUN_VOID (statistics_clear) -{ - int cntr, arlen; - struct bch_GC_statistic * ptr; - - arlen = (((sizeof (all_gc_statistics)) - / (sizeof (struct bch_GC_statistic))) - - 1); - for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++) - (* (ptr->counter)) = 0; - return; -} - -static int statistics_print_level = 0; - -static void -DEFUN (statistics_print, (level, noise), int level AND char * noise) -{ - char format[30]; - int cntr, arlen, len, name_len; - struct bch_GC_statistic * ptr; - - if (level > statistics_print_level) - return; - arlen = (((sizeof (all_gc_statistics)) - / (sizeof (struct bch_GC_statistic))) - - 1); - name_len = -1; - for (cntr = 0, ptr = &all_gc_statistics[0]; - cntr < arlen; - cntr++, ptr++) - if ((* (ptr->counter)) != 0L) - { - len = (strlen (ptr->name)); - if (len > name_len) - name_len = len; - } - - if (name_len >= 0) - { - sprintf (&format[0], "\t%%-%ds : %%ld\n", name_len); - - outf_console ("\nGC I/O statistics %s:\n", noise); - for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++) - if ((* (ptr->counter)) != 0L) - outf_console (&format[0], ptr->name, (* (ptr->counter))); - outf_flush_console (); - } - return; -} -#endif /* RECORD_GC_STATISTICS */ - -static SCHEME_OBJECT -DEFUN_VOID (statistics_names) -{ - SCHEME_OBJECT vector, * scan; - struct bch_GC_statistic * ptr; - int len, cntr; - - len = (((sizeof (all_gc_statistics)) - / (sizeof (struct bch_GC_statistic))) - - 1); - if (len == 0) - return (SHARP_F); - - vector = (allocate_marked_vector (TC_VECTOR, len, true)); - for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0)); - cntr < len; - cntr++, ptr++) - *scan++ = (char_pointer_to_string (ptr->name)); - return (vector); -} - -static void -DEFUN_VOID (statistics_read) -{ - SCHEME_OBJECT vector, *scan; - struct bch_GC_statistic * ptr; - int len, cntr; - - len = (((sizeof (all_gc_statistics)) - / (sizeof (struct bch_GC_statistic))) - - 1); - if (len == 0) - signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE); - - vector = (VECTOR_ARG (1)); - if (len != ((int) (VECTOR_LENGTH (vector)))) - error_bad_range_arg (1); - - for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0)); - cntr < len; - cntr++, ptr++) - *scan++ = (long_to_integer (* (ptr->counter))); - return; -} - -/* Additional primitives for statistics collection and - manipulation of parameters from Scheme - */ - -DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-NAMES", Prim_bchscheme_stat_names, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN (statistics_names ()); -} - -DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-READ!", Prim_bchscheme_read_stats, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - statistics_read (); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* There are other parameters that could be set, especially the drone program - to run, and the file to gc from, but... - */ - -#ifndef GET_SLEEP_DELTA -#define GET_SLEEP_DELTA() -1 -#define SET_SLEEP_DELTA(v) do { } while (0) -#endif - -#define N_PARAMS 6 - -DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-GET", Prim_bchscheme_get_params, 0, 0, 0) -{ - SCHEME_OBJECT vector; - PRIMITIVE_HEADER (0); - - vector = (allocate_marked_vector (TC_VECTOR, N_PARAMS, true)); - - VECTOR_SET (vector, 0, - (long_to_integer ((long) CAN_RECONFIGURE_GC_BUFFERS))); - VECTOR_SET (vector, 1, (long_to_integer ((long) gc_buffer_size))); - VECTOR_SET (vector, 2, (long_to_integer ((long) read_overlap))); - VECTOR_SET (vector, 3, (long_to_integer ((long) write_overlap))); - VECTOR_SET (vector, 4, (long_to_integer ((long) (GET_SLEEP_DELTA ())))); - VECTOR_SET (vector, 5, (char_pointer_to_string (drone_file_name))); - - PRIMITIVE_RETURN (vector); -} - -#if CAN_RECONFIGURE_GC_BUFFERS -static long -DEFUN (bchscheme_long_parameter, (vector, index), - SCHEME_OBJECT vector AND int index) -{ - SCHEME_OBJECT temp; - long value; - - temp = (VECTOR_REF (vector, index)); - if ((! (INTEGER_P (temp))) || (! (integer_to_long_p (temp)))) - error_bad_range_arg (1); - value = (integer_to_long (temp)); - if (value < 0) - error_bad_range_arg (1); - return (value); -} -#endif /* CAN_RECONFIGURE_GC_BUFFERS */ - -DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-SET!", Prim_bchscheme_set_params, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - -#if !CAN_RECONFIGURE_GC_BUFFERS - signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE); - /*NOTREACHED*/ - return (0); -#else - - { - char * new_drone_ptr; - SCHEME_OBJECT vector, new_drone; - long - new_buffer_size, new_read_overlap, - new_write_overlap, new_sleep_period, - old_buffer_size = gc_buffer_size, - old_buffer_shift = gc_buffer_shift; - - vector = (VECTOR_ARG (1)); - if ((VECTOR_LENGTH (vector)) != N_PARAMS) - error_bad_range_arg (1); - - /* Slot 0 ignored. */ - new_buffer_size = (bchscheme_long_parameter (vector, 1)); - new_read_overlap = (bchscheme_long_parameter (vector, 2)); - new_write_overlap = (bchscheme_long_parameter (vector, 3)); - new_sleep_period = (bchscheme_long_parameter (vector, 4)); - new_drone = (VECTOR_REF (vector, 5)); - if (! (STRING_P (new_drone))) - error_bad_range_arg (1); - if ((STRING_LENGTH (new_drone)) == 0) - new_drone_ptr = ((char *) NULL); - else - { - new_drone_ptr = ((char *) (malloc ((STRING_LENGTH (new_drone)) + 1))); - if (new_drone_ptr != ((char *) NULL)) - strcpy (new_drone_ptr, ((char *) (STRING_LOC (new_drone, 0)))); - } - - if (new_buffer_size != old_buffer_size) - { - int power = (next_exponent_of_two (new_buffer_size)); - - if (((1L << power) != new_buffer_size) - || ((set_gc_buffer_sizes (power)) != 0)) - error_bad_range_arg (1); - if (! (recompute_gc_end_position ())) - { - set_gc_buffer_sizes (old_buffer_shift); - error_bad_range_arg (1); - } - } - - BUFFER_SHUTDOWN (0); - SET_SLEEP_DELTA (new_sleep_period); - if ((drone_file_name != ((char *) NULL)) - && (drone_file_name != option_gc_drone)) - free ((PTR) drone_file_name); - - if ((RE_INITIALIZE_GC_BUFFERS (0, - Highest_Allocated_Address, - ((sizeof (SCHEME_OBJECT)) - * (CEILING ((saved_heap_size - + saved_constant_size), - gc_buffer_size))), - new_read_overlap, - new_write_overlap, - new_drone_ptr)) - == 0) - PRIMITIVE_RETURN (UNSPECIFIC); - else - { - if (new_buffer_size != old_buffer_size) - { - set_gc_buffer_sizes (old_buffer_shift); - recompute_gc_end_position (); - } - - BUFFER_SHUTDOWN (0); - if (new_drone_ptr != ((char *) NULL)) - free (new_drone_ptr); - - if ((RE_INITIALIZE_GC_BUFFERS (0, - Highest_Allocated_Address, - (saved_heap_size - * (sizeof (SCHEME_OBJECT))), - 0, 0, - option_gc_drone)) != 0) - Microcode_Termination (TERM_EXIT); - else - signal_error_from_primitive (ERR_EXTERNAL_RETURN); - } - /*NOTREACHED*/ - return (0); - } -#endif /* (CAN_RECONFIGURE_GC_BUFFERS == 0) */ -} diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c deleted file mode 100644 index 8fe3cca0c..000000000 --- a/v7/src/microcode/bchpur.c +++ /dev/null @@ -1,302 +0,0 @@ -/* -*-C-*- - -$Id: bchpur.c,v 9.76 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* - * This file contains the code for primitives dealing with pure - * and constant space. Garbage collection to disk version. - * - * Poorly implemented: If there is not enough space, instead of - * undoing the changes, it crashes. - * It should be changed to do the job in two passes like the - * "normal" version. - */ - -#include "scheme.h" -#include "prims.h" -#include "bchgcc.h" -#include "zones.h" - -static void EXFUN (purify, (SCHEME_OBJECT, Boolean)); -static SCHEME_OBJECT * EXFUN (purify_header_overflow, (SCHEME_OBJECT *)); - -/* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN) - - Copy an object from the heap into constant space. It should only - be used through the wrapper provided in the Scheme runtime system. - - To purify an object we just copy it into Pure Space in two - parts with the appropriate headers and footers. The actual - copying is done by gc_loop. - - Once the copy is complete we run a full GC which handles the - broken hearts which now point into pure space. - - This primitive does not return normally. It always escapes into - the interpreter because some of its cached registers (e.g. - history_register) have changed. */ - -DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) -{ - Boolean pure_p; - SCHEME_OBJECT object, result, daemon; - PRIMITIVE_HEADER (3); - PRIMITIVE_CANONICALIZE_CONTEXT (); - - STACK_SANITY_CHECK ("PURIFY"); - Save_Time_Zone (Zone_Purify); - TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object); - CHECK_ARG (2, BOOLEAN_P); - pure_p = (BOOLEAN_ARG (2)); - GC_Reserve = (arg_nonnegative_integer (3)); - - POP_PRIMITIVE_FRAME (3); - - ENTER_CRITICAL_SECTION ("purify"); - purify (object, pure_p); - result = (MAKE_POINTER_OBJECT (TC_LIST, Free)); - Free += 2; - Free[-2] = SHARP_T; - Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); - - Will_Push (CONTINUATION_SIZE); - Store_Return (RC_NORMAL_GC_DONE); - exp_register = result; - Save_Cont (); - Pushed (); - - RENAME_CRITICAL_SECTION ("purify daemon"); - daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); - if (daemon == SHARP_F) - { - PRIMITIVE_ABORT (PRIM_POP_RETURN); - /*NOTREACHED*/ - } - - Will_Push (2); - STACK_PUSH (daemon); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed (); - PRIMITIVE_ABORT (PRIM_APPLY); - /*NOTREACHED*/ - return (UNSPECIFIC); -} - -static void -DEFUN (purify, (object, pure_p), SCHEME_OBJECT object AND Boolean pure_p) -{ - long length; - long pure_length; - long delta; - SCHEME_OBJECT * free_buffer_ptr; - SCHEME_OBJECT * old_free_const; - SCHEME_OBJECT * block_start; - SCHEME_OBJECT * new_free_const; - SCHEME_OBJECT * pending_scan; - SCHEME_OBJECT * root; - SCHEME_OBJECT * root2; - SCHEME_OBJECT the_precious_objects; - - run_pre_gc_hooks (); - STACK_SANITY_CHECK ("PURIFY"); - initialize_weak_pair_transport (Stack_Bottom); - free_buffer_ptr = (initialize_free_buffer ()); - Terminate_Old_Stacklet (); - SEAL_CONSTANT_SPACE (); - the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects)); - - Constant_Top = Free_Constant; - old_free_const = Free_Constant; - new_free_const = old_free_const; - block_start = ((SCHEME_OBJECT *) (ALIGN_DOWN_TO_IO_PAGE (old_free_const))); - delta = (old_free_const - block_start); - - free_buffer_ptr += delta; - (*free_buffer_ptr++) = SHARP_F; /* Pure block header. */ - (*free_buffer_ptr++) = object; - new_free_const += 2; - if (free_buffer_ptr >= free_buffer_top) - free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0)); - - if (pure_p) - { - gc_loop (((initialize_scan_buffer (block_start)) + delta), - (&free_buffer_ptr), (&new_free_const), Constant_Top, - PURE_COPY, 1); - pure_length = ((new_free_const - old_free_const) + 1); - } - else - pure_length = 3; - - (*free_buffer_ptr++) - = (pure_p - ? (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, new_free_const)) - : (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1))); - (*free_buffer_ptr++) = (MAKE_OBJECT (CONSTANT_PART, pure_length)); - new_free_const += 2; - if (free_buffer_ptr >= free_buffer_top) - free_buffer_ptr = (purify_header_overflow (free_buffer_ptr)); - - { - SCHEME_OBJECT * scan_start - = ((initialize_scan_buffer (block_start)) + delta); - if (pure_p) - { - SCHEME_OBJECT * pure_area_limit = (new_free_const - 2); - SCHEME_OBJECT * result - = (gc_loop (scan_start, (&free_buffer_ptr), (&new_free_const), - Constant_Top, CONSTANT_COPY, 0)); - if ((*result) - != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, pure_area_limit))) - { - gc_death (TERM_BROKEN_HEART, "gc_loop ended too early", - result, free_buffer_ptr); - /*NOTREACHED*/ - } - (*result) = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); - scan_start = (result + 2); - } - pending_scan - = (gc_loop (scan_start, (&free_buffer_ptr), (&new_free_const), - Constant_Top, NORMAL_GC, 1)); - } - - length = (new_free_const + 1 - old_free_const); - (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); - (*free_buffer_ptr++) = (MAKE_OBJECT (END_OF_BLOCK, length)); - new_free_const += 2; - if (free_buffer_ptr >= free_buffer_top) - free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0)); - - Free_Constant = new_free_const; - if (!update_allocator_parameters (Free_Constant)) - { - gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL); - /*NOTREACHED*/ - } - while (!FLOATING_ALIGNED_P (Free_Constant)) - { - (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); - Free_Constant += 1; - } - if (Constant_Top > Free_Constant) - { - /* This assumes that the distance between the new constant space - and the new free constant is smaller than a bufferful. */ - long bump = (Constant_Top - Free_Constant); - (*free_buffer_ptr) - = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (bump - 1))); - free_buffer_ptr += bump; - if (free_buffer_ptr >= free_buffer_top) - free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0)); - } - while (!FLOATING_ALIGNED_P (Free)) - { - (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); - Free += 1; - } - - root = Free; - Free += (GC_relocate_root (&free_buffer_ptr)); - - { - struct saved_scan_state scan_state; - save_scan_state ((&scan_state), pending_scan); - set_fixed_scan_area (0, Highest_Allocated_Address); - { - SCHEME_OBJECT * result - = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer_ptr), (&Free), - old_free_const, NORMAL_GC, 0)); - if (result != old_free_const) - { - gc_death (TERM_EXIT, "gc_loop ended too early", - result, free_buffer_ptr); - /*NOTREACHED*/ - } - } - pending_scan = (restore_scan_state (&scan_state)); - } - - pending_scan - = (gc_loop (pending_scan, (&free_buffer_ptr), (&Free), - old_free_const, NORMAL_GC, 1)); - - root2 = Free; - (*free_buffer_ptr++) = the_precious_objects; - Free += 1; - if (free_buffer_ptr >= free_buffer_top) - free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0)); - - gc_loop (pending_scan, (&free_buffer_ptr), (&Free), - old_free_const, NORMAL_GC, 1); - - end_transport (0); - fix_weak_chain_1 (old_free_const); - - /* Load new space into memory carefully to prevent the shared - buffer from losing any values. */ - { - unsigned long counter; - - for (counter = 0; (counter < delta); counter += 1) - (scan_buffer_bottom[counter]) = (block_start[counter]); - - final_reload (block_start, (Free - block_start), "new space"); - - for (counter = 0; (counter < delta); counter += 1) - (block_start[counter]) = (scan_buffer_bottom[counter]); - } - - fix_weak_chain_2 (); - GC_end_root_relocation (root, root2); - - (*old_free_const++) - = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length)); - (*old_free_const) = (MAKE_OBJECT (PURE_PART, length)); - SEAL_CONSTANT_SPACE (); - run_post_gc_hooks (); -} - -/* This is not paranoia! - The two words in the header may overflow the free buffer. */ -static SCHEME_OBJECT * -DEFUN (purify_header_overflow, (free_buffer), SCHEME_OBJECT * free_buffer) -{ - long delta = (free_buffer - free_buffer_top); - free_buffer = (dump_and_reset_free_buffer (free_buffer, 0)); - { - SCHEME_OBJECT * scan_buffer - = (dump_and_reload_scan_buffer (scan_buffer_top, 0)); - if ((scan_buffer + delta) != free_buffer) - { - gc_death (TERM_EXIT, - "purify: scan and free do not meet at the end", - (scan_buffer + delta), free_buffer); - /*NOTREACHED*/ - } - } - return (free_buffer); -} diff --git a/v7/src/microcode/bchutl.c b/v7/src/microcode/bchutl.c deleted file mode 100644 index f775f1d0b..000000000 --- a/v7/src/microcode/bchutl.c +++ /dev/null @@ -1,147 +0,0 @@ -/* -*-C-*- - -$Id: bchutl.c,v 1.17 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -#include "config.h" -#include - -#include -#ifndef EINTR -# define EINTR 1999 -#endif - -#ifdef HAVE_UNISTD_H -# include -#endif - -#ifdef STDC_HEADERS -# include -#endif - -#ifdef HAVE_STRERROR - -char * -DEFUN (error_name, (code), int code) -{ - static char buf [512]; - sprintf (buf, "%d, %s", code, (strerror (code))); - return (buf); -} - -#else /* not HAVE_STRERROR */ -#ifdef __WIN32__ - -#define lseek _lseek - -char * -DEFUN (error_name, (code), int code) -{ - static char buf [512]; - sprintf (buf, "%d, unknown error", code); - return (buf); -} - -#else /* not __WIN32__ */ -#ifdef __OS2__ - -#if defined(__IBMC__) || defined(__WATCOMC__) || defined(__EMX__) -# include -#endif - -char * -DEFUN (error_name, (code), int code) -{ - static char buf [512]; - sprintf (buf, "%d, unknown error", code); - return (buf); -} - -#else /* not __OS2__ */ - -char * -DEFUN (error_name, (code), int code) -{ - static char buf [512]; - if ((code >= 0) && (code <= sys_nerr)) - sprintf (buf, "%d, %s", code, sys_errlist[code]); - else - sprintf (buf, "%d, unknown error", code); - return (buf); -} - -#endif /* not __OS2__ */ -#endif /* not __WIN32__ */ -#endif /* not HAVE_STRERROR */ - -#ifndef SEEK_SET -# define SEEK_SET 0 -#endif - -int -DEFUN (retrying_file_operation, - (operation, fid, ptr, position, nbytes, name, noise, curpos, abort_p), - int EXFUN ((*operation), (int, char *, unsigned int)) - AND int fid AND char * ptr AND long position AND long nbytes - AND char * name AND char * noise AND long * curpos - AND int EXFUN ((*abort_p), (char *, char *))) -{ - char * membuf = ptr; - long - bytes_to_transfer = nbytes, - bytes_transferred; - - if (*curpos != position) - while ((lseek (fid, position, SEEK_SET)) == -1) - if ((errno != EINTR) && ((*abort_p) ("lseek", noise))) - goto fail; - - while ((bytes_to_transfer > 0) - && ((bytes_transferred = - ((*operation) (fid, membuf, ((unsigned int) bytes_to_transfer)))) - != bytes_to_transfer)) - if (bytes_transferred == -1) - { - if ((errno != EINTR) && ((*abort_p) (name, noise))) - goto fail; - - while ((lseek (fid, (position + (nbytes - bytes_to_transfer)), SEEK_SET)) - == -1) - if ((errno != EINTR) && ((*abort_p) ("lseek", noise))) - goto fail; - } - else - { - bytes_to_transfer -= bytes_transferred; - membuf += bytes_transferred; - } - *curpos = (position + nbytes); - return (nbytes); - -fail: - *curpos = -1; - return (-1); -} - diff --git a/v7/src/microcode/bignmint.h b/v7/src/microcode/bignmint.h index a20de7b11..fb3c14bf8 100644 --- a/v7/src/microcode/bignmint.h +++ b/v7/src/microcode/bignmint.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bignmint.h,v 1.10 2007/01/05 21:19:25 cph Exp $ +$Id: bignmint.h,v 1.11 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -32,8 +32,8 @@ USA. /* The memory model is based on the following definitions, and on the definition of the type `bignum_type'. The only other special - definition is `CHAR_BIT', which is defined in the Ansi C header - file "limits.h". */ + definition is `CHAR_BIT', which is defined in the header file + "limits.h". */ typedef long bignum_digit_type; typedef long bignum_length_type; @@ -66,7 +66,7 @@ typedef long bignum_length_type; /* BIGNUM_DEALLOCATE is called when disposing of bignums which are created as intermediate temporaries; Scheme doesn't need this. */ -#define BIGNUM_DEALLOCATE(bignum) +#define BIGNUM_DEALLOCATE(bignum) do {} while (0) /* If BIGNUM_FORCE_NEW_RESULTS is defined, all bignum-valued operations return freshly-allocated results. This is useful for some kinds of @@ -85,18 +85,17 @@ typedef long bignum_length_type; #define BIGNUM_DEALLOCATE free #define BIGNUM_FORCE_NEW_RESULTS #define BIGNUM_EXCEPTION abort -#define fast register extern void free (); extern void abort (); -#endif /* MIT_SCHEME */ +#endif /* not MIT_SCHEME */ #define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2) #define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2) -#define BIGNUM_RADIX (((unsigned long) 1) << BIGNUM_DIGIT_LENGTH) -#define BIGNUM_RADIX_ROOT (((unsigned long) 1) << BIGNUM_HALF_DIGIT_LENGTH) -#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1) -#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1) +#define BIGNUM_RADIX (1UL << BIGNUM_DIGIT_LENGTH) +#define BIGNUM_RADIX_ROOT (1UL << BIGNUM_HALF_DIGIT_LENGTH) +#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1UL) +#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1UL) #define BIGNUM_START_PTR(bignum) \ ((BIGNUM_TO_POINTER (bignum)) + 1) diff --git a/v7/src/microcode/bignum.c b/v7/src/microcode/bignum.c index 22be8b92e..69c80ec5d 100644 --- a/v7/src/microcode/bignum.c +++ b/v7/src/microcode/bignum.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bignum.c,v 9.56 2007/01/05 21:19:25 cph Exp $ +$Id: bignum.c,v 9.57 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -28,21 +28,17 @@ USA. /* Implementation of Bignums (unlimited precision integers) */ #ifdef MIT_SCHEME -#include "scheme.h" -#undef CHAR_BIT /* redefined in "limits.h" */ +# include "scheme.h" #else -#include "bignum.h" +# include "bignum.h" #endif #include "bignmint.h" -#include "limits.h" -#include "float.h" -#include #ifndef MIT_SCHEME static bignum_type -DEFUN (bignum_malloc, (length), bignum_length_type length) +bignum_malloc (bignum_length_type length) { extern char * malloc (); char * result = (malloc ((length + 1) * (sizeof (bignum_digit_type)))); @@ -51,8 +47,7 @@ DEFUN (bignum_malloc, (length), bignum_length_type length) } static bignum_type -DEFUN (bignum_realloc, (bignum, length), - bignum_type bignum AND bignum_length_type length) +bignum_realloc (bignum_type bignum, bignum_length_type length) { extern char * realloc (); char * result = @@ -65,72 +60,44 @@ DEFUN (bignum_realloc, (bignum, length), #endif /* not MIT_SCHEME */ /* Forward references */ -static int EXFUN (bignum_equal_p_unsigned, - (bignum_type, bignum_type)); -static enum bignum_comparison EXFUN (bignum_compare_unsigned, - (bignum_type, bignum_type)); -static bignum_type EXFUN (bignum_add_unsigned, - (bignum_type, bignum_type, int)); -static bignum_type EXFUN (bignum_subtract_unsigned, - (bignum_type, bignum_type)); -static bignum_type EXFUN (bignum_multiply_unsigned, - (bignum_type, bignum_type, int)); -static bignum_type EXFUN (bignum_multiply_unsigned_small_factor, - (bignum_type, bignum_digit_type, int)); -static void EXFUN (bignum_destructive_scale_up, - (bignum_type, bignum_digit_type)); -static void EXFUN (bignum_destructive_add, - (bignum_type, bignum_digit_type)); -static void EXFUN (bignum_divide_unsigned_large_denominator, - (bignum_type, bignum_type, bignum_type *, bignum_type *, - int, int)); -static void EXFUN (bignum_destructive_normalization, - (bignum_type, bignum_type, int)); -static void EXFUN (bignum_destructive_unnormalization, - (bignum_type, int)); -static void EXFUN (bignum_divide_unsigned_normalized, - (bignum_type, bignum_type, bignum_type)); -static bignum_digit_type EXFUN (bignum_divide_subtract, - (bignum_digit_type *, bignum_digit_type *, - bignum_digit_type, bignum_digit_type *)); -static void EXFUN (bignum_divide_unsigned_medium_denominator, - (bignum_type, bignum_digit_type, bignum_type *, - bignum_type *, int, int)); -static bignum_digit_type EXFUN (bignum_digit_divide, - (bignum_digit_type, bignum_digit_type, - bignum_digit_type, bignum_digit_type *)); -static bignum_digit_type EXFUN (bignum_digit_divide_subtract, - (bignum_digit_type, bignum_digit_type, - bignum_digit_type, bignum_digit_type *)); -static void EXFUN (bignum_divide_unsigned_small_denominator, - (bignum_type, bignum_digit_type, bignum_type *, - bignum_type *, int, int)); -static bignum_digit_type EXFUN (bignum_destructive_scale_down, - (bignum_type, bignum_digit_type)); -static bignum_type EXFUN (bignum_remainder_unsigned_small_denominator, - (bignum_type, bignum_digit_type, int)); -static bignum_type EXFUN (bignum_digit_to_bignum, - (bignum_digit_type, int)); -static bignum_type EXFUN (bignum_allocate, - (bignum_length_type, int)); -static bignum_type EXFUN (bignum_allocate_zeroed, - (bignum_length_type, int)); -static bignum_type EXFUN (bignum_shorten_length, - (bignum_type, bignum_length_type)); -static bignum_type EXFUN (bignum_trim, - (bignum_type)); -static bignum_type EXFUN (bignum_copy, - (bignum_type)); -static bignum_type EXFUN (bignum_new_sign, - (bignum_type, int)); -static bignum_type EXFUN (bignum_maybe_new_sign, - (bignum_type, int)); -static void EXFUN (bignum_destructive_copy, - (bignum_type, bignum_type)); +static int bignum_equal_p_unsigned (bignum_type, bignum_type); +static enum bignum_comparison bignum_compare_unsigned (bignum_type, bignum_type); +static bignum_type bignum_add_unsigned (bignum_type, bignum_type, int); +static bignum_type bignum_subtract_unsigned (bignum_type, bignum_type); +static bignum_type bignum_multiply_unsigned (bignum_type, bignum_type, int); +static bignum_type bignum_multiply_unsigned_small_factor (bignum_type, bignum_digit_type, int); +static void bignum_destructive_scale_up (bignum_type, bignum_digit_type); +static void bignum_destructive_add (bignum_type, bignum_digit_type); +static void bignum_divide_unsigned_large_denominator (bignum_type, bignum_type, bignum_type *, bignum_type *, + int, int); +static void bignum_destructive_normalization (bignum_type, bignum_type, int); +static void bignum_destructive_unnormalization (bignum_type, int); +static void bignum_divide_unsigned_normalized (bignum_type, bignum_type, bignum_type); +static bignum_digit_type bignum_divide_subtract (bignum_digit_type *, bignum_digit_type *, + bignum_digit_type, bignum_digit_type *); +static void bignum_divide_unsigned_medium_denominator (bignum_type, bignum_digit_type, bignum_type *, + bignum_type *, int, int); +static bignum_digit_type bignum_digit_divide (bignum_digit_type, bignum_digit_type, + bignum_digit_type, bignum_digit_type *); +static bignum_digit_type bignum_digit_divide_subtract (bignum_digit_type, bignum_digit_type, + bignum_digit_type, bignum_digit_type *); +static void bignum_divide_unsigned_small_denominator (bignum_type, bignum_digit_type, bignum_type *, + bignum_type *, int, int); +static bignum_digit_type bignum_destructive_scale_down (bignum_type, bignum_digit_type); +static bignum_type bignum_remainder_unsigned_small_denominator (bignum_type, bignum_digit_type, int); +static bignum_type bignum_digit_to_bignum (bignum_digit_type, int); +static bignum_type bignum_allocate (bignum_length_type, int); +static bignum_type bignum_allocate_zeroed (bignum_length_type, int); +static bignum_type bignum_shorten_length (bignum_type, bignum_length_type); +static bignum_type bignum_trim (bignum_type); +static bignum_type bignum_copy (bignum_type); +static bignum_type bignum_new_sign (bignum_type, int); +static bignum_type bignum_maybe_new_sign (bignum_type, int); +static void bignum_destructive_copy (bignum_type, bignum_type); #define ULONG_LENGTH_IN_BITS(digit, len) \ do { \ - fast unsigned long w = digit; \ + unsigned long w = digit; \ len = 0; \ while (w > 0xff) { len += 8; w >>= 8; } \ while (w > 0) { len += 1; w >>= 1; } \ @@ -139,25 +106,24 @@ do { \ /* Exports */ bignum_type -DEFUN_VOID (bignum_make_zero) +bignum_make_zero (void) { - fast bignum_type result = (BIGNUM_ALLOCATE (0)); + bignum_type result = (BIGNUM_ALLOCATE (0)); BIGNUM_SET_HEADER (result, 0, 0); return (result); } bignum_type -DEFUN (bignum_make_one, (negative_p), int negative_p) +bignum_make_one (int negative_p) { - fast bignum_type result = (BIGNUM_ALLOCATE (1)); + bignum_type result = (BIGNUM_ALLOCATE (1)); BIGNUM_SET_HEADER (result, 1, negative_p); (BIGNUM_REF (result, 0)) = 1; return (result); } int -DEFUN (bignum_equal_p, (x, y), - fast bignum_type x AND fast bignum_type y) +bignum_equal_p (bignum_type x, bignum_type y) { return ((BIGNUM_ZERO_P (x)) @@ -170,7 +136,7 @@ DEFUN (bignum_equal_p, (x, y), } enum bignum_comparison -DEFUN (bignum_test, (bignum), fast bignum_type bignum) +bignum_test (bignum_type bignum) { return ((BIGNUM_ZERO_P (bignum)) @@ -181,8 +147,7 @@ DEFUN (bignum_test, (bignum), fast bignum_type bignum) } enum bignum_comparison -DEFUN (bignum_compare, (x, y), - fast bignum_type x AND fast bignum_type y) +bignum_compare (bignum_type x, bignum_type y) { return ((BIGNUM_ZERO_P (x)) @@ -205,8 +170,7 @@ DEFUN (bignum_compare, (x, y), } bignum_type -DEFUN (bignum_add, (x, y), - fast bignum_type x AND fast bignum_type y) +bignum_add (bignum_type x, bignum_type y) { return ((BIGNUM_ZERO_P (x)) @@ -223,8 +187,7 @@ DEFUN (bignum_add, (x, y), } bignum_type -DEFUN (bignum_subtract, (x, y), - fast bignum_type x AND fast bignum_type y) +bignum_subtract (bignum_type x, bignum_type y) { return ((BIGNUM_ZERO_P (x)) @@ -243,7 +206,7 @@ DEFUN (bignum_subtract, (x, y), } bignum_type -DEFUN (bignum_negate, (x), fast bignum_type x) +bignum_negate (bignum_type x) { return ((BIGNUM_ZERO_P (x)) @@ -252,12 +215,11 @@ DEFUN (bignum_negate, (x), fast bignum_type x) } bignum_type -DEFUN (bignum_multiply, (x, y), - fast bignum_type x AND fast bignum_type y) +bignum_multiply (bignum_type x, bignum_type y) { - fast bignum_length_type x_length = (BIGNUM_LENGTH (x)); - fast bignum_length_type y_length = (BIGNUM_LENGTH (y)); - fast int negative_p = + bignum_length_type x_length = (BIGNUM_LENGTH (x)); + bignum_length_type y_length = (BIGNUM_LENGTH (y)); + int negative_p = ((BIGNUM_NEGATIVE_P (x)) ? (! (BIGNUM_NEGATIVE_P (y))) : (BIGNUM_NEGATIVE_P (y))); @@ -285,9 +247,8 @@ DEFUN (bignum_multiply, (x, y), } int -DEFUN (bignum_divide, (numerator, denominator, quotient, remainder), - bignum_type numerator AND bignum_type denominator - AND bignum_type * quotient AND bignum_type * remainder) +bignum_divide (bignum_type numerator, bignum_type denominator + , bignum_type * quotient, bignum_type * remainder) { if (BIGNUM_ZERO_P (denominator)) return (1); @@ -356,8 +317,7 @@ DEFUN (bignum_divide, (numerator, denominator, quotient, remainder), } bignum_type -DEFUN (bignum_quotient, (numerator, denominator), - bignum_type numerator AND bignum_type denominator) +bignum_quotient (bignum_type numerator, bignum_type denominator) { if (BIGNUM_ZERO_P (denominator)) return (BIGNUM_OUT_OF_BAND); @@ -408,8 +368,7 @@ DEFUN (bignum_quotient, (numerator, denominator), } bignum_type -DEFUN (bignum_remainder, (numerator, denominator), - bignum_type numerator AND bignum_type denominator) +bignum_remainder (bignum_type numerator, bignum_type denominator) { if (BIGNUM_ZERO_P (denominator)) return (BIGNUM_OUT_OF_BAND); @@ -468,17 +427,17 @@ DEFUN (bignum_remainder, (numerator, denominator), #ifndef BIGNUM_NO_ULONG bignum_type -DEFUN (long_to_bignum, (n), long n) +long_to_bignum (long n) { int negative_p; bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG]; - fast bignum_digit_type * end_digits = result_digits; + bignum_digit_type * end_digits = result_digits; /* Special cases win when these small constants are cached. */ if (n == 0) return (BIGNUM_ZERO ()); if (n == 1) return (BIGNUM_ONE (0)); if (n == -1) return (BIGNUM_ONE (1)); { - fast unsigned long accumulator = ((negative_p = (n < 0)) ? (-n) : n); + unsigned long accumulator = ((negative_p = (n < 0)) ? (-n) : n); do { (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); @@ -489,8 +448,8 @@ DEFUN (long_to_bignum, (n), long n) { bignum_type result = (bignum_allocate ((end_digits - result_digits), negative_p)); - fast bignum_digit_type * scan_digits = result_digits; - fast bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); + bignum_digit_type * scan_digits = result_digits; + bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); while (scan_digits < end_digits) (*scan_result++) = (*scan_digits++); return (result); @@ -498,14 +457,14 @@ DEFUN (long_to_bignum, (n), long n) } long -DEFUN (bignum_to_long, (bignum), bignum_type bignum) +bignum_to_long (bignum_type bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); { - fast unsigned long accumulator = 0; - fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + unsigned long accumulator = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); while (start < scan) accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); return @@ -516,15 +475,15 @@ DEFUN (bignum_to_long, (bignum), bignum_type bignum) } bignum_type -DEFUN (ulong_to_bignum, (n), unsigned long n) +ulong_to_bignum (unsigned long n) { bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG]; - fast bignum_digit_type * end_digits = result_digits; + bignum_digit_type * end_digits = result_digits; /* Special cases win when these small constants are cached. */ if (n == 0) return (BIGNUM_ZERO ()); if (n == 1) return (BIGNUM_ONE (0)); { - fast unsigned long accumulator = n; + unsigned long accumulator = n; do { (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); @@ -535,8 +494,8 @@ DEFUN (ulong_to_bignum, (n), unsigned long n) { bignum_type result = (bignum_allocate ((end_digits - result_digits), 0)); - fast bignum_digit_type * scan_digits = result_digits; - fast bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); + bignum_digit_type * scan_digits = result_digits; + bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); while (scan_digits < end_digits) (*scan_result++) = (*scan_digits++); return (result); @@ -544,14 +503,14 @@ DEFUN (ulong_to_bignum, (n), unsigned long n) } unsigned long -DEFUN (bignum_to_ulong, (bignum), bignum_type bignum) +bignum_to_ulong (bignum_type bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); { - fast unsigned long accumulator = 0; - fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + unsigned long accumulator = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); while (start < scan) accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); return (accumulator); @@ -570,7 +529,7 @@ DEFUN (bignum_to_ulong, (bignum), bignum_type bignum) } while (0) bignum_type -DEFUN (double_to_bignum, (x), double x) +double_to_bignum (double x) { int exponent; double significand = (frexp (x, (&exponent))); @@ -622,14 +581,14 @@ DEFUN (double_to_bignum, (x), double x) */ /* double -DEFUN (bignum_to_double, (bignum), bignum_type bignum) +bignum_to_double (bignum_type bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); { - fast double accumulator = 0; - fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + double accumulator = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); while (start < scan) accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan)); return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator); @@ -638,7 +597,7 @@ DEFUN (bignum_to_double, (bignum), bignum_type bignum) */ double -DEFUN (bignum_to_double, (bignum), bignum_type bignum) +bignum_to_double (bignum_type bignum) { if (BIGNUM_ZERO_P (bignum)) return (0.0); @@ -779,14 +738,14 @@ DEFUN (bignum_to_double, (bignum), bignum_type bignum) */ int -DEFUN (bignum_fits_in_word_p, (bignum, word_length, twos_complement_p), - bignum_type bignum AND long word_length AND int twos_complement_p) +bignum_fits_in_word_p (bignum_type bignum, long word_length, + int twos_complement_p) { unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length); BIGNUM_ASSERT (n_bits > 0); { - fast bignum_length_type length = (BIGNUM_LENGTH (bignum)); - fast unsigned int max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits)); + bignum_length_type length = (BIGNUM_LENGTH (bignum)); + unsigned int max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits)); if (((unsigned int) length) < max_digits) return (1); if (((unsigned int) length) > max_digits) @@ -805,15 +764,15 @@ DEFUN (bignum_fits_in_word_p, (bignum, word_length, twos_complement_p), } bignum_type -DEFUN (bignum_length_in_bits, (bignum), bignum_type bignum) +bignum_length_in_bits (bignum_type bignum) { if (BIGNUM_ZERO_P (bignum)) return (BIGNUM_ZERO ()); { bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); - fast bignum_digit_type digit = (BIGNUM_REF (bignum, index)); - fast bignum_digit_type delta = 0; - fast bignum_type result = (bignum_allocate (2, 0)); + bignum_digit_type digit = (BIGNUM_REF (bignum, index)); + bignum_digit_type delta = 0; + bignum_type result = (bignum_allocate (2, 0)); (BIGNUM_REF (result, 0)) = index; (BIGNUM_REF (result, 1)) = 0; bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH); @@ -824,16 +783,16 @@ DEFUN (bignum_length_in_bits, (bignum), bignum_type bignum) } bignum_type -DEFUN_VOID (bignum_length_upper_limit) +bignum_length_upper_limit (void) { - fast bignum_type result = (bignum_allocate (2, 0)); + bignum_type result = (bignum_allocate (2, 0)); (BIGNUM_REF (result, 0)) = 0; (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH; return (result); } bignum_type -DEFUN (bignum_shift_left, (n, m), bignum_type n AND unsigned long m) +bignum_shift_left (bignum_type n, unsigned long m) { unsigned long ln = (BIGNUM_LENGTH (n)); unsigned long delta = 0; @@ -874,10 +833,7 @@ DEFUN (bignum_shift_left, (n, m), bignum_type n AND unsigned long m) } bignum_type -DEFUN (unsigned_long_to_shifted_bignum, (n, m, sign), - unsigned long n AND - unsigned long m AND - int sign) +unsigned_long_to_shifted_bignum (unsigned long n, unsigned long m, int sign) { unsigned long delta = 0; if (n == 0) @@ -907,13 +863,11 @@ DEFUN (unsigned_long_to_shifted_bignum, (n, m, sign), } bignum_type -DEFUN (digit_stream_to_bignum, - (n_digits, producer, context, radix, negative_p), - fast unsigned int n_digits - AND unsigned int EXFUN ((*producer), (bignum_procedure_context)) - AND bignum_procedure_context context - AND fast unsigned int radix - AND int negative_p) +digit_stream_to_bignum (unsigned int n_digits, + unsigned int (*producer) (bignum_procedure_context), + bignum_procedure_context context, + unsigned int radix, + int negative_p) { BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT)); if (n_digits == 0) @@ -926,13 +880,13 @@ DEFUN (digit_stream_to_bignum, { bignum_length_type length; { - fast unsigned int log_radix = 0; + unsigned int log_radix = 0; ULONG_LENGTH_IN_BITS (radix, log_radix); /* This length will be at least as large as needed. */ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix)); } { - fast bignum_type result = (bignum_allocate_zeroed (length, negative_p)); + bignum_type result = (bignum_allocate_zeroed (length, negative_p)); while ((n_digits--) > 0) { bignum_destructive_scale_up (result, ((bignum_digit_type) radix)); @@ -945,18 +899,17 @@ DEFUN (digit_stream_to_bignum, } void -DEFUN (bignum_to_digit_stream, (bignum, radix, consumer, context), - bignum_type bignum - AND unsigned int radix - AND void EXFUN ((*consumer), (bignum_procedure_context, long)) - AND bignum_procedure_context context) +bignum_to_digit_stream (bignum_type bignum, + unsigned int radix, + void (*consumer) (bignum_procedure_context, long), + bignum_procedure_context context) { BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT)); if (! (BIGNUM_ZERO_P (bignum))) { - fast bignum_type working_copy = (bignum_copy (bignum)); - fast bignum_digit_type * start = (BIGNUM_START_PTR (working_copy)); - fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (working_copy))); + bignum_type working_copy = (bignum_copy (bignum)); + bignum_digit_type * start = (BIGNUM_START_PTR (working_copy)); + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (working_copy))); while (start < scan) { if ((scan[-1]) == 0) @@ -971,7 +924,7 @@ DEFUN (bignum_to_digit_stream, (bignum, radix, consumer, context), } long -DEFUN_VOID (bignum_max_digit_stream_radix) +bignum_max_digit_stream_radix (void) { return (BIGNUM_RADIX_ROOT); } @@ -979,17 +932,16 @@ DEFUN_VOID (bignum_max_digit_stream_radix) /* Comparisons */ static int -DEFUN (bignum_equal_p_unsigned, (x, y), - bignum_type x AND bignum_type y) +bignum_equal_p_unsigned (bignum_type x, bignum_type y) { bignum_length_type length = (BIGNUM_LENGTH (x)); if (length != ((bignum_length_type) (BIGNUM_LENGTH (y)))) return (0); else { - fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - fast bignum_digit_type * end_x = (scan_x + length); + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_x = (scan_x + length); while (scan_x < end_x) if ((*scan_x++) != (*scan_y++)) return (0); @@ -998,8 +950,7 @@ DEFUN (bignum_equal_p_unsigned, (x, y), } static enum bignum_comparison -DEFUN (bignum_compare_unsigned, (x, y), - bignum_type x AND bignum_type y) +bignum_compare_unsigned (bignum_type x, bignum_type y) { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); @@ -1008,13 +959,13 @@ DEFUN (bignum_compare_unsigned, (x, y), if (x_length > y_length) return (bignum_comparison_greater); { - fast bignum_digit_type * start_x = (BIGNUM_START_PTR (x)); - fast bignum_digit_type * scan_x = (start_x + x_length); - fast bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length); + bignum_digit_type * start_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_x = (start_x + x_length); + bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length); while (start_x < scan_x) { - fast bignum_digit_type digit_x = (*--scan_x); - fast bignum_digit_type digit_y = (*--scan_y); + bignum_digit_type digit_x = (*--scan_x); + bignum_digit_type digit_y = (*--scan_y); if (digit_x < digit_y) return (bignum_comparison_less); if (digit_x > digit_y) @@ -1027,8 +978,7 @@ DEFUN (bignum_compare_unsigned, (x, y), /* Addition */ static bignum_type -DEFUN (bignum_add_unsigned, (x, y, negative_p), - bignum_type x AND bignum_type y AND int negative_p) +bignum_add_unsigned (bignum_type x, bignum_type y, int negative_p) { if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { @@ -1039,13 +989,13 @@ DEFUN (bignum_add_unsigned, (x, y, negative_p), { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_type r = (bignum_allocate ((x_length + 1), negative_p)); - fast bignum_digit_type sum; - fast bignum_digit_type carry = 0; - fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - fast bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); + bignum_digit_type sum; + bignum_digit_type carry = 0; + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); { - fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - fast bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); while (scan_y < end_y) { sum = ((*scan_x++) + (*scan_y++) + carry); @@ -1062,7 +1012,7 @@ DEFUN (bignum_add_unsigned, (x, y, negative_p), } } { - fast bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); + bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); if (carry != 0) while (scan_x < end_x) { @@ -1091,8 +1041,7 @@ DEFUN (bignum_add_unsigned, (x, y, negative_p), /* Subtraction */ static bignum_type -DEFUN (bignum_subtract_unsigned, (x, y), - bignum_type x AND bignum_type y) +bignum_subtract_unsigned (bignum_type x, bignum_type y) { int negative_p = 0; switch (bignum_compare_unsigned (x, y)) @@ -1114,13 +1063,13 @@ DEFUN (bignum_subtract_unsigned, (x, y), { bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_type r = (bignum_allocate (x_length, negative_p)); - fast bignum_digit_type difference; - fast bignum_digit_type borrow = 0; - fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); - fast bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); + bignum_digit_type difference; + bignum_digit_type borrow = 0; + bignum_digit_type * scan_x = (BIGNUM_START_PTR (x)); + bignum_digit_type * scan_r = (BIGNUM_START_PTR (r)); { - fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); - fast bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); + bignum_digit_type * scan_y = (BIGNUM_START_PTR (y)); + bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y))); while (scan_y < end_y) { difference = (((*scan_x++) - (*scan_y++)) - borrow); @@ -1137,7 +1086,7 @@ DEFUN (bignum_subtract_unsigned, (x, y), } } { - fast bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); + bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length); if (borrow != 0) while (scan_x < end_x) { @@ -1166,8 +1115,7 @@ DEFUN (bignum_subtract_unsigned, (x, y), where R == BIGNUM_RADIX_ROOT */ static bignum_type -DEFUN (bignum_multiply_unsigned, (x, y, negative_p), - bignum_type x AND bignum_type y AND int negative_p) +bignum_multiply_unsigned (bignum_type x, bignum_type y, int negative_p) { if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x))) { @@ -1176,14 +1124,14 @@ DEFUN (bignum_multiply_unsigned, (x, y, negative_p), y = z; } { - fast bignum_digit_type carry; - fast bignum_digit_type y_digit_low; - fast bignum_digit_type y_digit_high; - fast bignum_digit_type x_digit_low; - fast bignum_digit_type x_digit_high; + bignum_digit_type carry; + bignum_digit_type y_digit_low; + bignum_digit_type y_digit_high; + bignum_digit_type x_digit_low; + bignum_digit_type x_digit_high; bignum_digit_type product_low; - fast bignum_digit_type * scan_r; - fast bignum_digit_type * scan_y; + bignum_digit_type * scan_r; + bignum_digit_type * scan_y; bignum_length_type x_length = (BIGNUM_LENGTH (x)); bignum_length_type y_length = (BIGNUM_LENGTH (y)); bignum_type r = @@ -1234,8 +1182,7 @@ DEFUN (bignum_multiply_unsigned, (x, y, negative_p), } static bignum_type -DEFUN (bignum_multiply_unsigned_small_factor, (x, y, negative_p), - bignum_type x AND bignum_digit_type y AND int negative_p) +bignum_multiply_unsigned_small_factor (bignum_type x, bignum_digit_type y, int negative_p) { bignum_length_type length_x = (BIGNUM_LENGTH (x)); bignum_type p = (bignum_allocate ((length_x + 1), negative_p)); @@ -1246,13 +1193,12 @@ DEFUN (bignum_multiply_unsigned_small_factor, (x, y, negative_p), } static void -DEFUN (bignum_destructive_scale_up, (bignum, factor), - bignum_type bignum AND bignum_digit_type factor) +bignum_destructive_scale_up (bignum_type bignum, bignum_digit_type factor) { - fast bignum_digit_type carry = 0; - fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type two_digits; - fast bignum_digit_type product_low; + bignum_digit_type carry = 0; + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type two_digits; + bignum_digit_type product_low; #define product_high carry bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum))); BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT)); @@ -1277,11 +1223,10 @@ DEFUN (bignum_destructive_scale_up, (bignum, factor), } static void -DEFUN (bignum_destructive_add, (bignum, n), - bignum_type bignum AND bignum_digit_type n) +bignum_destructive_add (bignum_type bignum, bignum_digit_type n) { - fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type digit; + bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); + bignum_digit_type digit; digit = ((*scan) + n); if (digit < BIGNUM_RADIX) { @@ -1309,15 +1254,12 @@ DEFUN (bignum_destructive_add, (bignum, n), section 4.3.1, "Multiple-Precision Arithmetic". */ static void -DEFUN (bignum_divide_unsigned_large_denominator, (numerator, denominator, - quotient, remainder, - q_negative_p, r_negative_p), - bignum_type numerator - AND bignum_type denominator - AND bignum_type * quotient - AND bignum_type * remainder - AND int q_negative_p - AND int r_negative_p) +bignum_divide_unsigned_large_denominator (bignum_type numerator, + bignum_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) { bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1); bignum_length_type length_d = (BIGNUM_LENGTH (denominator)); @@ -1329,7 +1271,7 @@ DEFUN (bignum_divide_unsigned_large_denominator, (numerator, denominator, int shift = 0; BIGNUM_ASSERT (length_d > 1); { - fast bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1))); + bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1))); while (v1 < (BIGNUM_RADIX / 2)) { v1 <<= 1; @@ -1362,8 +1304,7 @@ DEFUN (bignum_divide_unsigned_large_denominator, (numerator, denominator, } static void -DEFUN (bignum_divide_unsigned_normalized, (u, v, q), - bignum_type u AND bignum_type v AND bignum_type q) +bignum_divide_unsigned_normalized (bignum_type u, bignum_type v, bignum_type q) { bignum_length_type u_length = (BIGNUM_LENGTH (u)); bignum_length_type v_length = (BIGNUM_LENGTH (v)); @@ -1376,14 +1317,14 @@ DEFUN (bignum_divide_unsigned_normalized, (u, v, q), bignum_digit_type * q_scan = 0; bignum_digit_type v1 = (v_end[-1]); bignum_digit_type v2 = (v_end[-2]); - fast bignum_digit_type ph; /* high half of double-digit product */ - fast bignum_digit_type pl; /* low half of double-digit product */ - fast bignum_digit_type guess; - fast bignum_digit_type gh; /* high half-digit of guess */ - fast bignum_digit_type ch; /* high half of double-digit comparand */ - fast bignum_digit_type v2l = (HD_LOW (v2)); - fast bignum_digit_type v2h = (HD_HIGH (v2)); - fast bignum_digit_type cl; /* low half of double-digit comparand */ + bignum_digit_type ph; /* high half of double-digit product */ + bignum_digit_type pl; /* low half of double-digit product */ + bignum_digit_type guess; + bignum_digit_type gh; /* high half-digit of guess */ + bignum_digit_type ch; /* high half of double-digit comparand */ + bignum_digit_type v2l = (HD_LOW (v2)); + bignum_digit_type v2h = (HD_HIGH (v2)); + bignum_digit_type cl; /* low half of double-digit comparand */ #define gl ph /* low half-digit of guess */ #define uj pl #define qj ph @@ -1438,22 +1379,21 @@ DEFUN (bignum_divide_unsigned_normalized, (u, v, q), } static bignum_digit_type -DEFUN (bignum_divide_subtract, (v_start, v_end, guess, u_start), - bignum_digit_type * v_start - AND bignum_digit_type * v_end - AND bignum_digit_type guess - AND bignum_digit_type * u_start) +bignum_divide_subtract (bignum_digit_type * v_start, + bignum_digit_type * v_end, + bignum_digit_type guess, + bignum_digit_type * u_start) { bignum_digit_type * v_scan = v_start; bignum_digit_type * u_scan = u_start; - fast bignum_digit_type carry = 0; + bignum_digit_type carry = 0; if (guess == 0) return (0); { bignum_digit_type gl = (HD_LOW (guess)); bignum_digit_type gh = (HD_HIGH (guess)); - fast bignum_digit_type v; - fast bignum_digit_type pl; - fast bignum_digit_type vl; + bignum_digit_type v; + bignum_digit_type pl; + bignum_digit_type vl; #define vh v #define ph carry #define diff pl @@ -1518,15 +1458,12 @@ DEFUN (bignum_divide_subtract, (v_start, v_end, guess, u_start), } static void -DEFUN (bignum_divide_unsigned_medium_denominator, (numerator, denominator, - quotient, remainder, - q_negative_p, r_negative_p), - bignum_type numerator - AND bignum_digit_type denominator - AND bignum_type * quotient - AND bignum_type * remainder - AND int q_negative_p - AND int r_negative_p) +bignum_divide_unsigned_medium_denominator (bignum_type numerator, + bignum_digit_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) { bignum_length_type length_n = (BIGNUM_LENGTH (numerator)); bignum_length_type length_q; @@ -1551,9 +1488,9 @@ DEFUN (bignum_divide_unsigned_medium_denominator, (numerator, denominator, bignum_destructive_normalization (numerator, q, shift); } { - fast bignum_digit_type r = 0; - fast bignum_digit_type * start = (BIGNUM_START_PTR (q)); - fast bignum_digit_type * scan = (start + length_q); + bignum_digit_type r = 0; + bignum_digit_type * start = (BIGNUM_START_PTR (q)); + bignum_digit_type * scan = (start + length_q); bignum_digit_type qj; if (quotient != ((bignum_type *) 0)) { @@ -1581,13 +1518,12 @@ DEFUN (bignum_divide_unsigned_medium_denominator, (numerator, denominator, } static void -DEFUN (bignum_destructive_normalization, (source, target, shift_left), - bignum_type source AND bignum_type target AND int shift_left) +bignum_destructive_normalization (bignum_type source, bignum_type target, int shift_left) { - fast bignum_digit_type digit; - fast bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); - fast bignum_digit_type carry = 0; - fast bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); + bignum_digit_type digit; + bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); + bignum_digit_type carry = 0; + bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target))); int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left); @@ -1606,13 +1542,12 @@ DEFUN (bignum_destructive_normalization, (source, target, shift_left), } static void -DEFUN (bignum_destructive_unnormalization, (bignum, shift_right), - bignum_type bignum AND int shift_right) +bignum_destructive_unnormalization (bignum_type bignum, int shift_right) { bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); - fast bignum_digit_type digit; - fast bignum_digit_type carry = 0; + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); + bignum_digit_type digit; + bignum_digit_type carry = 0; int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right); bignum_digit_type mask = ((1L << shift_right) - 1); while (start < scan) @@ -1654,16 +1589,15 @@ DEFUN (bignum_destructive_unnormalization, (bignum, shift_right), } static bignum_digit_type -DEFUN (bignum_digit_divide, (uh, ul, v, q), - bignum_digit_type uh AND bignum_digit_type ul - AND bignum_digit_type v AND bignum_digit_type * q) /* return value */ +bignum_digit_divide (bignum_digit_type uh, bignum_digit_type ul, + bignum_digit_type v, bignum_digit_type * q) /* return value */ { - fast bignum_digit_type guess; - fast bignum_digit_type comparand; - fast bignum_digit_type v1 = (HD_HIGH (v)); - fast bignum_digit_type v2 = (HD_LOW (v)); - fast bignum_digit_type uj; - fast bignum_digit_type uj_uj1; + bignum_digit_type guess; + bignum_digit_type comparand; + bignum_digit_type v1 = (HD_HIGH (v)); + bignum_digit_type v2 = (HD_LOW (v)); + bignum_digit_type uj; + bignum_digit_type uj_uj1; bignum_digit_type q1; bignum_digit_type q2; bignum_digit_type u [4]; @@ -1726,14 +1660,13 @@ DEFUN (bignum_digit_divide, (uh, ul, v, q), } static bignum_digit_type -DEFUN (bignum_digit_divide_subtract, (v1, v2, guess, u), - bignum_digit_type v1 AND bignum_digit_type v2 - AND bignum_digit_type guess AND bignum_digit_type * u) +bignum_digit_divide_subtract (bignum_digit_type v1, bignum_digit_type v2, + bignum_digit_type guess, bignum_digit_type * u) { { - fast bignum_digit_type product; - fast bignum_digit_type diff; - fast bignum_digit_type carry; + bignum_digit_type product; + bignum_digit_type diff; + bignum_digit_type carry; BDDS_MULSUB (v2, (u[2]), 0); BDDS_MULSUB (v1, (u[1]), carry); if (carry == 0) @@ -1748,8 +1681,8 @@ DEFUN (bignum_digit_divide_subtract, (v1, v2, guess, u), } } { - fast bignum_digit_type sum; - fast bignum_digit_type carry; + bignum_digit_type sum; + bignum_digit_type carry; BDDS_ADD(v2, (u[2]), 0); BDDS_ADD(v1, (u[1]), carry); if (carry == 1) @@ -1762,15 +1695,12 @@ DEFUN (bignum_digit_divide_subtract, (v1, v2, guess, u), #undef BDDS_ADD static void -DEFUN (bignum_divide_unsigned_small_denominator, (numerator, denominator, - quotient, remainder, - q_negative_p, r_negative_p), - bignum_type numerator - AND bignum_digit_type denominator - AND bignum_type * quotient - AND bignum_type * remainder - AND int q_negative_p - AND int r_negative_p) +bignum_divide_unsigned_small_denominator (bignum_type numerator, + bignum_digit_type denominator, + bignum_type * quotient, + bignum_type * remainder, + int q_negative_p, + int r_negative_p) { bignum_type q = (bignum_new_sign (numerator, q_negative_p)); bignum_digit_type r = (bignum_destructive_scale_down (q, denominator)); @@ -1785,12 +1715,11 @@ DEFUN (bignum_divide_unsigned_small_denominator, (numerator, denominator, that all digits are < BIGNUM_RADIX. */ static bignum_digit_type -DEFUN (bignum_destructive_scale_down, (bignum, denominator), - bignum_type bignum AND fast bignum_digit_type denominator) +bignum_destructive_scale_down (bignum_type bignum, bignum_digit_type denominator) { - fast bignum_digit_type numerator; - fast bignum_digit_type remainder = 0; - fast bignum_digit_type two_digits; + bignum_digit_type numerator; + bignum_digit_type remainder = 0; + bignum_digit_type two_digits; #define quotient_high remainder bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); @@ -1809,13 +1738,12 @@ DEFUN (bignum_destructive_scale_down, (bignum, denominator), } static bignum_type -DEFUN (bignum_remainder_unsigned_small_denominator, (n, d, negative_p), - bignum_type n AND bignum_digit_type d AND int negative_p) +bignum_remainder_unsigned_small_denominator (bignum_type n, bignum_digit_type d, int negative_p) { - fast bignum_digit_type two_digits; + bignum_digit_type two_digits; bignum_digit_type * start = (BIGNUM_START_PTR (n)); - fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n))); - fast bignum_digit_type r = 0; + bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n))); + bignum_digit_type r = 0; BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT)); while (start < scan) { @@ -1829,14 +1757,13 @@ DEFUN (bignum_remainder_unsigned_small_denominator, (n, d, negative_p), } static bignum_type -DEFUN (bignum_digit_to_bignum, (digit, negative_p), - fast bignum_digit_type digit AND int negative_p) +bignum_digit_to_bignum (bignum_digit_type digit, int negative_p) { if (digit == 0) return (BIGNUM_ZERO ()); else { - fast bignum_type result = (bignum_allocate (1, negative_p)); + bignum_type result = (bignum_allocate (1, negative_p)); (BIGNUM_REF (result, 0)) = digit; return (result); } @@ -1845,26 +1772,24 @@ DEFUN (bignum_digit_to_bignum, (digit, negative_p), /* Allocation */ static bignum_type -DEFUN (bignum_allocate, (length, negative_p), - fast bignum_length_type length AND int negative_p) +bignum_allocate (bignum_length_type length, int negative_p) { BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); { - fast bignum_type result = (BIGNUM_ALLOCATE (length)); + bignum_type result = (BIGNUM_ALLOCATE (length)); BIGNUM_SET_HEADER (result, length, negative_p); return (result); } } static bignum_type -DEFUN (bignum_allocate_zeroed, (length, negative_p), - fast bignum_length_type length AND int negative_p) +bignum_allocate_zeroed (bignum_length_type length, int negative_p) { BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX)); { - fast bignum_type result = (BIGNUM_ALLOCATE (length)); - fast bignum_digit_type * scan = (BIGNUM_START_PTR (result)); - fast bignum_digit_type * end = (scan + length); + bignum_type result = (BIGNUM_ALLOCATE (length)); + bignum_digit_type * scan = (BIGNUM_START_PTR (result)); + bignum_digit_type * end = (scan + length); BIGNUM_SET_HEADER (result, length, negative_p); while (scan < end) (*scan++) = 0; @@ -1873,10 +1798,9 @@ DEFUN (bignum_allocate_zeroed, (length, negative_p), } static bignum_type -DEFUN (bignum_shorten_length, (bignum, length), - fast bignum_type bignum AND fast bignum_length_type length) +bignum_shorten_length (bignum_type bignum, bignum_length_type length) { - fast bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); + bignum_length_type current_length = (BIGNUM_LENGTH (bignum)); BIGNUM_ASSERT ((length >= 0) || (length <= current_length)); if (length < current_length) { @@ -1888,17 +1812,17 @@ DEFUN (bignum_shorten_length, (bignum, length), } static bignum_type -DEFUN (bignum_trim, (bignum), bignum_type bignum) +bignum_trim (bignum_type bignum) { - fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); - fast bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); - fast bignum_digit_type * scan = end; + bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); + bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum))); + bignum_digit_type * scan = end; while ((start <= scan) && ((*--scan) == 0)) ; scan += 1; if (scan < end) { - fast bignum_length_type length = (scan - start); + bignum_length_type length = (scan - start); BIGNUM_SET_HEADER (bignum, length, ((length != 0) && (BIGNUM_NEGATIVE_P (bignum)))); BIGNUM_REDUCE_LENGTH (bignum, bignum, length); @@ -1909,27 +1833,25 @@ DEFUN (bignum_trim, (bignum), bignum_type bignum) /* Copying */ static bignum_type -DEFUN (bignum_copy, (source), fast bignum_type source) +bignum_copy (bignum_type source) { - fast bignum_type target = + bignum_type target = (bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source)))); bignum_destructive_copy (source, target); return (target); } static bignum_type -DEFUN (bignum_new_sign, (bignum, negative_p), - fast bignum_type bignum AND int negative_p) +bignum_new_sign (bignum_type bignum, int negative_p) { - fast bignum_type result = + bignum_type result = (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); bignum_destructive_copy (bignum, result); return (result); } static bignum_type -DEFUN (bignum_maybe_new_sign, (bignum, negative_p), - fast bignum_type bignum AND int negative_p) +bignum_maybe_new_sign (bignum_type bignum, int negative_p) { #ifndef BIGNUM_FORCE_NEW_RESULTS if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p)) @@ -1937,7 +1859,7 @@ DEFUN (bignum_maybe_new_sign, (bignum, negative_p), else #endif /* not BIGNUM_FORCE_NEW_RESULTS */ { - fast bignum_type result = + bignum_type result = (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p)); bignum_destructive_copy (bignum, result); return (result); @@ -1945,13 +1867,12 @@ DEFUN (bignum_maybe_new_sign, (bignum, negative_p), } static void -DEFUN (bignum_destructive_copy, (source, target), - bignum_type source AND bignum_type target) +bignum_destructive_copy (bignum_type source, bignum_type target) { - fast bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); - fast bignum_digit_type * end_source = + bignum_digit_type * scan_source = (BIGNUM_START_PTR (source)); + bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source))); - fast bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); + bignum_digit_type * scan_target = (BIGNUM_START_PTR (target)); while (scan_source < end_source) (*scan_target++) = (*scan_source++); return; diff --git a/v7/src/microcode/bignum.h b/v7/src/microcode/bignum.h index 0c6ca6173..4fc3eac77 100644 --- a/v7/src/microcode/bignum.h +++ b/v7/src/microcode/bignum.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bignum.h,v 9.35 2007/01/05 21:19:25 cph Exp $ +$Id: bignum.h,v 9.36 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -27,6 +27,9 @@ USA. /* External Interface to Bignum Code */ +#ifndef SCM_BIGNUM_H_INCLUDED +#define SCM_BIGNUM_H_INCLUDED 1 + /* The `unsigned long' type is used for the conversion procedures `bignum_to_long' and `long_to_bignum'. Older implementations of C don't support this type; if you have such an implementation you can @@ -34,8 +37,6 @@ USA. you could write alternate versions that don't require this type). */ /* #define BIGNUM_NO_ULONG */ -#include "ansidecl.h" - #ifdef MIT_SCHEME typedef SCHEME_OBJECT bignum_type; @@ -53,51 +54,51 @@ enum bignum_comparison bignum_comparison_equal, bignum_comparison_less, bignum_comparison_greater }; -typedef PTR bignum_procedure_context; -extern bignum_type EXFUN (bignum_make_zero, (void)); -extern bignum_type EXFUN (bignum_make_one, (int negative_p)); -extern int EXFUN (bignum_equal_p, (bignum_type, bignum_type)); -extern enum bignum_comparison EXFUN (bignum_test, (bignum_type)); -extern enum bignum_comparison EXFUN - (bignum_compare, (bignum_type, bignum_type)); -extern bignum_type EXFUN (bignum_add, (bignum_type, bignum_type)); -extern bignum_type EXFUN (bignum_subtract, (bignum_type, bignum_type)); -extern bignum_type EXFUN (bignum_negate, (bignum_type)); -extern bignum_type EXFUN (bignum_multiply, (bignum_type, bignum_type)); -extern int EXFUN - (bignum_divide, (bignum_type numerator, +typedef void * bignum_procedure_context; +extern bignum_type bignum_make_zero (void); +extern bignum_type bignum_make_one (int negative_p); +extern int bignum_equal_p (bignum_type, bignum_type); +extern enum bignum_comparison bignum_test (bignum_type); +extern enum bignum_comparison bignum_compare + (bignum_type, bignum_type); +extern bignum_type bignum_add (bignum_type, bignum_type); +extern bignum_type bignum_subtract (bignum_type, bignum_type); +extern bignum_type bignum_negate (bignum_type); +extern bignum_type bignum_multiply (bignum_type, bignum_type); +extern int bignum_divide + (bignum_type numerator, bignum_type denominator, bignum_type * quotient, - bignum_type * remainder)); -extern bignum_type EXFUN (bignum_quotient, (bignum_type, bignum_type)); -extern bignum_type EXFUN (bignum_remainder, (bignum_type, bignum_type)); + bignum_type * remainder); +extern bignum_type bignum_quotient (bignum_type, bignum_type); +extern bignum_type bignum_remainder (bignum_type, bignum_type); #ifndef BIGNUM_NO_ULONG -extern bignum_type EXFUN (long_to_bignum, (long)); -extern bignum_type EXFUN (ulong_to_bignum, (unsigned long)); -extern long EXFUN (bignum_to_long, (bignum_type)); -extern unsigned long EXFUN (bignum_to_ulong, (bignum_type)); +extern bignum_type long_to_bignum (long); +extern bignum_type ulong_to_bignum (unsigned long); +extern long bignum_to_long (bignum_type); +extern unsigned long bignum_to_ulong (bignum_type); #endif /* not BIGNUM_NO_ULONG */ -extern bignum_type EXFUN (double_to_bignum, (double)); -extern double EXFUN (bignum_to_double, (bignum_type)); -extern int EXFUN - (bignum_fits_in_word_p, (bignum_type, +extern bignum_type double_to_bignum (double); +extern double bignum_to_double (bignum_type); +extern int bignum_fits_in_word_p + (bignum_type, long word_length, - int twos_complement_p)); -extern bignum_type EXFUN (bignum_length_in_bits, (bignum_type)); -extern bignum_type EXFUN (bignum_length_upper_limit, (void)); -extern bignum_type EXFUN (bignum_shift_left, (bignum_type, unsigned long)); -extern bignum_type EXFUN - (unsigned_long_to_shifted_bignum, (unsigned long, unsigned long, int)); -extern bignum_type EXFUN - (digit_stream_to_bignum, - (unsigned int n_digits, - unsigned int EXFUN ((*producer), (bignum_procedure_context)), + int twos_complement_p); +extern bignum_type bignum_length_in_bits (bignum_type); +extern bignum_type bignum_length_upper_limit (void); +extern bignum_type bignum_shift_left (bignum_type, unsigned long); +extern bignum_type unsigned_long_to_shifted_bignum + (unsigned long, unsigned long, int); +extern bignum_type digit_stream_to_bignum + (unsigned int n_digits, + unsigned int (*producer) (bignum_procedure_context), bignum_procedure_context context, unsigned int radix, - int negative_p)); -extern void EXFUN - (bignum_to_digit_stream, - (bignum_type, unsigned int radix, - void EXFUN ((*consumer), (bignum_procedure_context, long)), - bignum_procedure_context context)); -extern long EXFUN (bignum_max_digit_stream_radix, (void)); + int negative_p); +extern void bignum_to_digit_stream + (bignum_type, unsigned int radix, + void (*consumer) (bignum_procedure_context, long), + bignum_procedure_context context); +extern long bignum_max_digit_stream_radix (void); + +#endif /* !SCM_BIGNUM_H_INCLUDED */ diff --git a/v7/src/microcode/bigprm.c b/v7/src/microcode/bigprm.c index a1e405fbc..835dc2aeb 100644 --- a/v7/src/microcode/bigprm.c +++ b/v7/src/microcode/bigprm.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bigprm.c,v 1.10 2007/01/05 21:19:25 cph Exp $ +$Id: bigprm.c,v 1.11 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -29,12 +29,10 @@ USA. #include "scheme.h" #include "prims.h" -#include "zones.h" #define BIGNUM_TEST(predicate) \ { \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ CHECK_ARG (1, BIGNUM_P); \ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (predicate (ARG_REF (1)))); \ } @@ -49,7 +47,6 @@ DEFINE_PRIMITIVE ("BIGNUM-POSITIVE?", Prim_bignum_positive_p, 1, 1, 0) #define BIGNUM_COMPARISON(predicate) \ { \ PRIMITIVE_HEADER (2); \ - Set_Time_Zone (Zone_Math); \ CHECK_ARG (1, BIGNUM_P); \ CHECK_ARG (2, BIGNUM_P); \ PRIMITIVE_RETURN \ @@ -64,7 +61,6 @@ DEFINE_PRIMITIVE ("BIGNUM-LESS?", Prim_bignum_less_p, 2, 2, 0) #define BIGNUM_BINARY(operator) \ { \ PRIMITIVE_HEADER (2); \ - Set_Time_Zone (Zone_Math); \ CHECK_ARG (1, BIGNUM_P); \ CHECK_ARG (2, BIGNUM_P); \ PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2)))); \ @@ -82,7 +78,6 @@ DEFINE_PRIMITIVE ("BIGNUM-DIVIDE", Prim_bignum_divide, 2, 2, 0) SCHEME_OBJECT quotient; SCHEME_OBJECT remainder; PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, BIGNUM_P); CHECK_ARG (2, BIGNUM_P); if (bignum_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder))) @@ -94,7 +89,6 @@ DEFINE_PRIMITIVE ("BIGNUM-DIVIDE", Prim_bignum_divide, 2, 2, 0) { \ SCHEME_OBJECT result; \ PRIMITIVE_HEADER (2); \ - Set_Time_Zone (Zone_Math); \ CHECK_ARG (1, BIGNUM_P); \ CHECK_ARG (2, BIGNUM_P); \ result = (operator ((ARG_REF (1)), (ARG_REF (2)))); \ @@ -109,8 +103,7 @@ DEFINE_PRIMITIVE ("BIGNUM-REMAINDER", Prim_bignum_remainder, 2, 2, 0) BIGNUM_QR (bignum_remainder) static void -DEFUN (listify_bignum_consumer, (previous_cdr, digit), - PTR previous_cdr AND +listify_bignum_consumer (void * previous_cdr, long digit) { (* ((SCHEME_OBJECT *) previous_cdr)) = @@ -122,7 +115,6 @@ DEFINE_PRIMITIVE ("LISTIFY-BIGNUM", Prim_listify_bignum, 2, 2, "Returns a list of the digits of BIGNUM in RADIX.") { PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, BIGNUM_P); { SCHEME_OBJECT bignum = (ARG_REF (1)); @@ -142,7 +134,6 @@ DEFINE_PRIMITIVE ("LISTIFY-BIGNUM", Prim_listify_bignum, 2, 2, DEFINE_PRIMITIVE ("FIXNUM->BIGNUM", Prim_fixnum_to_bignum, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, FIXNUM_P); PRIMITIVE_RETURN (FIXNUM_TO_BIGNUM (ARG_REF (1))); } @@ -150,7 +141,6 @@ DEFINE_PRIMITIVE ("FIXNUM->BIGNUM", Prim_fixnum_to_bignum, 1, 1, 0) DEFINE_PRIMITIVE ("BIGNUM->FIXNUM", Prim_bignum_to_fixnum, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, BIGNUM_P); PRIMITIVE_RETURN (bignum_to_fixnum (ARG_REF (1))); } @@ -158,7 +148,6 @@ DEFINE_PRIMITIVE ("BIGNUM->FIXNUM", Prim_bignum_to_fixnum, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM->BIGNUM", Prim_flonum_to_bignum, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, FLONUM_P); PRIMITIVE_RETURN (FLONUM_TO_BIGNUM (ARG_REF (1))); } @@ -166,7 +155,6 @@ DEFINE_PRIMITIVE ("FLONUM->BIGNUM", Prim_flonum_to_bignum, 1, 1, 0) DEFINE_PRIMITIVE ("BIGNUM->FLONUM", Prim_bignum_to_flonum, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, BIGNUM_P); PRIMITIVE_RETURN (bignum_to_flonum (ARG_REF (1))); } diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c deleted file mode 100644 index 0244ae9ef..000000000 --- a/v7/src/microcode/bintopsb.c +++ /dev/null @@ -1,2499 +0,0 @@ -/* -*-C-*- - -$Id: bintopsb.c,v 9.81 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This File contains the code to translate internal format binary - files to portable format. */ - -/* IO definitions */ - -#include "psbmap.h" -#include "limits.h" -#define internal_file input_file -#define portable_file output_file - -#undef HEAP_MALLOC -#define HEAP_MALLOC malloc - -static long -DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where) -{ - return (fread (((char *) To_Where), - (sizeof (SCHEME_OBJECT)), - Count, - internal_file)); -} - -#define INHIBIT_FASL_VERSION_CHECK -#define INHIBIT_COMPILED_VERSION_CHECK -#define INHIBIT_CHECKSUMS -#include "load.c" -#include "bltdef.h" -#include "trap.h" - -/* Character macros and procedures */ - -#ifndef __IRIX__ -extern int strlen (); -#endif - -#ifndef isalpha - -/* Just in case the stdio library atypically contains the character - macros, just like the C book claims. */ - -#include - -#endif /* isalpha */ - -#ifndef ispunct - -/* This is in some libraries but not others */ - -static char - punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!"; - -static Boolean -DEFUN (ispunct_local, (c), fast char c) -{ - fast char * s; - - s = &punctuation[0]; - while (*s != '\0') - if (*s++ == c) - return (true); - return (false); -} - -#define ispunct ispunct_local - -#endif /* ispunct */ - -/* Needed to upgrade */ - -#define TC_PRIMITIVE_EXTERNAL 0x10 - -#define STRING_LENGTH_TO_LONG(value) \ - ((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value))) - -/* In case there is no compiled code support. */ - -#ifndef FORMAT_WORD_LOW_BYTE -#define FORMAT_WORD_LOW_BYTE(x) x -#endif - -#ifndef FORMAT_WORD_HIGH_BYTE -#define FORMAT_WORD_HIGH_BYTE(x) x -#endif - -#ifndef COMPILED_ENTRY_FORMAT_WORD -#define COMPILED_ENTRY_FORMAT_WORD(entry) 0 -#endif - -#ifndef EXTRACT_EXECUTE_CACHE_ARITY -#define EXTRACT_EXECUTE_CACHE_ARITY(v,a) do { } while (0) -#endif - -#if (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE) - -#undef START_CLOSURE_RELOCATION -#undef END_CLOSURE_RELOCATION -#undef EXTRACT_CLOSURE_ENTRY_ADDRESS -#undef STORE_CLOSURE_ENTRY_ADDRESS -#undef EXTRACT_OPERATOR_LINKAGE_ADDRESS -#undef STORE_OPERATOR_LINKAGE_ADDRESS -#undef START_OPERATOR_RELOCATION -#undef END_OPERATOR_RELOCATION - -#define START_CLOSURE_RELOCATION(foo) do {} while (0) -#define END_CLOSURE_RELOCATION(foo) do {} while (0) -#define EXTRACT_CLOSURE_ENTRY_ADDRESS(var,addr) do {} while (0) -#define STORE_CLOSURE_ENTRY_ADDRESS(var,addr) do {} while (0) -#define EXTRACT_OPERATOR_LINKAGE_ADDRESS(var,addr) do {} while (0) -#define STORE_OPERATOR_LINKAGE_ADDRESS(var,addr) do {} while (0) -#define START_OPERATOR_RELOCATION(foo) do {} while (0) -#define END_OPERATOR_RELOCATION(foo) do {} while (0) - -#endif /* (COMPILER_PROCESSOR_TYPE != COMPILER_LOSING_C_TYPE) */ - -/* Global data */ - -static Boolean - allow_bands_p = false, - allow_compiled_p = false, - allow_constant_space_p = false, - allow_nmv_p = false, - c_compiled_p = false, - endian_invert_p = false, - shuffle_bytes_p = false, - swap_bytes_p = false, - upgrade_compiled_p = false, - upgrade_lengths_p = false, - upgrade_primitives_p = false, - upgrade_traps_p = false, - warn_portable_p = true; - -static long - Heap_Relocation, Constant_Relocation, - Max_Stack_Offset, - Scan, Free, Objects, - Scan_Constant, Free_Constant, Constant_Objects, - Scan_Pure, Free_Pure, Pure_Objects; - -static SCHEME_OBJECT - * Mem_Base, * Constant_Space, * Constant_Top, - * Free_Objects, * Free_Cobjects, * Free_Pobjects, - * compiled_entry_table, * compiled_entry_pointer, - * compiled_entry_table_end, - * compiled_block_table, * compiled_block_pointer, - * compiled_block_table_end, - * primitive_table, * primitive_table_end, - * c_code_table, * c_code_table_end; - -static long - NFlonums, - NIntegers, NBits, - NBitstrs, NBBits, - NStrings, NChars, - NPChars, NCChars; - -#define NO_ALIGNMENT(index) do { } while (0) - -#ifdef FLOATING_ALIGNMENT -#define INDEX_ALIGN_FLOAT(index) do \ -{ \ - while (((((unsigned long) (& Mem_Base[(index) + 1])) \ - - ((unsigned long) (& Mem_Base[0]))) \ - & FLOATING_ALIGNMENT) \ - != 0) \ - Mem_Base[(index)++] = SHARP_F; \ -} while (0) -#endif /* FLOATING_ALIGNMENT */ - -#ifndef INDEX_ALIGN_FLOAT -#define INDEX_ALIGN_FLOAT NO_ALIGNMENT -#endif /* INDEX_ALIGN_FLOAT */ - -#define OUT(s) \ -{ \ - fprintf (portable_file, (s)); \ - break; \ -} - -static void -DEFUN (print_a_char, (c, name), fast char c AND char * name) -{ - switch (c) - { - case '\n': OUT ("\\n"); - case '\t': OUT ("\\t"); - case '\b': OUT ("\\b"); - case '\r': OUT ("\\r"); - case '\f': OUT ("\\f"); - case '\\': OUT ("\\\\"); - case '\0': OUT ("\\0"); - case ' ' : OUT (" "); - - default: - if ((isascii (c)) && ((isalpha (c)) || (isdigit (c)) || (ispunct (c)))) - putc (c, portable_file); - else - { - unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1)); - if (warn_portable_p) - { - fprintf (stderr, - "%s: %s: File may not be portable: c = 0x%x\n", - program_name, name, x); - warn_portable_p = false; - } - /* This does not follow C conventions, but eliminates ambiguity */ - fprintf (portable_file, "\\X%d ", x); - } - } - return; -} - -#undef MAKE_BROKEN_HEART -#define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset)) - -#define DO_COMPOUND(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (*Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents)); \ - else \ - kernel_code; \ -} while (0) - -#define STANDARD_KERNEL(kernel_code, type, Code, Scn, Obj, FObj) do \ -{ \ - (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \ - { \ - fast long length = (OBJECT_DATUM (Old_Contents)); \ - kernel_code; \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \ - (Obj) += 1; \ - (*(FObj)++) = (MAKE_OBJECT ((type), 0)); \ - (*(FObj)++) = Old_Contents; \ - while ((length--) > 0) \ - (*(FObj)++) = (*Old_Address++); \ - } \ -} while (0) - -#define DO_STRING_KERNEL() do \ -{ \ - NStrings += 1; \ - NChars += (pointer_to_char (length - 1)); \ -} while (0) - -#define DO_BIGNUM_KERNEL() do \ -{ \ - NIntegers += 1; \ - NBits += \ - (((* ((bignum_digit_type *) (Old_Address + 1))) \ - & BIGNUM_DIGIT_MASK) \ - * BIGNUM_DIGIT_LENGTH); \ -} while (0) - -#define DO_BIT_STRING_KERNEL() do \ -{ \ - NBitstrs += 1; \ - NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]); \ -} while (0) - -#define DO_FLONUM_KERNEL(Code, Scn, Obj, FObj) do \ -{ \ - int ctr; \ - SCHEME_OBJECT * dest; \ - \ - (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \ - NFlonums += 1; \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \ - (Obj) += 1; \ - (*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0)); \ - dest = (FObj); \ - for (ctr = 0; ctr < float_to_pointer; ctr++) \ - *dest++ = (*Old_Address++); \ - (FObj) = dest; \ -} while (0) - -#define DO_STRING(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \ - STANDARD_KERNEL (DO_STRING_KERNEL (), \ - TC_CHARACTER_STRING, \ - Code, Scn, Obj, FObj)) - -#define DO_BIGNUM(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \ - STANDARD_KERNEL (DO_BIGNUM_KERNEL (), TC_BIG_FIXNUM, \ - Code, Scn, Obj, FObj)) - -#define DO_BIT_STRING(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \ - STANDARD_KERNEL (DO_BIT_STRING_KERNEL (), TC_BIT_STRING, \ - Code, Scn, Obj, FObj)) - -#define DO_FLONUM(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_COMPOUND (Code, Rel, Fre, Scn, Obj, FObj, \ - DO_FLONUM_KERNEL (Code, Scn, Obj, FObj)) - -static void -DEFUN (print_a_fixnum, (val), long val) -{ - fast long size_in_bits; - fast unsigned long temp; - - temp = ((val < 0) ? -val : val); - for (size_in_bits = 0; temp != 0; size_in_bits += 1) - temp = temp >> 1; - fprintf (portable_file, "%02x %c ", TC_FIXNUM, (val < 0 ? '-' : '+')); - if (val == 0) - fprintf (portable_file, "0\n"); - else - { - fprintf (portable_file, "%ld ", size_in_bits); - temp = ((val < 0) ? -val : val); - while (temp != 0) - { - fprintf (portable_file, "%01lx", (temp & 0xf)); - temp = temp >> 4; - } - fprintf (portable_file, "\n"); - } - return; -} - -static void -DEFUN (print_a_string_internal, (len, str), fast long len AND fast char * str) -{ - fprintf (portable_file, "%ld ", len); - if (shuffle_bytes_p) - { - while (len > 0) - { - print_a_char (str[3], "print_a_string"); - if (len > 1) - print_a_char (str[2], "print_a_string"); - if (len > 2) - print_a_char (str[1], "print_a_string"); - if (len > 3) - print_a_char (str[0], "print_a_string"); - len -= 4; - str += 4; - } - } - else - while (--len >= 0) - print_a_char (*str++, "print_a_string"); - putc ('\n', portable_file); - return; -} - -static void -DEFUN (print_a_string, (from), SCHEME_OBJECT * from) -{ - long len, maxlen; - - maxlen = ((pointer_to_char ((OBJECT_DATUM (*from++)) - 1)) - 1); - len = (STRING_LENGTH_TO_LONG (*from++)); - - /* If compacting, do not compact strings that have non-default - maximum lengths. - */ - - fprintf (portable_file, - "%02x %ld ", - TC_CHARACTER_STRING, - ((compact_p - && ((BYTES_TO_WORDS (len + 1)) == (BYTES_TO_WORDS (maxlen + 1)))) - ? len - : maxlen)); - - print_a_string_internal (len, ((char *) from)); - return; -} - -static void -DEFUN (print_a_primitive, (arity, length, name), - long arity AND long length AND char * name) -{ - fprintf (portable_file, "%ld ", arity); - print_a_string_internal (length, name); - return; -} - -static void -DEFUN (print_a_c_code_block, (nentries, length, name), - long nentries AND long length AND char * name) -{ - fprintf (portable_file, "%ld ", nentries); - print_a_string_internal (length, name); - return; -} - -static long -DEFUN (bignum_length, (bignum), SCHEME_OBJECT bignum) -{ - if (BIGNUM_ZERO_P (bignum)) - return (0); - { - bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1); - fast bignum_digit_type digit = (BIGNUM_REF (bignum, index)); - fast long result; - if (index >= (LONG_MAX / BIGNUM_DIGIT_LENGTH)) - goto loser; - result = (index * BIGNUM_DIGIT_LENGTH); - while (digit > 0) - { - result += 1; - if (result >= LONG_MAX) - goto loser; - digit >>= 1; - } - return (result); - } - loser: - fprintf (stderr, "%s: Bignum exceeds representable length.\n", - program_name); - quit (1); - /*NOTREACHED*/ - return (0); -} - -static void -DEFUN (print_a_bignum, (bignum_ptr), SCHEME_OBJECT * bignum_ptr) -{ - SCHEME_OBJECT bignum; - - bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr)); - - if (BIGNUM_ZERO_P (bignum)) - { - fprintf (portable_file, "%02x + 0\n", - (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM)); - return; - } - { - int the_type = TC_BIG_FIXNUM; - bignum_digit_type * scan = (BIGNUM_START_PTR (bignum)); - fast long length_in_bits = (bignum_length (bignum)); - fast int bits_in_digit = 0; - fast bignum_digit_type accumulator; - - /* This attempts to preserve non-canonicalized bignums as such. - The test below fails for the most negative fixnum represented - as a bignum - */ - - if (compact_p && (length_in_bits > fixnum_to_bits)) - the_type = TC_FIXNUM; - - fprintf (portable_file, "%02x %c %ld ", - the_type, - ((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'), - length_in_bits); - accumulator = (*scan++); - bits_in_digit = ((length_in_bits < BIGNUM_DIGIT_LENGTH) - ? length_in_bits - : BIGNUM_DIGIT_LENGTH); - while (length_in_bits > 0) - { - if (bits_in_digit > 4) - { - fprintf (portable_file, "%01lx", (accumulator & 0xf)); - length_in_bits -= 4; - accumulator >>= 4; - bits_in_digit -= 4; - } - else if (bits_in_digit == 4) - { - fprintf (portable_file, "%01lx", accumulator); - length_in_bits -= 4; - if (length_in_bits >= BIGNUM_DIGIT_LENGTH) - { - accumulator = (*scan++); - bits_in_digit = BIGNUM_DIGIT_LENGTH; - } - else if (length_in_bits > 0) - { - accumulator = (*scan++); - bits_in_digit = length_in_bits; - } - else - break; - } - else if (bits_in_digit < length_in_bits) - { - long carry = accumulator; - int diff_bits = (4 - bits_in_digit); - accumulator = (*scan++); - fprintf (portable_file, "%01lx", - (carry - | ((accumulator & ((1 << diff_bits) - 1)) << - bits_in_digit))); - length_in_bits -= 4; - bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits); - if (length_in_bits >= bits_in_digit) - accumulator >>= diff_bits; - else if (length_in_bits > 0) - { - accumulator >>= diff_bits; - bits_in_digit = length_in_bits; - } - else - break; - } - else - { - fprintf (portable_file, "%01lx", accumulator); - break; - } - } - } - fprintf (portable_file, "\n"); - return; -} - -/* The following procedure assumes that a C long is at least 4 bits. */ - -static void -DEFUN (print_a_bit_string, (from), SCHEME_OBJECT * from) -{ - SCHEME_OBJECT the_bit_string; - fast long bits_remaining, leftover_bits; - fast SCHEME_OBJECT accumulator = ((SCHEME_OBJECT) 0), next_word, *scan; - - the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from)); - bits_remaining = (BIT_STRING_LENGTH (the_bit_string)); - fprintf (portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining); - - if (bits_remaining != 0) - { - fprintf (portable_file, " "); - scan = (BIT_STRING_LOW_PTR (the_bit_string)); - for (leftover_bits = 0; - bits_remaining > 0; - bits_remaining -= OBJECT_LENGTH) - { - next_word = (* (INC_BIT_STRING_PTR (scan))); - - if (bits_remaining < OBJECT_LENGTH) - next_word &= (LOW_MASK (bits_remaining)); - - if (leftover_bits == 0) - leftover_bits = ((bits_remaining > OBJECT_LENGTH) - ? OBJECT_LENGTH - : bits_remaining); - else - { - accumulator &= (LOW_MASK (leftover_bits)); - accumulator |= - ((next_word & (LOW_MASK (4 - leftover_bits))) << leftover_bits); - next_word = (next_word >> (4 - leftover_bits)); - leftover_bits += ((bits_remaining > OBJECT_LENGTH) - ? (OBJECT_LENGTH - 4) - : (bits_remaining - 4)); - fprintf (portable_file, "%01lx", (accumulator & 0xf)); - } - - for (accumulator = next_word; leftover_bits >= 4; leftover_bits -= 4) - { - fprintf (portable_file, "%01lx", (accumulator & 0xf)); - accumulator = (accumulator >> 4); - } - } - if (leftover_bits != 0) - fprintf (portable_file, "%01lx", (accumulator & 0xf)); - } - fprintf (portable_file, "\n"); - return; -} - -union flonum_u -{ - double dval; - unsigned long lval[float_to_pointer]; -}; - -static void -DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src) -{ - double val; - union flonum_u utemp; - fast long size_in_bits; - fast double mant, temp; - int expt, ctr; - extern double EXFUN (frexp, (double, int *)); - - for (ctr = 0; ctr < float_to_pointer; ctr++) - utemp.lval[ctr] = ((unsigned long) src[ctr]); - val = utemp.dval; - - fprintf (portable_file, "%02x %c ", - TC_BIG_FLONUM, - ((val < 0.0) ? '-' : '+')); - if (val == 0.0) - { - fprintf (portable_file, "0\n"); - return; - } - mant = frexp (((val < 0.0) ? -val : val), &expt); - size_in_bits = 1; - - for (temp = ((mant * 2.0) - 1.0); temp != 0; size_in_bits += 1) - { - temp *= 2.0; - if (temp >= 1.0) - temp -= 1.0; - } - fprintf (portable_file, "%d %ld ", expt, size_in_bits); - - for (size_in_bits = (hex_digits (size_in_bits)); - size_in_bits > 0; - size_in_bits -= 1) - { - fast unsigned int digit; - - digit = 0; - for (expt = 4; --expt >= 0;) - { - mant *= 2.0; - digit = digit << 1; - if (mant >= 1.0) - { - mant -= 1.0; - digit += 1; - } - } - fprintf (portable_file, "%01x", digit); - } - putc ('\n', portable_file); - return; -} - -/* Normal Objects */ - -#define DO_CELL(Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (*Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \ - else \ - { \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - } \ -} while (0) - -#define DO_PAIR(Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (*Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \ - else \ - { \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - } \ -} while (0) - -#define DO_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (*Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \ - else \ - { \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - } \ -} while (0) - -#define DO_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (*Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \ - else \ - { \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - } \ -} while (0) - -#define DO_RAW_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (* Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = (OBJECT_DATUM (Old_Contents)); \ - else \ - { \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Scn)]) = (Fre); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - } \ -} while (0) - -#define COPY_VECTOR(Fre) do \ -{ \ - fast long len = (OBJECT_DATUM (Old_Contents)); \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - while ((len--) > 0) \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ -} while (0) - -/* This is a hack to get the cross compiler to work - accross different endianness. -*/ - -#define COPY_INVERTED_VECTOR(Fre) do \ -{ \ - fast long len1, len2; \ - SCHEME_OBJECT * Saved; \ - \ - len1 = (OBJECT_DATUM (Old_Contents)); \ - (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \ - (Mem_Base [(Fre)++]) = Old_Contents; \ - if ((OBJECT_TYPE (* Old_Address)) != TC_MANIFEST_NM_VECTOR) \ - { \ - fprintf (stderr, "%s: Bad compiled code block found.\n", \ - program_name); \ - quit (1); \ - } \ - len2 = (OBJECT_DATUM (*Old_Address)); \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ - Old_Address += len2; \ - Saved = Old_Address; \ - len1 -= (len2 + 1); \ - while ((len2--) > 0) \ - (Mem_Base [(Fre)++]) = (*--Old_Address); \ - Old_Address = Saved; \ - while ((len1--) > 0) \ - (Mem_Base [(Fre)++]) = (*Old_Address++); \ -} while (0) - -#define DO_VECTOR_2(aligner, copier, Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - Old_Address += (Rel); \ - Old_Contents = (*Old_Address); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (Mem_Base [(Scn)]) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \ - else \ - { \ - aligner (Fre); \ - (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \ - copier (Fre); \ - } \ -} while (0) - -#define DO_VECTOR(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_VECTOR_2 (NO_ALIGNMENT, COPY_VECTOR, \ - Code, Rel, Fre, Scn, Obj, FObj) - -#define DO_INVERTED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_VECTOR_2 (NO_ALIGNMENT, COPY_INVERTED_VECTOR, \ - Code, Rel, Fre, Scn, Obj, FObj) - -#ifdef HAS_COMPILER_SUPPORT - -#define CHAR_OFFSET(a,b) (((char *) (a)) - ((char *) (b))) -#define OBJ_OFFSET(a,b) (((SCHEME_OBJECT *) (a)) - ((SCHEME_OBJECT *) (b))) - -#define DO_ENTRY_INTERNAL(sub, copy, Code, Rel, Fre, Scn, Obj, FObj) do \ -{ \ - long offset; \ - SCHEME_OBJECT * saved; \ - \ - Old_Address += (Rel); \ - saved = Old_Address; \ - Get_Compiled_Block (Old_Address, saved); \ - Old_Contents = (*Old_Address); \ - entry_no = (compiled_entry_pointer - compiled_entry_table); \ - offset = (sub (saved, Old_Address)); \ - (*compiled_entry_pointer++) = (LONG_TO_UNSIGNED_FIXNUM (offset)); \ - if (BROKEN_HEART_P (Old_Contents)) \ - (*compiled_entry_pointer++) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \ - else \ - { \ - INDEX_ALIGN_FLOAT (Fre); \ - (*compiled_entry_pointer++) = \ - (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \ - copy (Fre); \ - } \ -} while (0) - -#define DO_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_VECTOR, \ - Code, Rel, Fre, Scn, Obj, FObj) - -#define DO_INVERTED_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_INVERTED_VECTOR, \ - Code, Rel, Fre, Scn, Obj, FObj) - -#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_VECTOR_2 (INDEX_ALIGN_FLOAT, COPY_C_COMPILED_BLOCK, \ - Code, Rel, Fre, Scn, Obj, FObj) - -#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_ENTRY_INTERNAL (CHAR_OFFSET, COPY_VECTOR, \ - Code, Rel, Fre, Scn, Obj, FObj) - -#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \ - DO_ENTRY_INTERNAL (OBJ_OFFSET, COPY_C_COMPILED_BLOCK, \ - Code, Rel, Fre, Scn, Obj, FObj) - -/* This depends on the fact that a compiled code block has an NMV - header in the first or second words. - */ - -long -DEFUN (copy_c_compiled_block, (Fre, Old_Contents, Old_Address), - long Fre AND SCHEME_OBJECT Old_Contents AND SCHEME_OBJECT * Old_Address) -{ - SCHEME_OBJECT preserved_nmv, preserved_loc; - SCHEME_OBJECT nmv_replacement - = (MAKE_OBJECT (TC_BROKEN_HEART, - (compiled_block_pointer - - compiled_block_table))); - fast long len = (OBJECT_DATUM (Old_Contents)); - - *Old_Address++ = (MAKE_BROKEN_HEART (Fre)); - if ((OBJECT_TYPE (Old_Contents)) != TC_MANIFEST_CLOSURE) - { - if ((OBJECT_TYPE (Old_Contents)) == TC_MANIFEST_NM_VECTOR) - { - preserved_nmv = Old_Contents; - preserved_loc = (LONG_TO_UNSIGNED_FIXNUM (Fre)); - Old_Contents = nmv_replacement; - } - else if ((OBJECT_TYPE (*Old_Address)) == TC_MANIFEST_NM_VECTOR) - { - preserved_nmv = *Old_Address; - preserved_loc = (LONG_TO_UNSIGNED_FIXNUM ((Fre) + 1)); - *Old_Address = nmv_replacement; - } - else - { - fprintf (stderr, - "%s: Improperly formatted C-compiled code block.\n", - program_name); - quit (1); - } - - *compiled_block_pointer++ = preserved_loc; - *compiled_block_pointer++ = preserved_nmv; - } - - (Mem_Base [(Fre)++]) = Old_Contents; - while ((len--) > 0) - (Mem_Base [(Fre)++]) = (*Old_Address++); - return (Fre); -} - -#define COPY_C_COMPILED_BLOCK(Fre) do \ -{ \ - Fre = copy_c_compiled_block (Fre, Old_Contents, Old_Address); \ -} while (0) - -#else /* no HAS_COMPILER_SUPPORT */ - -#define COMPILER_BAD_STMT(name) do \ -{ \ - fprintf (stderr, \ - "%s: Invoking %s with no compiler support!\n", \ - program_name, name); \ - quit (1); \ -} while (0) - -#define DO_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \ - COMPILER_BAD_STMT ("DO_COMPILED_ENTRY") - -#define DO_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - COMPILER_BAD_STMT ("DO_COMPILED_BLOCK") - -#define DO_INVERTED_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - COMPILER_BAD_STMT ("DO_INVERTED_COMPILED_BLOCK") - -#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \ - COMPILER_BAD_STMT ("DO_C_COMPILED_ENTRY") - -#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \ - COMPILER_BAD_STMT ("DO_C_COMPILED_BLOCK") - -#endif /* HAS_COMPILER_SUPPORT */ - -/* Constant/Pure space utilities */ - -static SCHEME_OBJECT * -DEFUN (find_constant_top, (constant_space, count), - SCHEME_OBJECT * constant_space AND unsigned long count) -{ - SCHEME_OBJECT pattern = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); - SCHEME_OBJECT * limit = (constant_space + count); - - while (((* (limit - 1)) == pattern) - && (limit > constant_space)) - limit -= 1; - return (limit); -} - -static Boolean -DEFUN (address_in_pure_space, (addr), SCHEME_OBJECT * addr) -{ - Boolean result = false; - SCHEME_OBJECT * where, * low_constant; - - low_constant = Constant_Space; - where = (Constant_Top - 1); - - while (where >= low_constant) - { - where -= (1 + (OBJECT_DATUM (* where))); - if (where < addr) - { - where += 1; /* block start */ - result = (addr <= (where + (OBJECT_DATUM (* where)))); - break; - } - } - return (result); -} - -/* Common Pointer Code */ - -#define DO_POINTER(Scn, Action) do \ -{ \ - long the_datum; \ - \ - Old_Address = (OBJECT_ADDRESS (This)); \ - the_datum = (OBJECT_DATUM (This)); \ - if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \ - Action (HEAP_CODE, Heap_Relocation, Free, \ - Scn, Objects, Free_Objects); \ - else if ((the_datum >= Const_Base) \ - && (the_datum < Dumped_Constant_Top)) \ - { \ - SCHEME_OBJECT * new_addr; \ - \ - new_addr = (Old_Address + Constant_Relocation); \ - if (address_in_pure_space (new_addr)) \ - Action (PURE_CODE, Constant_Relocation, Free_Pure, \ - Scn, Pure_Objects, Free_Pobjects); \ - else \ - Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \ - Scn, Constant_Objects, Free_Cobjects); \ - } \ - else \ - out_of_range_pointer (This); \ - (Scn) += 1; \ -} while (0) - -#define DO_RAW_POINTER(ptr, Scn, Action) do \ -{ \ - long the_datum; \ - \ - the_datum = (SCHEME_ADDR_TO_OLD_DATUM (ptr)); \ - Old_Address = (DATUM_TO_ADDRESS (the_datum)); \ - if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) \ - Action (HEAP_CODE, Heap_Relocation, Free, \ - Scn, Objects, Free_Objects); \ - else if ((the_datum >= Const_Base) \ - && (the_datum < Dumped_Constant_Top)) \ - { \ - SCHEME_OBJECT * new_addr; \ - \ - new_addr = (Old_Address + Constant_Relocation); \ - if (address_in_pure_space (new_addr)) \ - Action (PURE_CODE, Constant_Relocation, Free_Pure, \ - Scn, Pure_Objects, Free_Pobjects); \ - else \ - Action (CONSTANT_CODE, Constant_Relocation, Free_Constant, \ - Scn, Constant_Objects, Free_Cobjects); \ - } \ - else \ - out_of_range_pointer (This); \ -} while (0) - -static void -DEFUN (out_of_range_pointer, (ptr), SCHEME_OBJECT ptr) -{ - fprintf (stderr, - "%s: The input file is not portable: Out of range pointer.\n", - program_name); - fprintf (stderr, "Heap_Base = 0x%lx;\tHeap_Top = 0x%lx\n", - Heap_Base, Dumped_Heap_Top); - fprintf (stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n", - Const_Base, Dumped_Constant_Top); - fprintf (stderr, "ptr = 0x%02x|0x%lx\n", - (OBJECT_TYPE (ptr)), (OBJECT_DATUM (ptr))); - quit (1); -} - -static SCHEME_OBJECT * -DEFUN (relocate, (object), SCHEME_OBJECT object) -{ - long the_datum; - SCHEME_OBJECT * result; - - result = (OBJECT_ADDRESS (object)); - the_datum = (OBJECT_DATUM (object)); - - if ((the_datum >= Heap_Base) && - (the_datum < Dumped_Heap_Top)) - result += Heap_Relocation; - else if ((the_datum >= Const_Base) && - (the_datum < Dumped_Constant_Top)) - result += Constant_Relocation; - else - out_of_range_pointer (object); - return (result); -} - -/* Primitive upgrading code. */ - -#define PRIMITIVE_UPGRADE_SPACE 2048 - -static SCHEME_OBJECT - * internal_renumber_table, - * external_renumber_table, - * external_prim_name_table; - -static Boolean - found_ext_prims = false; - -static SCHEME_OBJECT -DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT prim) -{ - long the_datum, the_type, new_type, code; - SCHEME_OBJECT new; - - the_datum = (OBJECT_DATUM (prim)); - the_type = (OBJECT_TYPE (prim)); - if (the_type != TC_PRIMITIVE_EXTERNAL) - { - code = the_datum; - new_type = the_type; - } - else - { - found_ext_prims = true; - code = (the_datum + (MAX_BUILTIN_PRIMITIVE + 1)); - new_type = TC_PRIMITIVE; - } - - new = internal_renumber_table[code]; - if (new != SHARP_F) - return (OBJECT_NEW_TYPE (new_type, new)); - else - { - /* - This does not need to check for overflow because the worst case - was checked in setup_primitive_upgrade; - */ - - new = (MAKE_OBJECT (new_type, Primitive_Table_Length)); - internal_renumber_table[code] = new; - external_renumber_table[Primitive_Table_Length] = prim; - Primitive_Table_Length += 1; - if (the_type == TC_PRIMITIVE_EXTERNAL) - NPChars += - STRING_LENGTH_TO_LONG ((((SCHEME_OBJECT *) - (external_prim_name_table[the_datum])) - [STRING_LENGTH_INDEX])); - else - NPChars += strlen (builtin_prim_name_table[the_datum]); - return (new); - } -} - -static SCHEME_OBJECT * -DEFUN (setup_primitive_upgrade, (Heap), SCHEME_OBJECT * Heap) -{ - fast long count, length; - SCHEME_OBJECT * old_prims_vector; - - internal_renumber_table = &Heap[0]; - external_renumber_table = - &internal_renumber_table[PRIMITIVE_UPGRADE_SPACE]; - external_prim_name_table = - &external_renumber_table[PRIMITIVE_UPGRADE_SPACE]; - - old_prims_vector = (relocate (Ext_Prim_Vector)); - if (*old_prims_vector == SHARP_F) - length = 0; - else - { - old_prims_vector = (relocate (*old_prims_vector)); - length = (OBJECT_DATUM (*old_prims_vector)); - old_prims_vector += VECTOR_DATA; - for (count = 0; count < length; count += 1) - { - SCHEME_OBJECT *temp; - - /* symbol */ - temp = (relocate (old_prims_vector[count])); - /* string */ - temp = (relocate (temp[SYMBOL_NAME])); - external_prim_name_table[count] = ((SCHEME_OBJECT) temp); - } - } - length += (MAX_BUILTIN_PRIMITIVE + 1); - if (length > PRIMITIVE_UPGRADE_SPACE) - { - fprintf (stderr, "%s: Too many primitives.\n", program_name); - fprintf (stderr, - "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n", - program_name); - quit (1); - } - for (count = 0; count < length; count += 1) - internal_renumber_table[count] = SHARP_F; - - NPChars = 0; - return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]); -} - -/* Processing of a single area */ - -#define DO_AREA(code, Area, Bound, Obj, FObj) \ - Process_Area (code, &Area, &Bound, &Obj, &FObj) - -static void -DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj), - int Code - AND fast long * Area - AND fast long * Bound - AND fast long * Obj - AND fast SCHEME_OBJECT ** FObj) -{ - unsigned long entry_no; - fast SCHEME_OBJECT This, * Old_Address, Old_Contents; - - while (*Area != *Bound) - { - This = Mem_Base[*Area]; - -#ifdef PRIMITIVE_EXTERNAL_REUSED - if (upgrade_primitives_p && - ((OBJECT_TYPE (This)) == TC_PRIMITIVE_EXTERNAL)) - { - Mem_Base[*Area] = (upgrade_primitive (This)); - *Area += 1; - continue; - } -#endif /* PRIMITIVE_EXTERNAL_REUSED */ - - Switch_by_GC_Type (This) - { - -#ifndef PRIMITIVE_EXTERNAL_REUSED - - case TC_PRIMITIVE_EXTERNAL: - -#endif /* PRIMITIVE_EXTERNAL_REUSED */ - - case TC_PRIMITIVE: - case TC_PCOMB0: - if (upgrade_primitives_p) - Mem_Base[*Area] = (upgrade_primitive (This)); - *Area += 1; - break; - - case TC_MANIFEST_NM_VECTOR: - nmv_p = true; - if (null_nmv_p) - { - fast long i; - - i = (OBJECT_DATUM (This)); - *Area += 1; - for ( ; --i >= 0; *Area += 1) - Mem_Base[*Area] = SHARP_F; - break; - } - else if (!allow_nmv_p) - { - if (((OBJECT_DATUM (This)) != 0) && warn_portable_p) - { - warn_portable_p = false; - fprintf (stderr, "%s: File is not portable: NMH found\n", - program_name); - } - } - *Area += (1 + (OBJECT_DATUM (This))); - break; - - case TC_BROKEN_HEART: - { - /* [Broken Heart | 0] is the cdr of fasdumped symbols. */ - /* [Broken Heart | x > 0] indicates a C compiled block. */ - unsigned long the_datum = (OBJECT_DATUM (This)); - - if (the_datum == 0) - { - *Area += 1; - break; - } - else if ((! allow_compiled_p) - || (! c_compiled_p) - || ((OBJECT_DATUM (This)) - >= (compiled_block_pointer - compiled_block_table)) - || ((*Area) - != (UNSIGNED_FIXNUM_TO_LONG - (compiled_block_table [the_datum])))) - { - fprintf (stderr, "%s: Broken Heart found in scan.\n", - program_name); - quit (1); - } - else - { - *Area += (1 + (OBJECT_DATUM (compiled_block_table [1 + the_datum]))); - break; - } - } - - case TC_MANIFEST_CLOSURE: - if ((! allow_compiled_p) || (! c_compiled_p)) - { - fprintf (stderr, - "%s: File contains compiled closures.\n", - program_name); - quit (1); - } - else - { - char * word_ptr; - long count, address = 0; - SCHEME_OBJECT * area_end, * scan, * i_scan; - - i_scan = (&Mem_Base[*Area]); - START_CLOSURE_RELOCATION (i_scan); - scan = (i_scan + 1); - count = (MANIFEST_CLOSURE_COUNT (scan)); - word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan)); - area_end = ((MANIFEST_CLOSURE_END (scan, count)) - 1); - - while ((--count) >= 0) - { - scan = ((SCHEME_OBJECT *) (word_ptr)); - word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); - EXTRACT_CLOSURE_ENTRY_ADDRESS (address, scan); - DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY); - STORE_CLOSURE_ENTRY_ADDRESS (entry_no, scan); - } - - END_CLOSURE_RELOCATION (area_end); - *Area += (1 + (area_end - i_scan)); - break; - } - - case TC_LINKAGE_SECTION: - if ((! allow_compiled_p) || (! c_compiled_p)) - { - fprintf (stderr, - "%s: File contains linked compiled code.\n", - program_name); - quit (1); - } - else - { - switch (READ_LINKAGE_KIND (This)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - long count = (READ_CACHE_LINKAGE_COUNT (This)); - - *Area += 1; - while (--count >= 0) - { - DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_TRIPLE); - *Area += 1; - } - break; - } - - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: - { - char * word_ptr; - long count, address = 0; - SCHEME_OBJECT * area_end, * scan, * i_scan; - - i_scan = (&Mem_Base[*Area]); - START_OPERATOR_RELOCATION (i_scan); - count = (READ_OPERATOR_LINKAGE_COUNT (This)); - word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan)); - area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count)); - - while (--count >= 0) - { - scan = ((SCHEME_OBJECT *) word_ptr); - word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); - EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan); - DO_RAW_POINTER (address, *Area, DO_C_COMPILED_ENTRY); - STORE_OPERATOR_LINKAGE_ADDRESS (entry_no, scan); - } - END_OPERATOR_RELOCATION (area_end); - *Area += (1 + (area_end - i_scan)); - break; - } - - default: - { - fprintf (stderr, "%s: Unknown linkage kind.\n", - program_name); - quit (1); - } - } - break; - } - - case TC_COMPILED_CODE_BLOCK: - compiled_p = true; - if (! allow_compiled_p) - { - fprintf (stderr, - "%s: File contains compiled code.\n", - program_name); - quit (1); - } - else if (c_compiled_p) - DO_POINTER (*Area, DO_C_COMPILED_BLOCK); - else if (endian_invert_p) - DO_POINTER (*Area, DO_INVERTED_COMPILED_BLOCK); - else - DO_POINTER (*Area, DO_COMPILED_BLOCK); - break; - - case_compiled_entry_point: - compiled_p = true; - if (! allow_compiled_p) - { - fprintf (stderr, - "%s: File contains compiled code.\n", - program_name); - quit (1); - } - else if (c_compiled_p) - DO_POINTER (*Area, DO_C_COMPILED_ENTRY); - else - DO_POINTER (*Area, DO_COMPILED_ENTRY); - Mem_Base[*Area - 1] = (MAKE_OBJECT (TC_COMPILED_ENTRY, entry_no)); - break; - - case TC_STACK_ENVIRONMENT: - if (! allow_bands_p) - { - fprintf (stderr, - "%s: File contains stack environments.\n", - program_name); - quit (1); - } - else - { - unsigned long delta; - - delta = (((SCHEME_OBJECT *) Dumped_Stack_Top) - - ((SCHEME_OBJECT *) (OBJECT_DATUM (This)))); - if (delta > Max_Stack_Offset) - Max_Stack_Offset = delta; - Mem_Base[*Area] = (MAKE_OBJECT (TC_STACK_ENVIRONMENT, delta)); - *Area += 1; - } - break; - - case TC_FIXNUM: - NIntegers += 1; - NBits += fixnum_to_bits; - /* Fall Through */ - - case TC_CHARACTER: - Mem_Base[*Area] = (MAKE_OBJECT (Code, *Obj)); - *Obj += 1; - **FObj = This; - *FObj += 1; - /* Fall through */ - - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case_simple_Non_Pointer: - *Area += 1; - break; - - case TC_REFERENCE_TRAP: - { - long kind; - - kind = (OBJECT_DATUM (This)); - - if (upgrade_traps_p) - { - /* It is an old UNASSIGNED object. */ - if (kind == 0) - { - Mem_Base[*Area] = UNASSIGNED_OBJECT; - *Area += 1; - break; - } - if (kind == 1) - { - Mem_Base[*Area] = UNBOUND_OBJECT; - *Area += 1; - break; - } - fprintf (stderr, - "%s: Bad old unassigned object. 0x%x.\n", - program_name, This); - quit (1); - } - if (kind <= TRAP_MAX_IMMEDIATE) - { - /* It is a non pointer. */ - - *Area += 1; - break; - } - } - /* Fall through */ - - case TC_WEAK_CONS: - case_Pair: - DO_POINTER (*Area, DO_PAIR); - break; - - case_Cell: - DO_POINTER (*Area, DO_CELL); - break; - - case TC_VARIABLE: - case_Triple: - DO_POINTER (*Area, DO_TRIPLE); - break; - - case_Quadruple: - DO_POINTER (*Area, DO_QUAD); - break; - - case TC_BIG_FLONUM: - DO_POINTER (*Area, DO_FLONUM); - break; - - case TC_BIG_FIXNUM: - DO_POINTER (*Area, DO_BIGNUM); - break; - - case TC_CHARACTER_STRING: - DO_POINTER (*Area, DO_STRING); - break; - - case TC_ENVIRONMENT: - if (upgrade_traps_p) - { - fprintf (stderr, - "%s: Cannot upgrade environments.\n", - program_name); - quit (1); - } - /* Fall through */ - - case TC_FUTURE: - case_simple_Vector: - if (BIT_STRING_P (This)) - DO_POINTER (*Area, DO_BIT_STRING); - else - DO_POINTER (*Area, DO_VECTOR); - break; - - default: - fprintf (stderr, "%s: Unknown Type Code 0x%x found.\n", - program_name, (OBJECT_TYPE (This))); - quit (1); - } - } -} - -/* Output procedures */ - -static void -DEFUN (print_binary_objects, (from, count), - fast SCHEME_OBJECT * from AND fast long count) -{ - while (--count >= 0) - { - switch (OBJECT_TYPE (* from)) - { - case TC_FIXNUM: - print_a_fixnum (FIXNUM_TO_LONG (*from)); - from += 1; - break; - - case TC_BIT_STRING: - print_a_bit_string (++from); - from += (1 + (OBJECT_DATUM (*from))); - break; - - case TC_BIG_FIXNUM: - print_a_bignum (++from); - from += (1 + (OBJECT_DATUM (*from))); - break; - - case TC_CHARACTER_STRING: - print_a_string (++from); - from += (1 + (OBJECT_DATUM (*from))); - break; - - case TC_BIG_FLONUM: - print_a_flonum (from + 1); - from += (1 + float_to_pointer); - break; - - case TC_CHARACTER: - fprintf (portable_file, "%02x %07x\n", - TC_CHARACTER, ((*from) & MASK_MIT_ASCII)); - from += 1; - break; - -#ifdef FLOATING_ALIGNMENT - - case TC_MANIFEST_NM_VECTOR: - if ((OBJECT_DATUM (*from)) == 0) - { - from += 1; - count += 1; - break; - } - /* fall through */ - -#endif /* FLOATING_ALIGNMENT */ - - default: - fprintf (stderr, - "%s: Bad Binary Object to print %lx\n", - program_name, *from); - quit (1); - } - } - return; -} - -static void -DEFUN (print_c_compiled_entries, (entry, count), - SCHEME_OBJECT * entry AND unsigned long count) -{ - while (count > 0) - { - unsigned long entry_index = (* ((unsigned long *) entry)); - unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry)); - SCHEME_OBJECT * block; - - Get_Compiled_Block (block, entry); - fprintf (portable_file, "%02x %lx %ld %ld %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_ENTRY_FORMAT), - ((long) (FORMAT_WORD_LOW_BYTE (format))), - ((long) (FORMAT_WORD_HIGH_BYTE (format))), - ((long) (entry - block))); - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_ENTRY_CODE), - entry_index); - count -= 1; - entry += 2; - } - return; -} - -static void -DEFUN (print_c_closure_entries, (entry, count), - SCHEME_OBJECT * entry AND unsigned long count) -{ - while (count > 0) - { - unsigned long entry_index = (* ((unsigned long *) entry)); - unsigned long format = (COMPILED_ENTRY_FORMAT_WORD (entry)); - SCHEME_OBJECT * block, base; - unsigned long entry_number = 0; - long offset; - - EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_number, entry); - offset = (UNSIGNED_FIXNUM_TO_LONG - (compiled_entry_table [entry_number])); - base = compiled_entry_table[entry_number + 1]; - - Get_Compiled_Block (block, entry); - fprintf (portable_file, "%02x %lx %ld %ld %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_ENTRY_FORMAT), - ((long) (FORMAT_WORD_LOW_BYTE (format))), - ((long) (FORMAT_WORD_HIGH_BYTE (format))), - ((long) (entry - block))); - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_ENTRY_CODE), - entry_index); - fprintf (portable_file, "%02x %lx %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_EXECUTE_ENTRY), - offset, - (OBJECT_DATUM (base))); - count -= 1; - entry += 3; - } - return; -} - -static void -DEFUN (print_objects, (from, to), - fast SCHEME_OBJECT * from AND fast SCHEME_OBJECT * to) -{ - fast long the_datum, the_type; - - while (from < to) - { - the_type = (OBJECT_TYPE (* from)); - the_datum = (OBJECT_DATUM (* from)); - from += 1; - - switch (the_type) - { - case TC_MANIFEST_NM_VECTOR: - { - fprintf (portable_file, "%02x %lx\n", the_type, the_datum); - while (--the_datum >= 0) - fprintf (portable_file, "%lx\n", ((unsigned long) *from++)); - break; - } - - case TC_COMPILED_ENTRY: - { - SCHEME_OBJECT base; - long offset; - - offset = (UNSIGNED_FIXNUM_TO_LONG (compiled_entry_table [the_datum])); - base = compiled_entry_table[the_datum + 1]; - - fprintf (portable_file, "%02x %lx %02x %lx\n", - TC_COMPILED_ENTRY, offset, - (OBJECT_TYPE (base)), (OBJECT_DATUM (base))); - break; - } - - case TC_LINKAGE_SECTION: - { - SCHEME_OBJECT header = (from[-1]); - - switch (READ_LINKAGE_KIND (header)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - long count = (READ_CACHE_LINKAGE_COUNT (header)); - - fprintf (portable_file, "%02x %lx %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_LINKAGE_HEADER), - ((long) (READ_LINKAGE_KIND (header))), - ((long) count)); - while (--count >= 0) - { - unsigned long the_triple = ((unsigned long) *from++); - - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_RAW_TRIPLE), - the_triple); - } - break; - } - - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: - { - char * word_ptr; - long count = 0; - SCHEME_OBJECT This, * area_end, * scan, * i_scan; - - i_scan = (from - 1); - This = *i_scan; - START_OPERATOR_RELOCATION (i_scan); - count = (READ_OPERATOR_LINKAGE_COUNT (This)); - word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (i_scan)); - area_end = (END_OPERATOR_LINKAGE_AREA (i_scan, count)); - - fprintf (portable_file, "%02x %lx %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_LINKAGE_HEADER), - ((long) (READ_LINKAGE_KIND (header))), - ((long) count)); - - while (--count >= 0) - { - SCHEME_OBJECT base; - long arity, offset, address = 0; - - scan = ((SCHEME_OBJECT *) word_ptr); - word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); - EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, scan); - EXTRACT_EXECUTE_CACHE_ARITY (arity, scan); - - offset = (UNSIGNED_FIXNUM_TO_LONG - (compiled_entry_table[address])); - base = compiled_entry_table[address + 1]; - - fprintf (portable_file, "%02x %lx %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_EXECUTE_ENTRY), - offset, - (OBJECT_DATUM (base))); - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_EXECUTE_ARITY), - arity); - } - END_OPERATOR_RELOCATION (area_end); - from += (area_end - i_scan); - break; - } - - default: - { - fprintf (stderr, "%s: Unknown linkage kind.\n", - program_name); - quit (1); - } - } - break; - } - - case TC_MANIFEST_CLOSURE: - { - unsigned long nentries; - SCHEME_OBJECT * entry, * area_end; - - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_CLOSURE_HEADER), - the_datum); - - nentries = (MANIFEST_CLOSURE_COUNT (from)); - entry = ((SCHEME_OBJECT *) (FIRST_MANIFEST_CLOSURE_ENTRY (from))); - area_end = ((MANIFEST_CLOSURE_END (from, nentries)) - 1); - - if (entry != (from + 1)) - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_MULTI_CLOSURE_HEADER), - nentries); - - print_c_closure_entries (entry, nentries); - from = (area_end + 1); - break; - } - - case TC_BROKEN_HEART: - if (the_datum == 0) - goto ordinary_object; - /* An NMV header fending off C-compiled code descriptors. - This knows in detail the format - */ - - { - unsigned long nmv_length; - - nmv_length = (OBJECT_DATUM (compiled_block_table [the_datum + 1])); - fprintf (portable_file, "%02x %lx %lx\n", - TC_C_COMPILED_TAG, - ((long) C_COMPILED_FAKE_NMV), - nmv_length); - - print_c_compiled_entries (from + 1, (nmv_length / 2)); - from += nmv_length; - break; - } - - default: - ordinary_object: - { - fprintf (portable_file, "%02x %lx\n", the_type, the_datum); - break; - } - } - } - return; -} - -/* Debugging Aids and Consistency Checks */ - -#define DEBUG 0 - -#if (DEBUG > 0) - -#define WHEN(condition, message) when(condition, message) - -static void -DEFUN (when, (what, message), Boolean what AND char * message) -{ - if (what) - { - fprintf (stderr, "%s: Inconsistency: %s!\n", - program_name, (message)); - quit (1); - } - return; -} - -#else /* DEBUG <= 0 */ - -#define WHEN(what, message) do { } while (0) - -#endif /* DEBUG > 0 */ - -#if (DEBUG > 1) - -#define DEBUGGING1(action) action - -#define WRITE_HEADER(name, format, obj) do \ -{ \ - fprintf (portable_file, (format), (obj)); \ - fprintf (portable_file, "\n"); \ - fprintf (stderr, "%s: ", (name)); \ - fprintf (stderr, (format), (obj)); \ - fprintf (stderr, "\n"); \ -} while (0) - -#else /* DEBUG <= 1 */ - -#define DEBUGGING1(action) do { } while (0) - -#define WRITE_HEADER(name, format, obj) do \ -{ \ - fprintf (portable_file, (format), (obj)); \ - fprintf (portable_file, "\n"); \ -} while (0) - -#endif /* DEBUG > 1 */ - -/* The main program */ - -static void -DEFUN_VOID (do_it) -{ - while (true) - { - /* Load the Data */ - - SCHEME_OBJECT - * Heap, - * Lowest_Allocated_Address, - * Highest_Allocated_Address; - long - Heap_Start, Heap_Objects_Start, - Constant_Start, Constant_Objects_Start, - Pure_Start, Pure_Objects_Start; - - switch (Read_Header ()) - { - /* There should really be a difference between no header - and a short header. - */ - - case FASL_FILE_TOO_SHORT: - return; - - case FASL_FILE_FINE: - break; - - default: - fprintf (stderr, - "%s: Input is not a Scheme binary file.\n", - program_name); - quit (1); - /*NOTREACHED*/ - } - - if ( (Version > FASL_FORMAT_VERSION) - || (Version < FASL_OLDEST_VERSION) - || (Sub_Version > FASL_SUBVERSION) - || (Sub_Version < FASL_OLDEST_SUBVERSION) - || ((Machine_Type != FASL_INTERNAL_FORMAT) && (! swap_bytes_p))) - { - fprintf (stderr, "%s:\n", program_name); - fprintf (stderr, - "FASL File Version %ld Subversion %ld Machine Type %ld\n", - Version, Sub_Version , Machine_Type); - fprintf (stderr, - "Expected: Version %d Subversion %d Machine Type %d\n", - FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT); - quit (1); - } - - if ((((compiler_processor_type != COMPILER_NONE_TYPE) - && (dumped_processor_type != COMPILER_NONE_TYPE) - && (compiler_processor_type != dumped_processor_type)) - || ((compiler_interface_version != 0) - && (dumped_interface_version != 0) - && (compiler_interface_version != dumped_interface_version))) - && (! upgrade_compiled_p)) - { - fprintf (stderr, "\nread_file:\n"); - fprintf (stderr, - "FASL File: compiled code interface %4d; processor %4d.\n", - dumped_interface_version, dumped_processor_type); - fprintf (stderr, - "Expected: compiled code interface %4d; processor %4d.\n", - compiler_interface_version, compiler_processor_type); - quit (1); - } - if (compiler_processor_type != 0) - dumped_processor_type = compiler_processor_type; - if (compiler_interface_version != 0) - dumped_interface_version = compiler_interface_version; - c_compiled_p = (compiler_processor_type == COMPILER_LOSING_C_TYPE); - DEBUGGING1 (fprintf (stderr, - "compiler_processor_type = %d; c_compiled_p = %s\n", - compiler_processor_type, - (c_compiled_p ? "true" : "false"))); - - if (band_p && (! allow_bands_p)) - { - fprintf (stderr, "%s: Input file is a band.\n", program_name); - quit (1); - } - - if ((Const_Count != 0) && (! allow_constant_space_p)) - { - fprintf (stderr, - "%s: Input file has a constant space area.\n", - program_name); - quit (1); - } - - shuffle_bytes_p = swap_bytes_p; - if (Machine_Type == FASL_INTERNAL_FORMAT) - shuffle_bytes_p = false; - - upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP); - upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES); - upgrade_lengths_p = upgrade_primitives_p; - - DEBUGGING1 (fprintf (stderr, - "Dumped Heap Base = 0x%08x\n", - Heap_Base)); - - DEBUGGING1 (fprintf (stderr, - "Dumped Constant Base = 0x%08x\n", - Const_Base)); - - DEBUGGING1 (fprintf (stderr, - "Dumped Constant Top = 0x%08x\n", - Dumped_Constant_Top)); - - DEBUGGING1 (fprintf (stderr, - "Heap Count = %6d\n", - Heap_Count)); - - DEBUGGING1 (fprintf (stderr, - "Constant Count = %6d\n", - Const_Count)); - - { - long Size; - - /* This is way larger than needed, but... what the hell? */ - - Size = ( - /* All pointers must have datum > TRAP_MAX_IMMEDIATE */ - (2 * (TRAP_MAX_IMMEDIATE + 1)) - /* Floating alignment of Heap and Constant Space - in incoming image, and of output arenas. - */ - + (5 * ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT)))) - /* Space taken by incoming image. */ - + (Heap_Count + Const_Count) - /* We don't know the partition of the outgoing image, - so, make each of the areas large enough: - Heap pointers and external heap objects, - Constant pointers and external constant objects, - Pure pointers and exteranl pure objects - */ - + (2 * (Heap_Count + (2 * Const_Count))) - /* Space for the roots */ - + (NROOTS + 1) - /* Space for the primitive table, or space to upgrade */ - + (upgrade_primitives_p - ? (3 * PRIMITIVE_UPGRADE_SPACE) - : Primitive_Table_Size) - /* Everything might be compiled code blocks, requiring - extra tables to map entries to objects, and block alignment - */ - + (allow_compiled_p - ? (2 + ((c_compiled_p ? 5 : 3) * (Heap_Count + Const_Count))) - : 0) - /* C code IDs */ - + C_Code_Table_Size); - - ALLOCATE_HEAP_SPACE (Size, - Lowest_Allocated_Address, - Highest_Allocated_Address); - - if (Lowest_Allocated_Address == ((SCHEME_OBJECT *) NULL)) - { - fprintf (stderr, - "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n", - program_name, Size); - quit (1); - } - } - - Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1)); - ALIGN_FLOAT (Heap); - if ((Load_Data (Heap_Count, Heap)) != Heap_Count) - { - fprintf (stderr, "%s: Could not load the heap's contents.\n", - program_name); - quit (1); - } - Constant_Space = (Heap + Heap_Count); - ALIGN_FLOAT (Constant_Space); - if ((Load_Data (Const_Count, Constant_Space)) != Const_Count) - { - fprintf (stderr, "%s: Could not load constant space.\n", - program_name); - quit (1); - } - Constant_Top = (find_constant_top (Constant_Space, Const_Count)); - Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base))); - Constant_Relocation = ((&Constant_Space[0]) - - (OBJECT_ADDRESS (Const_Base))); - Max_Stack_Offset = 0; - - /* Setup compiled code and primitive tables. */ - - compiled_entry_table = &Constant_Space[Const_Count]; - compiled_entry_pointer = compiled_entry_table; - compiled_entry_table_end = compiled_entry_pointer; - if (allow_compiled_p) - compiled_entry_table_end += (2 * (Heap_Count + Const_Count)); - - compiled_block_table = compiled_entry_table_end; - compiled_block_pointer = &compiled_block_table[2]; - compiled_block_table_end = compiled_block_pointer; - if (allow_compiled_p && c_compiled_p) - compiled_block_table_end += (2 *(Heap_Count + Const_Count)); - - primitive_table = compiled_block_table_end; - if (upgrade_primitives_p) - primitive_table_end = (setup_primitive_upgrade (primitive_table)); - else - { - fast SCHEME_OBJECT * table; - fast long count, char_count; - - if ((Load_Data (Primitive_Table_Size, primitive_table)) - != Primitive_Table_Size) - { - fprintf (stderr, "%s: Could not load the primitive table.\n", - program_name); - quit (1); - } - for (char_count = 0, - count = Primitive_Table_Length, - table = primitive_table; - --count >= 0;) - { - char_count += (STRING_LENGTH_TO_LONG (table[1 + STRING_LENGTH_INDEX])); - table += (2 + (OBJECT_DATUM (table[1 + STRING_HEADER]))); - } - NPChars = char_count; - primitive_table_end = (&primitive_table[Primitive_Table_Size]); - } - - c_code_table = primitive_table_end; - c_code_table_end = &c_code_table[C_Code_Table_Size]; - if (C_Code_Table_Size == 0) - c_code_table[0] = (LONG_TO_UNSIGNED_FIXNUM (0)); - else - { - fast SCHEME_OBJECT * table; - fast long count, char_count; - - if ((Load_Data (C_Code_Table_Size, c_code_table)) != C_Code_Table_Size) - { - fprintf (stderr, "%s: Could not load the C code table.\n", - program_name); - quit (1); - } - for (char_count = 0, - count = C_Code_Table_Length, - table = &c_code_table[1]; - --count >= 0; ) - { - long slen; - - slen = (strlen ((char *) (table + 1))); - table += (1 + (BYTES_TO_WORDS (1 + slen))); - char_count += slen; - } - NCChars = char_count; - } - - Mem_Base = c_code_table_end; - - /* Reformat the data */ - - NFlonums = NIntegers = NStrings = 0; - NBits = NBBits = NChars = 0; - - Heap_Start = (NROOTS + (TRAP_MAX_IMMEDIATE + 1)); - INDEX_ALIGN_FLOAT (Heap_Start); - Heap_Objects_Start = (Heap_Start - + (allow_compiled_p - ? (2 * Heap_Count) - : Heap_Count)); - if (! band_p) - dumped_utilities = SHARP_F; - Mem_Base[(Heap_Start - NROOTS) + 0] = dumped_utilities; - if (dumped_utilities != SHARP_F) - { - /* This knows the format of the utilities vector. */ - SCHEME_OBJECT * uv = (relocate (dumped_utilities)); - unsigned long len = (OBJECT_DATUM (uv[0])); - - uv[len - 1] = ((SCHEME_OBJECT) - (((unsigned long) uv[len - 1]) - / (sizeof (SCHEME_OBJECT)))); - uv[len - 0] = ((SCHEME_OBJECT) - (((unsigned long) uv[len - 0]) - / (sizeof (SCHEME_OBJECT)))); - } - Mem_Base[(Heap_Start - NROOTS) + 1] - = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object)); - Scan = (Heap_Start - NROOTS); - Free = Heap_Start; - Free_Objects = &Mem_Base[Heap_Objects_Start]; - Objects = 0; - - Constant_Start = (Heap_Objects_Start + Heap_Count); - INDEX_ALIGN_FLOAT (Constant_Start); - Constant_Objects_Start = (Constant_Start - + (allow_compiled_p - ? (2 * Const_Count) - : Const_Count)); - Scan_Constant = Constant_Start; - Free_Constant = Constant_Start; - Free_Cobjects = &Mem_Base[Constant_Objects_Start]; - Constant_Objects = 0; - - Pure_Start = (Constant_Objects_Start + Const_Count); - INDEX_ALIGN_FLOAT (Pure_Start); - Pure_Objects_Start = (Pure_Start - + (allow_compiled_p - ? (2 * Const_Count) - : Const_Count)); - Scan_Pure = Pure_Start; - Free_Pure = Pure_Start; - Free_Pobjects = &Mem_Base[Pure_Objects_Start]; - Pure_Objects = 0; - - if (Const_Count == 0) - DO_AREA (HEAP_CODE, Scan, Free, Objects, Free_Objects); - else - while ((Scan != Free) - || (Scan_Constant != Free_Constant) - || (Scan_Pure != Free_Pure)) - { - DO_AREA (HEAP_CODE, Scan, Free, - Objects, Free_Objects); - DO_AREA (CONSTANT_CODE, Scan_Constant, Free_Constant, - Constant_Objects, Free_Cobjects); - DO_AREA (PURE_CODE, Scan_Pure, Free_Pure, - Pure_Objects, Free_Pobjects); - } - - /* Consistency checks */ - - WHEN (((Free - Heap_Start) > Heap_Count), "Free overran Heap"); - - WHEN (((Free_Objects - &Mem_Base[Heap_Objects_Start]) - > Heap_Count), - "Free_Objects overran Heap Object Space"); - - WHEN (((Free_Constant - Constant_Start) > Const_Count), - "Free_Constant overran Constant Space"); - - WHEN (((Free_Cobjects - &Mem_Base[Constant_Objects_Start]) - > Const_Count), - "Free_Cobjects overran Constant Object Space"); - - WHEN (((Free_Pure - Pure_Start) > Const_Count), - "Free_Pure overran Pure Space"); - - WHEN (((Free_Cobjects - &Mem_Base[Pure_Objects_Start]) - > Const_Count), - "Free_Cobjects overran Pure Object Space"); - - /* Output the data */ - - if (found_ext_prims) - { - fprintf (stderr, "%s:\n", program_name); - fprintf (stderr, "NOTE: The arity of some primitives is not known.\n"); - fprintf (stderr, " The portable file has %ld as their arity.\n", - UNKNOWN_PRIMITIVE_ARITY); - fprintf (stderr, " You may want to fix this by hand.\n"); - } - - if (! compiled_p) - { - dumped_processor_type = 0; - dumped_interface_version = 0; - } - - /* Header: - Portable Version - Machine - Version - Sub Version - Flags - Heap Count - Heap Base - Heap Objects - Constant Count - Constant Base - Constant Objects - Pure Count - Pure Base - Pure Objects - & Dumped Object - Maximum Stack Offset - Number of flonums - Number of integers - Number of bits in integers - Number of bit strings - Number of bits in bit strings - Number of character strings - Number of characters in strings - Number of primitives - Number of characters in primitives - CPU type - Compiled code interface version - Compiler utilities vector - Number of C code blocks - Number of characters in C code blocks - Number of reserved C entries - */ - - WRITE_HEADER ("Portable Version", "%ld", PORTABLE_VERSION); - WRITE_HEADER ("Machine", "%ld", FASL_INTERNAL_FORMAT); - WRITE_HEADER ("Version", "%ld", FASL_FORMAT_VERSION); - WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION); - WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ())); - - WRITE_HEADER ("Heap Count", "%ld", (Free - Heap_Start)); - WRITE_HEADER ("Heap Base", "%ld", Heap_Start); - WRITE_HEADER ("Heap Objects", "%ld", Objects); - - WRITE_HEADER ("Constant Count", "%ld", (Free_Constant - Constant_Start)); - WRITE_HEADER ("Constant Base", "%ld", Constant_Start); - WRITE_HEADER ("Constant Objects", "%ld", Constant_Objects); - - WRITE_HEADER ("Pure Count", "%ld", (Free_Pure - Pure_Start)); - WRITE_HEADER ("Pure Base", "%ld", Pure_Start); - WRITE_HEADER ("Pure Objects", "%ld", Pure_Objects); - - WRITE_HEADER ("& Dumped Object", "%ld", - (OBJECT_DATUM (Mem_Base[(Heap_Start - NROOTS) + 1]))); - WRITE_HEADER ("Maximum Stack Offset", "%ld", Max_Stack_Offset); - - WRITE_HEADER ("Number of flonums", "%ld", NFlonums); - WRITE_HEADER ("Number of integers", "%ld", NIntegers); - WRITE_HEADER ("Number of bits in integers", "%ld", NBits); - WRITE_HEADER ("Number of bit strings", "%ld", NBitstrs); - WRITE_HEADER ("Number of bits in bit strings", "%ld", NBBits); - WRITE_HEADER ("Number of character strings", "%ld", NStrings); - WRITE_HEADER ("Number of characters in strings", "%ld", NChars); - - WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length); - WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars); - - WRITE_HEADER ("CPU type", "%ld", dumped_processor_type); - WRITE_HEADER ("Compiled code interface version", "%ld", - dumped_interface_version); - if (allow_bands_p) - WRITE_HEADER ("Compiler utilities vector", "%ld", - (OBJECT_DATUM (Mem_Base[(Heap_Start - NROOTS) + 0]))); - else - WRITE_HEADER ("Compiler utilities vector", "%ld", 0); - - WRITE_HEADER ("Number of C code blocks", "%ld", C_Code_Table_Length); - WRITE_HEADER ("Number of characters in C code blocks", "%ld", NCChars); - WRITE_HEADER ("Number of reserved C entries", "%ld", - (OBJECT_DATUM (c_code_table[0]))); - - /* Binary Objects */ - - print_binary_objects (&Mem_Base[Pure_Objects_Start], Pure_Objects); - print_binary_objects (&Mem_Base[Constant_Objects_Start], Constant_Objects); - print_binary_objects (&Mem_Base[Heap_Objects_Start], Objects); - - /* Normal Objects: pointers, simple non-pointers (e.g. SHARP_F) */ - - print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]); - print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]); - print_objects (&Mem_Base[Heap_Start], &Mem_Base[Free]); - - /* Primitives */ - - if (upgrade_primitives_p) - { - SCHEME_OBJECT obj; - fast SCHEME_OBJECT *table; - fast long count, the_datum; - - for (count = Primitive_Table_Length, - table = external_renumber_table; - --count >= 0;) - { - obj = *table++; - the_datum = (OBJECT_DATUM (obj)); - if ((OBJECT_TYPE (obj)) == TC_PRIMITIVE_EXTERNAL) - { - SCHEME_OBJECT *strobj; - - strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum])); - print_a_primitive (((long) UNKNOWN_PRIMITIVE_ARITY), - (STRING_LENGTH_TO_LONG - (strobj[STRING_LENGTH_INDEX])), - ((char *) &strobj[STRING_CHARS])); - } - else - { - char *str; - - str = builtin_prim_name_table[the_datum]; - print_a_primitive (((long) builtin_prim_arity_table[the_datum]), - ((long) strlen(str)), - str); - } - } - } - else - { - long count; - SCHEME_OBJECT * table = primitive_table; - - for (count = Primitive_Table_Length; --count >= 0; ) - { - long arity = (FIXNUM_TO_LONG (* table)); - table += 1; - print_a_primitive - (arity, - (STRING_LENGTH_TO_LONG (table[STRING_LENGTH_INDEX])), - ((char *) &table[STRING_CHARS])); - table += (1 + (OBJECT_DATUM (table[STRING_HEADER]))); - } - } - - /* C Code block information */ - - { - long count; - SCHEME_OBJECT * table = &c_code_table[1]; - - for (count = C_Code_Table_Length; --count >= 0; ) - { - char * name; - long nentries, namelen; - - nentries = (FIXNUM_TO_LONG (* table)); - name = ((char *) (table + 1)); - namelen = (strlen (name)); - print_a_c_code_block (nentries, namelen, name); - table += (1 + (BYTES_TO_WORDS (namelen + 1))); - } - } - - fflush (portable_file); - free ((char *) Lowest_Allocated_Address); - } -} - -/* Top Level */ - -static Boolean - allow_constant_sup_p, - ci_version_sup_p, - ci_processor_sup_p, - help_p = false, - help_sup_p, - warn_portable_sup_p; - -/* The boolean value here is what value to store when the option is present. */ - -static struct keyword_struct - options[] = { - KEYWORD ("swap_bytes", &swap_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("ci_version", &compiler_interface_version, INT_KYWRD, "%ld", - &ci_version_sup_p), - KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld", - &ci_processor_sup_p), - KEYWORD ("endian_invert", &endian_invert_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("allow_bands", &allow_bands_p, BOOLEAN_KYWRD, BFRMT, NULL), - KEYWORD ("allow_constant_space", &allow_constant_space_p, - BOOLEAN_KYWRD, BFRMT, &allow_constant_sup_p), - KEYWORD ("warn_portable", &warn_portable_p, BOOLEAN_KYWRD, BFRMT, - &warn_portable_sup_p), - KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p), - OUTPUT_KEYWORD (), - INPUT_KEYWORD (), - END_KEYWORD () - }; - -int -DEFUN (main, (argc, argv), int argc AND char **argv) -{ - parse_keywords (argc, argv, options, false); - - if (help_sup_p && help_p) - { - print_usage_and_exit(options, 0); - /*NOTREACHED*/ - } - - upgrade_compiled_p = - (upgrade_compiled_p || ci_version_sup_p || ci_processor_sup_p); - allow_compiled_p = (allow_compiled_p || upgrade_compiled_p - || c_compiled_p || allow_bands_p); - allow_nmv_p = (allow_nmv_p || allow_compiled_p || endian_invert_p); - if (null_nmv_p && allow_nmv_p) - { - fprintf (stderr, - "%s: NMVs are both allowed and to be nulled out!\n", - program_name); - quit (1); - } - if (allow_bands_p && warn_portable_p && (! warn_portable_sup_p)) - warn_portable_p = false; - if (allow_bands_p && (! allow_constant_space_p) && (! allow_constant_sup_p)) - allow_constant_space_p = true; - - setup_io ("rb", "w"); - do_it (); - quit (0); - return (0); -} diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c index c5c7c50bf..0e4646d99 100644 --- a/v7/src/microcode/bitstr.c +++ b/v7/src/microcode/bitstr.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bitstr.c,v 9.68 2007/01/05 21:19:25 cph Exp $ +$Id: bitstr.c,v 9.69 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -35,19 +35,18 @@ USA. #include "prims.h" #include "bitstr.h" -static void EXFUN - (copy_bits, (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long)); -extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long)); +static void copy_bits + (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long); SCHEME_OBJECT -DEFUN (allocate_bit_string, (length), long length) +allocate_bit_string (unsigned long length) { long total_pointers; SCHEME_OBJECT result; total_pointers = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (length))); result = (allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true)); - FAST_MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length); + MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length); return (result); } @@ -57,7 +56,7 @@ DEFUN (allocate_bit_string, (length), long length) DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0) { PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (allocate_bit_string (arg_nonnegative_integer (1))); + PRIMITIVE_RETURN (allocate_bit_string (arg_ulong_integer (1))); } /* (BIT-STRING? object) @@ -65,15 +64,12 @@ DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0) DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1, 1, 0) { - fast SCHEME_OBJECT object; PRIMITIVE_HEADER (1); - TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object); - PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (object))); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (ARG_REF (1)))); } void -DEFUN (fill_bit_string, (bit_string, sense), - SCHEME_OBJECT bit_string AND +fill_bit_string (SCHEME_OBJECT bit_string, int sense) { SCHEME_OBJECT *scanner; @@ -87,10 +83,8 @@ DEFUN (fill_bit_string, (bit_string, sense), (* (DEC_BIT_STRING_PTR (scanner))) = filler; } -extern void EXFUN (clear_bit_string, (SCHEME_OBJECT)); - void -DEFUN (clear_bit_string, (bit_string), SCHEME_OBJECT bit_string) +clear_bit_string (SCHEME_OBJECT bit_string) { SCHEME_OBJECT *scanner; long i; @@ -108,7 +102,7 @@ set to zero if the initialization is false, one otherwise.") { SCHEME_OBJECT result; PRIMITIVE_HEADER (2); - result = allocate_bit_string (arg_nonnegative_integer (1)); + result = allocate_bit_string (arg_ulong_integer (1)); fill_bit_string (result, (OBJECT_TO_BOOLEAN (ARG_REF (2)))); PRIMITIVE_RETURN (result); } @@ -136,10 +130,10 @@ Returns the number of bits in BIT-STRING.") } #define REF_INITIALIZATION() \ - fast SCHEME_OBJECT bit_string; \ - fast long index; \ - fast SCHEME_OBJECT *ptr; \ - fast long mask; \ + SCHEME_OBJECT bit_string; \ + long index; \ + SCHEME_OBJECT *ptr; \ + long mask; \ PRIMITIVE_HEADER (2); \ \ CHECK_ARG (1, BIT_STRING_P); \ @@ -174,7 +168,7 @@ Sets the indexed bit to zero, returning its previous value as a boolean.") PRIMITIVE_RETURN (SHARP_T); } -DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2, +DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2, "(BIT-STRING INDEX)\n\ Sets the indexed bit to one, returning its previous value as a boolean.") { @@ -197,9 +191,9 @@ DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1, 1, "(BIT-STRING)\n\ Returns true the argument has no \"set\" bits.") { - fast SCHEME_OBJECT bit_string; - fast SCHEME_OBJECT *scan; - fast long i; + SCHEME_OBJECT bit_string; + SCHEME_OBJECT *scan; + long i; long length, odd_bits; PRIMITIVE_HEADER (1); CHECK_ARG (1, BIT_STRING_P); @@ -229,14 +223,14 @@ Returns true the argument has no \"set\" bits.") PRIMITIVE_RETURN (SHARP_T); \ } -DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2, +DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2, "(BIT-STRING-1 BIT-STRING-2)\n\ Returns true iff the two bit strings contain the same bits.") { SCHEME_OBJECT bit_string_1, bit_string_2; long length; - fast SCHEME_OBJECT *scan1, *scan2; - fast long i; + SCHEME_OBJECT *scan1, *scan2; + long i; long odd_bits; PRIMITIVE_HEADER (2); CHECK_ARG (1, BIT_STRING_P); @@ -277,8 +271,8 @@ Returns true iff the two bit strings contain the same bits.") #define BITWISE_OP(action) \ { \ SCHEME_OBJECT bit_string_1, bit_string_2; \ - fast long i; \ - fast SCHEME_OBJECT *scan1, *scan2; \ + long i; \ + SCHEME_OBJECT *scan1, *scan2; \ PRIMITIVE_HEADER (2); \ bit_string_1 = (ARG_REF (1)); \ bit_string_2 = (ARG_REF (2)); \ @@ -311,14 +305,14 @@ DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2, 2, 0) DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2, 2, 0) BITWISE_OP (^=) -DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5, +DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5, "(SOURCE START1 END1 DESTINATION START2)\n\ Destructively copies the substring of SOURCE between START1 and \ END1 into DESTINATION at START2. The copying is done from the \ MSB to the LSB (which only matters when SOURCE and DESTINATION \ are the same).") { - fast SCHEME_OBJECT bit_string_1, bit_string_2; + SCHEME_OBJECT bit_string_1, bit_string_2; long start1, end1, start2, end2, nbits; long end1_mod, end2_mod; PRIMITIVE_HEADER (5); @@ -370,12 +364,10 @@ are the same).") starting with the MSB of a bit string and moving down. */ static void -DEFUN (copy_bits, - (source, source_offset, destination, destination_offset, nbits), - SCHEME_OBJECT * source AND - long source_offset AND - SCHEME_OBJECT * destination AND - long destination_offset AND +copy_bits (SCHEME_OBJECT * source, + long source_offset, + SCHEME_OBJECT * destination, + long destination_offset, long nbits) { @@ -535,74 +527,52 @@ DEFUN (copy_bits, /* Integer <-> Bit-string Conversions */ -long -DEFUN (count_significant_bits, (number, start), long number AND long start) +static unsigned long +ulong_significant_bits (unsigned long number) { - long significant_bits, i; - - significant_bits = start; - for (i = (1L << (start - 1)); (i >= 0); i >>= 1) + unsigned long limit = 1; + unsigned int nbits = 1; + while (true) { - if (number >= i) - break; - significant_bits -= 1; + if (number <= limit) + return (nbits); + limit = ((limit * 2) + 1); + nbits += 1; } - return (significant_bits); } -long -DEFUN (long_significant_bits, (number), long number) +static SCHEME_OBJECT +zero_to_bit_string (unsigned long length) { - return - ((number < 0) - ? ((sizeof (long)) * CHAR_BIT) - : (count_significant_bits (number, (((sizeof (long)) * CHAR_BIT) - 1)))); -} - -SCHEME_OBJECT -DEFUN (zero_to_bit_string, (length), long length) -{ - SCHEME_OBJECT result; - - result = (allocate_bit_string (length)); + SCHEME_OBJECT result = (allocate_bit_string (length)); clear_bit_string (result); return (result); } -SCHEME_OBJECT -DEFUN (long_to_bit_string, (length, number), long length AND long number) +static SCHEME_OBJECT +ulong_to_bit_string (unsigned long length, unsigned long number) { - if (number < 0) - error_bad_range_arg (2); - if (number == 0) - { - return (zero_to_bit_string (length)); - } - else - { - SCHEME_OBJECT result; - - if (length < (long_significant_bits (number))) - error_bad_range_arg (2); - result = (zero_to_bit_string (length)); - (BIT_STRING_LSW (result)) = number; - return (result); - } + return (zero_to_bit_string (length)); + if (length < (ulong_significant_bits (number))) + error_bad_range_arg (2); + { + SCHEME_OBJECT result = (zero_to_bit_string (length)); + (BIT_STRING_LSW (result)) = number; + return (result); + } } static void -DEFUN (btbs_consumer, (result_ptr, digit), - PTR result_ptr - AND long digit) +btbs_consumer (void * result_ptr, + long digit) { (* (INC_BIT_STRING_PTR (* ((unsigned char **) result_ptr)))) = ((unsigned char) digit); } -SCHEME_OBJECT -DEFUN (bignum_to_bit_string, (length, bignum), - long length AND SCHEME_OBJECT bignum) +static SCHEME_OBJECT +bignum_to_bit_string (unsigned long length, SCHEME_OBJECT bignum) { switch (bignum_test (bignum)) { @@ -615,8 +585,8 @@ DEFUN (bignum_to_bit_string, (length, bignum), error_bad_range_arg (2); { SCHEME_OBJECT result = (zero_to_bit_string (length)); - unsigned char * result_ptr = - ((unsigned char *) (BIT_STRING_LOW_PTR (result))); + unsigned char * result_ptr + = ((unsigned char *) (BIT_STRING_LOW_PTR (result))); bignum_to_digit_stream (bignum, (1L << CHAR_BIT), btbs_consumer, (&result_ptr)); return (result); @@ -629,12 +599,12 @@ DEFUN (bignum_to_bit_string, (length, bignum), struct bitstr_to_bignm_context { - unsigned char *source_ptr; + unsigned char * source_ptr; unsigned int mask; }; static unsigned int -DEFUN (bstb_producer, (context), PTR context) +bstb_producer (void * context) { struct bitstr_to_bignm_context * c = context; unsigned int result = (c->mask & (BIT_STRING_WORD (c->source_ptr))); @@ -643,29 +613,30 @@ DEFUN (bstb_producer, (context), PTR context) return (result); } -SCHEME_OBJECT -DEFUN (bit_string_to_bignum, (nbits, bitstr), - long nbits AND SCHEME_OBJECT bitstr) +static SCHEME_OBJECT +bit_string_to_bignum (unsigned long nbits, SCHEME_OBJECT bitstr) { + unsigned long ndigits = ((nbits + (CHAR_BIT - 1)) / CHAR_BIT); struct bitstr_to_bignm_context context; - int ndigits, skip; - - ndigits = ((nbits + (CHAR_BIT - 1)) / CHAR_BIT); - context.mask = (LOW_MASK (((nbits - 1) % (CHAR_BIT)) + 1)); - context.source_ptr = - ((unsigned char *) - (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, (nbits - 1)))))); + (context.mask) = (LOW_MASK (((nbits - 1) % (CHAR_BIT)) + 1)); + (context.source_ptr) + = ((unsigned char *) + (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, (nbits - 1)))))); if (ndigits != 0) - { - skip = ((sizeof (SCHEME_OBJECT)) - - (((ndigits - 1) % (sizeof (SCHEME_OBJECT))) + 1)); - while ((--skip) >= 0) { - DEC_BIT_STRING_PTR (context.source_ptr); + unsigned long skip + = ((sizeof (SCHEME_OBJECT)) + - (((ndigits - 1) + % (sizeof (SCHEME_OBJECT))) + + 1)); + while (skip > 0) + { + DEC_BIT_STRING_PTR (context.source_ptr); + skip -= 1; + } } - } return (digit_stream_to_bignum (ndigits, bstb_producer, @@ -673,24 +644,24 @@ DEFUN (bit_string_to_bignum, (nbits, bitstr), 0)); } -DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2, +DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2, "(LENGTH INTEGER)\n\ INTEGER, which must be a non-negative integer, is converted to \ a bit-string of length LENGTH. If INTEGER is too large, an \ error is signalled.") { - fast long length; - fast SCHEME_OBJECT object; + unsigned long length; + SCHEME_OBJECT object; PRIMITIVE_HEADER (2); - length = (arg_nonnegative_integer (1)); + + length = (arg_ulong_integer (1)); object = (ARG_REF (2)); if (FIXNUM_P (object)) { - if (FIXNUM_NEGATIVE_P (object)) + if (!FIXNUM_TO_ULONG_P (object)) error_bad_range_arg (2); PRIMITIVE_RETURN - (long_to_bit_string - (length, (UNSIGNED_FIXNUM_TO_LONG (object)))); + (ulong_to_bit_string (length, (FIXNUM_TO_ULONG (object)))); } if (BIGNUM_P (object)) PRIMITIVE_RETURN (bignum_to_bit_string (length, object)); @@ -706,9 +677,13 @@ DEFINE_PRIMITIVE ("BIT-STRING->UNSIGNED-INTEGER", Prim_bit_string_to_unsigned, 1 BIT-STRING is converted to the appropriate non-negative integer. \ This operation is the inverse of `unsigned-integer->bit-string'.") { - fast SCHEME_OBJECT bit_string, *scan; - long nwords, nbits, word; + SCHEME_OBJECT bit_string; + SCHEME_OBJECT * scan; + unsigned long nwords; + unsigned long nbits; + unsigned long word; PRIMITIVE_HEADER (1); + CHECK_ARG (1, BIT_STRING_P); bit_string = (ARG_REF (1)); /* Count the number of significant bits.*/ @@ -726,7 +701,7 @@ This operation is the inverse of `unsigned-integer->bit-string'.") } if (nwords == 0) PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0)); - nbits = (((nwords - 1) * OBJECT_LENGTH) + (long_significant_bits (word))); + nbits = (((nwords - 1) * OBJECT_LENGTH) + (ulong_significant_bits (word))); PRIMITIVE_RETURN ((nbits <= FIXNUM_LENGTH) ? (LONG_TO_UNSIGNED_FIXNUM (word)) @@ -860,11 +835,8 @@ DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_b (BIT_STRING_INDEX_PAIR_TO_INDEX (bit_string, word, bit))); } -extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int)); - void -DEFUN (bit_string_set, (bitstr, index, value), - SCHEME_OBJECT bitstr AND long index AND int value) +bit_string_set (SCHEME_OBJECT bitstr, long index, int value) { unsigned long mask; SCHEME_OBJECT * ptr; diff --git a/v7/src/microcode/bitstr.h b/v7/src/microcode/bitstr.h index beb04c1be..c629ecde4 100644 --- a/v7/src/microcode/bitstr.h +++ b/v7/src/microcode/bitstr.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bitstr.h,v 1.14 2007/01/05 21:19:25 cph Exp $ +$Id: bitstr.h,v 1.15 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -37,7 +37,7 @@ USA. #define ANY_MASK(nbits, offset) ((LOW_MASK (nbits)) << (offset)) #define BIT_STRING_LENGTH(bit_string) \ - ((long) (FAST_MEMORY_REF ((bit_string), BIT_STRING_LENGTH_OFFSET))) + ((long) (MEMORY_REF ((bit_string), BIT_STRING_LENGTH_OFFSET))) #define BIT_STRING_MSW(bit_string) \ (BIT_STRING_WORD (BIT_STRING_HIGH_PTR (bit_string))) @@ -87,7 +87,7 @@ The "size in bits" is a C "long" integer. #define BIT_STRING_WORD(ptr) (*((ptr) - 1)) #define DEC_BIT_STRING_PTR(ptr) (--(ptr)) #define INC_BIT_STRING_PTR(ptr) ((ptr)++) - + /* This is off by one so BIT_STRING_WORD will get the correct word. */ #define BIT_STRING_INDEX_TO_WORD(bit_string, index) \ diff --git a/v7/src/microcode/bkpt.c b/v7/src/microcode/bkpt.c index b073ccc76..cd744c505 100644 --- a/v7/src/microcode/bkpt.c +++ b/v7/src/microcode/bkpt.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bkpt.c,v 9.36 2007/01/05 21:19:25 cph Exp $ +$Id: bkpt.c,v 9.37 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,13 +30,13 @@ USA. #include "scheme.h" -#ifdef ENABLE_DEBUGGING_FLAGS +#ifdef ENABLE_DEBUGGING_TOOLS #define sp_nil ((struct sp_record *) 0) sp_record_list SP_List = sp_nil; -extern Boolean EXFUN (Add_a_Pop_Return_Breakpoint, (SCHEME_OBJECT *)); +extern bool Add_a_Pop_Return_Breakpoint (SCHEME_OBJECT *); static struct sp_record One_Before = { @@ -44,8 +44,8 @@ static struct sp_record One_Before = sp_nil }; -Boolean -DEFUN (Add_a_Pop_Return_Breakpoint, (SP), SCHEME_OBJECT * SP) +bool +Add_a_Pop_Return_Breakpoint (SCHEME_OBJECT * SP) { sp_record_list old = SP_List; SP_List = ((sp_record_list) (malloc (sizeof(struct sp_record)))); @@ -65,23 +65,22 @@ DEFUN (Add_a_Pop_Return_Breakpoint, (SP), SCHEME_OBJECT * SP) /* A breakpoint can be placed here from a C debugger to examine the state of the world. */ -extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT)); +extern bool Print_One_Continuation_Frame (SCHEME_OBJECT); void -DEFUN_VOID (Handle_Pop_Return_Break) +Handle_Pop_Return_Break (void) { - SCHEME_OBJECT *Old_Stack = sp_register; + SCHEME_OBJECT *Old_Stack = stack_pointer; - printf ("Pop Return Break: SP = 0x%lx\n", ((long) sp_register)); - (void) (Print_One_Continuation_Frame (ret_register)); - sp_register = Old_Stack; - return; + printf ("Pop Return Break: SP = %#lx\n", ((unsigned long) stack_pointer)); + (void) (Print_One_Continuation_Frame (GET_RET)); + stack_pointer = Old_Stack; } void -DEFUN_VOID (Pop_Return_Break_Point) +Pop_Return_Break_Point (void) { - SCHEME_OBJECT * SP = sp_register; + SCHEME_OBJECT * SP = stack_pointer; sp_record_list previous = &One_Before; sp_record_list this = previous->next; /* = SP_List */ @@ -97,9 +96,6 @@ DEFUN_VOID (Pop_Return_Break_Point) } } SP_List = One_Before.next; - return; } -#else -/* Not ENABLE_DEBUGGING_FLAGS */ -#endif +#endif /* ENABLE_DEBUGGING_TOOLS */ diff --git a/v7/src/microcode/bkpt.h b/v7/src/microcode/bkpt.h index a556624e9..6f5acd85c 100644 --- a/v7/src/microcode/bkpt.h +++ b/v7/src/microcode/bkpt.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bkpt.h,v 9.38 2007/01/05 21:19:25 cph Exp $ +$Id: bkpt.h,v 9.39 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,11 +25,9 @@ USA. */ -/* This file contains breakpoint utilities. - Disabled when not debugging the interpreter. - It "shadows" definitions in default.h */ +/* This file contains breakpoint utility definitions. */ -#ifdef ENABLE_DEBUGGING_FLAGS +#ifdef ENABLE_DEBUGGING_TOOLS struct sp_record { @@ -38,28 +36,23 @@ struct sp_record }; typedef struct sp_record * sp_record_list; +extern sp_record_list SP_List; -#define debug_maxslots 100 +#define DEBUG_MAXSLOTS 100 -#define Eval_Ucode_Hook() \ +#define EVAL_UCODE_HOOK() do \ { \ - (local_circle [local_slotno++]) = exp_register; \ - if (local_slotno >= debug_maxslots) \ + (local_circle [local_slotno++]) = GET_EXP; \ + if (local_slotno >= DEBUG_MAXSLOTS) \ local_slotno = 0; \ - if (local_nslots < debug_maxslots) \ + if (local_nslots < DEBUG_MAXSLOTS) \ local_nslots += 1; \ -} +} while (0) -#define Pop_Return_Ucode_Hook() \ +#define POP_RETURN_UCODE_HOOK() do \ { \ if (SP_List != 0) \ - { \ Pop_Return_Break_Point (); \ - } \ -} +} while (0) -/* Not implemented yet */ - -#define Apply_Ucode_Hook() - -#endif /* ENABLE_DEBUGGING_FLAGS */ +#endif /* ENABLE_DEBUGGING_TOOLS */ diff --git a/v7/src/microcode/bltdef.h b/v7/src/microcode/bltdef.h deleted file mode 100644 index e40c38533..000000000 --- a/v7/src/microcode/bltdef.h +++ /dev/null @@ -1,905 +0,0 @@ -/* -*-C-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* $Id: bltdef.h,v 1.8 2007/01/05 21:19:25 cph Exp $ - * - * Names and arity's of old "built-in" primitives. - * The tables here are used by Bintopsb to upgrade binaries. - */ - -#define MAX_BUILTIN_PRIMITIVE 431 - -int builtin_prim_arity_table[] = { - 3, - 2, - 3, - 1, - 2, - 2, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 2, - 2, - 2, - 1, - 2, - 2, - 2, - 2, - 1, - 0, - 1, - 2, - 3, - 0, - 1, - 2, - 3, - 1, - 1, - 2, - 1, - 1, - 2, - 2, - 0, - 0, - 2, - 3, - 2, - 3, - 3, - 2, - 1, - 2, - 1, - 3, - 1, - 0, - 2, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 2, - 2, - 2, - 2, - 2, - 2, - 1, - 1, - 1, - 2, - 3, - 1, - 0, - 0, - 0, - 3, - 2, - 2, - 2, - 2, - 2, - 2, - 2, - 2, - 1, - 2, - 1, - 3, - 1, - 3, - 2, - 0, - 0, - 2, - 1, - 2, - 1, - 2, - 1, - 1, - 1, - 1, - 1, - 2, - 1, - 1, - 2, - 2, - 2, - 2, - 2, - 2, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 0, - 0, - 1, - 1, - 3, - 1, - 1, - 1, - 2, - 2, - 1, - 3, - 1, - 1, - 1, - 2, - 2, - 2, - 0, - 2, - 2, - 1, - 2, - 2, - 1, - 2, - 2, - 1, - 2, - 1, - 2, - 3, - 1, - 2, - 3, - 1, - 5, - 5, - 4, - 0, - 0, - 0, - 1, - 1, - 2, - 3, - 1, - 1, - 1, - 2, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 2, - 1, - 0, - 2, - 2, - 1, - 1, - 1, - 1, - 1, - 2, - 2, - 1, - 1, - 1, - 2, - 1, - 2, - 2, - 1, - 0, - 2, - 3, - 3, - 2, - 1, - 0, - 0, - 0, - 1, - 2, - 1, - 1, - 2, - 5, - 2, - 2, - 1, - 3, - 0, - 2, - 1, - 0, - 3, - 3, - 1, - 4, - 1, - 0, - 0, - 1, - 1, - 1, - 2, - 2, - 2, - 2, - 2, - 2, - 2, - 2, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 1, - 0, - 0, - 0, - 1, - 2, - 0, - 0, - 0, - 2, - 0, - 0, - 1, - 0, - 2, - 0, - 0, - 0, - 0, - 2, - 2, - 1, - 3, - 1, - 0, - 1, - 7, - 7, - 7, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 2, - 1, - 1, - 2, - 3, - 5, - 5, - 1, - 1, - 2, - 4, - 4, - 4, - 4, - 4, - 4, - 4, - 6, - 6, - 6, - 3, - 3, - 6, - 6, - 6, - 6, - 1, - 0, - 2, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 1, - 4, - 4, - 7, - 7, - 7, - 4, - 4, - 2, - 4, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 3, - 2, - 2, - 4, - 7, - 7, - 7, - 2, - 3, - 2, - 2, - 2, - 2, - 2, - 2, - 2, - 0, - 1, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0, - 0 -}; - -static char No_Name[] = ""; - -char *builtin_prim_name_table[] = { - "LEXICAL-ASSIGNMENT", - "LOCAL-REFERENCE", - "LOCAL-ASSIGNMENT", - "CALL-WITH-CURRENT-CONTINUATION", - "SCODE-EVAL", - "APPLY", - "SET-INTERRUPT-ENABLES!", - "STRING->SYMBOL", - "GET-WORK", - "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", - "CURRENT-DYNAMIC-STATE", - "SET-CURRENT-DYNAMIC-STATE!", - "NULL?", - "EQ?", - "STRING-EQUAL?", - "PRIMITIVE-TYPE?", - "PRIMITIVE-TYPE", - "PRIMITIVE-SET-TYPE", - "LEXICAL-REFERENCE", - "LEXICAL-UNREFERENCEABLE?", - "MAKE-CHAR", - "CHAR-BITS", - "EXIT", - "CHAR-CODE", - "LEXICAL-UNASSIGNED?", - "INSERT-NON-MARKED-VECTOR!", - "HALT", - "CHAR->INTEGER", - "MEMQ", - "INSERT-STRING", - "ENABLE-INTERRUPTS!", - "MAKE-EMPTY-STRING", - "CONS", - "CAR", - "CDR", - "SET-CAR!", - "SET-CDR!", - "GET-COMMAND-LINE", - "TTY-GET-CURSOR", - "GENERAL-CAR-CDR", - "HUNK3-CONS", - "HUNK3-CXR", - "HUNK3-SET-CXR!", - "INSERT-STRING!", - "VECTOR-CONS", - "VECTOR-LENGTH", - "VECTOR-REF", - "SET-CURRENT-HISTORY!", - "VECTOR-SET!", - "NON-MARKED-VECTOR-CONS", - No_Name, - "LEXICAL-UNBOUND?", - "INTEGER->CHAR", - "CHAR-DOWNCASE", - "CHAR-UPCASE", - "ASCII->CHAR", - "CHAR-ASCII?", - "CHAR->ASCII", - "GARBAGE-COLLECT", - "PLUS-FIXNUM", - "MINUS-FIXNUM", - "MULTIPLY-FIXNUM", - "DIVIDE-FIXNUM", - "EQUAL-FIXNUM?", - "LESS-THAN-FIXNUM?", - "POSITIVE-FIXNUM?", - "ONE-PLUS-FIXNUM", - "MINUS-ONE-PLUS-FIXNUM", - "TRUNCATE-STRING!", - "SUBSTRING", - "ZERO-FIXNUM?", - No_Name, - No_Name, - No_Name, - "SUBSTRING->LIST", - "MAKE-FILLED-STRING", - "PLUS-BIGNUM", - "MINUS-BIGNUM", - "MULTIPLY-BIGNUM", - "DIVIDE-BIGNUM", - "LISTIFY-BIGNUM", - "EQUAL-BIGNUM?", - "LESS-THAN-BIGNUM?", - "POSITIVE-BIGNUM?", - "FILE-OPEN-CHANNEL", - "FILE-CLOSE-CHANNEL", - "PRIMITIVE-FASDUMP", - "BINARY-FASLOAD", - "STRING-POSITION", - "STRING-LESS?", - No_Name, - No_Name, - "REHASH", - "LENGTH", - "ASSQ", - "LIST->STRING", - "EQUAL-STRING-TO-LIST?", - "MAKE-CELL", - "CELL-CONTENTS", - "CELL?", - "CHARACTER-UPCASE", - "CHARACTER-LIST-HASH", - "GCD-FIXNUM", - "COERCE-FIXNUM-TO-BIGNUM", - "COERCE-BIGNUM-TO-FIXNUM", - "PLUS-FLONUM", - "MINUS-FLONUM", - "MULTIPLY-FLONUM", - "DIVIDE-FLONUM", - "EQUAL-FLONUM?", - "LESS-THAN-FLONUM?", - "ZERO-BIGNUM?", - "TRUNCATE-FLONUM", - "ROUND-FLONUM", - "COERCE-INTEGER-TO-FLONUM", - "SINE-FLONUM", - "COSINE-FLONUM", - "ARCTAN-FLONUM", - "EXP-FLONUM", - "LN-FLONUM", - "SQRT-FLONUM", - No_Name, - "GET-FIXED-OBJECTS-VECTOR", - "SET-FIXED-OBJECTS-VECTOR!", - "LIST->VECTOR", - "SUBVECTOR->LIST", - "PAIR?", - "NEGATIVE-FIXNUM?", - "NEGATIVE-BIGNUM?", - "GREATER-THAN-FIXNUM?", - "GREATER-THAN-BIGNUM?", - "STRING-HASH", - "SYSTEM-PAIR-CONS", - "SYSTEM-PAIR?", - "SYSTEM-PAIR-CAR", - "SYSTEM-PAIR-CDR", - "SYSTEM-PAIR-SET-CAR!", - "SYSTEM-PAIR-SET-CDR!", - "STRING-HASH-MOD", - No_Name, - "SET-CELL-CONTENTS!", - "&MAKE-OBJECT", - "SYSTEM-HUNK3-CXR0", - "SYSTEM-HUNK3-SET-CXR0!", - "MAP-MACHINE-ADDRESS-TO-CODE", - "SYSTEM-HUNK3-CXR1", - "SYSTEM-HUNK3-SET-CXR1!", - "MAP-CODE-TO-MACHINE-ADDRESS", - "SYSTEM-HUNK3-CXR2", - "SYSTEM-HUNK3-SET-CXR2!", - "PRIMITIVE-PROCEDURE-ARITY", - "SYSTEM-LIST-TO-VECTOR", - "SYSTEM-SUBVECTOR-TO-LIST", - "SYSTEM-VECTOR?", - "SYSTEM-VECTOR-REF", - "SYSTEM-VECTOR-SET!", - "WITH-HISTORY-DISABLED", - "SUBVECTOR-MOVE-RIGHT!", - "SUBVECTOR-MOVE-LEFT!", - "SUBVECTOR-FILL!", - No_Name, - No_Name, - No_Name, - "VECTOR-8B-CONS", - "VECTOR-8B?", - "VECTOR-8B-REF", - "VECTOR-8B-SET!", - "ZERO-FLONUM?", - "POSITIVE-FLONUM?", - "NEGATIVE-FLONUM?", - "GREATER-THAN-FLONUM?", - "INTERN-CHARACTER-LIST", - "COMPILED-CODE-ADDRESS->OFFSET", - "VECTOR-8B-SIZE", - "SYSTEM-VECTOR-SIZE", - "FORCE", - "PRIMITIVE-DATUM", - "MAKE-NON-POINTER-OBJECT", - "DEBUGGING-PRINTER", - "STRING-UPCASE", - "PRIMITIVE-PURIFY", - "COMPILED-CODE-ADDRESS->BLOCK", - No_Name, - "DUMP-BAND", - "SUBSTRING-SEARCH", - "LOAD-BAND", - "CONSTANT?", - "PURE?", - "PRIMITIVE-GC-TYPE", - "PRIMITIVE-IMPURIFY", - "WITH-THREADED-CONTINUATION", - "WITHIN-CONTROL-POINT", - "SET-RUN-LIGHT!", - "FILE-EOF?", - "FILE-READ-CHAR", - "FILE-FILL-INPUT-BUFFER", - "FILE-LENGTH", - "FILE-WRITE-CHAR", - "FILE-WRITE-STRING", - "CLOSE-LOST-OPEN-FILES", - No_Name, - "WITH-INTERRUPTS-REDUCED", - "PRIMITIVE-EVAL-STEP", - "PRIMITIVE-APPLY-STEP", - "PRIMITIVE-RETURN-STEP", - "TTY-READ-CHAR-READY?", - "TTY-READ-CHAR", - "TTY-READ-CHAR-IMMEDIATE", - "TTY-READ-FINISH", - "BIT-STRING-ALLOCATE", - "MAKE-BIT-STRING", - "BIT-STRING?", - "BIT-STRING-LENGTH", - "BIT-STRING-REF", - "BIT-SUBSTRING-MOVE-RIGHT!", - "BIT-STRING-SET!", - "BIT-STRING-CLEAR!", - "BIT-STRING-ZERO?", - "BIT-SUBSTRING-FIND-NEXT-SET-BIT", - No_Name, - "UNSIGNED-INTEGER->BIT-STRING", - "BIT-STRING->UNSIGNED-INTEGER", - No_Name, - "READ-BITS!", - "WRITE-BITS!", - "MAKE-STATE-SPACE", - "EXECUTE-AT-NEW-POINT", - "TRANSLATE-TO-STATE-POINT", - "GET-NEXT-CONSTANT", - "MICROCODE-IDENTIFY", - "ZERO?", - "POSITIVE?", - "NEGATIVE?", - "&=", - "&<", - "&>", - "&+", - "&-", - "&*", - "&/", - "INTEGER-DIVIDE", - "1+", - "-1+", - "TRUNCATE", - "ROUND", - "FLOOR", - "CEILING", - "SQRT", - "EXP", - "LOG", - "SIN", - "COS", - "&ATAN", - "TTY-WRITE-CHAR", - "TTY-WRITE-STRING", - "TTY-BEEP", - "TTY-CLEAR", - "GET-PRIMITIVE-COUNTS", - "GET-PRIMITIVE-NAME", - "GET-PRIMITIVE-ADDRESS", - No_Name, - No_Name, - "GET-NEXT-INTERRUPT-CHARACTER", - "CHECK-AND-CLEAN-UP-INPUT-CHANNEL", - No_Name, - "SYSTEM-CLOCK", - "FILE-EXISTS?", - No_Name, - "TTY-MOVE-CURSOR", - No_Name, - No_Name, - No_Name, - No_Name, - "COPY-FILE", - "RENAME-FILE", - "REMOVE-FILE", - "LINK-FILE", - "MAKE-DIRECTORY", - No_Name, - "SET-WORKING-DIRECTORY-PATHNAME!", - "RE-MATCH-SUBSTRING", - "RE-SEARCH-SUBSTRING-FORWARD", - "RE-SEARCH-SUBSTRING-BACKWARD", - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - "CURRENT-YEAR", - "CURRENT-MONTH", - "CURRENT-DAY", - "CURRENT-HOUR", - "CURRENT-MINUTE", - "CURRENT-SECOND", - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - "CLEAR-TO-END-OF-LINE", - No_Name, - No_Name, - "WITH-INTERRUPT-MASK", - "STRING?", - "STRING-LENGTH", - "STRING-REF", - "STRING-SET!", - "SUBSTRING-MOVE-RIGHT!", - "SUBSTRING-MOVE-LEFT!", - "STRING-ALLOCATE", - "STRING-MAXIMUM-LENGTH", - "SET-STRING-LENGTH!", - "VECTOR-8B-FILL!", - "VECTOR-8B-FIND-NEXT-CHAR", - "VECTOR-8B-FIND-PREVIOUS-CHAR", - "VECTOR-8B-FIND-NEXT-CHAR-CI", - "VECTOR-8B-FIND-PREVIOUS-CHAR-CI", - "SUBSTRING-FIND-NEXT-CHAR-IN-SET", - "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", - "SUBSTRING=?", - "SUBSTRING-CI=?", - "SUBSTRINGSYNTAX-ENTRY", - "SCAN-WORD-FORWARD", - "SCAN-WORD-BACKWARD", - "SCAN-LIST-FORWARD", - "SCAN-LIST-BACKWARD", - "SCAN-SEXPS-FORWARD", - "SCAN-FORWARD-TO-WORD", - "SCAN-BACKWARD-PREFIX-CHARS", - "CHAR->SYNTAX-CODE", - "QUOTED-CHAR?", - "MICROCODE-TABLES-FILENAME", - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - "ERROR-PROCEDURE", - "BIT-STRING-XOR!", - "RE-CHAR-SET-ADJOIN!", - "RE-COMPILE-FASTMAP", - "RE-MATCH-BUFFER", - "RE-SEARCH-BUFFER-FORWARD", - "RE-SEARCH-BUFFER-BACKWARD", - "SYSTEM-MEMORY-REF", - "SYSTEM-MEMORY-SET!", - "BIT-STRING-FILL!", - "BIT-STRING-MOVE!", - "BIT-STRING-MOVEC!", - "BIT-STRING-OR!", - "BIT-STRING-AND!", - "BIT-STRING-ANDC!", - "BIT-STRING=?", - "WORKING-DIRECTORY-PATHNAME", - "OPEN-DIRECTORY", - "DIRECTORY-READ", - "UNDER-EMACS?", - "TTY-FLUSH-OUTPUT", - "RELOAD-BAND-NAME", - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name, - No_Name -}; - diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 0b7231011..b7e3d6c19 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: boot.c,v 9.126 2007/04/07 19:53:49 cph Exp $ +$Id: boot.c,v 9.127 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,49 +30,50 @@ USA. #include "scheme.h" #include "prims.h" #include "option.h" -#ifndef islower -#include -#endif #include "ostop.h" #include "ostty.h" -#ifdef NATIVE_CODE_IS_C -# include "osfs.h" -# define FILE_READABLE(filename) (OS_file_access ((filename), 4)) +extern void init_exit_scheme (void); +extern void OS_announcement (void); +extern void OS_syscall_names (unsigned long *, const char ***); +extern void OS_syserr_names (unsigned long *, const char ***); +extern SCHEME_OBJECT initialize_history (void); +extern SCHEME_OBJECT initialize_interrupt_handler_vector (void); +extern SCHEME_OBJECT initialize_interrupt_mask_vector (void); +extern SCHEME_OBJECT Re_Enter_Interpreter (void); + +#ifdef __WIN32__ + extern void NT_initialize_win32_system_utilities (void); + extern void NT_initialize_fov (SCHEME_OBJECT); + extern void win32_enter_interpreter (void (*) (void)); +# define HOOK_ENTER_INTERPRETER win32_enter_interpreter #endif -#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__) -#include -#else -extern PTR EXFUN (malloc, (unsigned int size)); +#ifdef __OS2__ + extern void OS2_initialize_early (void); + extern void OS2_enter_interpreter (void (*) (void)); +# define HOOK_ENTER_INTERPRETER OS2_enter_interpreter #endif -extern void EXFUN (free, (PTR ptr)); -extern void EXFUN (init_exit_scheme, (void)); -extern void EXFUN (Clear_Memory, (int, int, int)); -extern void EXFUN (Setup_Memory, (int, int, int)); -extern void EXFUN (compiler_initialize, (long fasl_p)); -extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int)); -extern void EXFUN (OS_announcement, (void)); +#ifndef HOOK_ENTER_INTERPRETER +# define HOOK_ENTER_INTERPRETER(func) func () +#endif -static void EXFUN (Start_Scheme, (int, CONST char *)); -static void EXFUN (Enter_Interpreter, (void)); +static void start_scheme (void); +static void Enter_Interpreter (void); -CONST char * scheme_program_name; -CONST char * OS_Name; -CONST char * OS_Variant; +const char * scheme_program_name; +const char * OS_Name; +const char * OS_Variant; struct obstack scratch_obstack; -PTR initial_C_stack_pointer; +void * initial_C_stack_pointer; static char * reload_saved_string; static unsigned int reload_saved_string_length; -/* If true, this is an executable created by dump-world. */ -Boolean scheme_dumped_p = false; - -PTR -DEFUN (obstack_chunk_alloc, (size), size_t size) +void * +obstack_chunk_alloc (size_t size) { - PTR result = (malloc (size)); + void * result = (malloc (size)); if (result == 0) { outf_fatal ("\n%s: unable to allocate obstack chunk of %d bytes\n", @@ -84,10 +85,6 @@ DEFUN (obstack_chunk_alloc, (size), size_t size) #define obstack_chunk_free free -#ifndef INIT_FIXED_OBJECTS -#define INIT_FIXED_OBJECTS initialize_fixed_objects_vector -#endif - /* Declare the outermost critical section. */ DECLARE_CRITICAL_SECTION (); @@ -100,27 +97,20 @@ DECLARE_CRITICAL_SECTION (); #endif int -DEFUN (main_name, (argc, argv), - int argc AND CONST char ** argv) +main_name (int argc, const char ** argv) { init_exit_scheme (); scheme_program_name = (argv[0]); - initial_C_stack_pointer = ((PTR) (&argc)); + initial_C_stack_pointer = ((void *) (&argc)); #ifdef __WIN32__ - { - extern void NT_initialize_win32_system_utilities(); - NT_initialize_win32_system_utilities (); - } + NT_initialize_win32_system_utilities (); #endif #ifdef PREALLOCATE_HEAP_MEMORY PREALLOCATE_HEAP_MEMORY (); #endif #ifdef __OS2__ - { - extern void OS2_initialize_early (void); - OS2_initialize_early (); - } + OS2_initialize_early (); #endif obstack_init (&scratch_obstack); dstack_initialize (); @@ -129,245 +119,102 @@ DEFUN (main_name, (argc, argv), reload_saved_string_length = 0; read_command_line_options (argc, argv); - if (scheme_dumped_p) - { - extern SCHEME_OBJECT compiler_utilities; - extern void EXFUN (compiler_reset, (SCHEME_OBJECT)); - - if (! ((Heap_Size == ((long) option_heap_size)) - && (Stack_Size == ((long) option_stack_size)) - && (Constant_Size == ((long) option_constant_size)))) - { - outf_error ("%s: warning: ignoring allocation parameters.\n", - scheme_program_name); - outf_flush_error (); - } - OS_reset (); - compiler_reset (compiler_utilities); - if (!option_band_specified) - { - outf_console ("Scheme Microcode Version %s\n", PACKAGE_VERSION); - OS_initialize (); - Enter_Interpreter (); - } - else - { - Clear_Memory ((BLOCKS_TO_BYTES (Heap_Size)), - (BLOCKS_TO_BYTES (Stack_Size)), - (BLOCKS_TO_BYTES (Constant_Size))); - /* We are reloading from scratch anyway. */ - scheme_dumped_p = false; - if (option_fasl_file) - Start_Scheme (BOOT_FASLOAD, option_fasl_file); - else - Start_Scheme (BOOT_LOAD_BAND, option_band_file); - } - } - else - { - extern void EXFUN (initialize_primitives, (void)); - - Heap_Size = option_heap_size; - Stack_Size = option_stack_size; - Constant_Size = option_constant_size; - Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)), - (BLOCKS_TO_BYTES (Stack_Size)), - (BLOCKS_TO_BYTES (Constant_Size))); - -#ifdef EMPTY_LIST_VALUE - /* EMPTY_LIST_VALUE is defined if it is teh true value for '() and - EMPTY_LIST is a location used to store '() or #F - */ - if (option_empty_list_eq_false) - EMPTY_LIST = SHARP_F; - else - EMPTY_LIST = EMPTY_LIST_VALUE; -#endif + setup_memory ((BLOCKS_TO_BYTES (option_heap_size)), + (BLOCKS_TO_BYTES (option_stack_size)), + (BLOCKS_TO_BYTES (option_constant_size))); - initialize_primitives (); - if (! option_fasl_file) - { - compiler_initialize (0); - Start_Scheme (BOOT_LOAD_BAND, option_band_file); - } -#ifdef NATIVE_CODE_IS_C - else if (! (FILE_READABLE (option_fasl_file))) - { - compiler_initialize (1); - Start_Scheme (BOOT_EXECUTE, option_fasl_file); - } -#endif - else - { - compiler_initialize (1); - Start_Scheme (BOOT_FASLOAD, option_fasl_file); - } - } + initialize_primitives (); + compiler_initialize (option_fasl_file != 0); + OS_initialize (); + start_scheme (); termination_init_error (); return (0); } static SCHEME_OBJECT -DEFUN (names_to_vector, (length, names), - unsigned int length AND - unsigned char ** names) +names_to_vector (unsigned long length, const char ** names) { - SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, length, 1)); - unsigned int i; + SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, length, true)); + unsigned long i; for (i = 0; (i < length); i += 1) - { - VECTOR_SET (v, i, (char_pointer_to_symbol ((char *) (names [i])))); - } + VECTOR_SET (v, i, (char_pointer_to_symbol (names[i]))); return (v); } static SCHEME_OBJECT -DEFUN_VOID (fixed_objects_syscall_names) +fixed_objects_syscall_names (void) { - unsigned int length; - unsigned char ** names; - extern void EXFUN (OS_syscall_names, (unsigned int *, unsigned char ***)); + unsigned long length; + const char ** names; OS_syscall_names ((&length), (&names)); return (names_to_vector (length, names)); } static SCHEME_OBJECT -DEFUN_VOID (fixed_objects_syserr_names) +fixed_objects_syserr_names (void) { - unsigned int length; - unsigned char ** names; - extern void EXFUN (OS_syserr_names, (unsigned int *, unsigned char ***)); + unsigned long length; + const char ** names; OS_syserr_names ((&length), (&names)); return (names_to_vector (length, names)); } void -DEFUN_VOID (initialize_fixed_objects_vector) +initialize_fixed_objects_vector (void) { - extern SCHEME_OBJECT EXFUN (initialize_history, (void)); - extern SCHEME_OBJECT EXFUN (initialize_interrupt_handler_vector, (void)); - extern SCHEME_OBJECT EXFUN (initialize_interrupt_mask_vector, (void)); - - /* 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)); - Fixed_Objects = fixed_objects_vector; - FAST_VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector); - FAST_VECTOR_SET - (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_CONSTANT, 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - System_Interrupt_Vector, - (initialize_interrupt_handler_vector ())); - FAST_VECTOR_SET - (fixed_objects_vector, - FIXOBJ_INTERRUPT_MASK_VECTOR, - (initialize_interrupt_mask_vector ())); + fixed_objects = (make_vector (N_FIXED_OBJECTS, SHARP_F, false)); + VECTOR_SET (fixed_objects, NON_OBJECT, (MAKE_OBJECT (TC_CONSTANT, 2))); + VECTOR_SET (fixed_objects, SYSTEM_INTERRUPT_VECTOR, + (initialize_interrupt_handler_vector ())); + VECTOR_SET (fixed_objects, FIXOBJ_INTERRUPT_MASK_VECTOR, + (initialize_interrupt_mask_vector ())); /* Error vector is not needed at boot time */ - 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))); - 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))); - FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_EDWIN_AUTO_SAVE, EMPTY_LIST); - FAST_VECTOR_SET (fixed_objects_vector, FIXOBJ_FILES_TO_DELETE, EMPTY_LIST); - FAST_VECTOR_SET - (fixed_objects_vector, - FIXOBJ_SYSTEM_CALL_NAMES, - (fixed_objects_syscall_names ())); - FAST_VECTOR_SET - (fixed_objects_vector, - FIXOBJ_SYSTEM_CALL_ERRORS, - (fixed_objects_syserr_names ())); - - (*Free++) = EMPTY_LIST; - (*Free++) = EMPTY_LIST; - FAST_VECTOR_SET - (fixed_objects_vector, - The_Work_Queue, - (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)))); - - 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?", 1))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_POSITIVE_P, - (make_primitive ("INTEGER-POSITIVE?", 1))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_NEGATIVE_P, - (make_primitive ("INTEGER-NEGATIVE?", 1))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_SUCCESSOR, - (make_primitive ("INTEGER-ADD-1", 1))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_PREDECESSOR, - (make_primitive ("INTEGER-SUBTRACT-1", 1))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_EQUAL_P, - (make_primitive ("INTEGER-EQUAL?", 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_LESS_P, - (make_primitive ("INTEGER-LESS?", 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_GREATER_P, - (make_primitive ("INTEGER-GREATER?", 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_ADD, - (make_primitive ("INTEGER-ADD", 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_SUBTRACT, - (make_primitive ("INTEGER-SUBTRACT", 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_MULTIPLY, - (make_primitive ("INTEGER-MULTIPLY", 2))); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_DIVIDE, - SHARP_F); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_QUOTIENT, - SHARP_F); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_REMAINDER, - SHARP_F); - FAST_VECTOR_SET - (fixed_objects_vector, - GENERIC_TRAMPOLINE_MODULO, - SHARP_F); - - FAST_VECTOR_SET - (fixed_objects_vector, - ARITY_DISPATCHER_TAG, - char_pointer_to_symbol("#[(microcode)arity-dispatcher-tag]")); + VECTOR_SET (fixed_objects, SYSTEM_ERROR_VECTOR, SHARP_F); + VECTOR_SET (fixed_objects, OBARRAY, + (make_vector (OBARRAY_SIZE, EMPTY_LIST, false))); + VECTOR_SET (fixed_objects, DUMMY_HISTORY, (initialize_history ())); + VECTOR_SET (fixed_objects, State_Space_Tag, SHARP_T); + VECTOR_SET (fixed_objects, Bignum_One, (long_to_bignum (1))); + VECTOR_SET (fixed_objects, FIXOBJ_EDWIN_AUTO_SAVE, EMPTY_LIST); + VECTOR_SET (fixed_objects, FIXOBJ_FILES_TO_DELETE, EMPTY_LIST); + VECTOR_SET (fixed_objects, FIXOBJ_SYSTEM_CALL_NAMES, + (fixed_objects_syscall_names ())); + VECTOR_SET (fixed_objects, FIXOBJ_SYSTEM_CALL_ERRORS, + (fixed_objects_syserr_names ())); + + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_ZERO_P, + (make_primitive ("INTEGER-ZERO?", 1))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_POSITIVE_P, + (make_primitive ("INTEGER-POSITIVE?", 1))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_NEGATIVE_P, + (make_primitive ("INTEGER-NEGATIVE?", 1))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_SUCCESSOR, + (make_primitive ("INTEGER-ADD-1", 1))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_PREDECESSOR, + (make_primitive ("INTEGER-SUBTRACT-1", 1))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_EQUAL_P, + (make_primitive ("INTEGER-EQUAL?", 2))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_LESS_P, + (make_primitive ("INTEGER-LESS?", 2))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_GREATER_P, + (make_primitive ("INTEGER-GREATER?", 2))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_ADD, + (make_primitive ("INTEGER-ADD", 2))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_SUBTRACT, + (make_primitive ("INTEGER-SUBTRACT", 2))); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_MULTIPLY, + (make_primitive ("INTEGER-MULTIPLY", 2))); + + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_DIVIDE, SHARP_F); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_QUOTIENT, SHARP_F); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_REMAINDER, SHARP_F); + VECTOR_SET (fixed_objects, GENERIC_TRAMPOLINE_MODULO, SHARP_F); + + VECTOR_SET (fixed_objects, ARITY_DISPATCHER_TAG, + (char_pointer_to_symbol ("#[(microcode)arity-dispatcher-tag]"))); #ifdef __WIN32__ - { - extern void EXFUN (NT_initialize_fov, (SCHEME_OBJECT)); - NT_initialize_fov (fixed_objects_vector); - } + NT_initialize_fov (fixed_objects); #endif } @@ -378,203 +225,94 @@ DEFUN_VOID (initialize_fixed_objects_vector) #endif static void -DEFUN (Start_Scheme, (Start_Prim, File_Name), - int Start_Prim AND CONST char * File_Name) +start_scheme (void) { - SCHEME_OBJECT FName; - SCHEME_OBJECT expr = SHARP_F; - SCHEME_OBJECT * inner_arg; - SCHEME_OBJECT prim; - /* fast long i; */ - /* Parallel processor test */ - Boolean I_Am_Master = (Start_Prim != BOOT_GET_WORK); - OS_initialize (); - if (I_Am_Master) + SCHEME_OBJECT expr; + + if (!option_batch_mode) { - if (!option_batch_mode) - { - outf_console ("MIT/GNU Scheme running under %s\n", OS_Variant); - OS_announcement (); - outf_console ("\n"); - outf_flush_console (); - } - Current_State_Point = SHARP_F; - Fluid_Bindings = EMPTY_LIST; - INIT_FIXED_OBJECTS (); + outf_console ("MIT/GNU Scheme running under %s\n", OS_Variant); + OS_announcement (); + outf_console ("\n"); + outf_flush_console (); } + current_state_point = SHARP_F; + initialize_fixed_objects_vector (); - /* The initial program to execute is one of - (SCODE-EVAL (BINARY-FASLOAD ) SYSTEM-GLOBAL-ENVIRONMENT), - (LOAD-BAND ), or - ((GET-WORK)) - (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK ) GLOBAL-ENV) - depending on the value of Start_Prim. */ - switch (Start_Prim) - { - case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD ) GLOBAL-ENV) */ - FName = (char_pointer_to_string (File_Name)); - prim = (make_primitive ("BINARY-FASLOAD", 1)); - inner_arg = Free; - *Free++ = prim; - *Free++ = FName; - prim = (make_primitive ("SCODE-EVAL", 2)); - expr = MAKE_POINTER_OBJECT (TC_PCOMB2, Free); - *Free++ = prim; - *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); - *Free++ = THE_GLOBAL_ENV; - break; - - case BOOT_LOAD_BAND: /* (LOAD-BAND ) */ - FName = (char_pointer_to_string (File_Name)); - prim = (make_primitive ("LOAD-BAND", 1)); - inner_arg = Free; - *Free++ = prim; - *Free++ = FName; - expr = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); - break; - - case BOOT_GET_WORK: /* ((GET-WORK)) */ - prim = (make_primitive ("GET-WORK", 0)); - inner_arg = Free; - *Free++ = prim; - *Free++ = SHARP_F; - expr = MAKE_POINTER_OBJECT (TC_COMBINATION, Free); - *Free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1); - *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg); - break; - - case BOOT_EXECUTE: + if (option_fasl_file != 0) + { +#ifdef CC_IS_C /* (SCODE-EVAL (INITIALIZE-C-COMPILED-BLOCK ) GLOBAL-ENV) */ - FName = (char_pointer_to_string (File_Name)); - prim = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1)); - inner_arg = Free; - *Free++ = prim; - *Free++ = FName; - prim = (make_primitive ("SCODE-EVAL", 2)); + SCHEME_OBJECT prim1 = (make_primitive ("INITIALIZE-C-COMPILED-BLOCK", 1)); +#else + /* (SCODE-EVAL (BINARY-FASLOAD ) GLOBAL-ENV) */ + SCHEME_OBJECT prim1 = (make_primitive ("BINARY-FASLOAD", 1)); +#endif + SCHEME_OBJECT fn_object = (char_pointer_to_string (option_fasl_file)); + SCHEME_OBJECT prim2 = (make_primitive ("SCODE-EVAL", 2)); + SCHEME_OBJECT * inner_arg = Free; + (*Free++) = prim1; + (*Free++) = fn_object; expr = (MAKE_POINTER_OBJECT (TC_PCOMB2, Free)); - *Free++ = prim; - *Free++ = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg)); - *Free++ = THE_GLOBAL_ENV; - break; - - - default: - outf_fatal ("Unknown boot time option: %d\n", Start_Prim); - Microcode_Termination (TERM_BAD_PRIMITIVE); - /*NOTREACHED*/ - } + (*Free++) = prim2; + (*Free++) = (MAKE_POINTER_OBJECT (TC_PCOMB1, inner_arg)); + (*Free++) = THE_GLOBAL_ENV; + } + else + { + /* (LOAD-BAND ) */ + SCHEME_OBJECT prim = (make_primitive ("LOAD-BAND", 1)); + SCHEME_OBJECT fn_object = (char_pointer_to_string (option_band_file)); + expr = (MAKE_POINTER_OBJECT (TC_PCOMB1, Free)); + (*Free++) = prim; + (*Free++) = fn_object; + } /* Setup registers */ - INITIALIZE_INTERRUPTS (); - SET_INTERRUPT_MASK (0); - env_register = THE_GLOBAL_ENV; - Trapping = false; - Return_Hook_Address = NULL; + INITIALIZE_INTERRUPTS (0); + SET_ENV (THE_GLOBAL_ENV); + trapping = false; /* Give the interpreter something to chew on, and ... */ - Will_Push (CONTINUATION_SIZE); - Store_Return (RC_END_OF_COMPUTATION); - exp_register = SHARP_F; - Save_Cont (); - Pushed (); + Will_Push (CONTINUATION_SIZE); + SET_RC (RC_END_OF_COMPUTATION); + SET_EXP (SHARP_F); + SAVE_CONT (); + Pushed (); - exp_register = expr; + SET_EXP (expr); /* Go to it! */ - if ((sp_register <= Stack_Guard) || (Free > MemTop)) - { - outf_fatal ("Configuration won't hold initial data.\n"); - termination_init_error (); - } + if (! ((SP_OK_P (stack_pointer)) && (Free <= heap_alloc_limit))) + { + outf_fatal ("Configuration won't hold initial data.\n"); + termination_init_error (); + } ENTRY_HOOK (); Enter_Interpreter (); } -#ifdef __WIN32__ - extern void EXFUN (win32_enter_interpreter, (void (*) (void))); -# define HOOK_ENTER_INTERPRETER win32_enter_interpreter -#else -# ifdef __OS2__ - extern void EXFUN (OS2_enter_interpreter, (void (*) (void))); -# define HOOK_ENTER_INTERPRETER OS2_enter_interpreter -# else -# define HOOK_ENTER_INTERPRETER(func) func () -# endif -#endif - static void -DEFUN_VOID (Do_Enter_Interpreter) +Do_Enter_Interpreter (void) { - Interpret (scheme_dumped_p); + Interpret (); outf_fatal ("\nThe interpreter returned to top level!\n"); Microcode_Termination (TERM_EXIT); } static void -DEFUN_VOID (Enter_Interpreter) +Enter_Interpreter (void) { HOOK_ENTER_INTERPRETER (Do_Enter_Interpreter); } /* This must be used with care, and only synchronously. */ -extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void)); - SCHEME_OBJECT -DEFUN_VOID (Re_Enter_Interpreter) +Re_Enter_Interpreter (void) { - Interpret (1); - return (val_register); -} - -/* Garbage collection debugging utilities. */ - -extern SCHEME_OBJECT - *deadly_free, - *deadly_scan; - -extern unsigned long - gc_counter; - -extern void EXFUN (gc_death, - (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)); -extern void EXFUN (stack_death, (CONST char *)); - -extern char - gc_death_message_buffer[]; - -SCHEME_OBJECT - *deadly_free, - *deadly_scan; - -unsigned long - gc_counter = 0; - -char - gc_death_message_buffer[100]; - -void -DEFUN (gc_death, (code, message, scan, free), - long code AND char * message - AND SCHEME_OBJECT * scan AND SCHEME_OBJECT * free) -{ - outf_fatal ("\n%s.\n", message); - outf_fatal ("scan = 0x%lx; free = 0x%lx\n", scan, free); - deadly_scan = scan; - deadly_free = free; - Microcode_Termination (code); - /*NOTREACHED*/ -} - -void -DEFUN (stack_death, (name), CONST char * name) -{ - outf_fatal - ("\n%s: The stack has overflowed and overwritten adjacent memory.\n", - name); - outf_fatal ("This was probably caused by a runaway recursion.\n"); - Microcode_Termination (TERM_STACK_OVERFLOW); - /*NOTREACHED*/ + Interpret (); + return (GET_VAL); } /* Utility primitives. */ @@ -593,39 +331,28 @@ DEFUN (stack_death, (name), CONST char * name) #define ID_STACK_TYPE 10 /* Scheme stack type (string) */ #define ID_MACHINE_TYPE 11 /* Machine type (string) */ -#ifdef USE_STACKLETS -#define STACK_TYPE_STRING "stacklets" -#else -#define STACK_TYPE_STRING "standard" -#endif - DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0) { SCHEME_OBJECT Result; PRIMITIVE_HEADER (0); Result = (make_vector (IDENTITY_LENGTH, SHARP_F, true)); - FAST_VECTOR_SET (Result, ID_RELEASE, SHARP_F); - FAST_VECTOR_SET - (Result, ID_MICRO_VERSION, (char_pointer_to_string (PACKAGE_VERSION))); - FAST_VECTOR_SET (Result, ID_MICRO_MOD, SHARP_F); - FAST_VECTOR_SET + VECTOR_SET (Result, ID_RELEASE, SHARP_F); + VECTOR_SET (Result, ID_MICRO_VERSION, + (char_pointer_to_string (PACKAGE_VERSION))); + VECTOR_SET (Result, ID_MICRO_MOD, SHARP_F); + VECTOR_SET (Result, ID_PRINTER_WIDTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_x_size ()))); - FAST_VECTOR_SET + VECTOR_SET (Result, ID_PRINTER_LENGTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_y_size ()))); - FAST_VECTOR_SET - (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n'))); - FAST_VECTOR_SET + VECTOR_SET (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n'))); + VECTOR_SET (Result, ID_FLONUM_PRECISION, (LONG_TO_UNSIGNED_FIXNUM (DBL_MANT_DIG))); - FAST_VECTOR_SET + VECTOR_SET (Result, ID_FLONUM_EPSILON, (double_to_flonum ((double) DBL_EPSILON))); - FAST_VECTOR_SET - (Result, ID_OS_NAME, (char_pointer_to_string (OS_Name))); - FAST_VECTOR_SET (Result, ID_OS_VARIANT, - (char_pointer_to_string (OS_Variant))); - FAST_VECTOR_SET (Result, ID_STACK_TYPE, - (char_pointer_to_string (STACK_TYPE_STRING))); - FAST_VECTOR_SET (Result, ID_MACHINE_TYPE, - (char_pointer_to_string (MACHINE_TYPE))); + VECTOR_SET (Result, ID_OS_NAME, (char_pointer_to_string (OS_Name))); + VECTOR_SET (Result, ID_OS_VARIANT, (char_pointer_to_string (OS_Variant))); + VECTOR_SET (Result, ID_STACK_TYPE, (char_pointer_to_string ("standard"))); + VECTOR_SET (Result, ID_MACHINE_TYPE, (char_pointer_to_string (MACHINE_TYPE))); PRIMITIVE_RETURN (Result); } @@ -651,8 +378,8 @@ DEFINE_PRIMITIVE ("MICROCODE-LIBRARY-PATH", Prim_microcode_library_path, 0, 0, 0 { PRIMITIVE_HEADER (0); { - CONST char ** scan = option_library_path; - CONST char ** end = option_library_path; + const char ** scan = option_library_path; + const char ** end = option_library_path; while (1) { if ((*end) == 0) @@ -661,7 +388,7 @@ DEFINE_PRIMITIVE ("MICROCODE-LIBRARY-PATH", Prim_microcode_library_path, 0, 0, 0 } { SCHEME_OBJECT result = - (allocate_marked_vector (TC_VECTOR, (end - scan), 1)); + (allocate_marked_vector (TC_VECTOR, (end - scan), true)); SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0)); while (scan < end) (*scan_result++) = (char_pointer_to_string (*scan++)); @@ -671,11 +398,11 @@ DEFINE_PRIMITIVE ("MICROCODE-LIBRARY-PATH", Prim_microcode_library_path, 0, 0, 0 } static SCHEME_OBJECT -DEFUN (argv_to_object, (argc, argv), int argc AND CONST char ** argv) +argv_to_object (int argc, const char ** argv) { SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, argc, 1)); - CONST char ** scan = argv; - CONST char ** end = (scan + argc); + const char ** scan = argv; + const char ** end = (scan + argc); SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0)); while (scan < end) (*scan_result++) = (char_pointer_to_string (*scan++)); @@ -719,7 +446,7 @@ DEFINE_PRIMITIVE ("RELOAD-SAVE-STRING", Prim_reload_save_string, 1, 1, 0) reload_saved_string = (OS_malloc (length)); reload_saved_string_length = length; { - char * scan = ((char *) (STRING_LOC ((ARG_REF (1)), 0))); + char * scan = (STRING_POINTER (ARG_REF (1))); char * end = (scan + length); char * scan_result = reload_saved_string; while (scan < end) diff --git a/v7/src/microcode/breakup.c b/v7/src/microcode/breakup.c deleted file mode 100644 index 146641047..000000000 --- a/v7/src/microcode/breakup.c +++ /dev/null @@ -1,162 +0,0 @@ -/* -*-C-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* $Id: breakup.c,v 9.29 2007/01/05 21:19:25 cph Exp $ */ - -#include - -#ifndef isdigit -#include -#endif - -#define boolean char -#define false 0 -#define true 1 - -#define isoctal(c) (isdigit(c) && (c != '8') && (c != '9')) - -int get_a_char() -{ register int c; - register int count = 2; - for (c = getchar(); - isoctal(c) && count >= 0; - c = getchar(), count -=1) - putchar(c); - if (count != 2) return c; - putchar(c); - return getchar(); -} - -main() -{ register int c; - register boolean after_new_line = true; - while ((c = getchar()) != EOF) -re_dispatch: - switch(c) - { case '\f': - break; - case ',': - putchar(c); - while (((c = getchar()) == ' ') || (c == '\t')) - if (c == EOF) - { fprintf(stderr, "Confused expression: ,\n"); - exit(1); - } - if (c == '\n') - { putchar(c); - after_new_line = true; - break; - } - putchar(' '); - goto re_dispatch; - case ';': - case ':': - case '?': - case '}': - putchar(c); - putchar('\n'); - after_new_line = true; - break; - case '\n': - if (!after_new_line) - { after_new_line = true; - putchar('\n'); - } - break; - case '\'': - putchar(c); - c = getchar(); - if (c == EOF) - { fprintf(stderr, "Confused character: EOF\n"); - exit(1); - } - putchar(c); - if (c == '\n') - { fprintf(stderr, "Confused character: \\n\n"); - after_new_line = true; - break; - } - if (c == '\'') - { fprintf(stderr, "Confused character: \\\'\n"); - break; - } - if (c == '\\') - c = get_a_char(); - else c = getchar(); - if (c == EOF) - { fprintf(stderr, "Confused character: EOF\n"); - exit(1); - } - putchar(c); - if (c != '\'') - fprintf(stderr, "Confused character: %c = 0x%x\n", - c); - break; - case '"': - after_new_line = false; - putchar(c); - c = getchar(); - while (true) - { while ((c != EOF) && - (c != '"') && - (c != '\n') && - (c != '\\')) - { putchar(c); - c = getchar(); - } - if (c == EOF) - { fprintf(stderr, "Confused string: EOF\n"); - exit(1); - } - putchar(c); - if (c == '\n') - { fprintf(stderr, "Confused string: \\n\n"); - after_new_line = true; - break; - } - if (c == '"') break; - if (c == '\\') - c = get_a_char(); - } - break; - case '#': - if (after_new_line) - { while (((c = getchar()) != EOF) && (c != '\n')) ; - if (c == EOF) exit(0); - break; - } - putchar(c); - break; - case '{': - if (!after_new_line) - putchar('\n'); - /* Fall Through */ - default: - after_new_line = false; - putchar(c); - } - fflush(stdout); - exit(0); -} diff --git a/v7/src/microcode/char.c b/v7/src/microcode/char.c index 581a217cb..ddd806473 100644 --- a/v7/src/microcode/char.c +++ b/v7/src/microcode/char.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: char.c,v 9.37 2007/01/05 21:19:25 cph Exp $ +$Id: char.c,v 9.38 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -32,11 +32,11 @@ USA. #include long -DEFUN (arg_ascii_char, (n), int n) +arg_ascii_char (int n) { CHECK_ARG (n, CHARACTER_P); { - fast SCHEME_OBJECT object = (ARG_REF (n)); + SCHEME_OBJECT object = (ARG_REF (n)); if (! (CHAR_TO_ASCII_P (object))) error_bad_range_arg (n); return (CHAR_TO_ASCII (object)); @@ -44,7 +44,7 @@ DEFUN (arg_ascii_char, (n), int n) } long -DEFUN (arg_ascii_integer, (n), int n) +arg_ascii_integer (int n) { return (arg_index_integer (n, MAX_ASCII)); } @@ -93,13 +93,13 @@ DEFINE_PRIMITIVE ("INTEGER->CHAR", Prim_integer_to_char, 1, 1, 0) } long -DEFUN (char_downcase, (c), fast long c) +char_downcase (long c) { return ((isupper (c)) ? ((c - 'A') + 'a') : c); } long -DEFUN (char_upcase, (c), fast long c) +char_upcase (long c) { return ((islower (c)) ? ((c - 'a') + 'A') : c); } @@ -139,7 +139,7 @@ DEFINE_PRIMITIVE ("CHAR-ASCII?", Prim_char_ascii_p, 1, 1, 0) PRIMITIVE_HEADER (1); CHECK_ARG (1, CHARACTER_P); { - fast SCHEME_OBJECT character = ARG_REF (1); + SCHEME_OBJECT character = ARG_REF (1); PRIMITIVE_RETURN (((OBJECT_DATUM (character)) >= MAX_ASCII) ? SHARP_F : diff --git a/v7/src/microcode/cmpauxmd/c.c b/v7/src/microcode/cmpauxmd/c.c index da4ae4a72..5738fa8d6 100644 --- a/v7/src/microcode/cmpauxmd/c.c +++ b/v7/src/microcode/cmpauxmd/c.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: c.c,v 1.21 2007/01/12 06:17:31 cph Exp $ +$Id: c.c,v 1.22 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,7 +25,6 @@ USA. */ -#include #define LIARC_IN_MICROCODE #include "liarc.h" #include "prims.h" @@ -33,771 +32,596 @@ USA. #include "bitstr.h" #include "avltree.h" -#ifdef HAVE_STDLIB_H -# include -#else - extern PTR EXFUN (malloc, (unsigned long)); - extern PTR EXFUN (realloc, (PTR, unsigned long)); -#endif +extern int initialize_compiled_code_blocks (void); #ifdef BUG_GCC_LONG_CALLS -extern SCHEME_OBJECT EXFUN (memory_to_string, (unsigned long, CONST void *)); -extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *)); -extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean)); -extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (double_to_flonum, (double)); -extern SCHEME_OBJECT EXFUN (long_to_integer, (long)); -extern SCHEME_OBJECT EXFUN (digit_string_to_integer, - (Boolean, unsigned long, unsigned char *)); -extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, - (unsigned long, unsigned long, unsigned char *)); -extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int)); -extern SCHEME_OBJECT EXFUN (memory_to_uninterned_symbol, - (unsigned long, unsigned char *)); - -SCHEME_OBJECT EXFUN ((* (constructor_kludge [11])), ()) = -{ - ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_string), - ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_symbol), - ((SCHEME_OBJECT EXFUN ((*), ())) make_vector), - ((SCHEME_OBJECT EXFUN ((*), ())) cons), - ((SCHEME_OBJECT EXFUN ((*), ())) rconsm), - ((SCHEME_OBJECT EXFUN ((*), ())) double_to_flonum), - ((SCHEME_OBJECT EXFUN ((*), ())) long_to_integer), - ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_integer), - ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_bit_string), - ((SCHEME_OBJECT EXFUN ((*), ())) make_primitive), - ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_uninterned_symbol), +extern SCHEME_OBJECT memory_to_string (unsigned long, const void *); +extern SCHEME_OBJECT memory_to_symbol (long, const void *); +extern SCHEME_OBJECT make_vector (long, SCHEME_OBJECT, bool); +extern SCHEME_OBJECT cons (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT double_to_flonum (double); +extern SCHEME_OBJECT long_to_integer (long); +extern SCHEME_OBJECT digit_string_to_integer + (bool, unsigned long, const char *); +extern SCHEME_OBJECT digit_string_to_bit_string + (unsigned long, unsigned long, const char *); +extern SCHEME_OBJECT make_primitive (char *, int); +extern SCHEME_OBJECT memory_to_uninterned_symbol (unsigned long, const void *); + +SCHEME_OBJECT (* (constructor_kludge [11])) () = +{ + ((SCHEME_OBJECT (*) ()) memory_to_string), + ((SCHEME_OBJECT (*) ()) memory_to_symbol), + ((SCHEME_OBJECT (*) ()) make_vector), + ((SCHEME_OBJECT (*) ()) cons), + ((SCHEME_OBJECT (*) ()) rconsm), + ((SCHEME_OBJECT (*) ()) double_to_flonum), + ((SCHEME_OBJECT (*) ()) long_to_integer), + ((SCHEME_OBJECT (*) ()) digit_string_to_integer), + ((SCHEME_OBJECT (*) ()) digit_string_to_bit_string), + ((SCHEME_OBJECT (*) ()) make_primitive), + ((SCHEME_OBJECT (*) ()) memory_to_uninterned_symbol), }; #endif /* BUG_GCC_LONG_CALLS */ -extern char * interface_to_C_hook; -extern long C_return_value, MAX_TRAMPOLINE; -extern void EXFUN (C_to_interface, (PTR)); -extern void EXFUN (interface_initialize, (void)); -extern SCHEME_OBJECT EXFUN (initialize_C_compiled_block, (int, char *)); -extern int EXFUN (initialize_compiled_code_blocks, (void)); -extern void * scheme_hooks_low, * scheme_hooks_high; +static SCHEME_OBJECT dummy_entry = ((SCHEME_OBJECT) -1L); +utility_result_t interface_to_C_hook = ((utility_result_t) (&dummy_entry)); #define TRAMPOLINE_FUDGE 20 -typedef SCHEME_OBJECT * EXFUN ((* code_block), - (SCHEME_OBJECT *, entry_count_t)); - -typedef SCHEME_OBJECT * EXFUN ((* data_block), (entry_count_t)); - -typedef SCHEME_OBJECT EXFUN ((* data_generator), (void)); - -typedef void EXFUN ((* uninit_data), (void)); - -struct compiled_entry_s -{ - code_block code; /* C handler for this entry point */ - entry_count_t dispatch; /* Internal dispatch tag */ -}; - -#define COMPILED_BLOCK_FLAG_DATA_ONLY 1 - -struct compiled_block_s -{ - char * name; - union - { - uninit_data errgen; /* When not initialized yet */ - data_block constructor; /* Data handler for this compiled block */ - data_generator builder; /* Data generator for data-only cc blocks */ - } data; - entry_count_t nentries; /* Number of entry points in this block */ - entry_count_t dispatch; /* Base of dispatch for this block */ - unsigned flags; -}; +typedef struct +{ + const char * name; + liarc_code_proc_t * code_proc; /* C handler for this entry point */ + void * data_proc; /* Data handler for this compiled block */ + entry_count_t first_entry; /* Base of dispatch for this block */ + entry_count_t n_entries; /* Number of entry points in this block */ + unsigned int flags; +} compiled_block_t; + +static entry_count_t n_compiled_blocks = 0; +static entry_count_t compiled_blocks_table_size = 0; +static compiled_block_t * compiled_blocks = 0; +static tree_node compiled_blocks_tree = 0; + +static long initial_entry_number = (-1); +static entry_count_t n_compiled_entries = 0; +static entry_count_t compiled_entries_size = 0; +static compiled_block_t ** compiled_entries = 0; + +#define COMPILED_BLOCK_NAME(block) ((block) -> name) +#define COMPILED_BLOCK_CODE_PROC(block) ((block) -> code_proc) +#define _COMPILED_BLOCK_DATA_PROC(block) ((block) -> data_proc) +#define COMPILED_BLOCK_FIRST_ENTRY(block) ((block) -> first_entry) +#define COMPILED_BLOCK_N_ENTRIES(block) ((block) -> n_entries) +#define COMPILED_BLOCK_FLAGS(block) ((block) -> flags) + +#define COMPILED_BLOCK_DATA_PROC(block) \ + ((liarc_data_proc_t *) (_COMPILED_BLOCK_DATA_PROC (block))) + +#define SET_COMPILED_BLOCK_DATA_PROC(block, proc) do \ +{ \ + _CBFS (block, _CBF_DATA_INIT); \ + _CBFC (block, _CBF_DATA_ONLY); \ + (_COMPILED_BLOCK_DATA_PROC (block)) = (proc); \ +} while (false) + +#define COMPILED_BLOCK_OBJECT_PROC(block) \ + ((liarc_object_proc_t *) (_COMPILED_BLOCK_DATA_PROC (block))) + +#define SET_COMPILED_BLOCK_OBJECT_PROC(block, proc) do \ +{ \ + _CBFS (block, (_CBF_DATA_INIT | _CBF_DATA_ONLY)); \ + (_COMPILED_BLOCK_DATA_PROC (block)) = (proc); \ +} while (false) + +#define _CBFT(block, flag) (((COMPILED_BLOCK_FLAGS (block)) & (flag)) != 0) +#define _CBFS(block, flag) ((COMPILED_BLOCK_FLAGS (block)) |= (flag)) +#define _CBFC(block, flag) ((COMPILED_BLOCK_FLAGS (block)) &=~ (flag)) + +#define _CBF_DATA_ONLY 0x01 +#define _CBF_DATA_INIT 0x02 + +#define COMPILED_BLOCK_DATA_ONLY_P(block) (_CBFT (block, _CBF_DATA_ONLY)) +#define COMPILED_BLOCK_DATA_INIT_P(block) (_CBFT (block, _CBF_DATA_INIT)) + +static bool grow_compiled_blocks (void); +static bool grow_compiled_entries (entry_count_t); +static int declare_trampoline_block (entry_count_t); +static SCHEME_OBJECT * trampoline_procedure (SCHEME_OBJECT *, entry_count_t); +static compiled_block_t * find_compiled_block (const char *); +static SCHEME_OBJECT * unspecified_code (SCHEME_OBJECT *, entry_count_t); +static void * lrealloc (void *, size_t); +static unsigned int digit_string_producer (void *); +static unsigned int hex_digit_to_int (char); -int pc_zero_bits; -static SCHEME_OBJECT - dummy_entry = ((SCHEME_OBJECT) -1L); -char * - interface_to_C_hook = ((char *) & dummy_entry); -void - * scheme_hooks_low = NULL, - * scheme_hooks_high = NULL; - -#define PSEUDO_STATIC - -PSEUDO_STATIC long - initial_entry_number = -1; -PSEUDO_STATIC entry_count_t - max_compiled_entries = 0, - compiled_entries_size = 0; -PSEUDO_STATIC struct compiled_entry_s * - compiled_entries = ((struct compiled_entry_s *) NULL); - -PSEUDO_STATIC entry_count_t - max_compiled_blocks = 0, - compiled_blocks_table_size = 0; -PSEUDO_STATIC struct compiled_block_s * - compiled_blocks_table = ((struct compiled_block_s *) NULL); -PSEUDO_STATIC tree_node - compiled_blocks_tree = ((tree_node) NULL); +long C_return_value; -SCHEME_OBJECT * -DEFUN (trampoline_procedure, (trampoline, dispatch), - SCHEME_OBJECT * trampoline AND entry_count_t dispatch) -{ - return (invoke_utility (((int) (* ((unsigned long *) trampoline))), - ((long) (TRAMPOLINE_STORAGE (trampoline))), - 0, 0, 0)); -} - -int -DEFUN_VOID (NO_SUBBLOCKS) +long +C_to_interface (SCHEME_OBJECT * entry) { - return (0); + while (entry != 0) + { + entry_count_t index = ((entry_count_t) (*entry)); + compiled_block_t * block; + + if (index >= n_compiled_entries) + { + SET_EXP ((SCHEME_OBJECT) entry); + return (ERR_EXECUTE_MANIFEST_VECTOR); + } + block = (compiled_entries[index]); + entry = ((* (COMPILED_BLOCK_CODE_PROC (block))) + (entry, (COMPILED_BLOCK_FIRST_ENTRY (block)))); + } + return (C_return_value); } SCHEME_OBJECT * -DEFUN (no_data, (base_dispatch), entry_count_t base_dispatch) +invoke_utility (unsigned int code, + unsigned long arg1, unsigned long arg2, + unsigned long arg3, unsigned long arg4) { - return ((SCHEME_OBJECT *) NULL); + SCHEME_OBJECT * res; + (* (utility_table[code])) ((&res), arg1, arg2, arg3, arg4); + return (res); } void -DEFUN_VOID (uninitialized_data) +initialize_C_interface (void) { - /* Not yet assigned. Cannot construct data. */ - error_external_return (); - /*NOTREACHED*/ -} + if (initial_entry_number == (-1)) + /* TRAMPOLINE_FUDGE allows for future growth of max_trampoline. */ + initial_entry_number = (max_trampoline + TRAMPOLINE_FUDGE); -SCHEME_OBJECT * -DEFUN (unspecified_code, (entry, dispatch), - SCHEME_OBJECT * entry AND entry_count_t dispatch) -{ - exp_register = ((SCHEME_OBJECT) entry); - C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR); - return (&dummy_entry); + if (! (((declare_trampoline_block (initial_entry_number)) == 0) + && ((initialize_compiled_code_blocks ()) == 0))) + { + if (GET_PRIMITIVE != SHARP_F) + signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); + outf_fatal ("error initializing compiled code.\n"); + Microcode_Termination (TERM_EXIT); + } } - -PTR -DEFUN (lrealloc, (ptr, size), PTR ptr AND unsigned long size) -{ - if (ptr == ((PTR) NULL)) - return (malloc (size)); - else - return (realloc (ptr, size)); + +SCHEME_OBJECT +initialize_C_compiled_block (int argno, const char * name) +{ + compiled_block_t * block = (find_compiled_block (name)); + return + ((block == 0) + ? SHARP_F + : (COMPILED_BLOCK_DATA_ONLY_P (block)) + ? ((* (COMPILED_BLOCK_OBJECT_PROC (block))) ()) + : (MAKE_CC_ENTRY ((* (COMPILED_BLOCK_DATA_PROC (block))) + (COMPILED_BLOCK_FIRST_ENTRY (block))))); } -int -DEFUN (declare_trampoline_block, (nentries), entry_count_t nentries) +SCHEME_OBJECT +initialize_subblock (const char * name) { - int result; - - result = (declare_compiled_code ("#trampoline_code_block", - nentries, - NO_SUBBLOCKS, - trampoline_procedure)); -#if 0 - /* trampoline block is special. */ - - if (result != 0) - return (result); + compiled_block_t * block = (find_compiled_block (name)); + if ((block == 0) || (COMPILED_BLOCK_DATA_ONLY_P (block))) + error_external_return (); - result = (declare_compiled_data ("#trampoline_code_block", - NO_SUBBLOCKS, - no_data)); -#endif - return (result); + return + (MAKE_CC_BLOCK + (cc_entry_address_to_block_address + ((* (COMPILED_BLOCK_DATA_PROC (block))) + (COMPILED_BLOCK_FIRST_ENTRY (block))))); } - -void -DEFUN_VOID (interface_initialize) + +unsigned long +c_code_table_export_length (unsigned long * n_blocks_r) { - int i, pow, del; - - for (i = 0, pow = 1, del = ((sizeof (SCHEME_OBJECT)) / (sizeof (char))); - pow < del; i+= 1) - pow = (pow << 1); - - if (pow != del) - { - /* Not a power of two -- ill-defined pc_zero_bits. */ - outf_fatal ("interface_initialize: bad (sizeof (SCHEME_OBJECT)).\n"); - Microcode_Termination (TERM_EXIT); - } - pc_zero_bits = i; - - if (initial_entry_number == -1) - initial_entry_number = (MAX_TRAMPOLINE + TRAMPOLINE_FUDGE); - - if (((declare_trampoline_block (initial_entry_number)) != 0) - || (initialize_compiled_code_blocks ()) != 0) - { - if (Registers[REGBLOCK_PRIMITIVE] != SHARP_F) - signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); - else + compiled_block_t * block = compiled_blocks; + compiled_block_t * end = (block + n_compiled_blocks); + unsigned long n = 1; + + while (block < end) { - outf_fatal ("interface_initialize: error initializing compiled code.\n"); - Microcode_Termination (TERM_EXIT); + n += (1 + (BYTES_TO_WORDS ((strlen (COMPILED_BLOCK_NAME (block))) + 1))); + block += 1; } - } - return; + (*n_blocks_r) = n_compiled_blocks; + return (n); } - -entry_count_t -DEFUN (find_compiled_block, (name), char * name) -{ - tree_node node = (tree_lookup (compiled_blocks_tree, name)); - if (node == ((tree_node) NULL)) - return (max_compiled_blocks); - else - return (node->value); -} +void +export_c_code_table (SCHEME_OBJECT * start) +{ + compiled_block_t * block = compiled_blocks; + compiled_block_t * end = (block + n_compiled_blocks); -int -DEFUN (declare_compiled_data_ns, (name, data_proc), - char * name - AND SCHEME_OBJECT * EXFUN ((* data_proc), (entry_count_t))) -{ - entry_count_t slot = (find_compiled_block (name)); - if ((slot == max_compiled_blocks) - || ((compiled_blocks_table[slot].data.errgen != uninitialized_data) - && (compiled_blocks_table[slot].data.constructor != data_proc))) - return (-1); - compiled_blocks_table[slot].flags &= (~ COMPILED_BLOCK_FLAG_DATA_ONLY); - compiled_blocks_table[slot].data.constructor = data_proc; - return (0); + (*start++) = (LONG_TO_FIXNUM (initial_entry_number)); + while (block < end) + { + (*start++) = (LONG_TO_UNSIGNED_FIXNUM (COMPILED_BLOCK_N_ENTRIES (block))); + strcpy (((char *) start), (COMPILED_BLOCK_NAME (block))); + start += (BYTES_TO_WORDS ((strlen (COMPILED_BLOCK_NAME (block))) + 1)); + block += 1; + } } -int -DEFUN (declare_compiled_data, (name, decl_data, data_proc), - char * name - AND int EXFUN ((* decl_data), (void)) - AND SCHEME_OBJECT * EXFUN ((* data_proc), (entry_count_t))) +bool +import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks) { - int rc = (declare_compiled_data_ns (name, data_proc)); - return ((rc == 0) ? ((*decl_data) ()) : rc); -} + long dumped_initial_entry_number = (FIXNUM_TO_LONG (*table++)); + unsigned long count; -SCHEME_OBJECT -DEFUN (initialize_subblock, (name), char * name) -{ - SCHEME_OBJECT * ep, * block; - entry_count_t slot = (find_compiled_block (name)); + if (dumped_initial_entry_number < max_trampoline) + return (false); + initial_entry_number = dumped_initial_entry_number; - if ((slot == max_compiled_blocks) - || ((compiled_blocks_table[slot].flags & COMPILED_BLOCK_FLAG_DATA_ONLY) - != 0)) - error_external_return (); + if (compiled_entries != 0) + free (compiled_entries); + if (compiled_blocks != 0) + free (compiled_blocks); + if (compiled_blocks_tree != 0) + tree_free (compiled_blocks_tree); + + n_compiled_blocks = 0; + compiled_blocks_table_size = 0; + compiled_blocks = 0; + compiled_blocks_tree = 0; - ep = ((* compiled_blocks_table[slot].data.constructor) - (compiled_blocks_table[slot].dispatch)); - Get_Compiled_Block (block, ep); - return (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block)); -} + n_compiled_entries = 0; + compiled_entries_size = 0; + compiled_entries = 0; -SCHEME_OBJECT -DEFUN (initialize_C_compiled_block, (argno, name), int argno AND char * name) -{ - SCHEME_OBJECT val; - entry_count_t slot; + if ((declare_trampoline_block (initial_entry_number)) != 0) + return (false); - slot = (find_compiled_block (name)); - if (slot == max_compiled_blocks) - return (SHARP_F); + for (count = 0; (count < n_blocks); count += 1) + { + unsigned long n_entries = (FIXNUM_TO_ULONG (*table++)); + size_t nb = ((strlen ((const char *) table)) + 1); + char * ncopy = (malloc (nb)); + + if (ncopy == 0) + return (false); + strcpy (ncopy, ((const char *) table)); + if ((declare_compiled_code_ns (ncopy, n_entries, unspecified_code)) != 0) + return (false); + table += (BYTES_TO_WORDS (nb)); + } - if ((compiled_blocks_table[slot].flags & COMPILED_BLOCK_FLAG_DATA_ONLY) != 0) - val = ((* compiled_blocks_table[slot].data.builder) ()); - else - { - SCHEME_OBJECT * block; - - block = ((* compiled_blocks_table[slot].data.constructor) - (compiled_blocks_table[slot].dispatch)); - val = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, block)); - } - return (val); + return (true); } int -DEFUN (declare_compiled_code, - (name, nentries, decl_code, code_proc), - char * name - AND entry_count_t nentries - AND int EXFUN ((* decl_code), (void)) - AND code_block code_proc) -{ - entry_count_t slot = (find_compiled_block (name)); - - if (slot != max_compiled_blocks) - { - code_block old_code; - - old_code = (compiled_entries[compiled_blocks_table[slot].dispatch].code); - if (((old_code != unspecified_code) - && (old_code != code_proc) - && (code_proc != unspecified_code)) - || (compiled_blocks_table[slot].nentries != nentries)) - return (-1); - if (old_code == unspecified_code) +declare_compiled_code_ns (const char * name, + entry_count_t n_block_entries, + liarc_code_proc_t * code_proc) +{ + compiled_block_t * block = (find_compiled_block (name)); + if (block == 0) { - entry_count_t counter, limit; + entry_count_t entries_start = n_compiled_entries; + entry_count_t entries_end = (entries_start + n_block_entries); + tree_node new_tree; - counter = compiled_blocks_table[slot].dispatch; - limit = (counter + nentries); - while (counter < limit) - compiled_entries[counter++].code = code_proc; - } - } - else - { - entry_count_t dispatch = max_compiled_entries; - entry_count_t n_dispatch = (dispatch + nentries); - entry_count_t block_index = max_compiled_blocks; - - if (n_dispatch < dispatch) - /* Wrap around */ - return (-1); - - if (n_dispatch >= compiled_entries_size) - { - struct compiled_entry_s * new_entries; - entry_count_t new_entries_size = ((compiled_entries_size == 0) - ? 100 - : ((compiled_entries_size * 3) / 2)); - if (new_entries_size <= n_dispatch) - new_entries_size = (n_dispatch + 1); - - new_entries = ((struct compiled_entry_s *) - (lrealloc (compiled_entries, - (new_entries_size - * (sizeof (struct compiled_entry_s)))))); - if (new_entries == ((struct compiled_entry_s *) NULL)) - return (-1); - compiled_entries_size = new_entries_size; - compiled_entries = new_entries; - } - - if (block_index >= compiled_blocks_table_size) - { - struct compiled_block_s * new_blocks; - entry_count_t new_blocks_size - = ((compiled_blocks_table_size == 0) - ? 10 - : ((compiled_blocks_table_size * 3) / 2)); - new_blocks = ((struct compiled_block_s *) - (lrealloc (compiled_blocks_table, - (new_blocks_size - * (sizeof (struct compiled_block_s)))))); - if (new_blocks == ((struct compiled_block_s *) NULL)) + if (! ((entries_start <= entries_end) + && ((n_compiled_blocks < compiled_blocks_table_size) + || (grow_compiled_blocks ())) + && ((entries_end < compiled_entries_size) + || (grow_compiled_entries (entries_end))))) return (-1); - compiled_blocks_table_size = new_blocks_size; - compiled_blocks_table = new_blocks; - } - - { - tree_node new_tree; - tree_error_message = ((char *) NULL); - new_tree = (tree_insert (compiled_blocks_tree, name, block_index)); - if (tree_error_message != ((char *) NULL)) + tree_error_message = 0; + new_tree = (tree_insert (compiled_blocks_tree, name, n_compiled_blocks)); + if (tree_error_message != 0) return (-1); compiled_blocks_tree = new_tree; - } - - max_compiled_entries = n_dispatch; - max_compiled_blocks = (block_index + 1); - - compiled_blocks_table[block_index].name = name; - compiled_blocks_table[block_index].flags = 0; - compiled_blocks_table[block_index].data.errgen = uninitialized_data; - compiled_blocks_table[block_index].nentries = nentries; - compiled_blocks_table[block_index].dispatch = dispatch; - for (block_index = dispatch; block_index < n_dispatch; block_index++) + block = (compiled_blocks + (n_compiled_blocks++)); + (COMPILED_BLOCK_NAME (block)) = name; + (COMPILED_BLOCK_CODE_PROC (block)) = code_proc; + (_COMPILED_BLOCK_DATA_PROC (block)) = 0; + (COMPILED_BLOCK_FIRST_ENTRY (block)) = entries_start; + (COMPILED_BLOCK_N_ENTRIES (block)) = n_block_entries; + (COMPILED_BLOCK_FLAGS (block)) = 0; + + while (n_compiled_entries < entries_end) + (compiled_entries[n_compiled_entries++]) = block; + return (0); + } + else if ((((COMPILED_BLOCK_CODE_PROC (block)) == unspecified_code) + || ((COMPILED_BLOCK_CODE_PROC (block)) == code_proc) + || (code_proc == unspecified_code)) + && ((COMPILED_BLOCK_N_ENTRIES (block)) == n_block_entries)) { - compiled_entries[block_index].code = code_proc; - compiled_entries[block_index].dispatch = dispatch; + (COMPILED_BLOCK_CODE_PROC (block)) = code_proc; + return (0); } - } - return (* decl_code) (); + else + return (-1); } -int -DEFUN (declare_data_object, - (name, data_proc), - char * name - AND SCHEME_OBJECT EXFUN ((* data_proc), (void))) -{ - entry_count_t slot; - - slot = (find_compiled_block (name)); - if (slot == max_compiled_blocks) - { - declare_compiled_code (name, 0, NO_SUBBLOCKS, unspecified_code); - slot = (find_compiled_block (name)); - if (slot == max_compiled_blocks) - return (-1); - } - - if ((compiled_blocks_table[slot].data.errgen != uninitialized_data) - && (compiled_blocks_table[slot].data.builder != data_proc)) - return (-1); - - compiled_blocks_table[slot].flags |= (COMPILED_BLOCK_FLAG_DATA_ONLY); - compiled_blocks_table[slot].data.builder = data_proc; - - return (0); +static bool +grow_compiled_blocks (void) +{ + entry_count_t new_blocks_size + = ((compiled_blocks_table_size == 0) + ? 16 + : (compiled_blocks_table_size * 2)); + compiled_block_t * new_blocks + = (lrealloc (compiled_blocks, + (new_blocks_size * (sizeof (compiled_block_t))))); + if (new_blocks == 0) + return (false); + if (new_blocks != compiled_blocks) + { + compiled_block_t ** scan = compiled_entries; + compiled_block_t ** end = (scan + n_compiled_entries); + while (scan < end) + { + (*scan) = (((*scan) - compiled_blocks) + new_blocks); + scan += 1; + } + } + compiled_blocks_table_size = new_blocks_size; + compiled_blocks = new_blocks; + return (true); } -int -DEFUN (declare_compiled_code_mult, (nslots, slots), - unsigned nslots AND CONST struct liarc_code_S * slots) -{ - unsigned i; - int res = 0; - - for (i = 0; (i < nslots); i++) - { - res = (declare_compiled_code (((char *) (slots[i].name)), - (slots[i].nentries), - NO_SUBBLOCKS, - (slots[i].code))); - if (res != 0) - break; - } - return (res); +static bool +grow_compiled_entries (entry_count_t entries_end) +{ + entry_count_t new_entries_size + = ((compiled_entries_size == 0) + ? 128 + : compiled_entries_size); + compiled_block_t ** new_entries; + + while (new_entries_size <= entries_end) + new_entries_size *= 2; + new_entries + = (lrealloc (compiled_entries, + (new_entries_size * (sizeof (compiled_block_t *))))); + if (new_entries == 0) + return (false); + compiled_entries_size = new_entries_size; + compiled_entries = new_entries; + return (true); } int -DEFUN (declare_compiled_data_mult, (nslots, slots), - unsigned nslots AND CONST struct liarc_data_S * slots) -{ - unsigned i; - int res = 0; - - for (i = 0; (i < nslots); i++) - { - res = (declare_compiled_data (((char *) (slots[i].name)), - NO_SUBBLOCKS, - (slots[i].data))); - if (res != 0) - break; - } - return (res); -} - -/* For now */ - -extern SCHEME_OBJECT - * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -extern Boolean - EXFUN (install_c_code_table, (SCHEME_OBJECT *, long)); - -static SCHEME_OBJECT * -DEFUN (copy_c_code_block_information, (index, start, limit), - long index AND SCHEME_OBJECT * start AND SCHEME_OBJECT * limit) +declare_compiled_code (const char * name, + entry_count_t n_block_entries, + liarc_decl_code_t * decl_code, + liarc_code_proc_t * code_proc) { - long char_count; - char * src, * dest; - - if (start < limit) - *start++ - = (LONG_TO_UNSIGNED_FIXNUM (compiled_blocks_table[index].nentries)); - - src = compiled_blocks_table[index].name; - dest = ((char *) start); - - while ((dest < ((char *) limit)) && ((*dest++ = *src++) != '\0')) - ; - if (dest >= ((char *) limit)) - while (*src++ != '\0') - dest += 1; - - char_count = (dest - ((char *) start)); - return (start + (BYTES_TO_WORDS (dest - ((char *) start)))); + int rc = (declare_compiled_code_ns (name, n_block_entries, code_proc)); + return ((rc == 0) ? ((*decl_code) ()) : rc); } -SCHEME_OBJECT * -DEFUN (cons_c_code_table, (start, limit, length), - SCHEME_OBJECT * start AND SCHEME_OBJECT * limit AND long * length) +int +declare_compiled_data_ns (const char * name, liarc_data_proc_t * data_proc) { - long count; - - * length = max_compiled_blocks; - - if (start < limit) - *start++ = (LONG_TO_FIXNUM (initial_entry_number)); - - for (count = 0; ((count < max_compiled_blocks) && (start < limit)); count++) - start = (copy_c_code_block_information (count, start, limit)); - - return (start); + compiled_block_t * block = (find_compiled_block (name)); + if ((block == 0) + || ((COMPILED_BLOCK_DATA_INIT_P (block)) + && ((COMPILED_BLOCK_DATA_PROC (block)) != data_proc))) + return (-1); + SET_COMPILED_BLOCK_DATA_PROC (block, data_proc); + return (0); } -Boolean -DEFUN (install_c_code_table, (table, length), - SCHEME_OBJECT * table AND long length) +int +declare_compiled_data (const char * name, + liarc_decl_data_t * decl_data, + liarc_data_proc_t * data_proc) { - SCHEME_OBJECT the_fixnum; - long count, dumped_initial_entry_number; - - the_fixnum = *table++; - dumped_initial_entry_number = (FIXNUM_TO_LONG (the_fixnum)); - if (dumped_initial_entry_number < MAX_TRAMPOLINE) - return (false); - initial_entry_number = dumped_initial_entry_number; + int rc = (declare_compiled_data_ns (name, data_proc)); + return ((rc == 0) ? ((*decl_data) ()) : rc); +} - if (compiled_entries != ((struct compiled_entry_s *) NULL)) - free (compiled_entries); - if (compiled_blocks_table != ((struct compiled_block_s *) NULL)) - free (compiled_blocks_table); - if (compiled_blocks_tree != ((tree_node) NULL)) - tree_free (compiled_blocks_tree); - - max_compiled_entries = 0; - compiled_entries_size = 0; - compiled_entries = ((struct compiled_entry_s *) NULL); - max_compiled_blocks = 0; - compiled_blocks_table_size = 0; - compiled_blocks_table = ((struct compiled_block_s *) NULL); - compiled_blocks_tree = ((tree_node) NULL); +int +declare_data_object (const char * name, liarc_object_proc_t * object_proc) +{ + compiled_block_t * block = (find_compiled_block (name)); + if (block == 0) + { + declare_compiled_code_ns (name, 0, unspecified_code); + block = (find_compiled_block (name)); + if (block == 0) + return (-1); + } - if ((declare_trampoline_block (initial_entry_number)) != 0) - return (false); - - for (count = 0; count < length; count++) - { - long nentries = (UNSIGNED_FIXNUM_TO_LONG (* table++)); - int nlen = (strlen ((char *) table)); - char * ncopy = ((char *) (malloc (nlen + 1))); - - if (ncopy == ((char *) NULL)) - return (false); - strcpy (ncopy, ((char *) table)); - if ((declare_compiled_code (ncopy, - nentries, - NO_SUBBLOCKS, - unspecified_code)) - != 0) - return (false); - table += (BYTES_TO_WORDS (nlen + 1)); - } + if ((COMPILED_BLOCK_DATA_INIT_P (block)) + && ((COMPILED_BLOCK_OBJECT_PROC (block)) != object_proc)) + return (-1); - return (true); + SET_COMPILED_BLOCK_OBJECT_PROC (block, object_proc); + return (0); } - -#define C_COUNT_TRANSFERS -unsigned long c_to_interface_transfers = 0; -void -DEFUN (C_to_interface, (in_entry), PTR in_entry) +int +declare_compiled_code_mult (unsigned int nslots, + const struct liarc_code_S * slots) { - SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) in_entry); - - while (1) - { - unsigned long entry_index = (* ((unsigned long *) entry)); - -#ifdef C_COUNT_TRANSFERS - c_to_interface_transfers += 1; -#endif /* C_COUNT_TRANSFERS */ - - if (entry_index < ((unsigned long) max_compiled_entries)) - entry = ((* (compiled_entries[entry_index].code)) - (entry, compiled_entries[entry_index].dispatch)); - else + unsigned int i = 0; + while (i < nslots) { - if (entry != &dummy_entry) - { - exp_register = ((SCHEME_OBJECT) entry); - C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR); - } - return; + int res = (declare_compiled_code_ns (((char *) ((slots[i]) . name)), + ((slots[i]) . nentries), + ((slots[i]) . code))); + if (res != 0) + return (res); + i += 1; } - } + return (0); } -DEFINE_PRIMITIVE ("SWAP-C-COUNTER!", Prim_swap_c_counter, 1, 1, - "(new-value)\n\ -Set the C transfer counter to new-value. Return the old value.") +int +declare_compiled_data_mult (unsigned int nslots, + const struct liarc_data_S * slots) { - unsigned long new_counter, old_counter; - PRIMITIVE_HEADER (1); - - new_counter = (arg_integer (1)); - old_counter = c_to_interface_transfers; - c_to_interface_transfers = new_counter; - PRIMITIVE_RETURN (ulong_to_integer (old_counter)); + unsigned int i = 0; + while (i < nslots) + { + int res = (declare_compiled_data_ns (((char *) ((slots[i]) . name)), + ((slots[i]) . data))); + if (res != 0) + return (res); + i += 1; + } + return (0); +} + +static int +declare_trampoline_block (entry_count_t n_block_entries) +{ + return (declare_compiled_code_ns ("#trampoline_code_block", + n_block_entries, + trampoline_procedure)); } -typedef SCHEME_OBJECT * utility_result; - -typedef void EXFUN - ((* utility_table_entry), (utility_result *, long, long, long, long)); +bool +store_trampoline_insns (insn_t * entry, byte_t code) +{ + /* Trampoline entries are stored in the lowest part of the + compiled_entries table. That's why we reserve those above. */ + (*entry) = code; + return (false); +} -extern utility_table_entry utility_table[]; +static SCHEME_OBJECT * +trampoline_procedure (SCHEME_OBJECT * trampoline, entry_count_t dispatch) +{ + return (invoke_utility (((unsigned int) (* ((insn_t *) trampoline))), + ((unsigned long) + (trampoline_storage + (cc_entry_address_to_block_address + ((insn_t *) trampoline)))), + 0, 0, 0)); +} -SCHEME_OBJECT * -DEFUN (invoke_utility, (code, arg1, arg2, arg3, arg4), - int code AND long arg1 AND long arg2 AND long arg3 AND long arg4) +static compiled_block_t * +find_compiled_block (const char * name) { - utility_result res; + tree_node node = (tree_lookup (compiled_blocks_tree, name)); + return ((node == 0) ? 0 : (compiled_blocks + (node->value))); +} - (* utility_table[code]) ((& res), arg1, arg2, arg3, arg4); +static SCHEME_OBJECT * +unspecified_code (SCHEME_OBJECT * entry, entry_count_t dispatch) +{ + SET_EXP ((SCHEME_OBJECT) entry); + C_return_value = ERR_EXECUTE_MANIFEST_VECTOR; + return (0); +} - return ((SCHEME_OBJECT *) res); +static void * +lrealloc (void * ptr, size_t size) +{ + return ((ptr == 0) ? (malloc (size)) : (realloc (ptr, size))); } int -DEFUN (multiply_with_overflow, (x, y, res), long x AND long y AND long * res) +multiply_with_overflow (long x, long y, long * res) { - extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT)); - SCHEME_OBJECT ans; - - ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y)))); + SCHEME_OBJECT ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y)))); if (ans == SHARP_F) - { - /* Bogus... */ - (* res) = (x * y); - return (1); - } + { + /* Bogus... */ + (*res) = (x * y); + return (1); + } else - { - (* res) = (FIXNUM_TO_LONG (ans)); - return (0); - } -} - -static unsigned int -DEFUN (hex_digit_to_int, (h_digit), unsigned char h_digit) -{ - unsigned int digit = ((unsigned int) h_digit); - - return (((digit >= '0') && (digit <= '9')) - ? (digit - '0') - : (((digit >= 'A') && (digit <= 'F')) - ? ((digit - 'A') + 10) - : ((digit - 'a') + 10))); + { + (*res) = (FIXNUM_TO_LONG (ans)); + return (0); + } } SCHEME_OBJECT -DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits), - unsigned long n_bits - AND unsigned long n_digits - AND unsigned char * digits) -{ - extern void EXFUN (clear_bit_string, (SCHEME_OBJECT)); - extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long)); - extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int)); - SCHEME_OBJECT result = (allocate_bit_string ((long) n_bits)); - unsigned int digit, mask; - long i, posn; - int j; - - posn = 0; - clear_bit_string (result); - - for (i = 0; i < ((long) n_digits); i++) - { - digit = (hex_digit_to_int (*digits++)); - for (j = 0, mask = 1; - j < 4; - j++, mask = (mask << 1), posn++) - if ((digit & mask) != 0) - bit_string_set (result, posn, 1); - } - return (result); -} - -/* This avoids consing the string and symbol if it already exists. */ - -SCHEME_OBJECT -DEFUN (memory_to_uninterned_symbol, (length, string), - unsigned long length AND unsigned char * string) +memory_to_uninterned_symbol (unsigned long length, const void * string) { SCHEME_OBJECT name = (memory_to_string (length, string)); SCHEME_OBJECT res = (CONS (name, UNBOUND_OBJECT)); return (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, res)); } -static unsigned int -DEFUN (digit_string_producer, (digit_ptr), PTR v_digit_ptr) -{ - char ** digit_ptr = ((char **) v_digit_ptr); - char digit = ** digit_ptr; - * digit_ptr = ((* digit_ptr) + 1); - return (hex_digit_to_int (digit)); -} - SCHEME_OBJECT -DEFUN (digit_string_to_integer, (negative_p, n_digits, digits), - Boolean negative_p - AND unsigned long n_digits - AND unsigned char * digits) +rconsm (unsigned int nargs, SCHEME_OBJECT tail, ...) { - SCHEME_OBJECT bignum; - unsigned char * digit = digits; - extern SCHEME_OBJECT EXFUN (bignum_to_integer, (SCHEME_OBJECT)); + SCHEME_OBJECT result; + unsigned int i; + va_list arg_ptr; + va_start (arg_ptr, tail); - bignum = (digit_stream_to_bignum (((int) n_digits), - digit_string_producer, - ((PTR) & digit), - 16, - ((int) negative_p))); + result = tail; + for (i = 1; (i < nargs); i += 1) + result + = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)), + result)); - return (bignum_to_integer (bignum)); + va_end (arg_ptr); + return (result); } -#ifdef USE_STDARG - SCHEME_OBJECT -DEFUN (rconsm, (nargs, tail DOTS), - int nargs AND SCHEME_OBJECT tail DOTS) +digit_string_to_bit_string (unsigned long n_bits, + unsigned long n_digits, + const char * digits) { - va_list arg_ptr; - va_start (arg_ptr, tail); - - { - int i; - SCHEME_OBJECT result = tail; - - for (i = 1; i < nargs; i++) - result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)), - result)); + SCHEME_OBJECT result = (allocate_bit_string (n_bits)); + unsigned long posn = 0; + unsigned long i; - va_end (arg_ptr); - return (result); - } + clear_bit_string (result); + for (i = 0; (i < n_digits); i += 1) + { + unsigned int digit = (hex_digit_to_int (*digits++)); + unsigned int j = 0; + unsigned int mask = 1; + while (j < 4) + { + if ((digit & mask) != 0) + bit_string_set (result, posn, 1); + j += 1; + mask <<= 1; + posn += 1; + } + } + return (result); } -#else /* not USE_STDARG */ - SCHEME_OBJECT -rconsm (va_alist) -va_dcl +digit_string_to_integer (bool negative_p, + unsigned long n_digits, + const char * digits) { - va_list arg_ptr; - int nargs; - SCHEME_OBJECT tail; - - va_start (arg_ptr); - nargs = (va_arg (arg_ptr, int)); - tail = (va_arg (arg_ptr, SCHEME_OBJECT)); - - { - int i; - SCHEME_OBJECT result = tail; + SCHEME_OBJECT bignum + = (digit_stream_to_bignum (((int) n_digits), + digit_string_producer, + ((void *) (&digits)), + 16, + ((int) negative_p))); - for (i = 1; i < nargs; i++) - result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)), - result)); + return (bignum_to_integer (bignum)); +} - va_end (arg_ptr); - return (result); - } +static unsigned int +digit_string_producer (void * v_digit_ptr) +{ + const char ** digit_ptr = v_digit_ptr; + char digit = (**digit_ptr); + (*digit_ptr) = ((*digit_ptr) + 1); + return (hex_digit_to_int (digit)); } -#endif /* USE_STDARG */ +static unsigned int +hex_digit_to_int (char h_digit) +{ + unsigned int digit = ((unsigned int) h_digit); + return (((digit >= '0') && (digit <= '9')) + ? (digit - '0') + : (((digit >= 'A') && (digit <= 'F')) + ? ((digit - 'A') + 10) + : ((digit - 'a') + 10))); +} diff --git a/v7/src/microcode/cmpauxmd/i386.m4 b/v7/src/microcode/cmpauxmd/i386.m4 index 5a869a6c9..ee01ca253 100644 --- a/v7/src/microcode/cmpauxmd/i386.m4 +++ b/v7/src/microcode/cmpauxmd/i386.m4 @@ -1,6 +1,6 @@ ### -*-Midas-*- ### -### $Id: i386.m4,v 1.66 2007/01/05 21:19:26 cph Exp $ +### $Id: i386.m4,v 1.67 2007/04/22 16:31:24 cph Exp $ ### ### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, ### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, @@ -330,7 +330,7 @@ DECLARE_DATA_SEGMENT() declare_alignment(2) use_external_data(EVR(Free)) -use_external_data(EVR(sp_register)) +use_external_data(EVR(stack_pointer)) use_external_data(EVR(utility_table)) ifdef(`WIN32',` @@ -542,7 +542,7 @@ define_debugging_label(scheme_to_interface) # These two moves must happen _before_ the ffree instructions below. # Otherwise recovery from SIGFPE there will fail. - OP(mov,l) TW(REG(esp),EVR(sp_register)) + OP(mov,l) TW(REG(esp),EVR(stack_pointer)) OP(mov,l) TW(rfree,EVR(Free)) IF387(` @@ -602,7 +602,7 @@ interface_to_scheme_proceed: OP(mov,l) TW(LOF(REGBLOCK_VAL(),regs),REG(eax)) # Value/dynamic link OP(mov,l) TW(IMM(ADDRESS_MASK),rmask) # = %ebp - OP(mov,l) TW(EVR(sp_register),REG(esp)) + OP(mov,l) TW(EVR(stack_pointer),REG(esp)) OP(mov,l) TW(REG(eax),REG(ecx)) # Preserve if used OP(and,l) TW(rmask,REG(ecx)) # Restore potential dynamic link OP(mov,l) TW(REG(ecx),LOF(REGBLOCK_DLINK(),regs)) diff --git a/v7/src/microcode/cmpgc.h b/v7/src/microcode/cmpgc.h index a5f7585ba..84b3f298f 100644 --- a/v7/src/microcode/cmpgc.h +++ b/v7/src/microcode/cmpgc.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpgc.h,v 1.36 2007/01/05 21:19:25 cph Exp $ +$Id: cmpgc.h,v 1.37 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,484 +25,43 @@ USA. */ -/* +/* Utilities to relocate compiled code in garbage collection-like + processes. */ -Utilities to relocate compiled code in garbage collection-like processes. +#ifndef SCM_CMPGC_H +#define SCM_CMPGC_H 1 -This file is included by gccode.h. +#include "cmpint.h" -See cmpint.txt, cmpint.c, cmpint-md.h, and cmpaux-md.m4 for more details. -*/ - -#ifndef CMPGC_H_INCLUDED -#define CMPGC_H_INCLUDED - -#define NOP() do {} while (0) /* A useful macro */ - -/* These are needed whether or not there is a compiler, - so their definition must be outside the HAS_COMPILER_SUPPORT ifdef. - */ - -#define OPERATOR_LINKAGE_KIND 0x000000 -#define REFERENCE_LINKAGE_KIND 0x010000 -#define ASSIGNMENT_LINKAGE_KIND 0x020000 -#define GLOBAL_OPERATOR_LINKAGE_KIND 0x030000 -#define CLOSURE_PATTERN_LINKAGE_KIND 0x040000 - -#ifdef HAS_COMPILER_SUPPORT - -#include "cmpintmd.h" - -/* - The following is a kludge which is used to get return_to_interpreter - to work. The return to interpreter block is never dumped on normal - bin files, but is dumped in complete bands. As long as it does not - change in position with respect to the beginning of constant space, - it will be relocated correctly on reload. -*/ - -#ifndef In_Fasdump - -#define COMPILED_CODE_PRE_TEST(then_what) - -#else - -extern SCHEME_OBJECT compiler_utilities; - -#define COMPILED_CODE_PRE_TEST(then_what) \ -if (Old == (OBJECT_ADDRESS (compiler_utilities))) \ - then_what; \ -else - -#endif - -/* - The following code handles compiled entry points, where the - addresses point to the "middle" of the code vector. From the entry - address, the offset word can be extracted, and this offset allows - us to find the beginning of the block, so it can be copied as a - whole. The broken heart for the whole block lives in its usual - place (first word in the vector). - - The offset word contains an encoding of the offset and an encoding - of whether the resulting pointer points to the beginning of the - block or is another entry, so the process may have to be repeated. - - Pointers to char are used here because compiled entry points do not - in general point to Pointer boundaries. - */ - -#define Get_Compiled_Block(var, address) \ -{ \ - long offset_word; \ - \ - var = (address); \ - \ - do \ - { \ - offset_word = (COMPILED_ENTRY_OFFSET_WORD(var)); \ - var = ((SCHEME_OBJECT *) \ - (((char *) (var)) \ - - ((long) (OFFSET_WORD_TO_BYTE_OFFSET(offset_word))))); \ - } while (OFFSET_WORD_CONTINUATION_P (offset_word)); \ -} - -#define RELOCATE_COMPILED_INTERNAL(addr, new_block, old_block) \ - ((SCHEME_OBJECT *) \ - (((char *) new_block) \ - + (((char *) (addr)) - ((char *) old_block)))) - -#define RELOCATE_COMPILED_RAW_ADDRESS(addr, new_block, old_block) \ - (ADDR_TO_SCHEME_ADDR \ - (RELOCATE_COMPILED_INTERNAL ((SCHEME_ADDR_TO_ADDR (addr)), \ - new_block, old_block))) - -#define RELOCATE_COMPILED_ADDRESS(object, new_block, old_block) \ - ((SCHEME_OBJECT *) \ - (RELOCATE_COMPILED_INTERNAL ((OBJECT_ADDRESS (object)), \ - new_block, old_block))) - -#define RELOCATE_COMPILED(object, new_block, old_block) \ -MAKE_POINTER_OBJECT ((OBJECT_TYPE (object)), \ - (RELOCATE_COMPILED_ADDRESS (object, new_block, \ - old_block))) - -#define Compiled_BH(In_GC, then_what) \ -{ \ - /* Has it already been relocated? */ \ - \ - Get_Compiled_Block (Old, Old); \ - COMPILED_CODE_PRE_TEST (then_what) \ - if (BROKEN_HEART_P (* Old)) \ - { \ - Temp = (RELOCATE_COMPILED (Temp, (OBJECT_ADDRESS (* Old)), Old)); \ - then_what; \ - } \ -} - -#define RAW_COMPILED_BH(In_GC, then_what) \ -{ \ - Get_Compiled_Block (Old, Old); \ - COMPILED_CODE_PRE_TEST (then_what) \ - if (BROKEN_HEART_P (* Old)) \ - { \ - Temp = (RELOCATE_COMPILED_RAW_ADDRESS (Temp, \ - (OBJECT_ADDRESS (* Old)), \ - Old)); \ - then_what; \ - } \ -} - -#ifdef AUTOCLOBBER_BUG - -# define AUTOCLOBBER_BUMP(Old, To) do \ -{ \ - if ((OBJECT_TYPE (* Old)) == TC_MANIFEST_VECTOR) \ - { \ - *To = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, \ - ((PAGE_SIZE / (sizeof (SCHEME_OBJECT))) \ - - 1))); \ - To += (PAGE_SIZE / (sizeof (SCHEME_OBJECT))); \ - } \ -} while (0) - -#else - -# define AUTOCLOBBER_BUMP(Old, To) do { } while (0) - -#endif - -#define Transport_Compiled() do \ -{ \ - SCHEME_OBJECT * Saved_Old = Old; \ - \ - Real_Transport_Vector (); \ - AUTOCLOBBER_BUMP (Saved_Old, To); \ - *Saved_Old = New_Address; \ - Temp = (RELOCATE_COMPILED (Temp, \ - (OBJECT_ADDRESS (New_Address)), \ - Saved_Old)); \ -} while (0) - -#define TRANSPORT_RAW_COMPILED() do \ -{ \ - SCHEME_OBJECT * Saved_Old = Old; \ - \ - Real_Transport_Vector (); \ - AUTOCLOBBER_BUMP (Saved_Old, To); \ - *Saved_Old = New_Address; \ - Temp = (RELOCATE_COMPILED_RAW_ADDRESS \ - (Temp, \ - (OBJECT_ADDRESS (New_Address)), \ - Saved_Old)); \ -} while (0) - -/* Manifest and implied types */ - -/* Manifest closures */ - -/* A manifest closure header is followed by one or more closure entry - points. Each entry point consist of a pair of machine words (16 - bits each) that contain a format word and a GC offset followed by - the machine code for the closure (typically a jsr-type - instruction). If there is only one entry point to a closure, the - GC offset will be 8 bytes, pointing back to the manifest closure - header itself. Otherwise what would have been the first GC offset - is 0, and what would have been the first format word is the count - in entry points. The format word and GC offset for the first entry - follow this additional word. After the entry points there are the - values of the variables closed over: - - >=1 Entry Point =1 Entry Point - (offset in bytes from 1st instruction of 1st (only) entry) - - -12: Manifest Closure | tot. length - - 8: Count format word (with 0 GC) Manifest Closure | tot. length - - 4: Format word, 1st entry Format word, only entry - - 2: GC offset to -12 GC offset to -8 - 0: jsr instr., 1st entry jsr instr. - xx: more instructions if needed same - : Format word, 2nd entry closed over variable values - : GC offset to -16 - ...: etc. - ...: closed over variable values - - The following five macros are the only ones used outside of this - file to deal with closures. They can be overridden for specific - machines that use different formats. - - MANIFEST_CLOSURE_COUNT receives the address of the word past the - manifest closure header and extracts the count of entry points - in the closure block. - - FIRST_MANIFEST_CLOSURE_ENTRY receives the address of the word past - the manifest closure header (-4 for single entry point closures in - the above picture). It bumps it to the first entry point (i.e. to - 0 above), past the format word and the gc offset and the count - formart word if present. - - NEXT_MANIFEST_CLOSURE_ENTRY given an entry point in a multiclosure, - bump to the immediately following entry point - - CLOSURE_ENTRY_END given an entry point, return the address of the - first byte past the code in this entry point. - - MANIFEST_CLOSURE_END receives the address of the word past - the manifest closure header (-4 for single entry point closures in - the above picture). Returns the address of the word that precedes - the first free variable in the closure. - - CLOSURE_HEADER_TO_ENTRY is the distance (in bytes) from the - manifest closure header to the 1st instruction of the (1st) entry. - */ - -#define CLOSURE_HEADER_TO_ENTRY \ -((sizeof (SCHEME_OBJECT)) + (2 * (sizeof (format_word)))) - -#define CLOSURE_HEADER_TO_ENTRY_WORD \ -((format_word) (BYTE_OFFSET_TO_OFFSET_WORD (CLOSURE_HEADER_TO_ENTRY))) - -#ifndef MANIFEST_CLOSURE_COUNT -#define MANIFEST_CLOSURE_COUNT(scan) \ -(((((format_word *) (scan))[1]) == \ - CLOSURE_HEADER_TO_ENTRY_WORD) ? \ - 1 : \ - ((long) (((format_word *) (scan))[0]))) -#endif - -#ifndef FIRST_MANIFEST_CLOSURE_ENTRY -#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \ -(((((format_word *) (scan))[1]) == CLOSURE_HEADER_TO_ENTRY_WORD) \ - ? (((char *) (scan)) + (2 * (sizeof (format_word)))) \ - : (((char *) (scan)) + (4 * (sizeof (format_word))))) -#endif - -#ifndef NEXT_MANIFEST_CLOSURE_ENTRY -#define NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr) \ - (((char *) (word_ptr)) + (COMPILED_CLOSURE_ENTRY_SIZE)) -#endif +/* When the target address of a closure is stored as a relative + reference, the following three macros are used to aid relocation of + these targets. -/* Where this closure entry ends with respect to the entry point. - Since an entry point is preceded by a format word and a gc offset, - it is the address of the next entry minus these two words. - */ + DECLARE_RELOCATION_REFERENCE(reference) declares a variable to hold + reference information when code pointers are relative. -#ifndef CLOSURE_ENTRY_END -#define CLOSURE_ENTRY_END(word_ptr) \ - (((char *) (word_ptr)) + \ - ((COMPILED_CLOSURE_ENTRY_SIZE) - (2 * (sizeof (format_word))))) -#endif - -#define CHAR_TO_SCHEME_OBJECT(chars) \ -(((chars) + ((sizeof (SCHEME_OBJECT)) - 1)) / (sizeof (SCHEME_OBJECT))) - -/* This assumes that closures with exactly one entry point - are always represented in short format. */ - -#ifndef MANIFEST_CLOSURE_END -#define MANIFEST_CLOSURE_END(start, count) \ -(((SCHEME_OBJECT *) (start)) \ - + (CHAR_TO_SCHEME_OBJECT (((count) * COMPILED_CLOSURE_ENTRY_SIZE) \ - + (((count) == 1) \ - ? 0 \ - : (2 * sizeof(format_word)))))) -#endif - -/* Linkage sections */ - -#define READ_LINKAGE_KIND(header) \ - ((header) & 0xff0000) + START_CLOSURE_RELOCATION(block_addr, reference) is called + immediately before relocating a block of closure entries. */ -#define READ_CACHE_LINKAGE_COUNT(header) \ - ((header) & 0xffff) - -#ifndef FIRST_OPERATOR_LINKAGE_OFFSET -# define FIRST_OPERATOR_LINKAGE_OFFSET 1 +#ifndef DECLARE_RELOCATION_REFERENCE +# define DECLARE_RELOCATION_REFERENCE(reference) #endif - -#define READ_OPERATOR_LINKAGE_COUNT(header) \ - (EXECUTE_CACHE_COUNT_TO_ENTRIES \ - (((header) & 0xffff) - (FIRST_OPERATOR_LINKAGE_OFFSET - 1))) - -#define MAKE_LINKAGE_SECTION_HEADER(kind, count) \ - (MAKE_OBJECT(TC_LINKAGE_SECTION, \ - ((kind) \ - | ((((kind) == OPERATOR_LINKAGE_KIND) \ - || ((kind) == GLOBAL_OPERATOR_LINKAGE_KIND)) \ - ? ((EXECUTE_CACHE_ENTRIES_TO_COUNT (count)) \ - + (FIRST_OPERATOR_LINKAGE_OFFSET - 1)) \ - : (count))))) - -/* This takes into account the 1 added by the main loop of the - relocators. - */ - -#ifndef END_OPERATOR_LINKAGE_AREA -# define END_OPERATOR_LINKAGE_AREA(scan, count) \ - (((SCHEME_OBJECT *) (scan)) \ - + (((count) * EXECUTE_CACHE_ENTRY_SIZE)) \ - + (FIRST_OPERATOR_LINKAGE_OFFSET - 1)) -#endif - -#define FIRST_OPERATOR_LINKAGE_ENTRY(scan) \ - ((char *) (((SCHEME_OBJECT *) (scan)) + FIRST_OPERATOR_LINKAGE_OFFSET)) - -#define NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr) \ - ((char *) (((SCHEME_OBJECT *) (word_ptr)) + \ - EXECUTE_CACHE_ENTRY_SIZE)) - -#ifndef EXTRACT_OPERATOR_LINKAGE_ADDRESS -# define EXTRACT_OPERATOR_LINKAGE_ADDRESS(target, source) \ -{ \ - EXTRACT_EXECUTE_CACHE_ADDRESS (target, source); \ -} -#endif - -#ifndef STORE_OPERATOR_LINKAGE_ADDRESS -# define STORE_OPERATOR_LINKAGE_ADDRESS(source, target) \ -{ \ - STORE_EXECUTE_CACHE_ADDRESS (target, source); \ -} -#endif - -/* Heuristic recovery aid. See uxtrap.c for its use. - block is the address of a vector header followed by a non-marked - header (the way that compiled blocks start). - PLAUSIBLE_CC_BLOCK_P returns true if it is likely that compiled - code is contained in the header. This is done by checking whether - an entry is the first thing in the compiled code section. - There are two kinds of "possible entries": expressions (first thing - in the block) and procedures/continuations, which follow an interrupt - check. - */ - -#define PLAUSIBLE_CC_BLOCK_P(block) \ - (((PLAUSIBLE_BLOCK_START_P((block), CC_BLOCK_FIRST_ENTRY_OFFSET)) || \ - (PLAUSIBLE_BLOCK_START_P((block), \ - (CC_BLOCK_FIRST_ENTRY_OFFSET + \ - ENTRY_PREFIX_LENGTH)))) \ - && \ - (PLAUSIBLE_BLOCK_SPAN_AND_END_P(block, \ - (VECTOR_LOC((SCHEME_OBJECT)block, \ - ((VECTOR_LENGTH((SCHEME_OBJECT)block)) - 1)))))) - -#define PLAUSIBLE_BLOCK_START_P(addr, offset) \ -((*((format_word *) \ - (((char *) (addr)) + ((offset) - (sizeof (format_word)))))) == \ - ((BYTE_OFFSET_TO_OFFSET_WORD(offset)))) - -#define PLAUSIBLE_BLOCK_SPAN_AND_END_P(addr,end) \ - (((ADDRESS_HEAP_P(addr) && ADDRESS_HEAP_P(end)) || \ - (ADDRESS_CONSTANT_P(addr) && ADDRESS_CONSTANT_P(end))) \ - && \ - (ENVIRONMENT_P (*(SCHEME_OBJECT *) end))) - -#else /* not HAS_COMPILER_SUPPORT */ - -/* This can be anything. */ - -typedef unsigned short format_word; - -/* Is there anything else that can be done here? */ - -#define GC_NO_COMPILER_STMT() \ - gc_death \ - (TERM_COMPILER_DEATH, \ - "relocate_compiled: No compiler support!", \ - 0, 0) - -#define GC_NO_COMPILER_EXPR(value_type) \ - ((GC_NO_COMPILER_STMT ()), (value_type 0)) - -#define RELOCATE_COMPILED(obj, nb, ob) \ - (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT))) -#define RELOCATE_COMPILED_INTERNAL(ad,nb,ob) \ - (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT))) -#define RELOCATE_COMPILED_RAW_ADDRESS(ad,nb,ob) \ - (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT))) - -#define Transport_Compiled() (GC_NO_COMPILER_STMT ()) -#define TRANSPORT_RAW_COMPILED() (GC_NO_COMPILER_STMT ()) -#define Compiled_BH(flag, then_what) (GC_NO_COMPILER_STMT ()) -#define RAW_COMPILED_BH(flag, then_what) (GC_NO_COMPILER_STMT ()) -#define Get_Compiled_Block(var, address) (GC_NO_COMPILER_STMT ()) - -#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \ - (GC_NO_COMPILER_EXPR ((char *))) - -#define MANIFEST_CLOSURE_COUNT(scan) \ - (GC_NO_COMPILER_EXPR ((long))) - -#define NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr) \ - (GC_NO_COMPILER_EXPR ((char *))) - -#define CLOSURE_ENTRY_END(word_ptr) \ - (GC_NO_COMPILER_EXPR ((char *))) - -#define MANIFEST_CLOSURE_END(end, start) \ - (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *))) - -#define EXTRACT_CLOSURE_ENTRY_ADDRESS(target, source) \ - (GC_NO_COMPILER_STMT ()) - -#define STORE_CLOSURE_ENTRY_ADDRESS(source, target) \ - (GC_NO_COMPILER_STMT ()) - -#define READ_LINKAGE_KIND(header) \ - (GC_NO_COMPILER_EXPR ((int))) - -#define READ_CACHE_LINKAGE_COUNT(header) \ - (GC_NO_COMPILER_EXPR ((int))) - -#define READ_OPERATOR_LINKAGE_COUNT(header) \ - (GC_NO_COMPILER_EXPR ((int))) - -#define END_OPERATOR_LINKAGE_AREA(scan, count) \ - (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *))) - -#define FIRST_OPERATOR_LINKAGE_ENTRY(scan) \ - (GC_NO_COMPILER_EXPR ((char *))) - -#define NEXT_LINKAGE_OPERATOR_ENTRY(ptr) \ - (GC_NO_COMPILER_EXPR ((char *))) - -#define EXTRACT_OPERATOR_LINKAGE_ADDRESS(target, source) \ - (GC_NO_COMPILER_STMT ()) - -#define STORE_OPERATOR_LINKAGE_ADDRESS(source, target) \ - (GC_NO_COMPILER_STMT ()) - -#endif /* HAS_COMPILER_SUPPORT */ - -#ifndef FLUSH_I_CACHE -# define FLUSH_I_CACHE() do {} while (0) +#ifndef START_CLOSURE_RELOCATION +# define START_CLOSURE_RELOCATION(scan, reference) do {} while (false) #endif - -#if !defined(PUSH_D_CACHE_REGION) && defined(FLUSH_I_CACHE_REGION) -# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords) +#ifndef START_OPERATOR_RELOCATION +# define START_OPERATOR_RELOCATION(scan, reference) do {} while (false) #endif -#ifndef COMPILER_TRANSPORT_END -# define COMPILER_TRANSPORT_END() do \ +#ifdef CC_SUPPORT_P +#define CC_TRANSPORT_END() do \ { \ - Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0); \ - Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL); \ + SET_CLOSURE_FREE (0); \ + SET_CLOSURE_SPACE (0); \ FLUSH_I_CACHE (); \ -} while (0) -#endif /* COMPILER_TRANSPORT_END */ - -#ifndef START_CLOSURE_RELOCATION -# define START_CLOSURE_RELOCATION(scan) do { } while (0) -#endif -#ifndef END_CLOSURE_RELOCATION -# define END_CLOSURE_RELOCATION(scan) do { } while (0) -#endif - -#ifndef START_OPERATOR_RELOCATION -# define START_OPERATOR_RELOCATION(scan) do { } while (0) -#endif -#ifndef END_OPERATOR_RELOCATION -# define END_OPERATOR_RELOCATION(scan) do { } while (0) +} while (false) +#else +# define CC_TRANSPORT_END() do {} while (false) #endif -#endif /* CMPGC_H_INCLUDED */ +#endif /* SCM_CMPGC_H */ diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 5cd0ddf74..6b876d4df 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.108 2007/02/04 21:55:45 riastradh Exp $ +$Id: cmpint.c,v 1.109 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,91 +25,165 @@ USA. */ -/* - * - * Compiled code interface. Portable version. - * This file requires a bit of assembly language from cmpaux-md.m4 - * See also the files cmpint.txt, cmpgc.h, and cmpint-md.h . - * - */ - -/* - * Procedures in this file belong to the following categories: - * - * Local C procedures. These are local procedures called only by - * other procedures in this file, and have been separated only for - * modularity reasons. They are tagged with the C keyword `static'. - * They can return any C type. - * - * C utility procedures. These procedures are called from C - * primitives and other subsystems and never leave the C world. They - * constitute the compiled code data abstraction as far as other C - * parts of the Scheme "microcode" are concerned. They are tagged - * with the noise word `C_UTILITY'. They can return any C type. - * - * C interface entries. These procedures are called from the - * interpreter (written in C) and ultimately enter the Scheme compiled - * code world by using the assembly language utility - * `C_to_interface'. They are tagged with the noise word - * `C_TO_SCHEME'. They MUST return a C long indicating what - * the interpreter should do next. - * - * Scheme interface utilities. These procedures are called from the - * assembly language interface and return to it, and perform all the - * tasks that the compiler does not code inline. They are referenced - * by compiled scheme code by index, and the assembly language - * interface fetches them from an array. They are tagged with the - * noise word `SCHEME_UTILITY'. They return a C structure (struct - * utility_result) which describes whether computation should proceed - * in the interpreter or in compiled code, and how. - * - */ - -/* Macro imports */ - -#include "config.h" -#include -#ifdef STDC_HEADERS -# include -#endif -#include "dstack.h" /* Dynamic-stack support */ -#include "outf.h" /* error reporting */ -#include "types.h" /* Needed by const.h */ -#include "const.h" /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */ -#include "object.h" /* Making and destructuring Scheme objects */ -#include "intrpt.h" /* Interrupt processing macros */ -#include "gc.h" /* Request_GC, etc. */ -#include "sdata.h" /* ENTITY_OPERATOR */ -#include "errors.h" /* Error codes and Termination codes */ -#include "returns.h" /* Return addresses in the interpreter */ -#include "fixobj.h" /* To find the error handlers */ -#include "stack.h" /* Stacks and stacklets */ -#include "interp.h" /* Interpreter state and primitive destructuring */ -#include "default.h" /* various definitions */ -#include "extern.h" /* External decls (missing Cont_Debug, etc.) */ -#include "trap.h" /* CACHE_TYPE */ -#include "prims.h" /* LEXPR */ -#include "prim.h" /* Primitive_Procedure_Table, etc. */ - -#define ENTRY_TO_OBJECT(entry) \ - (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry)))) - -#define IN_CMPINT_C -#include "cmpgc.h" /* Compiled code object relocation */ +/* Compiled-code interface */ +/* Some of the cmpintmd/FOO.h files use this macro to alter their + behavior when included here. */ +#define IN_CMPINT_C 1 + +#include "scheme.h" +#include "prims.h" #include "lookup.h" +#include "trap.h" +#include "history.h" +#include "cmpgc.h" + +/* Two special classes of procedures are used in this file: + + Scheme interface entries. These procedures are called from C and + ultimately invoke 'ENTER_SCHEME' to enter compiled code, or return + a status code. + + Scheme interface utilities. These procedures are called from the + Scheme interface and perform tasks that the compiler does not code + inline. They are referenced from compiled Scheme code by index, + and the assembly language interface fetches them from an array. + They are defined with 'SCHEME_UTILITY_n' for some 'n', and + ultimately invoke either 'RETURN_TO_SCHEME' (in the normal case) or + 'RETURN_TO_C' (in the error case). */ + +typedef long cache_handler_t (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); + +typedef struct +{ + SCHEME_OBJECT * block_address; + SCHEME_OBJECT * scan; + unsigned long n_sections; + insn_t * return_address; + unsigned long n_linked_sections; + SCHEME_OBJECT * scan0; + linkage_section_type_t type; + unsigned long n_entries; + unsigned long n_linked_entries; +} link_cc_state_t; + +/* Ways to bypass the interpreter */ +typedef enum +{ + REFLECT_CODE_INTERNAL_APPLY, + REFLECT_CODE_RESTORE_INTERRUPT_MASK, + REFLECT_CODE_STACK_MARKER, + REFLECT_CODE_CC_BKPT +} reflect_code_t; -#ifdef HAS_COMPILER_SUPPORT +#define PUSH_REFLECTION(code) do \ +{ \ + STACK_PUSH (ULONG_TO_FIXNUM (code)); \ + STACK_PUSH (reflect_to_interface); \ +} while (false) + +typedef enum +{ + TRAMPOLINE_K_RETURN_TO_INTERPRETER, + TRAMPOLINE_K_APPLY, + TRAMPOLINE_K_ARITY, /* unused */ + TRAMPOLINE_K_ENTITY, /* unused */ + TRAMPOLINE_K_INTERPRETED, /* unused */ + TRAMPOLINE_K_LEXPR_PRIMITIVE, + TRAMPOLINE_K_PRIMITIVE, + TRAMPOLINE_K_LOOKUP, + TRAMPOLINE_K_1_0, + TRAMPOLINE_K_2_1, + TRAMPOLINE_K_2_0, + TRAMPOLINE_K_3_2, + TRAMPOLINE_K_3_1, + TRAMPOLINE_K_3_0, + TRAMPOLINE_K_4_3, + TRAMPOLINE_K_4_2, + TRAMPOLINE_K_4_1, + TRAMPOLINE_K_4_0, + TRAMPOLINE_K_REFLECT_TO_INTERFACE = 0x3A +} trampoline_type_t; + +#define TC_TRAMPOLINE_HEADER TC_FIXNUM +#define TRAMPOLINE_TABLE_SIZE 4 + +static trampoline_type_t +trampoline_arity_table [TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] = +{ + TRAMPOLINE_K_1_0, /* 1_0 */ + TRAMPOLINE_K_APPLY, /* 1_1 should not get here */ + TRAMPOLINE_K_APPLY, /* 1_2 should not get here */ + TRAMPOLINE_K_APPLY, /* 1_3 should not get here */ + TRAMPOLINE_K_2_0, /* 2_0 */ + TRAMPOLINE_K_2_1, /* 2_1 */ + TRAMPOLINE_K_APPLY, /* 2_2 should not get here */ + TRAMPOLINE_K_APPLY, /* 2_3 should not get here */ + TRAMPOLINE_K_3_0, /* 3_0 */ + TRAMPOLINE_K_3_1, /* 3_1 */ + TRAMPOLINE_K_3_2, /* 3_2 */ + TRAMPOLINE_K_APPLY, /* 3_3 should not get here */ + TRAMPOLINE_K_4_0, /* 4_0 */ + TRAMPOLINE_K_4_1, /* 4_1 */ + TRAMPOLINE_K_4_2, /* 4_2 */ + TRAMPOLINE_K_4_3 /* 4_3 */ +}; -/* ASM_ENTRY_POINT and EXFNX are for OS/2. The IBM C Set++/2 - compiler has several different external calling conventions. The - default calling convention is called _Optlink, uses a combination - of registers and the stack, and is complicated. The calling - convention used for operating system interface procedures is called - _System, uses only the stack, and is very similar to the calling - conventions used with our DOS compilers. So, in order to simplify - the changes to the assembly language, we use _System conventions - for calling C procedures from the assembly language file. +cc_arch_t compiler_processor_type; +unsigned int compiler_interface_version; + +SCHEME_OBJECT compiler_utilities; +SCHEME_OBJECT return_to_interpreter; +SCHEME_OBJECT reflect_to_interface; + +static bool linking_cc_block_p = 0; + +static SCHEME_OBJECT make_compiler_utilities (void); +static void open_stack_gap (unsigned long, unsigned long); +static void close_stack_gap (unsigned long, unsigned long); +static void recover_from_apply_error (SCHEME_OBJECT, unsigned long); +static long link_remaining_sections (link_cc_state_t *); +static void start_linking_cc_block (void); +static void end_linking_cc_block (link_cc_state_t *); +static void abort_linking_cc_block (void *); +static void update_cache_after_link (link_cc_state_t *); +static void start_linking_section (link_cc_state_t *); +static long link_section (link_cc_state_t *); +static bool link_section_handler + (linkage_section_type_t, cache_handler_t **, bool *); +static void back_out_of_link_section (link_cc_state_t *); +static void restore_link_cc_state (link_cc_state_t *); +static long setup_compiled_invocation (SCHEME_OBJECT, unsigned long); +static long setup_lexpr_invocation + (SCHEME_OBJECT, unsigned long, unsigned long); +static bool open_gap (unsigned long, unsigned long); +static bool cc_block_address_closure_p (SCHEME_OBJECT *); +static void write_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT *); +static long make_fake_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); +static long make_trampoline + (SCHEME_OBJECT *, cc_entry_type_t *, trampoline_type_t, unsigned int, ...); +static void make_trampoline_headers + (unsigned long, unsigned long, + SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long *); +static bool fill_trampoline + (SCHEME_OBJECT *, unsigned long, cc_entry_type_t *, trampoline_type_t); +static long make_redirection_trampoline + (SCHEME_OBJECT *, trampoline_type_t, SCHEME_OBJECT); +static long make_apply_trampoline + (SCHEME_OBJECT *, trampoline_type_t, SCHEME_OBJECT, unsigned long); + +/* ASM_ENTRY_POINT is for OS/2, but it could also be used for any + compiler that supports multiple calling conventions, such as GCC. + + The IBM C Set++/2 compiler has several different external calling + conventions. The default calling convention is called _Optlink, + uses a combination of registers and the stack, and is complicated. + The calling convention used for operating system interface + procedures is called _System, uses only the stack, and is very + similar to the calling conventions used with our DOS compilers. + So, in order to simplify the changes to the assembly language, we + use _System conventions for calling C procedures from the assembly + language file. Since _Optlink is the default, we must somehow cause the relevant procedures to be compiled using _System. The easiest way to do @@ -123,1747 +197,1210 @@ USA. #ifndef ASM_ENTRY_POINT # define ASM_ENTRY_POINT(name) name #endif - -#define EXFNX(name, proto) EXFUN (ASM_ENTRY_POINT (name), proto) - -/* Make noise words invisible to the C compiler. */ - -#define C_UTILITY -#define C_TO_SCHEME - -#define DEFINE_SCHEME_UTILITY_0(pname) \ -void \ -DEFUN (ASM_ENTRY_POINT (pname), \ - (DSU_result, ignore1, ignore2, ignore3, ignore4), \ - utility_result * DSU_result \ - AND long ignore1 \ - AND long ignore2 \ - AND long ignore3 \ - AND long ignore4) - -#define DEFINE_SCHEME_UTILITY_1(pname, av1) \ -void \ -DEFUN (ASM_ENTRY_POINT (pname), \ - (DSU_result, av1, ignore2, ignore3, ignore4), \ - utility_result * DSU_result \ - AND long av1 \ - AND long ignore2 \ - AND long ignore3 \ - AND long ignore4) - -#define DEFINE_SCHEME_UTILITY_2(pname, av1, av2) \ -void \ -DEFUN (ASM_ENTRY_POINT (pname), \ - (DSU_result, av1, av2, ignore3, ignore4), \ - utility_result * DSU_result \ - AND long av1 \ - AND long av2 \ - AND long ignore3 \ - AND long ignore4) - -#define DEFINE_SCHEME_UTILITY_3(pname, av1, av2, av3) \ -void \ -DEFUN (ASM_ENTRY_POINT (pname), \ - (DSU_result, av1, av2, av3, ignore4), \ - utility_result * DSU_result \ - AND long av1 \ - AND long av2 \ - AND long av3 \ - AND long ignore4) - -#define DEFINE_SCHEME_UTILITY_4(pname, av1, av2, av3, av4) \ -void \ -DEFUN (ASM_ENTRY_POINT (pname), \ - (DSU_result, av1, av2, av3, av4), \ - utility_result * DSU_result \ - AND long av1 \ - AND long av2 \ - AND long av3 \ - AND long av4) - -/* For clarity */ - -typedef char instruction; +#ifndef UTILITY_RESULT_DEFINED #ifdef CMPINT_USE_STRUCS #ifdef C_FUNC_PTR_IS_CLOSURE -# define REFENTRY(name) (name) -# define VARENTRY(name) instruction * name -# define EXTENTRY(name) extern instruction * name + typedef insn_t * c_func_t; #else -# ifdef __OPEN_WATCOM_14__ -# define REFENTRY(name) ((void *) name) -# else -# define REFENTRY(name) ((void EXFUN ((*), (void))) name) + typedef void c_func_t (void); +/* From trunk, but may not be needed: */ +# if 0 +# ifdef __OPEN_WATCOM_14__ +# define REFENTRY(name) ((void *) name) +# else +# define REFENTRY(name) ((c_func_t *) name) +# endif +# define VARENTRY(name) c_func_t * name +# define EXTENTRY(name) extern c_func_t ASM_ENTRY_POINT (name) # endif -# define VARENTRY(name) void EXFUN ((*name), (void)) -# define EXTENTRY(name) extern void EXFNX (name, (void)) #endif -/* Structure returned by SCHEME_UTILITYs */ - -typedef struct -{ - VARENTRY (interface_dispatch); - union additional_info - { - long code_to_interpreter; - instruction * entry_point; - } extra; -} utility_result; - -/* Imports from assembly language */ - -extern long EXFNX (C_to_interface, (PTR)); - -EXTENTRY (interface_to_C); -EXTENTRY (interface_to_scheme); - -/* Convenience macros */ - #define RETURN_TO_C(code) do \ { \ - (DSU_result -> interface_dispatch) = (REFENTRY (interface_to_C)); \ - ((DSU_result -> extra) . code_to_interpreter) = (code); \ + (DSU_result->interface_dispatch) = interface_to_C; \ + ((DSU_result->extra) . code_to_interpreter) = (code); \ return; \ -} while (0) +} while (false) #define RETURN_TO_SCHEME(ep) do \ { \ - (DSU_result -> interface_dispatch) \ - = (REFENTRY (interface_to_scheme)); \ - ((DSU_result -> extra) . entry_point) \ - = ((instruction *) (ep)); \ + (DSU_result->interface_dispatch) = interface_to_scheme; \ + ((DSU_result->extra) . entry_point) = (ep); \ return; \ -} while (0) - -#define ENTER_SCHEME(ep) return (C_to_interface ((PTR) (ep))) +} while (false) -#else /* not CMPINT_USE_STRUCS */ +extern c_func_t ASM_ENTRY_POINT (interface_to_C); +extern c_func_t ASM_ENTRY_POINT (interface_to_scheme); -typedef instruction * utility_result; +#define ENTER_SCHEME(ep) return (C_to_interface (ep)) +extern long ASM_ENTRY_POINT (C_to_interface) (insn_t *); -/* Imports from assembly language */ - -extern void EXFNX (C_to_interface, (PTR)); -extern utility_result interface_to_C_hook; - -extern long C_return_value; -long C_return_value; - -/* Convenience macros */ +#else /* !CMPINT_USE_STRUCS */ #define RETURN_TO_C(code) do \ { \ - (*DSU_result) = ((instruction *) interface_to_C_hook); \ + (*DSU_result) = interface_to_C_hook; \ C_return_value = (code); \ return; \ -} while (0) +} while (false) #define RETURN_TO_SCHEME(ep) do \ { \ - (*DSU_result) = ((instruction *) (ep)); \ + (*DSU_result) = (ep); \ return; \ -} while (0) +} while (false) #define ENTER_SCHEME(ep) do \ { \ - C_to_interface ((PTR) (ep)); \ + C_to_interface (ep); \ return (C_return_value); \ -} while (0) - -#endif /* not CMPINT_USE_STRUCS */ - -/* utility table entries. */ - -typedef void EXFUN - ((* (ASM_ENTRY_POINT (utility_table_entry))), - (utility_result *, long, long, long, long)); - -#define RETURN_UNLESS_EXCEPTION(code, entry_point) do \ -{ \ - int return_code = (code); \ - if (return_code == PRIM_DONE) \ - { \ - RETURN_TO_SCHEME (entry_point); \ - } \ - else \ - { \ - RETURN_TO_C (return_code); \ - } \ -} while (0) - -#define TAIL_CALL_1(pname, a1) do \ -{ \ - pname (DSU_result, (a1), 0, 0, 0); \ - return; \ -} while (0) +} while (false) -#define TAIL_CALL_2(pname, a1, a2) do \ -{ \ - pname (DSU_result, (a1), (a2), 0, 0); \ - return; \ -} while (0) +extern utility_result_t interface_to_C_hook; +extern void ASM_ENTRY_POINT (C_to_interface) (insn_t *); +long C_return_value; -#define MAKE_CC_BLOCK(block_addr) \ - (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr)) +#endif /* !CMPINT_USE_STRUCS */ +#endif /* !UTILITY_RESULT_DEFINED */ -/* Imports from the rest of the "microcode" */ - -/* Exports to the rest of the "microcode" */ - -extern long - compiler_interface_version, - compiler_processor_type; - -extern SCHEME_OBJECT - compiler_utilities, - return_to_interpreter; - -extern C_UTILITY long - EXFUN (make_fake_uuo_link, - (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)), - EXFUN (make_uuo_link, - (SCHEME_OBJECT value, SCHEME_OBJECT extension, - SCHEME_OBJECT block, long offset)), - EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)), - EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)), - EXFUN (coerce_to_compiled, - (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location)); - -extern C_UTILITY SCHEME_OBJECT - EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)), - EXFUN (extract_variable_cache, - (SCHEME_OBJECT extension, long offset)), - EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)), - EXFUN (compiled_block_environment, (SCHEME_OBJECT block)), - EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)), - EXFUN (apply_compiled_from_primitive, (int)), - EXFUN (compiled_with_interrupt_mask, (unsigned long, - SCHEME_OBJECT, - unsigned long)), - EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)), - * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -extern C_UTILITY Boolean - EXFUN (install_c_code_table, (SCHEME_OBJECT *, long)); - -extern C_UTILITY void - EXFUN (compiler_initialize, (long fasl_p)), - EXFUN (compiler_reset, (SCHEME_OBJECT new_block)), - EXFUN (store_variable_cache, - (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)), - EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block)); - -extern utility_table_entry utility_table[]; - -static SCHEME_OBJECT reflect_to_interface; - -/* Breakpoint stuff. */ - -extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_install, (PTR)); -extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR)); -extern C_UTILITY Boolean EXFUN (bkpt_p, (PTR)); -extern C_UTILITY SCHEME_OBJECT EXFUN - (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT)); -extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT)); +#define JUMP_TO_CC_ENTRY(entry) ENTER_SCHEME (CC_ENTRY_ADDRESS (entry)) -/* These definitions reflect the indices into the table above. */ - -#define TRAMPOLINE_K_RETURN 0x0 -#define TRAMPOLINE_K_APPLY 0x1 -#define TRAMPOLINE_K_ARITY 0x2 -#define TRAMPOLINE_K_ENTITY 0x3 -#define TRAMPOLINE_K_INTERPRETED 0x4 -#define TRAMPOLINE_K_LEXPR_PRIMITIVE 0x5 -#define TRAMPOLINE_K_PRIMITIVE 0x6 -#define TRAMPOLINE_K_LOOKUP 0x7 -#define TRAMPOLINE_K_1_0 0x8 -#define TRAMPOLINE_K_2_1 0x9 -#define TRAMPOLINE_K_2_0 0xa -#define TRAMPOLINE_K_3_2 0xb -#define TRAMPOLINE_K_3_1 0xc -#define TRAMPOLINE_K_3_0 0xd -#define TRAMPOLINE_K_4_3 0xe -#define TRAMPOLINE_K_4_2 0xf -#define TRAMPOLINE_K_4_1 0x10 -#define TRAMPOLINE_K_4_0 0x11 -#define TRAMPOLINE_K_REFLECT_TO_INTERFACE 0x3a - -#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED - -/* Ways to bypass the interpreter */ - -#define REFLECT_CODE_INTERNAL_APPLY 0 -#define REFLECT_CODE_RESTORE_INTERRUPT_MASK 1 -#define REFLECT_CODE_STACK_MARKER 2 -#define REFLECT_CODE_CC_BKPT 3 - -/* Markers for special entry points */ - -#ifndef FORMAT_BYTE_EXPR -#define FORMAT_BYTE_EXPR 0xFF -#endif -#ifndef FORMAT_BYTE_COMPLR -#define FORMAT_BYTE_COMPLR 0xFE -#endif -#ifndef FORMAT_BYTE_CMPINT -#define FORMAT_BYTE_CMPINT 0xFD -#endif -#ifndef FORMAT_BYTE_DLINK -#define FORMAT_BYTE_DLINK 0xFC -#endif -#ifndef FORMAT_BYTE_RETURN -#define FORMAT_BYTE_RETURN 0xFB -#endif -#ifndef FORMAT_BYTE_CLOSURE -#define FORMAT_BYTE_CLOSURE 0xFA +#ifndef COMPILER_REGBLOCK_N_FIXED +# define COMPILER_REGBLOCK_N_FIXED REGBLOCK_MINIMUM_LENGTH #endif -#ifndef FORMAT_BYTE_FRAMEMAX -#define FORMAT_BYTE_FRAMEMAX 0x7F + +#ifndef COMPILER_REGBLOCK_N_TEMPS +# define COMPILER_REGBLOCK_N_TEMPS 0 #endif -#ifndef FORMAT_WORD_EXPR -#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_EXPR)) +#ifndef COMPILER_TEMP_SIZE +# define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT))) #endif -#ifndef FORMAT_WORD_CMPINT -#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CMPINT)) + +#ifndef COMPILER_REGBLOCK_EXTRA_SIZE +# define COMPILER_REGBLOCK_EXTRA_SIZE 0 #endif -#ifndef FORMAT_WORD_RETURN -#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_RETURN)) + +#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED) +# include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!" #endif - -/* Utilities for application of compiled procedures. */ -/* NOTE: In this file, the number of arguments (or minimum - number of arguments, etc.) is always 1 greater than the number of - arguments (it includes the procedure object). - */ +#define REGBLOCK_LENGTH \ + (COMPILER_REGBLOCK_N_FIXED \ + + (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) \ + + COMPILER_REGBLOCK_EXTRA_SIZE) -/* open_gap: Default some optional parameters, and return the location - of the return address (one past the last actual argument location). - */ +#ifndef REGBLOCK_ALLOCATED_BY_INTERFACE + SCHEME_OBJECT Registers [REGBLOCK_LENGTH]; +#endif -static SCHEME_OBJECT * -DEFUN (open_gap, - (nactuals, delta), - register long nactuals AND register long delta) -{ - register SCHEME_OBJECT *gap_location, *source_location; +#ifndef ASM_RESET_HOOK +# define ASM_RESET_HOOK() do {} while (false) +#endif - /* Need to fill in optionals */ +#define SAVE_LAST_RETURN_CODE(code) do \ +{ \ + { \ + long SLRC_offset \ + = (STACK_LOCATIVE_DIFFERENCE (stack_pointer, last_return_code)); \ + assert (SLRC_offset > 0); \ + STACK_PUSH (LONG_TO_FIXNUM (SLRC_offset)); \ + } \ + PUSH_RC (code); \ + COMPILER_NEW_SUBPROBLEM (); \ +} while (false) - gap_location = STACK_LOC (delta); - source_location = STACK_LOC (0); - sp_register = gap_location; - while ((--nactuals) > 0) - { - STACK_LOCATIVE_POP (gap_location) = STACK_LOCATIVE_POP (source_location); - } - delta = (- delta); - while ((--delta) >= 0) - { - STACK_LOCATIVE_POP (gap_location) = DEFAULT_OBJECT; - } - return (source_location); -} +#define RESTORE_LAST_RETURN_CODE() do \ +{ \ + last_return_code = (STACK_LOC (FIXNUM_TO_ULONG (GET_EXP))); \ + CHECK_LAST_RETURN_CODE (); \ + COMPILER_END_SUBPROBLEM (); \ +} while (false) + +#define CHECK_LAST_RETURN_CODE() do \ +{ \ + assert \ + (RETURN_CODE_P \ + (STACK_LOCATIVE_REFERENCE (last_return_code, \ + CONTINUATION_RETURN_CODE))); \ +} while (false) -/* setup_lexpr_invocation: Setup a rest argument as appropriate. */ +/* Initialization */ -static long -DEFUN (setup_lexpr_invocation, - (nactuals, nmax, entry_address), - register long nactuals AND register long nmax - AND instruction * entry_address) +void +compiler_initialize (bool fasl_p) { - register long delta; + /* Called when scheme started. */ + SET_PRIMITIVE (SHARP_F); + compiler_processor_type = COMPILER_PROCESSOR_TYPE; + compiler_interface_version = COMPILER_INTERFACE_VERSION; + if (fasl_p) + compiler_reset (make_compiler_utilities ()); + else + { + /* Delay until after band-load, when compiler_reset will be invoked. */ + compiler_utilities = SHARP_F; + return_to_interpreter = SHARP_F; +#ifdef CC_ARCH_INITIALIZE + CC_ARCH_INITIALIZE (); +#endif + } +} - /* nmax is negative! */ +#define COMPILER_UTILITIES_HEADERS(h1, h2, n) \ + make_trampoline_headers (2, 2, (h1), (h2), (n)) - delta = (nactuals + nmax); +static SCHEME_OBJECT +make_compiler_utilities (void) +{ + SCHEME_OBJECT h1; + SCHEME_OBJECT h2; + unsigned long n_words; + SCHEME_OBJECT * block; - if (delta < 0) - { - /* Not enough arguments have been passed to allocate a list. - The missing optional arguments must be defaulted, and the - rest parameter needs to be set to the empty list. - */ + COMPILER_UTILITIES_HEADERS ((&h1), (&h2), (&n_words)); + if (GC_NEEDED_P (n_words)) + { + outf_fatal ("Can't allocate compiler_utilities.\n"); + Microcode_Termination (TERM_NO_SPACE); + } + h1 = (OBJECT_NEW_TYPE (TC_MANIFEST_VECTOR, h1)); - SCHEME_OBJECT *last_loc; + block = Free; + Free += n_words; + (block[0]) = h1; + (block[1]) = h2; - last_loc = open_gap (nactuals, delta); - (STACK_LOCATIVE_PUSH (last_loc)) = EMPTY_LIST; - return (PRIM_DONE); - } - else if (delta == 0) { - /* The number of arguments passed matches exactly the number of - formal paramters. The last argument needs to be replaced by - a list containing it, but there is no need to pop anything - since the frame has the right size. - This does not check for gc! - The procedure should (and currently will) on entry. - */ - - register SCHEME_OBJECT temp, *gap_location, *local_free; - - local_free = Free; - Free += 2; - gap_location = STACK_LOC (nactuals - 2); - temp = *gap_location; - *gap_location = (MAKE_POINTER_OBJECT (TC_LIST, local_free)); - *local_free++ = temp; - *local_free = EMPTY_LIST; - return (PRIM_DONE); + cc_entry_type_t cet; + make_cc_entry_type ((&cet), CET_RETURN_TO_INTERPRETER); + if ((fill_trampoline (block, 0, (&cet), TRAMPOLINE_K_RETURN_TO_INTERPRETER)) + || + (fill_trampoline (block, 1, (&cet), TRAMPOLINE_K_REFLECT_TO_INTERFACE))) + { + outf_fatal ("\nError in make_compiler_utilities\n"); + Microcode_Termination (TERM_COMPILER_DEATH); + /*NOTREACHED*/ + } } - else /* (delta > 0) */ - { - /* The number of arguments passed is greater than the number of - formal parameters named by the procedure. Excess arguments - need to be placed in a list passed at the last parameter - location. The extra arguments must then be popped from the stack. - */ - long list_size; - register SCHEME_OBJECT *gap_location, *source_location; - - /* Allocate the list, and GC if necessary. */ - - list_size = (2 * (delta + 1)); - if (GC_Check (list_size)) - { - Request_GC (list_size); - STACK_PUSH (ENTRY_TO_OBJECT (entry_address)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - return (PRIM_APPLY_INTERRUPT); - } - gap_location = &Free[list_size]; - Free = gap_location; - /* Place the arguments in the list, and link it. */ + /* These entries are no longer used, but are provided for + compatibility with the previous structure. */ + { + SCHEME_OBJECT * store = (trampoline_storage (block)); + (store[0]) = ((trampoline_entry_addr (block, 0)) - ((insn_t *) block)); + (store[1]) = ((trampoline_entry_addr (block, 1)) - ((insn_t *) block)); + } - source_location = (STACK_LOC (nactuals - 1)); - (*(--gap_location)) = EMPTY_LIST; + block = (copy_to_constant_space (block, n_words)); + return (MAKE_CC_BLOCK (block)); +} - while ((--delta) >= 0) +void +compiler_reset (SCHEME_OBJECT new_block) +{ + /* Called after a disk restore */ + SCHEME_OBJECT h1; + SCHEME_OBJECT h2; + unsigned long n_words; + SCHEME_OBJECT * nbp; + + COMPILER_UTILITIES_HEADERS ((&h1), (&h2), (&n_words)); + h1 = (OBJECT_NEW_TYPE (TC_MANIFEST_VECTOR, h1)); + if (! ((CC_BLOCK_P (new_block)) + && ((MEMORY_REF (new_block, 0)) == h1) + && ((MEMORY_REF (new_block, 1)) == h2))) { - gap_location -= 2; - (*(gap_location + 1)) = (STACK_LOCATIVE_PUSH (source_location)); - (*(gap_location)) = (MAKE_POINTER_OBJECT (TC_LIST, (gap_location + 1))); + outf_fatal ("\nThe world image being restored is incompatible" + " with this microcode.\n"); + Microcode_Termination (TERM_COMPILER_DEATH); + /*NOTREACHED*/ } - (*(--gap_location)) = (STACK_LOCATIVE_PUSH (source_location)); - - /* Place the list at the appropriate location in the stack. */ - - STACK_LOCATIVE_REFERENCE (source_location, 0) = - (MAKE_POINTER_OBJECT (TC_LIST, (gap_location))); - - /* Now move the arguments into their correct location in the stack - popping any unneeded locations. - */ + nbp = (OBJECT_ADDRESS (new_block)); + compiler_utilities = new_block; + return_to_interpreter = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 0))); + reflect_to_interface = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 1))); + SET_CLOSURE_FREE (0); + SET_CLOSURE_SPACE (0); + SET_REFLECTOR (reflect_to_interface); - gap_location = (STACK_LOC (nactuals - 1)); - STACK_LOCATIVE_INCREMENT (source_location); + ASM_RESET_HOOK (); +} + +/* Main compiled-code entry points */ - /* Remember that nmax is originally negative! */ +#define DEFINE_SCHEME_ENTRY(pname) long pname (void) - for (nmax = ((-nmax) - 1); ((--nmax) >= 0); ) - { - (STACK_LOCATIVE_PUSH (gap_location)) = - (STACK_LOCATIVE_PUSH (source_location)); - } - sp_register = gap_location; - return (PRIM_DONE); +DEFINE_SCHEME_ENTRY (enter_compiled_expression) +{ + SCHEME_OBJECT entry = GET_EXP; + { + cc_entry_type_t cet; + if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (entry)))) + return (ERR_COMPILED_CODE_ERROR); + if (cet.marker != CET_EXPRESSION) + { + /* evaluate to self */ + SET_VAL (entry); + return (PRIM_DONE); + } } + guarantee_cc_return (0); + JUMP_TO_CC_ENTRY (entry); } - -/* setup_compiled_invocation: Prepare the application frame the way that - the called procedure expects it (optional arguments and rest argument - initialized. - */ -static long -DEFUN (setup_compiled_invocation, - (nactuals, compiled_entry_address), - long nactuals AND instruction * compiled_entry_address) +DEFINE_SCHEME_ENTRY (apply_compiled_procedure) { - long nmin, nmax, delta; /* all +1 */ + unsigned long n_args = (POP_APPLY_FRAME_HEADER ()); + SCHEME_OBJECT procedure = (STACK_POP ()); + long code = (setup_compiled_invocation (procedure, n_args)); + if (code != PRIM_DONE) + return (code); + JUMP_TO_CC_ENTRY (procedure); +} - nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (compiled_entry_address)); - if (nactuals == nmax) - { - /* Either the procedure takes exactly the number of arguments - given, or it has optional arguments, no rest argument, and - all the optional arguments have been provided. Thus the - frame is in the right format and we are done. - */ - return (PRIM_DONE); - } - nmin = (COMPILED_ENTRY_MINIMUM_ARITY (compiled_entry_address)); - if (nmin < 0) - { - /* Not a procedure. */ - STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - return (ERR_INAPPLICABLE_OBJECT); - } - if (nactuals < nmin) - { - /* Too few arguments. */ - STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - return (ERR_WRONG_NUMBER_OF_ARGUMENTS); - } - delta = (nactuals - nmax); - if (delta <= 0) - { - /* The procedure takes optional arguments but no rest argument - and not all the optional arguments have been provided. - They must be defaulted. - */ - ((void) (open_gap (nactuals, delta))); - return (PRIM_DONE); - } - if (nmax > 0) +DEFINE_SCHEME_ENTRY (return_to_compiled_code) +{ + RESTORE_LAST_RETURN_CODE (); { - /* Too many arguments */ - STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - return (ERR_WRONG_NUMBER_OF_ARGUMENTS); + SCHEME_OBJECT cont = (STACK_POP ()); + { + cc_entry_type_t cet; + if ((read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (cont)))) + || (! ((cet.marker == CET_CONTINUATION) + || (cet.marker == CET_INTERNAL_CONTINUATION) + || (cet.marker == CET_RETURN_TO_INTERPRETER)))) + { + STACK_PUSH (cont); + SAVE_CONT (); + return (ERR_INAPPLICABLE_OBJECT); + } + } + JUMP_TO_CC_ENTRY (cont); } - /* The procedure can take arbitrarily many arguments, ie. - it is a lexpr. - */ - return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address)); } -/* Main compiled code entry points. - - These are the primary entry points that the interpreter - uses to execute compiled code. - The other entry points are special purpose return - points to compiled code invoked after the interpreter has been - employed to take corrective action (interrupt, error, etc). - They are coded adjacent to the place where the interpreter - is invoked. - */ - -C_TO_SCHEME long -DEFUN_VOID (enter_compiled_expression) -{ - instruction * compiled_entry_address; - - compiled_entry_address = - ((instruction *) (OBJECT_ADDRESS (exp_register))); - if ((COMPILED_ENTRY_FORMAT_WORD (compiled_entry_address)) != - FORMAT_WORD_EXPR) - { - /* It self evaluates. */ - val_register = exp_register; - ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); - } - ENTER_SCHEME (compiled_entry_address); +void +guarantee_cc_return (unsigned long offset) +{ + if (CC_ENTRY_P (STACK_REF (offset))) + return; + assert (RETURN_CODE_P (CONT_RET (offset))); + if (CHECK_RETURN_CODE (RC_REENTER_COMPILED_CODE, offset)) + { + unsigned long lrc = (FIXNUM_TO_ULONG (CONT_EXP (offset))); + close_stack_gap (offset, CONTINUATION_SIZE); + last_return_code = (STACK_LOC (offset + lrc)); + CHECK_LAST_RETURN_CODE (); + COMPILER_END_SUBPROBLEM (); + } + else + { + last_return_code = (STACK_LOC (offset)); + CHECK_LAST_RETURN_CODE (); + open_stack_gap (offset, 1); + (STACK_REF (offset)) = return_to_interpreter; + } } -C_TO_SCHEME long -DEFUN_VOID (apply_compiled_procedure) +void +guarantee_interp_return (void) { - SCHEME_OBJECT nactuals, procedure; - instruction * procedure_entry; - long result; - - nactuals = (STACK_POP ()); - procedure = (STACK_POP ()); - procedure_entry = ((instruction *) (OBJECT_ADDRESS (procedure))); - result = setup_compiled_invocation ((OBJECT_DATUM (nactuals)), - procedure_entry); - if (result == PRIM_DONE) - /* Go into compiled code. */ - ENTER_SCHEME (procedure_entry); + unsigned long offset = (1 + (APPLY_FRAME_SIZE ())); + if (RETURN_CODE_P (CONT_RET (offset))) + return; + assert (CC_ENTRY_P (STACK_REF (offset))); + if ((STACK_REF (offset)) == return_to_interpreter) + { + assert (RETURN_CODE_P (CONT_RET (offset + 1))); + close_stack_gap (offset, 1); + COMPILER_NEW_REDUCTION (); + } else - return (result); + { + open_stack_gap (offset, CONTINUATION_SIZE); + { + SCHEME_OBJECT * sp = stack_pointer; + stack_pointer = (STACK_LOC (offset + CONTINUATION_SIZE)); + SAVE_LAST_RETURN_CODE (RC_REENTER_COMPILED_CODE); + stack_pointer = sp; + } + } } -/* Note that this does not check that compiled_entry_address - is a valid return address. -- Should it? - */ +static void +open_stack_gap (unsigned long offset, unsigned long n_words) +{ + SCHEME_OBJECT * scan_from = (STACK_LOC (0)); + SCHEME_OBJECT * scan_end = (STACK_LOC (offset)); + SCHEME_OBJECT * scan_to = (STACK_LOC (-n_words)); + while (scan_from != scan_end) + (STACK_LOCATIVE_POP (scan_to)) = (STACK_LOCATIVE_POP (scan_from)); + stack_pointer = (STACK_LOC (-n_words)); +} -C_TO_SCHEME long -DEFUN_VOID (return_to_compiled_code) +static void +close_stack_gap (unsigned long offset, unsigned long n_words) { - instruction *compiled_entry_address; + SCHEME_OBJECT * scan_from = (STACK_LOC (offset)); + SCHEME_OBJECT * scan_end = (STACK_LOC (0)); + SCHEME_OBJECT * scan_to = (STACK_LOC (offset + n_words)); + while (scan_from != scan_end) + (STACK_LOCATIVE_PUSH (scan_to)) = (STACK_LOCATIVE_PUSH (scan_from)); + stack_pointer = (STACK_LOC (n_words)); +} - compiled_entry_address = - ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))); - ENTER_SCHEME (compiled_entry_address); +static void +recover_from_apply_error (SCHEME_OBJECT procedure, unsigned long n_args) +{ + STACK_PUSH (procedure); + PUSH_APPLY_FRAME_HEADER (n_args); + guarantee_interp_return (); } -C_UTILITY SCHEME_OBJECT -DEFUN (apply_compiled_from_primitive, (arity), int arity) +void +compiled_with_interrupt_mask (unsigned long old_mask, + SCHEME_OBJECT receiver, + unsigned long new_mask) { - SCHEME_OBJECT frame_size, procedure; - long result; - - frame_size = (STACK_POP ()); - procedure = (STACK_POP ()); - - switch (OBJECT_TYPE (procedure)) + STACK_PUSH (ULONG_TO_FIXNUM (old_mask)); + PUSH_REFLECTION (REFLECT_CODE_RESTORE_INTERRUPT_MASK); + STACK_PUSH (ULONG_TO_FIXNUM (new_mask)); { - case TC_ENTITY: - { - SCHEME_OBJECT data, operator; - unsigned long nactuals = (OBJECT_DATUM (frame_size)); - - data = (MEMORY_REF (procedure, ENTITY_DATA)); - if ((VECTOR_P (data)) - && (nactuals < (VECTOR_LENGTH (data))) - && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals))) - && ((VECTOR_REF (data, 0)) - == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG)))) - procedure = (VECTOR_REF (data, nactuals)); - else + long code = (setup_compiled_invocation (receiver, 1)); + if (code != PRIM_DONE) { - operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); - if (!COMPILED_CODE_ADDRESS_P (operator)) - goto defer_application; - STACK_PUSH (procedure); - frame_size += 1; - procedure = operator; + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + PRIMITIVE_ABORT (code); } - /* fall through */ - } + } + /* Pun: receiver is being invoked as a return address. */ + STACK_PUSH (receiver); +} - case TC_COMPILED_ENTRY: - { - result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)), - ((instruction *) - (OBJECT_ADDRESS (procedure)))); - if (result == PRIM_DONE) +void +compiled_with_stack_marker (SCHEME_OBJECT thunk) +{ + PUSH_REFLECTION (REFLECT_CODE_STACK_MARKER); + { + long code = (setup_compiled_invocation (thunk, 0)); + switch (code) { - STACK_PUSH (procedure); - sp_register = (STACK_LOC (- arity)); - return (SHARP_F); - } - else + case PRIM_DONE: + /* Pun: thunk is being invoked as a return address. */ + STACK_PUSH (thunk); break; - } - case TC_PRIMITIVE: - /* For now, fall through */ + case PRIM_APPLY_INTERRUPT: + PRIMITIVE_ABORT (code); + break; - default: -defer_application: - STACK_PUSH (procedure); - STACK_PUSH (frame_size); - break; + default: + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + PRIMITIVE_ABORT (code); + break; + } } - - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY); - STACK_PUSH (reflect_to_interface); - sp_register = (STACK_LOC (- arity)); - return (SHARP_F); } -C_UTILITY SCHEME_OBJECT -DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask), - unsigned long old_mask - AND SCHEME_OBJECT receiver - AND unsigned long new_mask) -{ - long result; +/* SCHEME_UTILITY procedures - STACK_PUSH (LONG_TO_FIXNUM (old_mask)); - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_RESTORE_INTERRUPT_MASK); - STACK_PUSH (reflect_to_interface); + Here's a mass of procedures that are called (via + 'scheme_to_interface', an assembly language hook) by compiled code + to do various jobs. */ - STACK_PUSH (LONG_TO_FIXNUM (new_mask)); - result = (setup_compiled_invocation (2, - ((instruction *) - (OBJECT_ADDRESS (receiver))))); - STACK_PUSH (receiver); +#define DEFINE_SCHEME_UTILITY_0(pname) \ +void \ +ASM_ENTRY_POINT (pname) \ + (utility_result_t * DSU_result, \ + unsigned long ignore1, \ + unsigned long ignore2, \ + unsigned long ignore3, \ + unsigned long ignore4) - if (result != PRIM_DONE) - { - STACK_PUSH (STACK_FRAME_HEADER + 1); - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY); - STACK_PUSH (reflect_to_interface); - } +#define DEFINE_SCHEME_UTILITY_1(pname, av1) \ +void \ +ASM_ENTRY_POINT (pname) \ + (utility_result_t * DSU_result, \ + unsigned long av1##_raw, \ + unsigned long ignore2, \ + unsigned long ignore3, \ + unsigned long ignore4) - sp_register = (STACK_LOC (- 2)); - return (SHARP_F); -} +#define DEFINE_SCHEME_UTILITY_2(pname, av1, av2) \ +void \ +ASM_ENTRY_POINT (pname) \ + (utility_result_t * DSU_result, \ + unsigned long av1##_raw, \ + unsigned long av2##_raw, \ + unsigned long ignore3, \ + unsigned long ignore4) -C_UTILITY SCHEME_OBJECT -DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk) -{ - long result; +#define DEFINE_SCHEME_UTILITY_3(pname, av1, av2, av3) \ +void \ +ASM_ENTRY_POINT (pname) \ + (utility_result_t * DSU_result, \ + unsigned long av1##_raw, \ + unsigned long av2##_raw, \ + unsigned long av3##_raw, \ + unsigned long ignore4) - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_STACK_MARKER); - STACK_PUSH (reflect_to_interface); +#define DEFINE_SCHEME_UTILITY_4(pname, av1, av2, av3, av4) \ +void \ +ASM_ENTRY_POINT (pname) \ + (utility_result_t * DSU_result, \ + unsigned long av1##_raw, \ + unsigned long av2##_raw, \ + unsigned long av3##_raw, \ + unsigned long av4##_raw) - result = (setup_compiled_invocation (1, - ((instruction *) - (OBJECT_ADDRESS (thunk))))); - STACK_PUSH (thunk); +#define DECLARE_UTILITY_ARG(at1, av1) at1 av1 = ((at1) av1##_raw) - if (result != PRIM_DONE) - { - STACK_PUSH (STACK_FRAME_HEADER); - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY); - STACK_PUSH (reflect_to_interface); - } +#define INVOKE_RETURN_ADDRESS() do \ +{ \ + if (Free >= GET_MEMTOP) \ + { \ + compiler_interrupt_common (DSU_result, 0, GET_VAL); \ + return; \ + } \ + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (STACK_POP ())); \ +} while (false) - sp_register = (STACK_LOC (- 3)); - return (SHARP_F); -} +#define TAIL_CALL_1(pname, a1) do \ +{ \ + pname (DSU_result, ((unsigned long) (a1)), 0, 0, 0); \ + return; \ +} while (false) + +#define TAIL_CALL_2(pname, a1, a2) do \ +{ \ + pname (DSU_result, \ + ((unsigned long) (a1)), \ + ((unsigned long) (a2)), \ + 0, \ + 0); \ + return; \ +} while (false) -/* - SCHEME_UTILITYs +DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, frame_size) +{ + DECLARE_UTILITY_ARG (SCHEME_OBJECT, procedure); + DECLARE_UTILITY_ARG (unsigned long, frame_size); - Here's a mass of procedures that are called (via scheme_to_interface, - an assembly language hook) by compiled code to do various jobs. - */ + while (1) + switch (OBJECT_TYPE (procedure)) + { + case TC_ENTITY: + { + SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && ((VECTOR_LENGTH (data)) > frame_size) + && ((VECTOR_REF (data, 0)) + == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))) + && ((VECTOR_REF (data, frame_size)) != SHARP_F)) + { + procedure = (VECTOR_REF (data, frame_size)); + break; + } + } + { + SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); + if (!CC_ENTRY_P (operator)) + goto handle_in_interpreter; + STACK_PUSH (procedure); + procedure = operator; + frame_size += 1; + } + /* fall through */ -/* - This is how compiled Scheme code normally returns back to the - Scheme interpreter. - It is invoked by a trampoline, which passes the address of the - trampoline storage block (empty) to it. - */ + case TC_COMPILED_ENTRY: + { + long code + = (setup_compiled_invocation (procedure, (frame_size - 1))); + if (code != PRIM_DONE) + RETURN_TO_C (code); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); -DEFINE_SCHEME_UTILITY_1 (comutil_return_to_interpreter, tramp_data_raw) -{ - RETURN_TO_C (PRIM_DONE); + case TC_PRIMITIVE: + if (IMPLEMENTED_PRIMITIVE_P (procedure)) + { + int arity = (PRIMITIVE_ARITY (procedure)); + if (arity == (frame_size - 1)) + TAIL_CALL_1 (comutil_primitive_apply, procedure); + else if (arity == LEXPR) + { + SET_LEXPR_ACTUALS (frame_size - 1); + TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure); + } + else + { + recover_from_apply_error (procedure, (frame_size - 1)); + RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + } + /* fall through */ + + handle_in_interpreter: + default: + { + recover_from_apply_error (procedure, (frame_size - 1)); + RETURN_TO_C (PRIM_APPLY); + } + } } -static void EXFUN - (compiler_interrupt_common, (utility_result *, SCHEME_ADDR, SCHEME_OBJECT)); - -#define COMPILER_INTERRUPT_COMMON(a1, a2) do \ -{ \ - compiler_interrupt_common (DSU_result, (a1), (a2)); \ - return; \ -} while (0) - -#if (COMPILER_PROCESSOR_TYPE != COMPILER_IA32_TYPE) +/* comutil_lexpr_apply is invoked to reformat the frame when compiled + code calls a known lexpr. The actual arguments are on the stack, + and it is given the number of arguments and the real entry point of + the procedure. */ -#define INVOKE_RETURN_ADDRESS() \ - RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ())) +DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, address, n_args) +{ + DECLARE_UTILITY_ARG (insn_t *, address); + DECLARE_UTILITY_ARG (unsigned long, n_args); + cc_entry_type_t cet; -#else /* COMPILER_IA32_TYPE */ + if (! ((!read_cc_entry_type ((&cet), address)) + && ((cet.marker) == CET_PROCEDURE) + && (cet.args.for_procedure.rest_p) + && (n_args >= (cet.args.for_procedure.n_required)))) + { + recover_from_apply_error ((MAKE_CC_ENTRY (address)), n_args); + RETURN_TO_C (ERR_COMPILED_CODE_ERROR); + } + { + long code + = (setup_lexpr_invocation ((MAKE_CC_ENTRY (address)), + n_args, + ((cet.args.for_procedure.n_required) + + (cet.args.for_procedure.n_optional)))); + if (code != PRIM_DONE) + RETURN_TO_C (code); + } + RETURN_TO_SCHEME (address); +} -#define INVOKE_RETURN_ADDRESS() do \ -{ \ - if (((long) (ADDR_TO_SCHEME_ADDR (Free))) \ - >= ((long) (Registers[REGBLOCK_MEMTOP]))) \ - COMPILER_INTERRUPT_COMMON (0, val_register); \ - else \ - RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \ -} while (0) - -#endif /* COMPILER_IA32_TYPE */ - -/* - comutil_primitive_apply is used to invoked a C primitive. - Note that some C primitives (the so called interpreter hooks) - will not return normally, but will "longjmp" to the interpreter - instead. Thus the assembly language invoking this should have - set up the appropriate locations in case this happens. - After invoking the primitive, it pops the arguments off the - Scheme stack, and proceeds by invoking the continuation on top - of the stack. - */ +/* comutil_primitive_apply is used to invoked a C primitive. Note + that some C primitives (the so called interpreter hooks) will not + return normally, but will "longjmp" to the interpreter instead. + Thus the assembly language invoking this should have set up the + appropriate locations in case this happens. After invoking the + primitive, it pops the arguments off the Scheme stack, and proceeds + by invoking the continuation on top of the stack. */ DEFINE_SCHEME_UTILITY_1 (comutil_primitive_apply, primitive) -{ - PRIMITIVE_APPLY (val_register, primitive); +{ + DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive); + PRIMITIVE_APPLY (primitive); POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive)); INVOKE_RETURN_ADDRESS (); } -/* - comutil_primitive_lexpr_apply is like comutil_primitive_apply - except that it is used to invoke primitives that take - an arbitrary number of arguments. - The number of arguments is in the REGBLOCK_LEXPR_ACTUALS slot - of the register block. - */ +/* comutil_primitive_lexpr_apply is like comutil_primitive_apply + except that it is used to invoke primitives that take an arbitrary + number of arguments. The number of arguments is in the + REGBLOCK_LEXPR_ACTUALS slot of the register block. */ DEFINE_SCHEME_UTILITY_1 (comutil_primitive_lexpr_apply, primitive) { - PRIMITIVE_APPLY (val_register, primitive); - POP_PRIMITIVE_FRAME (((long) (Registers[REGBLOCK_LEXPR_ACTUALS]))); + DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive); + PRIMITIVE_APPLY (primitive); + POP_PRIMITIVE_FRAME (GET_LEXPR_ACTUALS); INVOKE_RETURN_ADDRESS (); } + +/* comutil_error is used by compiled code to signal an error. It + expects the arguments to the error procedure to be pushed on the + stack, and is passed the number of arguments (+ 1). */ + +DEFINE_SCHEME_UTILITY_1 (comutil_error, frame_size) +{ + DECLARE_UTILITY_ARG (unsigned long, frame_size); + TAIL_CALL_2 (comutil_apply, + (VECTOR_REF (fixed_objects, CC_ERROR_PROCEDURE)), + frame_size); +} -/* - comutil_apply is used by compiled code to invoke an unknown - procedure. It dispatches on its type to the correct place. It - expects the procedure to invoke, and the number of arguments (+ 1). - */ +/* comutil_link is used to initialize all the variable cache slots for + a compiled code block. It is called at load time, by the compiled + code itself. It assumes that the return address has been saved on + the stack. If an error occurs during linking, or an interrupt must + be processed (because of the need to GC, etc.), it backs out and + sets up a return code that will invoke comp_link_caches_restart + when the error/interrupt processing is done. */ -DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, nactuals) +DEFINE_SCHEME_UTILITY_4 (comutil_link, + return_addr, + block_addr, + constant_addr, + n_sections) { - SCHEME_OBJECT orig_proc = procedure; + DECLARE_UTILITY_ARG (insn_t *, return_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, block_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, constant_addr); + DECLARE_UTILITY_ARG (unsigned long, n_sections); + link_cc_state_t s; -loop: - switch (OBJECT_TYPE (procedure)) - { - case TC_COMPILED_ENTRY: - callee_is_compiled: - { - instruction * entry_point; + (s.return_address) = return_addr; + (s.block_address) = block_addr; + (s.scan) = constant_addr; + (s.n_sections) = n_sections; + (s.n_linked_sections) = 0; - entry_point = ((instruction *) (OBJECT_ADDRESS (procedure))); - RETURN_UNLESS_EXCEPTION - ((setup_compiled_invocation (nactuals, entry_point)), - entry_point); - } + start_linking_cc_block (); + { + long result = (link_remaining_sections (&s)); + end_linking_cc_block (&s); + if (result != PRIM_DONE) + RETURN_TO_C (result); + } + RETURN_TO_SCHEME (s.return_address); +} - case TC_ENTITY: - { - SCHEME_OBJECT data, operator; - - data = (MEMORY_REF (procedure, ENTITY_DATA)); - if ((VECTOR_P (data)) - && (nactuals < (VECTOR_LENGTH (data))) - && ((VECTOR_REF (data, nactuals)) != SHARP_F) - && ((VECTOR_REF (data, 0)) - == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG)))) - { - /* No loops allowed! */ - SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals)); +/* comp_link_caches_restart is used to continue the linking process + started by comutil_link after the garbage collector has run. */ - if ((procedure == orig_proc) && (nproc != procedure)) - { - procedure = nproc; - goto loop; - } - else - procedure = orig_proc; - } +DEFINE_SCHEME_ENTRY (comp_link_caches_restart) +{ + link_cc_state_t s; + long result; - operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); - if (!(COMPILED_CODE_ADDRESS_P (operator))) - goto callee_is_interpreted; + restore_link_cc_state (&s); + SET_ENV (cc_block_environment (MAKE_CC_BLOCK (s.block_address))); - STACK_PUSH (procedure); /* The entity itself */ - procedure = operator; - nactuals += 1; - goto callee_is_compiled; - } - case TC_PRIMITIVE: - { - /* This code depends on the fact that unimplemented - primitives map into a "fake" primitive which accepts - any number of arguments, thus the arity test will - fail for unimplemented primitives. - */ + start_linking_cc_block (); - long arity; + result = (link_section (&s)); + if (result == PRIM_DONE) + result = (link_remaining_sections (&s)); + + end_linking_cc_block (&s); + if (result != PRIM_DONE) + return (result); - arity = (PRIMITIVE_ARITY (procedure)); - if (arity == ((long) (nactuals - 1))) - TAIL_CALL_1 (comutil_primitive_apply, procedure); + ENTER_SCHEME (s.return_address); +} - if (arity != LEXPR) +static long +link_remaining_sections (link_cc_state_t * s) +{ + while ((s->n_linked_sections) < (s->n_sections)) + { + start_linking_section (s); { - /* Wrong number of arguments. */ - STACK_PUSH (procedure); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS); + long result = (link_section (s)); + if (result != PRIM_DONE) + return (result); } - if (!(IMPLEMENTED_PRIMITIVE_P (procedure))) - /* Let the interpreter handle it. */ - goto callee_is_interpreted; - - /* "Lexpr" primitive. */ - (Registers[REGBLOCK_LEXPR_ACTUALS]) = ((SCHEME_OBJECT) (nactuals - 1)); - TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure); - } - - callee_is_interpreted: - default: - { - STACK_PUSH (procedure); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - RETURN_TO_C (PRIM_APPLY); } - } + return (PRIM_DONE); } -/* - comutil_error is used by compiled code to signal an error. It - expects the arguments to the error procedure to be pushed on the - stack, and is passed the number of arguments (+ 1). -*/ - -DEFINE_SCHEME_UTILITY_1 (comutil_error, nactuals) +static void +start_linking_cc_block (void) { - TAIL_CALL_2 - (comutil_apply, (Get_Fixed_Obj_Slot (Compiler_Err_Procedure)), nactuals); + bool * ap = (dstack_alloc (sizeof (bool))); + (*ap) = linking_cc_block_p; + transaction_begin (); + transaction_record_action (tat_always, abort_linking_cc_block, ap); + linking_cc_block_p = 1; } -/* - comutil_lexpr_apply is invoked to reformat the frame when compiled - code calls a known lexpr. The actual arguments are on the stack, - and it is given the number of arguments (WITHOUT counting the entry - point being invoked), and the real entry point of the procedure. - - Important: This code assumes that it is always invoked with a valid - number of arguments (the compiler checked it), and will not check. - */ - -DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, entry_address_raw, nactuals) +static void +end_linking_cc_block (link_cc_state_t * s) { - instruction * entry_address - = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_address_raw))); - - RETURN_UNLESS_EXCEPTION - ((setup_lexpr_invocation - ((nactuals + 1), - (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)), - entry_address)), - entry_address); + transaction_commit (); + update_cache_after_link (s); } - -static long -DEFUN (compiler_link_closure_pattern, (distance, block, offset), - SCHEME_OBJECT distance AND - SCHEME_OBJECT block AND - unsigned long offset) -{ - long objdist = (FIXNUM_TO_LONG (distance)); - long nmv_length = (OBJECT_DATUM (MEMORY_REF (block, 1))); - SCHEME_OBJECT * location = (MEMORY_LOC (block, offset)); - SCHEME_OBJECT * closptr = (location - objdist); - SCHEME_OBJECT * end_closptr = (MEMORY_LOC (block, (2 + nmv_length))); - SCHEME_OBJECT entry_offset, * area_end; - char * word_ptr; - long count; - - nmv_length -= (end_closptr - closptr); - while (closptr < end_closptr) - { - while ((* closptr) == ((SCHEME_OBJECT) 0)) - closptr ++; - closptr ++; - count = (MANIFEST_CLOSURE_COUNT (closptr)); - word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (closptr)); - area_end = ((MANIFEST_CLOSURE_END (closptr, count)) - 1); - while ((--count) >= 0) - { - closptr = ((SCHEME_OBJECT *) word_ptr); - word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); - EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr); - entry_offset = ((SCHEME_OBJECT) - (((long) closptr) - ((long) entry_offset))); - STORE_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr); - } - closptr = &area_end[1]; - } - MEMORY_SET (block, 1, (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length))); - return (PRIM_DONE); +static void +abort_linking_cc_block (void * ap) +{ + linking_cc_block_p = (* ((bool *) (ap))); } -static Boolean linking_cc_block_p = false; - static void -DEFUN (abort_link_cc_block, (ap), PTR ap) +update_cache_after_link (link_cc_state_t * s) { - linking_cc_block_p = (* ((Boolean *) (ap))); - return; +#if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION) + SCHEME_OBJECT * addr = (s->block_address); + if ((cc_entry_address_to_block_address (s->return_address)) == addr) +#ifdef FLUSH_I_CACHE_REGION + FLUSH_I_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr))); +#else + ; +#endif + else +#ifdef PUSH_D_CACHE_REGION + PUSH_D_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr))); +#else + ; +#endif +#endif } - -/* Core of comutil_link and comp_link_caches_restart. */ - -static long -DEFUN (link_cc_block, - (block_address, offset, last_header_offset, - sections, original_count, ret_add), - SCHEME_OBJECT * block_address AND - unsigned long offset AND - unsigned long last_header_offset AND - long sections AND - long original_count AND - instruction * ret_add) -{ - Boolean execute_p = false; - register long entry_size, count; - SCHEME_OBJECT block; - SCHEME_OBJECT header; - long result, kind, total_count; - long EXFUN ((*cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long)); - - transaction_begin (); - { - Boolean * ap = (dstack_alloc (sizeof (Boolean))); - *ap = linking_cc_block_p; - transaction_record_action (tat_abort, abort_link_cc_block, ap); - } - linking_cc_block_p = true; - result = PRIM_DONE; - block = (MAKE_CC_BLOCK (block_address)); - - while ((--sections) >= 0) +static void +start_linking_section (link_cc_state_t * s) +{ + (s->scan0) = (s->scan); + (s->n_linked_entries) = 0; { - SCHEME_OBJECT * scan = &(block_address[last_header_offset]); - header = (*scan); + SCHEME_OBJECT header = (*(s->scan)++); + (s->type) = (linkage_section_type (header)); + (s->n_entries) = (linkage_section_count (header)); + } +} - kind = (READ_LINKAGE_KIND (header)); - switch (kind) +static long +link_section (link_cc_state_t * s) +{ + SCHEME_OBJECT * scan1 = ((s->scan0) + 1); + SCHEME_OBJECT * scan = (s->scan); + SCHEME_OBJECT * block_address = (s->block_address); + unsigned long n_linked = (s->n_linked_entries); + unsigned long n_entries = (s->n_entries); + cache_handler_t * handler; + bool execute_p; + unsigned long entry_size; + long result = PRIM_DONE; + DECLARE_RELOCATION_REFERENCE (ref); + + if (!link_section_handler ((s->type), (&handler), (&execute_p))) { - case OPERATOR_LINKAGE_KIND: - cache_handler = compiler_cache_operator; - - handle_operator: - execute_p = true; - entry_size = EXECUTE_CACHE_ENTRY_SIZE; - START_OPERATOR_RELOCATION (scan); - count = (READ_OPERATOR_LINKAGE_COUNT (header)); - break; - - case GLOBAL_OPERATOR_LINKAGE_KIND: - cache_handler = compiler_cache_global_operator; - goto handle_operator; - - case ASSIGNMENT_LINKAGE_KIND: - cache_handler = compiler_cache_assignment; - goto handle_reference; - - case REFERENCE_LINKAGE_KIND: - cache_handler = compiler_cache_lookup; - handle_reference: - execute_p = false; - entry_size = 1; - count = (READ_CACHE_LINKAGE_COUNT (header)); - break; - - case CLOSURE_PATTERN_LINKAGE_KIND: - cache_handler = compiler_link_closure_pattern; - /* Not really a reference, but the same format. */ - goto handle_reference; - - default: - offset += 1; - total_count = (READ_CACHE_LINKAGE_COUNT (header)); - count = (total_count - 1); - result = ERR_COMPILED_CODE_ERROR; - goto back_out; + result = ERR_COMPILED_CODE_ERROR; + goto done; } - /* This accomodates the re-entry case after a GC. - It undoes the effects of the "smash header" code below. - */ - - if ((OBJECT_TYPE (header)) == TC_LINKAGE_SECTION) + if (execute_p) { - count = (original_count - count); - total_count = original_count; - } - else - { - total_count = count; - if (execute_p) - offset += (FIRST_OPERATOR_LINKAGE_OFFSET - 1); - } - - block_address[last_header_offset] = - (MAKE_LINKAGE_SECTION_HEADER (kind, total_count)); - for (offset += 1; ((--count) >= 0); offset += entry_size) - { - SCHEME_OBJECT info; /* A symbol or a fixnum */ - - if (! execute_p) - info = (block_address[offset]); + /* Hair: START_OPERATOR_RELOCATION requires scan to be pointing + to the first word after the header. Also, it might move scan + forward. If we are just starting the link, just use scan as + the argument and let it be changed. If we are restarting, we + need to use use a temporary variable that points to the right + place. */ + if (n_linked == 0) + START_OPERATOR_RELOCATION (scan, ref); else - EXTRACT_EXECUTE_CACHE_SYMBOL (info, &(block_address[offset])); + START_OPERATOR_RELOCATION (scan1, ref); + entry_size = UUO_LINK_SIZE; + } + else + entry_size = 1; - result = ((*cache_handler) (info, block, offset)); + while (n_linked < n_entries) + { + result = ((*handler) ((execute_p + ? (read_uuo_symbol (scan)) + : (*scan)), + (MAKE_CC_BLOCK (block_address)), + (scan - block_address))); if (result != PRIM_DONE) - { - /* Save enough state to continue. - Note that offset is decremented to compensate for it being - incremented by the for loop header. - Similary sections and count are incremented to compensate - for loop headers pre-decrementing. - count is saved although it's not needed for re-entry to - match the assembly language versions. - */ - - back_out: - if (execute_p) - END_OPERATOR_RELOCATION (&(block_address[offset])); - STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (sections + 1)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (last_header_offset)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (offset - 1)); - STACK_PUSH (block); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (count + 1)); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (total_count)); - - exp_register = SHARP_F; - Store_Return (RC_COMP_LINK_CACHES_RESTART); - Save_Cont (); - - /* Smash header for the garbage collector. - It is smashed back on return. See the comment above. - */ - - block_address[last_header_offset] = - (MAKE_LINKAGE_SECTION_HEADER (kind, (total_count - (count + 1)))); - goto exit_proc; - } + break; + scan += entry_size; + n_linked += 1; } - if (execute_p) - END_OPERATOR_RELOCATION (&(block_address[offset - 1])); - last_header_offset = offset; - } -exit_proc: - /* Rather than commit, since we want to undo */ - transaction_abort (); -#if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION) - { - SCHEME_OBJECT * ret_add_block; - unsigned long block_len = (((unsigned long) (* block_address)) + 1); - - Get_Compiled_Block (ret_add_block, ((SCHEME_OBJECT *) ret_add)); - if (ret_add_block == block_address) - { -#ifdef FLUSH_I_CACHE_REGION - FLUSH_I_CACHE_REGION (block_address, block_len); -#endif - } - else - { -#ifdef PUSH_D_CACHE_REGION - PUSH_D_CACHE_REGION (block_address, block_len); -#endif - } - } -#endif + done: + /* If we failed on the first entry, back scan up to where it was + before START_OPERATOR_RELOCATION possibly changed it. */ + (s->scan) = ((n_linked == 0) ? scan1 : scan); + (s->n_linked_entries) = n_linked; + (* (s->scan0)) = (make_linkage_section_marker ((s->type), n_linked)); + if (result == PRIM_DONE) + (s->n_linked_sections) += 1; + else + back_out_of_link_section (s); return (result); } -/* - comutil_link is used to initialize all the variable cache slots for - a compiled code block. It is called at load time, by the compiled - code itself. It assumes that the return address has been saved on - the stack. - If an error occurs during linking, or an interrupt must be processed - (because of the need to GC, etc.), it backs out and sets up a return - code that will invoke comp_link_caches_restart when the error/interrupt - processing is done. -*/ - -DEFINE_SCHEME_UTILITY_4 (comutil_link, ret_add_raw, block_address_raw, - constant_address_raw, sections) +static bool +link_section_handler (linkage_section_type_t type, + cache_handler_t ** handler_r, + bool * execute_p_r) { - instruction * ret_add - = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); - SCHEME_OBJECT * block_address - = (SCHEME_ADDR_TO_ADDR (block_address_raw)); - SCHEME_OBJECT * constant_address - = (SCHEME_ADDR_TO_ADDR (constant_address_raw)); - unsigned long offset; - -#ifdef AUTOCLOBBER_BUG - block_address[OBJECT_DATUM (* block_address)] = env_register; -#endif + switch (type) + { + case LINKAGE_SECTION_TYPE_OPERATOR: + (*handler_r) = compiler_cache_operator; + (*execute_p_r) = true; + return (true); + + case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR: + (*handler_r) = compiler_cache_global_operator; + (*execute_p_r) = true; + return (true); + + case LINKAGE_SECTION_TYPE_REFERENCE: + (*handler_r) = compiler_cache_lookup; + (*execute_p_r) = false; + return (true); + + case LINKAGE_SECTION_TYPE_ASSIGNMENT: + (*handler_r) = compiler_cache_assignment; + (*execute_p_r) = false; + return (true); - offset = (constant_address - block_address); - - RETURN_UNLESS_EXCEPTION - ((link_cc_block (block_address, - offset, - offset, - sections, - -1, - ret_add)), - ret_add); -} - -/* - comp_link_caches_restart is used to continue the linking process - started by comutil_link after the garbage collector has run. - It expects the top of the stack to be as left by link_cc_block. - */ - -C_TO_SCHEME long -DEFUN_VOID (comp_link_caches_restart) -{ - SCHEME_OBJECT block, environment; - long original_count, sections, code; - unsigned long offset; - unsigned long last_header_offset; - instruction * ret_add; - - original_count = (OBJECT_DATUM (STACK_POP())); - (void) STACK_POP (); /* Loop count, for debugger */ - block = (STACK_POP ()); - environment = (compiled_block_environment (block)); - env_register = environment; - offset = (OBJECT_DATUM (STACK_POP ())); - last_header_offset = (OBJECT_DATUM (STACK_POP ())); - sections = (OBJECT_DATUM (STACK_POP ())); - ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))); - code = (link_cc_block ((OBJECT_ADDRESS (block)), - offset, - last_header_offset, - sections, - original_count, - ret_add)); - if (code == PRIM_DONE) - /* Return to the block being linked. */ - ENTER_SCHEME (ret_add); - else - { - /* Another GC or error. We should be ready for back-out. */ - return (code); - } + default: + return (false); + } } - -/* TRAMPOLINE code - When a free variable appears in operator position in compiled code, - there must be a directly callable procedure in the corresponding - execute cache cell. If, at link time, there is no appropriate - value for the free variable, a fake compiled Scheme procedure that - calls one of these procedures will be placed into the cell instead. - - The trampolines themselves are made by make_uuo_link, - make_fake_uuo_link, and coerce_to_compiled. The trampoline looks - like a Scheme closure, containing some code to jump to one of - these procedures and additional information to be used by the - procedure. - - These procedures expect a single argument, the address of the - information block where they can find the relevant data, typically - the procedure to invoke and the number of arguments to invoke it - with. -*/ -DEFINE_SCHEME_UTILITY_1 (comutil_operator_apply_trap, tramp_data_raw) +static void +back_out_of_link_section (link_cc_state_t * s) { - /* Used by coerce_to_compiled. TRAMPOLINE_K_APPLY */ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1]))); + /* Save enough state to restart. */ + STACK_PUSH (MAKE_CC_ENTRY (s->return_address)); + STACK_PUSH (ULONG_TO_FIXNUM ((s->n_sections) - (s->n_linked_sections))); + STACK_PUSH (ULONG_TO_FIXNUM ((s->scan0) - (s->block_address))); + STACK_PUSH (ULONG_TO_FIXNUM ((s->scan) - (s->block_address))); + STACK_PUSH (MAKE_CC_BLOCK (s->block_address)); + STACK_PUSH (ULONG_TO_FIXNUM ((s->n_entries) - (s->n_linked_entries))); + STACK_PUSH (ULONG_TO_FIXNUM (s->n_entries)); + SAVE_LAST_RETURN_CODE (RC_COMP_LINK_CACHES_RESTART); } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_arity_trap, tramp_data_raw) +static void +restore_link_cc_state (link_cc_state_t * s) { - /* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1]))); -} + RESTORE_LAST_RETURN_CODE (); + (s->n_entries) = (OBJECT_DATUM (STACK_POP ())); + (s->n_linked_entries) = ((s->n_entries) - (OBJECT_DATUM (STACK_POP ()))); + (s->block_address) = (OBJECT_ADDRESS (STACK_POP ())); + (s->scan) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ()))); + (s->scan0) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ()))); + (s->n_sections) = (OBJECT_DATUM (STACK_POP ())); + (s->return_address) = (CC_ENTRY_ADDRESS (STACK_POP ())); -DEFINE_SCHEME_UTILITY_1 (comutil_operator_entity_trap, tramp_data_raw) -{ - /* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1]))); + (s->n_linked_sections) = 0; + (s->type) = (linkage_section_type (* (s->scan0))); } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_interpreted_trap, tramp_data_raw) -{ - /* Linker saw an interpreted procedure or a procedure that it cannot - link directly. TRAMPOLINE_K_INTERPRETED */ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1]))); -} +/* Interrupt/GC from Scheme + + These procedures are called from compiled code at the start + (respectively) of a procedure or continuation if an interrupt has + been detected. They must not be called unless there is an + interrupt to be serviced. + + The code that handles RC_COMP_INTERRUPT_RESTART in "interp.c" will + return control to comp_interrupt_restart (below). This assumes + that the Scheme stack contains a compiled code entry address (start + of continuation, procedure, etc.). The GET_EXP saved with the + continuation is a piece of state that will be returned to + GET_VAL and GET_ENV (both) upon return. */ -DEFINE_SCHEME_UTILITY_1 (comutil_operator_lexpr_trap, tramp_data_raw) +DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure) { - /* Linker saw a primitive of arbitrary number of arguments. - TRAMPOLINE_K_LEXPR_PRIMITIVE */ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - (Registers[REGBLOCK_LEXPR_ACTUALS]) = - ((SCHEME_OBJECT) ((OBJECT_DATUM (tramp_data[1])) - 1)); - TAIL_CALL_1 (comutil_primitive_lexpr_apply, (tramp_data[0])); + compiler_interrupt_common (DSU_result, 0, SHARP_F); } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_primitive_trap, tramp_data_raw) +DEFINE_SCHEME_UTILITY_2 (comutil_interrupt_dlink, entry_point, dlink) { - /* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - TAIL_CALL_1 (comutil_primitive_apply, (tramp_data[0])); + DECLARE_UTILITY_ARG (insn_t *, entry_point); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, dlink); + compiler_interrupt_common (DSU_result, + entry_point, + (MAKE_CC_STACK_ENV (dlink))); } - -/* The linker either couldn't find a binding or the binding was - unassigned, unbound, or a deep-bound (parallel processor) fluid. - This must report the correct name of the missing variable and the - environment in which the lookup begins for the error cases, or do - the correct deep reference for fluids. - - "extension" is the linker object corresponding to the operator - variable (it contains the actual value cell, the name, and linker - tables). code_block and offset point to the cache cell in question. - tramp_data contains extension, code_block, offset. TRAMPOLINE_K_LOOKUP -*/ -DEFINE_SCHEME_UTILITY_1 (comutil_operator_lookup_trap, tramp_data_raw) -{ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - SCHEME_OBJECT cache = (tramp_data[0]); - SCHEME_OBJECT block = (tramp_data[1]); - unsigned long offset = (OBJECT_DATUM (tramp_data[2])); - SCHEME_OBJECT true_operator; - long code - = (compiler_operator_reference_trap (cache, (&true_operator))); - SCHEME_OBJECT * cache_cell = (MEMORY_LOC (block, offset)); - long nargs; - - EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell); - if (code == PRIM_DONE) - TAIL_CALL_2 (comutil_apply, true_operator, nargs); - /* Error or interrupt */ - { - SCHEME_OBJECT trampoline; - - /* This could be done by bumping tramp_data to the entry point. - It would probably be better. */ - EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell); - STACK_PUSH (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (trampoline))); - /* Next three for debugger. */ - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs)); - STACK_PUSH (compiled_block_environment (block)); - STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR)); - exp_register = SHARP_F; - Store_Return (RC_COMP_OP_REF_TRAP_RESTART); - Save_Cont (); - RETURN_TO_C (code); - } +DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_procedure, entry_point) +{ + DECLARE_UTILITY_ARG (insn_t *, entry_point); + compiler_interrupt_common (DSU_result, entry_point, SHARP_F); } -/* - Re-start after processing an error/interrupt encountered in the previous - utility. - Extract the new trampoline or procedure (the user may have defined the - missing variable) and invoke it. - */ +/* GET_VAL has live data, and there is no entry address on the stack */ -C_TO_SCHEME long -DEFUN_VOID (comp_op_lookup_trap_restart) +DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_addr) { - SCHEME_OBJECT * old_trampoline, code_block, new_procedure; - long offset; + DECLARE_UTILITY_ARG (insn_t *, return_addr); + compiler_interrupt_common (DSU_result, return_addr, GET_VAL); +} - /* Discard name, env. and nargs */ +/* GET_ENV has live data; no entry point on the stack */ - sp_register = (STACK_LOC (3)); - old_trampoline = (OBJECT_ADDRESS (STACK_POP ())); - code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]); - offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2])); - EXTRACT_EXECUTE_CACHE_ADDRESS (new_procedure, - (MEMORY_LOC (code_block, offset))); - ENTER_SCHEME (SCHEME_ADDR_TO_ADDR (new_procedure)); +DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point) +{ + DECLARE_UTILITY_ARG (insn_t *, entry_point); + compiler_interrupt_common (DSU_result, entry_point, GET_ENV); } - -/* ARITY Mismatch handling - These receive the entry point as an argument and must fill the - Scheme stack with the missing default values. - They are invoked by TRAMPOLINE_K_n_m where n and m are the same - as in the name of the procedure. - The single item of information in the trampoline data area is - the real procedure to invoke. All the arguments are on the - Scheme stack. - */ -DEFINE_SCHEME_UTILITY_1 (comutil_operator_1_0_trap, tramp_data_raw) +DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2) { - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); + compiler_interrupt_common (DSU_result, 0, GET_VAL); +} - STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); +void +compiler_interrupt_common (utility_result_t * DSU_result, + insn_t * address, + SCHEME_OBJECT state) +{ + if (!FREE_OK_P (Free)) + REQUEST_GC (Free - heap_alloc_limit); + STACK_CHECK (0); + if (address != 0) + STACK_PUSH (MAKE_CC_ENTRY (address)); + STACK_PUSH (state); + SAVE_LAST_RETURN_CODE (RC_COMP_INTERRUPT_RESTART); + RETURN_TO_C (PRIM_INTERRUPT); } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_2_1_trap, tramp_data_raw) +DEFINE_SCHEME_ENTRY (comp_interrupt_restart) { - SCHEME_OBJECT Top; - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - Top = (STACK_POP ()); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (Top); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); + RESTORE_LAST_RETURN_CODE (); + { + SCHEME_OBJECT state = (STACK_POP ()); + SET_ENV (state); + SET_VAL (state); + } + JUMP_TO_CC_ENTRY (STACK_POP ()); } + +/* Other traps */ -DEFINE_SCHEME_UTILITY_1 (comutil_operator_2_0_trap, tramp_data_raw) -{ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); +/* Assigning a variable that contains a trap. */ - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); +DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap, + ret_addr, cache_addr, new_val) +{ + DECLARE_UTILITY_ARG (insn_t *, ret_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT, new_val); + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr)); + SCHEME_OBJECT old_val; + long code = (compiler_assignment_trap (cache, new_val, (&old_val))); + if (code != PRIM_DONE) + { + SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr)); + SCHEME_OBJECT block = (cc_entry_to_block (sra)); + STACK_PUSH (sra); + STACK_PUSH (new_val); + STACK_PUSH (cc_block_environment (block)); + STACK_PUSH + (compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT)); + SAVE_LAST_RETURN_CODE (RC_COMP_ASSIGNMENT_TRAP_RESTART); + RETURN_TO_C (code); + } + SET_VAL (old_val); + RETURN_TO_SCHEME (ret_addr); } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_2_trap, tramp_data_raw) +DEFINE_SCHEME_ENTRY (comp_assignment_trap_restart) { - SCHEME_OBJECT Top, Next; - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - Top = (STACK_POP ()); - Next = (STACK_POP ()); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (Next); - STACK_PUSH (Top); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); + RESTORE_LAST_RETURN_CODE (); + { + SCHEME_OBJECT name = (STACK_POP ()); + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT new_val = (STACK_POP ()); + SCHEME_OBJECT old_val; + long code = (assign_variable (environment, name, new_val, (&old_val))); + if (code != PRIM_DONE) + { + STACK_PUSH (new_val); + STACK_PUSH (environment); + STACK_PUSH (name); + SAVE_LAST_RETURN_CODE (RC_COMP_ASSIGNMENT_TRAP_RESTART); + return (code); + } + SET_VAL (old_val); + JUMP_TO_CC_ENTRY (STACK_POP ()); + } } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_1_trap, tramp_data_raw) +DEFINE_SCHEME_UTILITY_3 (comutil_cache_lookup_apply, + cache_addr, block_addr, frame_size) { - SCHEME_OBJECT Top; - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - Top = (STACK_POP ()); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (Top); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, block_addr); + DECLARE_UTILITY_ARG (unsigned long, frame_size); + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr)); + SCHEME_OBJECT value; + long code = (compiler_lookup_trap (cache, (&value))); + if (code != PRIM_DONE) + { + SCHEME_OBJECT block = (MAKE_CC_BLOCK (block_addr)); + STACK_PUSH (block); + STACK_PUSH (ULONG_TO_FIXNUM (frame_size)); + STACK_PUSH (cc_block_environment (block)); + STACK_PUSH + (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR)); + SAVE_LAST_RETURN_CODE (RC_COMP_CACHE_REF_APPLY_RESTART); + RETURN_TO_C (code); + } + TAIL_CALL_2 (comutil_apply, value, frame_size); } -DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_0_trap, tramp_data_raw) +DEFINE_SCHEME_ENTRY (comp_cache_lookup_apply_restart) { - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); -} - -DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_3_trap, tramp_data_raw) -{ - SCHEME_OBJECT Top, Middle, Bottom; - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - Top = (STACK_POP ()); - Middle = (STACK_POP ()); - Bottom = (STACK_POP ()); - - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (Bottom); - STACK_PUSH (Middle); - STACK_PUSH (Top); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); -} - -DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_2_trap, tramp_data_raw) -{ - SCHEME_OBJECT Top, Next; - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - Top = (STACK_POP ()); - Next = (STACK_POP ()); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (Next); - STACK_PUSH (Top); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); -} - -DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_1_trap, tramp_data_raw) -{ - SCHEME_OBJECT Top; - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - - Top = (STACK_POP ()); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (Top); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); -} - -DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_0_trap, tramp_data_raw) -{ - SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw)); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0])); + RESTORE_LAST_RETURN_CODE (); + { + SCHEME_OBJECT name = (STACK_POP ()); + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT frame_size = (STACK_POP ()); + SCHEME_OBJECT block = (STACK_POP ()); + SCHEME_OBJECT value; + { + long code = (lookup_variable (environment, name, (&value))); + if (code != PRIM_DONE) + { + STACK_PUSH (block); + STACK_PUSH (frame_size); + STACK_PUSH (environment); + STACK_PUSH (name); + SAVE_LAST_RETURN_CODE (RC_COMP_CACHE_REF_APPLY_RESTART); + return (code); + } + } + STACK_PUSH (value); + PUSH_APPLY_FRAME_HEADER ((FIXNUM_TO_ULONG (frame_size)) - 1); + if (CC_ENTRY_P (value)) + return (apply_compiled_procedure ()); + guarantee_interp_return (); + return (PRIM_APPLY); + } } -/* INTERRUPT/GC from Scheme - - These procedures are called from compiled code at the start - (respectively) of a procedure or continuation if an interrupt has - been detected. They must not be called unless there is an - interrupt to be serviced. - - The code that handles RC_COMP_INTERRUPT_RESTART in "interp.c" will - return control to comp_interrupt_restart (below). This assumes - that the Scheme stack contains a compiled code entry address - (start of continuation, procedure, etc.). The exp_register - saved with the continuation is a piece of state that will be - returned to val_register and env_register (both) upon return. - */ - -#define MAYBE_REQUEST_INTERRUPTS() \ -{ \ - if (Free >= MemTop) \ - Request_GC (Free - MemTop); \ - if (sp_register <= Stack_Guard) \ - REQUEST_INTERRUPT (INT_Stack_Overflow); \ -} +/* Variable reference traps: + Reference to a free variable that contains a reference trap. */ -static void -DEFUN (compiler_interrupt_common, (DSU_result, entry_point_raw, state), - utility_result * DSU_result - AND SCHEME_ADDR entry_point_raw - AND SCHEME_OBJECT state) +DEFINE_SCHEME_UTILITY_2 (comutil_lookup_trap, ret_addr, cache_addr) { - MAYBE_REQUEST_INTERRUPTS (); - if (entry_point_raw != ((SCHEME_ADDR) 0)) + DECLARE_UTILITY_ARG (insn_t *, ret_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr); + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr)); + SCHEME_OBJECT val; + long code = (compiler_lookup_trap (cache, (&val))); + if (code != PRIM_DONE) { - instruction * entry_point - = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw))); - STACK_PUSH (ENTRY_TO_OBJECT (entry_point)); + SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr)); + SCHEME_OBJECT block = (cc_entry_to_block (sra)); + STACK_PUSH (sra); + STACK_PUSH (cc_block_environment (block)); + STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP)); + SAVE_LAST_RETURN_CODE (RC_COMP_LOOKUP_TRAP_RESTART); + RETURN_TO_C (code); } - STACK_PUSH (state); - exp_register = SHARP_F; - Store_Return (RC_COMP_INTERRUPT_RESTART); - Save_Cont (); - RETURN_TO_C (PRIM_INTERRUPT); -} - -DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure) -{ - COMPILER_INTERRUPT_COMMON (0, SHARP_F); -} - -DEFINE_SCHEME_UTILITY_2 (comutil_interrupt_dlink, entry_point_raw, dlink_raw) -{ - SCHEME_OBJECT * dlink = (SCHEME_ADDR_TO_ADDR (dlink_raw)); - COMPILER_INTERRUPT_COMMON - (((PTR) entry_point_raw), - (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, dlink))); -} - -DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_procedure, entry_point_raw) -{ - COMPILER_INTERRUPT_COMMON (((PTR) entry_point_raw), SHARP_F); -} - -/* val_register has live data, and there is no entry address on the stack */ - -DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_address_raw) -{ - COMPILER_INTERRUPT_COMMON (((PTR) return_address_raw), val_register); -} - -/* env_register has live data; no entry point on the stack */ - -DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point_raw) -{ - COMPILER_INTERRUPT_COMMON (((PTR) entry_point_raw), env_register); + SET_VAL (val); + RETURN_TO_SCHEME (ret_addr); } -DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2) +DEFINE_SCHEME_ENTRY (comp_lookup_trap_restart) { - COMPILER_INTERRUPT_COMMON (0, val_register); + RESTORE_LAST_RETURN_CODE (); + { + SCHEME_OBJECT name = GET_EXP; + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT val; + long code = (lookup_variable (environment, name, (&val))); + if (code != PRIM_DONE) + { + STACK_PUSH (environment); + STACK_PUSH (name); + SAVE_LAST_RETURN_CODE (RC_COMP_LOOKUP_TRAP_RESTART); + return (code); + } + SET_VAL (val); + JUMP_TO_CC_ENTRY (STACK_POP ()); + } } -C_TO_SCHEME long -DEFUN_VOID (comp_interrupt_restart) +DEFINE_SCHEME_UTILITY_2 (comutil_safe_lookup_trap, ret_addr, cache_addr) { - SCHEME_OBJECT state = (STACK_POP ()); - env_register = state; - val_register = state; - ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); -} - -/* Other TRAPS */ - -/* Assigning a variable that has a trap in it (except unassigned) */ - -DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap, - return_address_raw, cache_addr_raw, value) -{ - instruction * return_address - = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); - SCHEME_OBJECT cache - = (MAKE_POINTER_OBJECT - (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); - long code = (compiler_assignment_trap (cache, value, (&val_register))); - if (code == PRIM_DONE) - RETURN_TO_SCHEME (return_address); - else + DECLARE_UTILITY_ARG (insn_t *, ret_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr); + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr)); + SCHEME_OBJECT val; + long code = (compiler_safe_lookup_trap (cache, (&val))); + if (code != PRIM_DONE) { - SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); - SCHEME_OBJECT block = (compiled_entry_to_block (sra)); + SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr)); + SCHEME_OBJECT block = (cc_entry_to_block (sra)); STACK_PUSH (sra); - STACK_PUSH (value); - STACK_PUSH (compiled_block_environment (block)); - STACK_PUSH - (compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT)); - exp_register = SHARP_F; - Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); - Save_Cont (); + STACK_PUSH (cc_block_environment (block)); + STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP)); + SAVE_LAST_RETURN_CODE (RC_COMP_SAFE_REF_TRAP_RESTART); RETURN_TO_C (code); } + SET_VAL (val); + RETURN_TO_SCHEME (ret_addr); } -C_TO_SCHEME long -DEFUN_VOID (comp_assignment_trap_restart) +DEFINE_SCHEME_ENTRY (comp_safe_lookup_trap_restart) { - SCHEME_OBJECT name = (STACK_POP ()); - SCHEME_OBJECT environment = (STACK_POP ()); - SCHEME_OBJECT value = (STACK_POP ()); - long code = (assign_variable (environment, name, value, (&val_register))); - if (code == PRIM_DONE) - ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); - else - { - STACK_PUSH (value); - STACK_PUSH (environment); - STACK_PUSH (name); - exp_register = SHARP_F; - Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART); - Save_Cont (); - return (code); - } -} - -DEFINE_SCHEME_UTILITY_3 (comutil_cache_lookup_apply, - cache_addr_raw, block_address_raw, nactuals) -{ - SCHEME_OBJECT cache - = (MAKE_POINTER_OBJECT - (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); - SCHEME_OBJECT value; - long code = (compiler_lookup_trap (cache, (&value))); - if (code == PRIM_DONE) - TAIL_CALL_2 (comutil_apply, value, nactuals); + RESTORE_LAST_RETURN_CODE (); { - SCHEME_OBJECT block - = (MAKE_CC_BLOCK (SCHEME_ADDR_TO_ADDR (block_address_raw))); - STACK_PUSH (block); - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - STACK_PUSH (compiled_block_environment (block)); - STACK_PUSH - (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR)); - exp_register = SHARP_F; - Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART); - Save_Cont (); - RETURN_TO_C (code); + SCHEME_OBJECT name = GET_EXP; + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT val; + long code = (safe_lookup_variable (environment, name, (&val))); + if (code != PRIM_DONE) + { + STACK_PUSH (environment); + STACK_PUSH (name); + SAVE_LAST_RETURN_CODE (RC_COMP_SAFE_REF_TRAP_RESTART); + return (code); + } + SET_VAL (val); + JUMP_TO_CC_ENTRY (STACK_POP ()); } } -C_TO_SCHEME long -DEFUN_VOID (comp_cache_lookup_apply_restart) +DEFINE_SCHEME_UTILITY_2 (comutil_unassigned_p_trap, ret_addr, cache_addr) { - SCHEME_OBJECT name = (STACK_POP ()); - SCHEME_OBJECT environment = (STACK_POP ()); - SCHEME_OBJECT value; - long code = (lookup_variable (environment, name, (&value))); - if (code == PRIM_DONE) - { - /* Replace block with actual operator */ - (* (STACK_LOC (1))) = value; - if (COMPILED_CODE_ADDRESS_P (value)) - return (apply_compiled_procedure ()); - else - return (PRIM_APPLY); - } - else + DECLARE_UTILITY_ARG (insn_t *, ret_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, cache_addr); + SCHEME_OBJECT cache = (MAKE_POINTER_OBJECT (CACHE_TYPE, cache_addr)); + SCHEME_OBJECT val; + long code = (compiler_unassigned_p_trap (cache, (&val))); + if (code != PRIM_DONE) { - STACK_PUSH (environment); - STACK_PUSH (name); - exp_register = SHARP_F; - Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART); - Save_Cont (); - return (code); + SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr)); + SCHEME_OBJECT block = (cc_entry_to_block (sra)); + STACK_PUSH (sra); + STACK_PUSH (cc_block_environment (block)); + STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP)); + SAVE_LAST_RETURN_CODE (RC_COMP_UNASSIGNED_TRAP_RESTART); + RETURN_TO_C (code); } + SET_VAL (val); + RETURN_TO_SCHEME (ret_addr); } - -/* Variable reference traps: - Reference to a free variable that has a reference trap -- either a - fluid or an error (unassigned / unbound). */ -#define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup) \ -DEFINE_SCHEME_UTILITY_2 (name, return_address_raw, cache_addr_raw) \ -{ \ - instruction * return_address \ - = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); \ - SCHEME_OBJECT cache \ - = (MAKE_POINTER_OBJECT \ - (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw)))); \ - long code = (c_trap (cache, (&val_register))); \ - if (code == PRIM_DONE) \ - RETURN_TO_SCHEME (return_address); \ - else \ - { \ - SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address)); \ - SCHEME_OBJECT block = (compiled_entry_to_block (sra)); \ - STACK_PUSH (sra); \ - STACK_PUSH (compiled_block_environment (block)); \ - STACK_PUSH \ - (compiler_var_error \ - (cache, block, CACHE_REFERENCES_LOOKUP)); \ - exp_register = SHARP_F; \ - Store_Return (ret_code); \ - Save_Cont (); \ - RETURN_TO_C (code); \ - } \ -} \ - \ -C_TO_SCHEME long \ -DEFUN_VOID (restart) \ -{ \ - SCHEME_OBJECT name = (STACK_POP ()); \ - SCHEME_OBJECT environment = (STACK_POP ()); \ - long code = (c_lookup (environment, name, (&val_register))); \ - if (code == PRIM_DONE) \ - ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \ - else \ - { \ - STACK_PUSH (environment); \ - STACK_PUSH (name); \ - exp_register = SHARP_F; \ - Store_Return (ret_code); \ - Save_Cont (); \ - return (code); \ - } \ +DEFINE_SCHEME_ENTRY (comp_unassigned_p_trap_restart) +{ + RESTORE_LAST_RETURN_CODE (); + { + SCHEME_OBJECT name = GET_EXP; + SCHEME_OBJECT environment = (STACK_POP ()); + SCHEME_OBJECT val; + long code = (variable_unassigned_p (environment, name, (&val))); + if (code != PRIM_DONE) + { + STACK_PUSH (environment); + STACK_PUSH (name); + SAVE_LAST_RETURN_CODE (RC_COMP_UNASSIGNED_TRAP_RESTART); + return (code); + } + SET_VAL (val); + JUMP_TO_CC_ENTRY (STACK_POP ()); + } } -/* Actual traps */ - -CMPLR_REF_TRAP(comutil_lookup_trap, - compiler_lookup_trap, - RC_COMP_LOOKUP_TRAP_RESTART, - comp_lookup_trap_restart, - lookup_variable) +/* Numeric routines -CMPLR_REF_TRAP(comutil_safe_lookup_trap, - compiler_safe_lookup_trap, - RC_COMP_SAFE_REF_TRAP_RESTART, - comp_safe_lookup_trap_restart, - safe_lookup_variable) - -CMPLR_REF_TRAP(comutil_unassigned_p_trap, - compiler_unassigned_p_trap, - RC_COMP_UNASSIGNED_TRAP_RESTART, - comp_unassigned_p_trap_restart, - variable_unassigned_p) - - -/* NUMERIC ROUTINES - Invoke the arithmetic primitive in the fixed objects vector. - The Scheme arguments are expected on the Scheme stack. - */ + Invoke the arithmetic primitive in the fixed objects vector. The + Scheme arguments are expected on the Scheme stack. */ #define COMPILER_ARITH_PRIM(name, fobj_index, arity) \ DEFINE_SCHEME_UTILITY_0 (name) \ { \ TAIL_CALL_2 \ - (comutil_apply, (Get_Fixed_Obj_Slot (fobj_index)), (arity)); \ + (comutil_apply, (VECTOR_REF (fixed_objects, fobj_index)), (arity)); \ } COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2) @@ -1881,2040 +1418,1408 @@ COMPILER_ARITH_PRIM (comutil_positive, GENERIC_TRAMPOLINE_POSITIVE_P, 2) COMPILER_ARITH_PRIM (comutil_quotient, GENERIC_TRAMPOLINE_QUOTIENT, 3) COMPILER_ARITH_PRIM (comutil_remainder, GENERIC_TRAMPOLINE_REMAINDER, 3) COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2) - -/* - Obsolete SCHEME_UTILITYs used to handle first class environments. - They have been superseded by the variable caching code. - They are here for completeness, and because the code in the compiler - that uses them has not yet been spliced out, although it is switched - off. -*/ - -#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \ -DEFINE_SCHEME_UTILITY_3 (util_name, ret_add_raw, environment, variable) \ -{ \ - instruction * ret_add \ - = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \ - long code = (c_proc (environment, variable, (&val_register))); \ - if (code == PRIM_DONE) \ - { \ - RETURN_TO_SCHEME (ret_add); \ - } \ - else \ - { \ - STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \ - STACK_PUSH (variable); \ - STACK_PUSH (environment); \ - exp_register = SHARP_F; \ - Store_Return (ret_code); \ - Save_Cont (); \ - RETURN_TO_C (code); \ - } \ -} \ - \ -C_TO_SCHEME long \ -DEFUN_VOID (restart_name) \ -{ \ - SCHEME_OBJECT environment, variable; \ - long code; \ - \ - environment = (STACK_POP ()); \ - variable = (STACK_POP ()); \ - code = (c_proc (environment, variable, (&val_register))); \ - if (code == PRIM_DONE) \ - { \ - env_register = environment; \ - ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \ - } \ - else \ - { \ - STACK_PUSH (variable); \ - STACK_PUSH (environment); \ - exp_register = SHARP_F; \ - Store_Return (ret_code); \ - Save_Cont (); \ - return (code); \ - } \ -} - -#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \ -DEFINE_SCHEME_UTILITY_4 (util_name, \ - ret_add_raw, environment, variable, value) \ -{ \ - instruction * ret_add \ - = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \ - long code = (c_proc (environment, variable, value)); \ - if (code == PRIM_DONE) \ - RETURN_TO_SCHEME (ret_add); \ - else \ - { \ - STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \ - STACK_PUSH (value); \ - STACK_PUSH (variable); \ - STACK_PUSH (environment); \ - exp_register = SHARP_F; \ - Store_Return (ret_code); \ - Save_Cont (); \ - RETURN_TO_C (code); \ - } \ -} \ - \ -C_TO_SCHEME long \ -DEFUN_VOID (restart_name) \ -{ \ - SCHEME_OBJECT environment, variable, value; \ - long code; \ - \ - environment = exp_register; \ - variable = (STACK_POP ()); \ - value = (STACK_POP ()); \ - code = (c_proc (environment, variable, value)); \ - if (code == PRIM_DONE) \ - { \ - env_register = environment; \ - ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \ - } \ - else \ - { \ - STACK_PUSH (value); \ - STACK_PUSH (variable); \ - STACK_PUSH (environment); \ - exp_register = SHARP_F; \ - Store_Return (ret_code); \ - Save_Cont (); \ - return (code); \ - } \ -} - -CMPLR_REFERENCE(comutil_access, - lookup_variable, - RC_COMP_ACCESS_RESTART, - comp_access_restart) - -CMPLR_REFERENCE(comutil_reference, - lookup_variable, - RC_COMP_REFERENCE_RESTART, - comp_reference_restart) - -CMPLR_REFERENCE(comutil_safe_reference, - safe_lookup_variable, - RC_COMP_SAFE_REFERENCE_RESTART, - comp_safe_reference_restart) - -CMPLR_REFERENCE(comutil_unassigned_p, - variable_unassigned_p, - RC_COMP_UNASSIGNED_P_RESTART, - comp_unassigned_p_restart) - -CMPLR_REFERENCE(comutil_unbound_p, - variable_unbound_p, - RC_COMP_UNBOUND_P_RESTART, - comp_unbound_p_restart) -static long -compiler_assign_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, - SCHEME_OBJECT value) +DEFINE_SCHEME_UTILITY_2 (comutil_primitive_error, ret_addr, primitive) { - return (assign_variable (environment, symbol, value, (&val_register))); + DECLARE_UTILITY_ARG (insn_t *, ret_addr); + DECLARE_UTILITY_ARG (SCHEME_OBJECT, primitive); + STACK_PUSH (MAKE_CC_ENTRY (ret_addr)); + STACK_PUSH (primitive); + SAVE_LAST_RETURN_CODE (RC_COMP_ERROR_RESTART); + RETURN_TO_C (ERR_COMPILED_CODE_ERROR); } -CMPLR_ASSIGNMENT(comutil_assignment, - compiler_assign_variable, - RC_COMP_ASSIGNMENT_RESTART, - comp_assignment_restart) - -static long -compiler_define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, - SCHEME_OBJECT value) +DEFINE_SCHEME_ENTRY (comp_error_restart) { - long result = (define_variable (environment, symbol, value)); - if (result == PRIM_DONE) - val_register = symbol; - return (result); + RESTORE_LAST_RETURN_CODE (); + (void) STACK_POP (); /* primitive */ + JUMP_TO_CC_ENTRY (STACK_POP ()); } - -CMPLR_ASSIGNMENT(comutil_definition, - compiler_define_variable, - RC_COMP_DEFINITION_RESTART, - comp_definition_restart) -DEFINE_SCHEME_UTILITY_3 (comutil_lookup_apply, environment, variable, nactuals) +long +apply_compiled_from_primitive (unsigned long n_args, + SCHEME_OBJECT procedure) { - long code = (lookup_variable (environment, variable, (&val_register))); - if (code == PRIM_DONE) - TAIL_CALL_2 (comutil_apply, val_register, nactuals); - { - STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); - STACK_PUSH (variable); - STACK_PUSH (environment); - exp_register = SHARP_F; - Store_Return (RC_COMP_LOOKUP_APPLY_RESTART); - Save_Cont (); - RETURN_TO_C (code); - } + while ((OBJECT_TYPE (procedure)) == TC_ENTITY) + { + { + unsigned long frame_size = (n_args + 1); + SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && (frame_size < (VECTOR_LENGTH (data))) + && (CC_ENTRY_P (VECTOR_REF (data, frame_size))) + && ((VECTOR_REF (data, 0)) + == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))) + { + procedure = (VECTOR_REF (data, frame_size)); + continue; + } + } + { + SCHEME_OBJECT operator = (MEMORY_REF (procedure, ENTITY_OPERATOR)); + if (CC_ENTRY_P (operator)) + { + STACK_PUSH (procedure); + n_args += 1; + procedure = operator; + } + } + break; + } + + if (CC_ENTRY_P (procedure)) + { + long code = (setup_compiled_invocation (procedure, n_args)); + if (code != PRIM_DONE) + { + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + return (code); + } + STACK_PUSH (procedure); + return (PRIM_DONE); + } + + STACK_PUSH (procedure); + PUSH_APPLY_FRAME_HEADER (n_args); + PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY); + return (PRIM_DONE); } + +/* Adjust the stack frame for applying a compiled procedure. Returns + PRIM_DONE when successful, otherwise sets up the call frame for + application by the interpreter and returns the appropriate code. */ -C_TO_SCHEME long -DEFUN_VOID (comp_lookup_apply_restart) +static long +setup_compiled_invocation (SCHEME_OBJECT procedure, unsigned long n_args) { - SCHEME_OBJECT environment = (STACK_POP ()); - SCHEME_OBJECT variable = (STACK_POP ()); - SCHEME_OBJECT value; - long code = (lookup_variable (environment, variable, (&value))); - if (code == PRIM_DONE) + cc_entry_type_t cet; + unsigned long n_min; + unsigned long n_max; + + if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (procedure)))) { - SCHEME_OBJECT nactuals = (STACK_POP ()); - STACK_PUSH (value); - STACK_PUSH (nactuals); - if (COMPILED_CODE_ADDRESS_P (value)) - return (apply_compiled_procedure ()); - else - return (PRIM_APPLY); + recover_from_apply_error (procedure, n_args); + return (ERR_COMPILED_CODE_ERROR); } - else + if ((cet.marker) != CET_PROCEDURE) + { + recover_from_apply_error (procedure, n_args); + return (ERR_INAPPLICABLE_OBJECT); + } + n_min = (cet.args.for_procedure.n_required); + if (n_args < n_min) + { + recover_from_apply_error (procedure, n_args); + return (ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + n_max = (n_min + (cet.args.for_procedure.n_optional)); + if (cet.args.for_procedure.rest_p) + return (setup_lexpr_invocation (procedure, n_args, n_max)); + if (n_args == n_max) + return (PRIM_DONE); + if (n_args > n_max) + { + recover_from_apply_error (procedure, n_args); + return (ERR_WRONG_NUMBER_OF_ARGUMENTS); + } + if (open_gap (n_args, n_max)) { - STACK_PUSH (variable); - STACK_PUSH (environment); - exp_register = SHARP_F; - Store_Return (RC_COMP_LOOKUP_APPLY_RESTART); - Save_Cont (); - return (code); + recover_from_apply_error (procedure, n_args); + return (PRIM_APPLY_INTERRUPT); } + return (PRIM_DONE); } -DEFINE_SCHEME_UTILITY_2 (comutil_primitive_error, ret_add_raw, primitive) +static long +setup_lexpr_invocation (SCHEME_OBJECT procedure, + unsigned long n_args, + unsigned long n_max) { - instruction * ret_add = - ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); - - STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); - STACK_PUSH (primitive); - exp_register = SHARP_F; - Store_Return (RC_COMP_ERROR_RESTART); - Save_Cont (); - RETURN_TO_C (ERR_COMPILED_CODE_ERROR); + if (n_args <= n_max) + { + if (open_gap (n_args, (n_max + 1))) + { + recover_from_apply_error (procedure, n_args); + return (PRIM_APPLY_INTERRUPT); + } + (STACK_REF (n_max)) = EMPTY_LIST; + return (PRIM_DONE); + } + { + unsigned long n_words = ((n_args - n_max) * 2); + if (GC_NEEDED_P (n_words)) + { + REQUEST_GC (n_words); + recover_from_apply_error (procedure, n_args); + return (PRIM_APPLY_INTERRUPT); + } + } + { + SCHEME_OBJECT rest_arg = (MAKE_POINTER_OBJECT (TC_LIST, Free)); + SCHEME_OBJECT * p1 = (STACK_LOC (n_max)); + { + unsigned long i; + for (i = n_max; (i < n_args); i += 1) + { + (Free[0]) = (STACK_LOCATIVE_POP (p1)); + (Free[1]) = (MAKE_POINTER_OBJECT (TC_LIST, (Free + 2))); + Free += 2; + } + } + (Free[-1]) = EMPTY_LIST; + (STACK_LOCATIVE_PUSH (p1)) = rest_arg; + { + SCHEME_OBJECT * p2 = (STACK_LOC (n_max)); + unsigned long i; + for (i = 0; (i < n_max); i += 1) + (STACK_LOCATIVE_PUSH (p1)) = (STACK_LOCATIVE_PUSH (p2)); + } + stack_pointer = p1; + } + return (PRIM_DONE); } -C_TO_SCHEME long -DEFUN_VOID (comp_error_restart) +static bool +open_gap (unsigned long n_args, unsigned long n_needed) { - instruction * ret_add; + unsigned long n_defaults = (n_needed - n_args); - (void) STACK_POP (); /* primitive */ - ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ()))); - ENTER_SCHEME (ret_add); + STACK_CHECK (n_defaults); + if (PENDING_INTERRUPTS_P) + return (true); + + open_stack_gap (n_args, n_defaults); + { + SCHEME_OBJECT * scan = (STACK_LOC (n_args)); + SCHEME_OBJECT * end = (STACK_LOC (n_needed)); + while (scan != end) + (STACK_LOCATIVE_POP (scan)) = DEFAULT_OBJECT; + } + return (false); } -/* Procedures to destructure compiled entries and closures. */ +void +make_compiled_procedure_type (cc_entry_type_t * cet, + unsigned int n_required, + unsigned int n_optional, + bool rest_p) +{ + (cet->marker) = CET_PROCEDURE; + (cet->args.for_procedure.n_required) = n_required; + (cet->args.for_procedure.n_optional) = n_optional; + (cet->args.for_procedure.rest_p) = rest_p; +} -/* - Extract the debugging information attached to `block'. Usually - this is a string which contains the filename where the debugging - info is stored. - */ +void +make_compiled_continuation_type (cc_entry_type_t * cet, unsigned long offset) +{ + (cet->marker) = CET_CONTINUATION; + (cet->args.for_continuation.offset) = offset; +} -C_UTILITY SCHEME_OBJECT -DEFUN (compiled_block_debugging_info, - (block), - SCHEME_OBJECT block) +void +make_cc_entry_type (cc_entry_type_t * cet, cc_entry_type_marker_t marker) { - long length; + assert (! ((marker == CET_PROCEDURE) || (marker == CET_CONTINUATION))); + (cet->marker) = marker; + memset ((& (cet->args)), 0, (sizeof (cet->marker))); +} - length = (VECTOR_LENGTH (block)); - return (FAST_MEMORY_REF (block, (length - 1))); +SCHEME_OBJECT +cc_entry_to_block (SCHEME_OBJECT entry) +{ + return (MAKE_CC_BLOCK (cc_entry_to_block_address (entry))); } -/* Extract the environment where the `block' was "loaded". */ +SCHEME_OBJECT * +cc_entry_to_block_address (SCHEME_OBJECT entry) +{ + return (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (entry))); +} -C_UTILITY SCHEME_OBJECT -DEFUN (compiled_block_environment, - (block), - SCHEME_OBJECT block) +SCHEME_OBJECT * +cc_entry_address_to_block_address (insn_t * entry) +{ + insn_t * p = entry; + while (1) + { + cc_entry_offset_t ceo; + read_cc_entry_offset ((&ceo), p); + p -= (ceo.offset); + if (! (ceo.continued_p)) + { + assert ((((unsigned long) p) % (sizeof (SCHEME_OBJECT))) == 0); + assert (((SCHEME_OBJECT *) entry) + < (CC_BLOCK_ADDR_END ((SCHEME_OBJECT *) p))); + return ((SCHEME_OBJECT *) p); + } + } +} + +int +plausible_cc_block_p (SCHEME_OBJECT * block) { - long length; + insn_t * zero = ((insn_t *) block); + insn_t * entry = (((insn_t *) (block + 2)) + CC_ENTRY_HEADER_SIZE); + { + cc_entry_type_t cet; + if ((read_cc_entry_type ((&cet), entry)) + || ((cet.marker) != CET_EXPRESSION)) + { + entry += CC_ENTRY_GC_TRAP_SIZE; + if ((read_cc_entry_type ((&cet), entry)) + || (! (((cet.marker) == CET_PROCEDURE) + || ((cet.marker) == CET_CONTINUATION)))) + return (0); + } + } + { + cc_entry_offset_t ceo; + if ((read_cc_entry_offset ((&ceo), entry)) + || ((ceo.offset) != (entry - zero))) + return (0); + } + { + SCHEME_OBJECT * block_end = ((CC_BLOCK_ADDR_END (block)) - 1); + return + ((((HEAP_ADDRESS_P (block)) && (HEAP_ADDRESS_P (block_end))) + || ((ADDRESS_IN_CONSTANT_P (block)) + && (ADDRESS_IN_CONSTANT_P (block_end)))) + && (ENVIRONMENT_P (*block_end))); + } +} - length = (VECTOR_LENGTH (block)); - return (FAST_MEMORY_REF (block, length)); +linkage_section_type_t +linkage_section_type (SCHEME_OBJECT marker) +{ + unsigned long type = ((OBJECT_DATUM (marker)) >> 16); + assert (type < N_LINKAGE_SECTION_TYPES); + return ((linkage_section_type_t) type); } -/* - Given `entry', a Scheme object representing a compiled code entry point, - it returns the address of the block to which it belongs. - */ +#ifndef UUO_WORDS_TO_COUNT +# define UUO_WORDS_TO_COUNT(nw) ((nw) / UUO_LINK_SIZE) +# define UUO_COUNT_TO_WORDS(nc) ((nc) * UUO_LINK_SIZE) +#endif -C_UTILITY SCHEME_OBJECT * -DEFUN (compiled_entry_to_block_address, - (entry), - SCHEME_OBJECT entry) +unsigned long +linkage_section_count (SCHEME_OBJECT marker) { - SCHEME_OBJECT *block_address; - - Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry))); - return (block_address); + linkage_section_type_t type = (linkage_section_type (marker)); + unsigned long n_words = ((OBJECT_DATUM (marker)) & 0xFFFFUL); + return (((type == LINKAGE_SECTION_TYPE_OPERATOR) + || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR)) + ? (UUO_WORDS_TO_COUNT (n_words)) + : n_words); } -C_UTILITY SCHEME_OBJECT -DEFUN (compiled_entry_to_block, - (entry), - SCHEME_OBJECT entry) +SCHEME_OBJECT +make_linkage_section_marker (linkage_section_type_t type, unsigned long count) { - SCHEME_OBJECT *block_address; + unsigned long n_words; - Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry))); - return (MAKE_CC_BLOCK (block_address)); + assert (type < N_LINKAGE_SECTION_TYPES); + n_words + = (((type == LINKAGE_SECTION_TYPE_OPERATOR) + || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR)) + ? (UUO_COUNT_TO_WORDS (count)) + : count); + assert (n_words < 0x10000); + return (MAKE_OBJECT (TC_LINKAGE_SECTION, + ((((unsigned long) (type)) << 16) | n_words))); } -/* Returns the offset from the block to the entry point. */ +/* Procedures to destructure compiled entries and closures. */ -#ifndef CC_BLOCK_DISTANCE +/* Returns the debugging information attached to 'block'. Usually + this is a string that contains the filename where the debugging + info is stored. */ -#define CC_BLOCK_DISTANCE(block,entry) \ - (((char *) (entry)) - ((char *) (block))) +SCHEME_OBJECT +cc_block_debugging_info (SCHEME_OBJECT block) +{ + return (VECTOR_REF (block, ((VECTOR_LENGTH (block)) - 2))); +} -#endif /* CC_BLOCK_DISTANCE */ +/* Returns the environment where 'block' was evaluated. */ -C_UTILITY long -DEFUN (compiled_entry_to_block_offset, - (entry), - SCHEME_OBJECT entry) +SCHEME_OBJECT +cc_block_environment (SCHEME_OBJECT block) { - SCHEME_OBJECT *entry_address, *block_address; + return (VECTOR_REF (block, ((VECTOR_LENGTH (block)) - 1))); +} - entry_address = (OBJECT_ADDRESS (entry)); - Get_Compiled_Block (block_address, entry_address); - return (CC_BLOCK_DISTANCE (block_address, entry_address)); +unsigned long +cc_entry_to_block_offset (SCHEME_OBJECT entry) +{ + return ((CC_ENTRY_ADDRESS (entry)) + - ((insn_t *) (cc_entry_to_block_address (entry)))); } -/* - Check whether the compiled code block whose address is `block_addr' - is a compiled closure block. - */ - -static long -DEFUN (block_address_closure_p, - (block_addr), - SCHEME_OBJECT * block_addr) +bool +cc_block_closure_p (SCHEME_OBJECT block) { - SCHEME_OBJECT header_word; - - header_word = (*block_addr); - return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE)); + return (cc_block_address_closure_p (OBJECT_ADDRESS (block))); } -/* - Check whether the compiled code block `block' is a compiled closure block. - */ - -C_UTILITY long -DEFUN (compiled_block_closure_p, - (block), - SCHEME_OBJECT block) +bool +cc_entry_closure_p (SCHEME_OBJECT entry) { - return (block_address_closure_p (OBJECT_ADDRESS (block))); + return (cc_block_address_closure_p (cc_entry_to_block_address (entry))); } -/* - Check whether the compiled entry point `entry' is a compiled closure. - */ - -C_UTILITY long -DEFUN (compiled_entry_closure_p, - (entry), - SCHEME_OBJECT entry) +static bool +cc_block_address_closure_p (SCHEME_OBJECT * block_addr) { - return (block_address_closure_p (compiled_entry_to_block_address (entry))); + SCHEME_OBJECT header_word = (*block_addr); + return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE)); } -/* - Extract the entry point ultimately invoked by the compiled closure - represented by `entry'. - */ +/* Return the entry point ultimately invoked by the compiled closure + 'entry'. */ -C_UTILITY SCHEME_OBJECT -DEFUN (compiled_closure_to_entry, - (entry), - SCHEME_OBJECT entry) +SCHEME_OBJECT +cc_closure_to_entry (SCHEME_OBJECT entry) { - SCHEME_OBJECT real_entry; - - EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry, (OBJECT_ADDRESS (entry))); - return (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (real_entry))); + return (compiled_closure_entry_to_target (CC_ENTRY_ADDRESS (entry))); } -/* - Store the information for `entry' into `buffer'. - This is used by the printer and debugging utilities. - */ - -/* Kinds and subkinds of entries. */ - -#define KIND_PROCEDURE 0 -#define KIND_CONTINUATION 1 -#define KIND_EXPRESSION 2 -#define KIND_OTHER 3 -#define KIND_ILLEGAL 4 - -/* Continuation subtypes */ - -#define CONTINUATION_NORMAL 0 -#define CONTINUATION_DYNAMIC_LINK 1 -#define CONTINUATION_RETURN_TO_INTERPRETER 2 - -/* Other subtypes */ - -#define OTHER_CLOSURE 0 -#define OTHER_RANDOM 1 - -C_UTILITY void -DEFUN (compiled_entry_type, - (entry, buffer), - SCHEME_OBJECT entry AND long * buffer) -{ - long kind, min_arity, max_arity, field1, field2; - SCHEME_OBJECT * entry_address; - - entry_address = (OBJECT_ADDRESS (entry)); - max_arity = (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)); - min_arity = (COMPILED_ENTRY_MINIMUM_ARITY (entry_address)); - field1 = min_arity; - field2 = max_arity; - if (min_arity >= 0) - kind = KIND_PROCEDURE; - else if (max_arity >= 0) - kind = KIND_ILLEGAL; - else if ((((unsigned long) max_arity) & 0xff) < 0xe0) - { - /* Field2 is the offset to the next continuation */ - - kind = KIND_CONTINUATION; - field1 = CONTINUATION_NORMAL; - field2 = (((((unsigned long) max_arity) & 0x3f) << 7) - | (((unsigned long) min_arity) & 0x7f)); - } - else if (min_arity != -1) - kind = KIND_ILLEGAL; - - else - { - switch (((unsigned long) max_arity) & 0xff) - { - case FORMAT_BYTE_EXPR: - { - kind = KIND_EXPRESSION; - break; - } - case FORMAT_BYTE_CLOSURE: - { - kind = KIND_OTHER; - field1 = OTHER_CLOSURE; - break; - } - case FORMAT_BYTE_COMPLR: - case FORMAT_BYTE_CMPINT: - { - kind = KIND_OTHER; - field1 = OTHER_RANDOM; - break; - } - case FORMAT_BYTE_DLINK: - { - kind = KIND_CONTINUATION; - field1 = CONTINUATION_DYNAMIC_LINK; - field2 = -1; - break; - } - case FORMAT_BYTE_RETURN: - { - kind = KIND_CONTINUATION; - field1 = CONTINUATION_RETURN_TO_INTERPRETER; - field2 = ((long) (entry != return_to_interpreter)); - break; - } - default: - { - kind = KIND_ILLEGAL; - break; - } - } - } - buffer[0] = kind; - buffer[1] = field1; - buffer[2] = field2; -} - void -DEFUN (declare_compiled_code_block, (block), SCHEME_OBJECT block) +declare_compiled_code_block (SCHEME_OBJECT block) { #ifdef PUSH_D_CACHE_REGION - SCHEME_OBJECT * block_addr = (OBJECT_ADDRESS (block)); - PUSH_D_CACHE_REGION (block_addr, (1+ (OBJECT_DATUM (* block_addr)))); + PUSH_D_CACHE_REGION ((OBJECT_ADDRESS (block)), (CC_BLOCK_END (block))); #endif } - -/* Destructuring free variable caches. */ - -C_UTILITY void -DEFUN (store_variable_cache, - (extension, block, offset), - SCHEME_OBJECT extension AND SCHEME_OBJECT block - AND long offset) -{ - FAST_MEMORY_SET (block, offset, - ((SCHEME_OBJECT) - (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (extension))))); -} -C_UTILITY SCHEME_OBJECT -DEFUN (extract_variable_cache, - (block, offset), - SCHEME_OBJECT block AND long offset) +void +write_variable_cache (SCHEME_OBJECT cache, + SCHEME_OBJECT block, + unsigned long offset) { - return (MAKE_POINTER_OBJECT (CACHE_TYPE, - ((SCHEME_OBJECT *) - (SCHEME_ADDR_TO_ADDR - (FAST_MEMORY_REF (block, offset)))))); + MEMORY_SET (block, offset, ((SCHEME_OBJECT) (OBJECT_ADDRESS (cache)))); } /* Get a compiled procedure from a cached operator reference. */ -C_UTILITY SCHEME_OBJECT -DEFUN (extract_uuo_link, - (block, offset), - SCHEME_OBJECT block AND long offset) +SCHEME_OBJECT +read_uuo_link (SCHEME_OBJECT block, unsigned long offset) { - SCHEME_OBJECT * cache_address, compiled_entry_address; - - cache_address = (MEMORY_LOC (block, offset)); - EXTRACT_EXECUTE_CACHE_ADDRESS (compiled_entry_address, cache_address); - return (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (compiled_entry_address))); + return + (MAKE_CC_ENTRY (read_uuo_target_no_reloc (MEMORY_LOC (block, offset)))); } static void -DEFUN (store_uuo_link, - (entry, cache_address), - SCHEME_OBJECT entry AND SCHEME_OBJECT * cache_address) +write_uuo_link (SCHEME_OBJECT target, SCHEME_OBJECT * cache_address) { - SCHEME_OBJECT * entry_address; - - entry_address = (OBJECT_ADDRESS (entry)); - STORE_EXECUTE_CACHE_CODE (cache_address); - STORE_EXECUTE_CACHE_ADDRESS (cache_address, - (ADDR_TO_SCHEME_ADDR (entry_address))); + write_uuo_target ((CC_ENTRY_ADDRESS (target)), cache_address); #ifdef FLUSH_I_CACHE_REGION if (!linking_cc_block_p) { /* The linker will flush the whole region afterwards. */ - FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE); + FLUSH_I_CACHE_REGION (cache_address, UUO_LINK_SIZE); } #endif } - -/* This makes a fake compiled procedure which traps to kind handler when - invoked. - */ - -#define TRAMPOLINE_SIZE (TRAMPOLINE_ENTRY_SIZE + 2) - -/* Enabled so that the profiler can distinguish trampolines */ -#if 1 || defined(AUTOCLOBBER_BUG) -# define TC_TRAMPOLINE_HEADER TC_FIXNUM -#else -# define TC_TRAMPOLINE_HEADER TC_MANIFEST_VECTOR -#endif - -static void -DEFUN (fill_trampoline, - (block, entry_point, fmt_word, kind), - SCHEME_OBJECT * block - AND instruction * entry_point - AND format_word fmt_word - AND long kind) +SCHEME_OBJECT * +compiled_closure_objects (SCHEME_OBJECT * block) { - (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word; - (COMPILED_ENTRY_OFFSET_WORD (entry_point)) = - (MAKE_OFFSET_WORD (entry_point, block, false)); - STORE_TRAMPOLINE_ENTRY (entry_point, kind); - return; -} + insn_t * start = (compiled_closure_start (block)); + unsigned long count = (compiled_closure_count (block)); -static long -DEFUN (make_trampoline, - (slot, fmt_word, kind, size, value1, value2, value3), - SCHEME_OBJECT * slot - AND format_word fmt_word - AND long kind AND long size - AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2 - AND SCHEME_OBJECT value3) -{ - instruction * entry_point; - SCHEME_OBJECT * ptr; - - if (GC_Check (TRAMPOLINE_SIZE + size)) - { - Request_GC (TRAMPOLINE_SIZE + size); - return (PRIM_INTERRUPT); - } + /* Skip to end of entries. */ + while (count > 0) + { + start = (compiled_closure_next (start)); + count -= 1; + } - ptr = Free; - Free += (TRAMPOLINE_SIZE + size); - ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, - ((TRAMPOLINE_SIZE - 1) + size))); - ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - TRAMPOLINE_ENTRY_SIZE)); - entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr))); - fill_trampoline (ptr, entry_point, fmt_word, kind); - *slot = (ENTRY_TO_OBJECT (entry_point)); - ptr = (TRAMPOLINE_STORAGE (entry_point)); - if ((--size) >= 0) - *ptr++ = value1; - if ((--size) >= 0) - *ptr++ = value2; - if ((--size) >= 0) - *ptr++ = value3; - return (PRIM_DONE); + /* Skip to first object. */ + return (skip_compiled_closure_padding (start)); } -/* Standard trampolines. */ - -static long -DEFUN (make_redirection_trampoline, - (slot, kind, procedure), - SCHEME_OBJECT * slot AND long kind AND SCHEME_OBJECT procedure) +bool +decode_old_style_format_word (cc_entry_type_t * cet, uint16_t fw) { - return (make_trampoline (slot, - ((format_word) FORMAT_WORD_CMPINT), - kind, - 1, - procedure, - SHARP_F, - SHARP_F)); -} + uint16_t low = (fw & 0x00FF); + uint16_t high = ((fw & 0xFF00) >> 8); + bool rest_p = false; -static long -DEFUN (make_apply_trampoline, - (slot, kind, procedure, nactuals), - SCHEME_OBJECT * slot AND long kind - AND SCHEME_OBJECT procedure AND long nactuals) -{ - return (make_trampoline (slot, - ((format_word) FORMAT_WORD_CMPINT), - kind, - 2, - procedure, - (LONG_TO_UNSIGNED_FIXNUM (nactuals)), - SHARP_F)); -} - -#define TRAMPOLINE_TABLE_SIZE 4 - -static long -trampoline_arity_table[TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] = -{ - TRAMPOLINE_K_1_0, /* 1_0 */ - TRAMPOLINE_K_ARITY, /* 1_1 should not get here */ - TRAMPOLINE_K_ARITY, /* 1_2 should not get here */ - TRAMPOLINE_K_ARITY, /* 1_3 should not get here */ - TRAMPOLINE_K_2_0, /* 2_0 */ - TRAMPOLINE_K_2_1, /* 2_1 */ - TRAMPOLINE_K_ARITY, /* 2_2 should not get here */ - TRAMPOLINE_K_ARITY, /* 2_3 should not get here */ - TRAMPOLINE_K_3_0, /* 3_0 */ - TRAMPOLINE_K_3_1, /* 3_1 */ - TRAMPOLINE_K_3_2, /* 3_2 */ - TRAMPOLINE_K_ARITY, /* 3_3 should not get here */ - TRAMPOLINE_K_4_0, /* 4_0 */ - TRAMPOLINE_K_4_1, /* 4_1 */ - TRAMPOLINE_K_4_2, /* 4_2 */ - TRAMPOLINE_K_4_3 /* 4_3 */ -}; - -/* - make_uuo_link is called by C and initializes a compiled procedure - cache at a location given by a block and an offset. - - make_uuo_link checks its procedure argument, and: - - - If it is not a compiled procedure, an entity, or a primitive - procedure with a matching number of arguments, it stores a fake - compiled procedure which will invoke comutil_operator_interpreted_trap - when invoked. - - - If its argument is an entity, it stores a fake compiled procedure - which will invoke comutil_operator_entity_trap when invoked. - - - If its argument is a primitive, it stores a fake compiled procedure - which will invoke comutil_operator_primitive_trap, or - comutil_operator_lexpr_trap when invoked. - - - If its argument is a compiled procedure that expects more or - less arguments than those provided, it stores a fake compiled - procedure which will invoke comutil_operator_arity_trap, or one of - its specialized versions when invoked. - - - Otherwise, the actual (compatible) operator is stored. -*/ - -C_UTILITY long -DEFUN (make_uuo_link, - (procedure, extension, block, offset), - SCHEME_OBJECT procedure AND SCHEME_OBJECT extension - AND SCHEME_OBJECT block AND long offset) -{ - long kind, result; - unsigned long nactuals; - SCHEME_OBJECT orig_proc, trampoline, *cache_address; - - cache_address = (MEMORY_LOC (block, offset)); - EXTRACT_EXECUTE_CACHE_ARITY (nactuals, cache_address); - /* nactuals >= 0 */ - - orig_proc = procedure; -loop: - switch (OBJECT_TYPE (procedure)) - { - case TC_COMPILED_ENTRY: + if (high < 0x80) { - SCHEME_OBJECT * entry; - long nmin, nmax; - - entry = (OBJECT_ADDRESS (procedure)); - nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (entry)); - if (((long) nactuals) == nmax) - { - store_uuo_link (procedure, cache_address); - return (PRIM_DONE); - } - nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry)); - if ((nmax > 1) && (nmin > 0) && (nmin <= ((long) nactuals)) && - (nactuals <= TRAMPOLINE_TABLE_SIZE) && - (nmax <= (TRAMPOLINE_TABLE_SIZE + 1))) - { - kind = (trampoline_arity_table[((nmax - 2) * TRAMPOLINE_TABLE_SIZE) + - (nactuals - 1)]); - /* Paranoia */ - if (kind != TRAMPOLINE_K_ARITY) + if ((high == 0x00) + || (low == 0x00) + || (low == 0x80)) + return (true); + if (low > 0x80) { - nactuals = 0; - break; + low = (0xFF - low); + rest_p = true; } - } - kind = TRAMPOLINE_K_ARITY; - break; + if (! (high <= low)) + return (true); + make_compiled_procedure_type (cet, (high - 1), (low - high), rest_p); + return (false); } - - case TC_ENTITY: + if (low < 0x80) + return (true); + if (low < 0xE0) { - SCHEME_OBJECT data; - - data = (MEMORY_REF (procedure, ENTITY_DATA)); - if ((VECTOR_P (data)) - && (nactuals < (VECTOR_LENGTH (data))) - && ((VECTOR_REF (data, nactuals)) != SHARP_F) - && ((VECTOR_REF (data, 0)) - == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG)))) - { - /* No loops allowed! */ - SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals)); - - if ((procedure == orig_proc) && (nproc != procedure)) - { - procedure = nproc; - goto loop; - } - else - procedure = orig_proc; - } - kind = TRAMPOLINE_K_ENTITY; - break; + make_compiled_continuation_type + (cet, + (((low & 0x7F) << 7) | (high & 0x7F))); + return (false); } - - case TC_PRIMITIVE: + if (high != 0xFF) + return (true); + switch (low) { - long arity; - - arity = (PRIMITIVE_ARITY (procedure)); - if (arity == ((long) (nactuals - 1))) - { - nactuals = 0; - kind = TRAMPOLINE_K_PRIMITIVE; - } - else if (arity == LEXPR_PRIMITIVE_ARITY) - kind = TRAMPOLINE_K_LEXPR_PRIMITIVE; - else - kind = TRAMPOLINE_K_OTHER; + case 0xFF: + make_cc_entry_type (cet, CET_EXPRESSION); break; - } - - case TC_PROCEDURE: /* and some others... */ - default: - /* uuo_link_interpreted: */ - { - kind = TRAMPOLINE_K_INTERPRETED; + case 0xFE: + make_cc_entry_type (cet, CET_INTERNAL_PROCEDURE); + break; + case 0xFD: + make_cc_entry_type (cet, CET_TRAMPOLINE); + break; + case 0xFC: + make_cc_entry_type (cet, CET_INTERNAL_CONTINUATION); + break; + case 0xFB: + make_cc_entry_type (cet, CET_RETURN_TO_INTERPRETER); + break; + case 0xFA: + make_cc_entry_type (cet, CET_CLOSURE); break; + default: + return (true); } - } - if (nactuals == 0) - result = (make_redirection_trampoline (&trampoline, kind, procedure)); - else - result = (make_apply_trampoline (&trampoline, kind, procedure, nactuals)); - if (result != PRIM_DONE) - return (result); - store_uuo_link (trampoline, cache_address); - return (PRIM_DONE); + return (false); } -C_UTILITY long -DEFUN (make_fake_uuo_link, - (extension, block, offset), - SCHEME_OBJECT extension AND SCHEME_OBJECT block AND long offset) +bool +encode_old_style_format_word (cc_entry_type_t * cet, uint16_t * fw_r) { - long result; - SCHEME_OBJECT trampoline, *cache_address; - - result = (make_trampoline (&trampoline, - ((format_word) FORMAT_WORD_CMPINT), - TRAMPOLINE_K_LOOKUP, - 3, - extension, - block, - (LONG_TO_UNSIGNED_FIXNUM (offset)))); - if (result != PRIM_DONE) - { - return (result); - } - cache_address = (MEMORY_LOC (block, offset)); - store_uuo_link (trampoline, cache_address); - return (PRIM_DONE); -} + unsigned int low; + unsigned int high; -/* C_UTILITY long fake_uuo_link_p does not appear to be used anymore */ + switch (cet->marker) + { + case CET_PROCEDURE: + high = ((cet->args.for_procedure.n_required) + 1); + low = (high + (cet->args.for_procedure.n_optional)); + if (! (low < 0x80)) + return (true); + if (cet->args.for_procedure.rest_p) + low = (0xFF - low); + break; -C_UTILITY long -DEFUN (coerce_to_compiled, - (procedure, arity, location), - SCHEME_OBJECT procedure AND long arity AND SCHEME_OBJECT * location) -{ - long frame_size; + case CET_CONTINUATION: + { + unsigned long n = (cet->args.for_continuation.offset); + if (! (n < 0x3000)) + return (true); + high = ((n & 0x7F) | 0x80); + low = ((n >> 7) | 0x80); + } + break; - frame_size = (arity + 1); - if ((!(COMPILED_CODE_ADDRESS_P (procedure))) || - (((long) (COMPILED_ENTRY_MAXIMUM_ARITY (OBJECT_ADDRESS (procedure)))) != - frame_size)) - { - if (frame_size > FORMAT_BYTE_FRAMEMAX) - return (ERR_WRONG_NUMBER_OF_ARGUMENTS); - return (make_trampoline (location, - ((format_word) - (MAKE_FORMAT_WORD (frame_size, frame_size))), - TRAMPOLINE_K_APPLY, - 2, - procedure, - (LONG_TO_UNSIGNED_FIXNUM (frame_size)), - SHARP_F)); - } - (*location) = procedure; - return (PRIM_DONE); -} - -#ifndef HAVE_BKPT_SUPPORT + case CET_EXPRESSION: + low = 0xFF; + high = 0xFF; + break; -C_UTILITY SCHEME_OBJECT -DEFUN (bkpt_install, (ep), PTR ep) -{ - return (SHARP_F); -} + case CET_INTERNAL_PROCEDURE: + low = 0xFE; + high = 0xFF; + break; -C_UTILITY SCHEME_OBJECT -DEFUN (bkpt_closure_install, (ep), PTR ep) -{ - return (SHARP_F); -} + case CET_TRAMPOLINE: + low = 0xFD; + high = 0xFF; + break; -C_UTILITY void -DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle) -{ - error_external_return (); -} + case CET_INTERNAL_CONTINUATION: + low = 0xFC; + high = 0xFF; + break; -C_UTILITY Boolean -DEFUN (bkpt_p, (ep), PTR ep) -{ - return (FALSE); -} + case CET_RETURN_TO_INTERPRETER: + low = 0xFB; + high = 0xFF; + break; -C_UTILITY SCHEME_OBJECT -DEFUN (bkpt_proceed, (ep, handle, state), - PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state) -{ - error_external_return (); - return (UNSPECIFIC); -} + case CET_CLOSURE: + low = 0xFA; + high = 0xFF; + break; -C_UTILITY PTR -DEFUN (do_bkpt_proceed, (value), unsigned long * value) -{ - * value = ((unsigned long) ERR_EXTERNAL_RETURN); - return (FALSE); + default: + return (true); + } + (*fw_r) = ((high << 8) | low); + return (false); } + +/* Trampolines -#else /* HAVE_BKPT_SUPPORT */ - -#define BKPT_PROCEED_FRAME_SIZE 3 + When a free variable appears in operator position in compiled code, + there must be a directly callable procedure in the corresponding + UUO cell. If, at link time, there is no appropriate value for the + free variable, a fake compiled Scheme procedure that calls one of + these procedures will be placed into the cell instead. + + The trampolines themselves are made by 'make_uuo_link', + 'make_fake_uuo_link', and 'coerce_to_compiled'. The trampoline + looks like a Scheme closure, containing some code that jumps to one + of these procedures, and additional information to be used by the + procedure. -C_UTILITY SCHEME_OBJECT -DEFUN (bkpt_proceed, (ep, handle, state), - PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state) -{ - if ((! (COMPILED_CODE_ADDRESS_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))) - || ((OBJECT_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) - != ((SCHEME_OBJECT *) ep))) - error_external_return (); + These procedures expect a single argument, the address of the + information block where they can find the relevant data: typically + the procedure to invoke and the number of arguments to invoke it + with. */ - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT); - STACK_PUSH (reflect_to_interface); - sp_register = (STACK_LOC (- BKPT_PROCEED_FRAME_SIZE)); - return (SHARP_F); -} -#endif /* HAVE_BKPT_SUPPORT */ - -DEFINE_SCHEME_UTILITY_2 (comutil_compiled_code_bkpt, - entry_point_raw, state_raw) -{ - long type_info[3]; - instruction * entry_point_a - = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw))); - SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a)); - SCHEME_OBJECT state; - SCHEME_OBJECT stack_ptr; +#define DEFINE_TRAMPOLINE(pname) \ +DEFINE_SCHEME_UTILITY_1 (pname, TRAMP_store) - STACK_PUSH (entry_point); /* return address */ +#define INIT_TRAMPOLINE_1(av1) \ + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \ + SCHEME_OBJECT av1 = (TRAMP_store[0]) - /* Potential bug: This does not preserve the environment for - IC procedures. There is no way to tell that we have - an IC procedure in our hands. It is not safe to preserve - it in general because the contents of the register may - be stale (predate the last GC). - However, the compiler no longer generates IC procedures, and - will probably never do it again. - */ +#define INIT_TRAMPOLINE_2(av1, av2) \ + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \ + SCHEME_OBJECT av1 = (TRAMP_store[0]); \ + SCHEME_OBJECT av2 = (TRAMP_store[1]) - compiled_entry_type (entry_point, &type_info[0]); - if ((type_info[0] == KIND_OTHER) && (type_info[1] == OTHER_CLOSURE)) - { - entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw))); - state = (ENTRY_TO_OBJECT (entry_point_a)); - } - else if (type_info[0] != KIND_CONTINUATION) - state = SHARP_F; - else if (type_info[1] == CONTINUATION_DYNAMIC_LINK) - state = (MAKE_POINTER_OBJECT - (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (state_raw)))); - else - state = val_register; +#define INIT_TRAMPOLINE_3(av1, av2, av3) \ + DECLARE_UTILITY_ARG (SCHEME_OBJECT *, TRAMP_store); \ + SCHEME_OBJECT av1 = (TRAMP_store[0]); \ + SCHEME_OBJECT av2 = (TRAMP_store[1]); \ + SCHEME_OBJECT av3 = (TRAMP_store[2]) - stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, sp_register)); - STACK_PUSH (state); /* state to preserve */ - STACK_PUSH (stack_ptr); /* "Environment" pointer */ - STACK_PUSH (entry_point); /* argument to handler */ - TAIL_CALL_2 - (comutil_apply, (Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)), 4); -} +/* This is how compiled Scheme code normally returns back to the + Scheme interpreter. It is invoked by a trampoline, which passes + the address of the (empty) trampoline storage block to it. */ -DEFINE_SCHEME_UTILITY_1 (comutil_compiled_closure_bkpt, entry_point_raw) +DEFINE_TRAMPOLINE (comutil_return_to_interpreter) { - instruction * entry_point_a - = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw))); - SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a)); - SCHEME_OBJECT stack_ptr; - - STACK_PUSH (entry_point); /* return address */ - - stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, sp_register)); - STACK_PUSH (SHARP_F); /* state to preserve */ - STACK_PUSH (stack_ptr); /* "Environment" pointer */ - STACK_PUSH (entry_point); /* argument to handler */ - TAIL_CALL_2 - (comutil_apply, (Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)), 4); + RETURN_TO_C (PRIM_DONE); } -DEFINE_SCHEME_UTILITY_1 (comutil_reflect_to_interface, tramp_data_raw) +DEFINE_TRAMPOLINE (comutil_reflect_to_interface) { SCHEME_OBJECT code = (STACK_POP ()); switch (OBJECT_DATUM (code)) - { - case REFLECT_CODE_INTERNAL_APPLY: { - long frame_size = (OBJECT_DATUM (STACK_POP ())); - SCHEME_OBJECT procedure = (STACK_POP ()); - TAIL_CALL_2 (comutil_apply, procedure, frame_size); - } + case REFLECT_CODE_INTERNAL_APPLY: + { + unsigned long frame_size = (OBJECT_DATUM (STACK_POP ())); + SCHEME_OBJECT procedure = (STACK_POP ()); + TAIL_CALL_2 (comutil_apply, procedure, frame_size); + } case REFLECT_CODE_RESTORE_INTERRUPT_MASK: - { SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ())); INVOKE_RETURN_ADDRESS (); - } case REFLECT_CODE_STACK_MARKER: - { (void) STACK_POP (); /* marker1 */ (void) STACK_POP (); /* marker2 */ INVOKE_RETURN_ADDRESS (); - } case REFLECT_CODE_CC_BKPT: - { - unsigned long value; - /* Attempt to process interrupts before really proceeding. */ - - if (((long) (ADDR_TO_SCHEME_ADDR (Free))) - >= ((long) (Registers[REGBLOCK_MEMTOP]))) + if (Free >= GET_MEMTOP) + { + PUSH_REFLECTION (REFLECT_CODE_CC_BKPT); + compiler_interrupt_common (DSU_result, 0, SHARP_F); + return; + } { - STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT); - STACK_PUSH (reflect_to_interface); - COMPILER_INTERRUPT_COMMON (0, SHARP_F); + insn_t * addr; + long code = (do_bkpt_proceed (&addr)); + if (code != PRIM_DONE) + { + STACK_PUSH (code); + RETURN_TO_C (code); + } + RETURN_TO_SCHEME (addr); } - if (do_bkpt_proceed (& value)) - RETURN_TO_SCHEME (value); - else - RETURN_TO_C (value); - } - default: STACK_PUSH (code); RETURN_TO_C (ERR_EXTERNAL_RETURN); - } -} - -/* - Utility table used by the assembly language interface to invoke - the SCHEME_UTILITY procedures that appear in this file. - - Important: Do NOT reorder this table without changing the indices - defined on the following page and the corresponding table in the - compiler. - - In addition, this table must be declared before compiler_reset_internal. - */ - -#define UTE(name) ((utility_table_entry) name) - -utility_table_entry utility_table[] = -{ - UTE(comutil_return_to_interpreter), /* 0x0 */ - UTE(comutil_operator_apply_trap), /* 0x1 */ - UTE(comutil_operator_arity_trap), /* 0x2 */ - UTE(comutil_operator_entity_trap), /* 0x3 */ - UTE(comutil_operator_interpreted_trap), /* 0x4 */ - UTE(comutil_operator_lexpr_trap), /* 0x5 */ - UTE(comutil_operator_primitive_trap), /* 0x6 */ - UTE(comutil_operator_lookup_trap), /* 0x7 */ - UTE(comutil_operator_1_0_trap), /* 0x8 */ - UTE(comutil_operator_2_1_trap), /* 0x9 */ - UTE(comutil_operator_2_0_trap), /* 0xa */ - UTE(comutil_operator_3_2_trap), /* 0xb */ - UTE(comutil_operator_3_1_trap), /* 0xc */ - UTE(comutil_operator_3_0_trap), /* 0xd */ - UTE(comutil_operator_4_3_trap), /* 0xe */ - UTE(comutil_operator_4_2_trap), /* 0xf */ - UTE(comutil_operator_4_1_trap), /* 0x10 */ - UTE(comutil_operator_4_0_trap), /* 0x11 */ - UTE(comutil_primitive_apply), /* 0x12 */ - UTE(comutil_primitive_lexpr_apply), /* 0x13 */ - UTE(comutil_apply), /* 0x14 */ - UTE(comutil_error), /* 0x15 */ - UTE(comutil_lexpr_apply), /* 0x16 */ - UTE(comutil_link), /* 0x17 */ - UTE(comutil_interrupt_closure), /* 0x18 */ - UTE(comutil_interrupt_dlink), /* 0x19 */ - UTE(comutil_interrupt_procedure), /* 0x1a */ - UTE(comutil_interrupt_continuation), /* 0x1b */ - UTE(comutil_interrupt_ic_procedure), /* 0x1c */ - UTE(comutil_assignment_trap), /* 0x1d */ - UTE(comutil_cache_lookup_apply), /* 0x1e */ - UTE(comutil_lookup_trap), /* 0x1f */ - UTE(comutil_safe_lookup_trap), /* 0x20 */ - UTE(comutil_unassigned_p_trap), /* 0x21 */ - UTE(comutil_decrement), /* 0x22 */ - UTE(comutil_divide), /* 0x23 */ - UTE(comutil_equal), /* 0x24 */ - UTE(comutil_greater), /* 0x25 */ - UTE(comutil_increment), /* 0x26 */ - UTE(comutil_less), /* 0x27 */ - UTE(comutil_minus), /* 0x28 */ - UTE(comutil_multiply), /* 0x29 */ - UTE(comutil_negative), /* 0x2a */ - UTE(comutil_plus), /* 0x2b */ - UTE(comutil_positive), /* 0x2c */ - UTE(comutil_zero), /* 0x2d */ - UTE(comutil_access), /* 0x2e */ - UTE(comutil_reference), /* 0x2f */ - UTE(comutil_safe_reference), /* 0x30 */ - UTE(comutil_unassigned_p), /* 0x31 */ - UTE(comutil_unbound_p), /* 0x32 */ - UTE(comutil_assignment), /* 0x33 */ - UTE(comutil_definition), /* 0x34 */ - UTE(comutil_lookup_apply), /* 0x35 */ - UTE(comutil_primitive_error), /* 0x36 */ - UTE(comutil_quotient), /* 0x37 */ - UTE(comutil_remainder), /* 0x38 */ - UTE(comutil_modulo), /* 0x39 */ - UTE(comutil_reflect_to_interface), /* 0x3a */ - UTE(comutil_interrupt_continuation_2), /* 0x3b */ - UTE(comutil_compiled_code_bkpt), /* 0x3c */ - UTE(comutil_compiled_closure_bkpt) /* 0x3d */ - }; - -extern long MAX_TRAMPOLINE; -long MAX_TRAMPOLINE = ((sizeof (utility_table)) - / (sizeof (utility_table_entry))); - -/* Support for trap handling. */ - -static void -DEFUN_VOID (end_of_utils) -{ - return; -} - -struct util_descriptor_s -{ - PTR pc; - char * name; -}; - -#ifdef STDC_HEADERS -# define UTLD(name) { ((PTR) name), #name } -#else -/* Hope that this works. */ -# define UTLD(name) { ((PTR) name), "name" } -#endif - -static -struct util_descriptor_s utility_descriptor_table[] = -{ -#ifdef DECLARE_CMPINTMD_UTILITIES - DECLARE_CMPINTMD_UTILITIES(), -#endif /* DECLARE_CMPINTMD_UTILITIES */ - UTLD(C_to_interface), - UTLD(open_gap), - UTLD(setup_lexpr_invocation), - UTLD(setup_compiled_invocation), - UTLD(enter_compiled_expression), - UTLD(apply_compiled_procedure), - UTLD(return_to_compiled_code), - UTLD(apply_compiled_from_primitive), - UTLD(compiled_with_interrupt_mask), - UTLD(compiled_with_stack_marker), - UTLD(comutil_return_to_interpreter), - UTLD(comutil_primitive_apply), - UTLD(comutil_primitive_lexpr_apply), - UTLD(comutil_apply), - UTLD(comutil_error), - UTLD(comutil_lexpr_apply), - UTLD(abort_link_cc_block), - UTLD(link_cc_block), - UTLD(comutil_link), - UTLD(comp_link_caches_restart), - UTLD(comutil_operator_apply_trap), - UTLD(comutil_operator_arity_trap), - UTLD(comutil_operator_entity_trap), - UTLD(comutil_operator_interpreted_trap), - UTLD(comutil_operator_lexpr_trap), - UTLD(comutil_operator_primitive_trap), - UTLD(comutil_operator_lookup_trap), - UTLD(comp_op_lookup_trap_restart), - UTLD(comutil_operator_1_0_trap), - UTLD(comutil_operator_2_1_trap), - UTLD(comutil_operator_2_0_trap), - UTLD(comutil_operator_3_2_trap), - UTLD(comutil_operator_3_1_trap), - UTLD(comutil_operator_3_0_trap), - UTLD(comutil_operator_4_3_trap), - UTLD(comutil_operator_4_2_trap), - UTLD(comutil_operator_4_1_trap), - UTLD(comutil_operator_4_0_trap), - UTLD(compiler_interrupt_common), - UTLD(comutil_interrupt_closure), - UTLD(comutil_interrupt_dlink), - UTLD(comutil_interrupt_procedure), - UTLD(comutil_interrupt_continuation), - UTLD(comutil_interrupt_ic_procedure), - UTLD(comutil_interrupt_continuation_2), - UTLD(comp_interrupt_restart), - - UTLD(comutil_assignment_trap), - UTLD(comp_assignment_trap_restart), - UTLD(comutil_cache_lookup_apply), - UTLD(comp_cache_lookup_apply_restart), - UTLD(comutil_lookup_trap), - UTLD(comp_lookup_trap_restart), - UTLD(comutil_safe_lookup_trap), - UTLD(comp_safe_lookup_trap_restart), - UTLD(comutil_unassigned_p_trap), - UTLD(comp_unassigned_p_trap_restart), - UTLD(comutil_decrement), - UTLD(comutil_divide), - UTLD(comutil_equal), - UTLD(comutil_greater), - UTLD(comutil_increment), - UTLD(comutil_less), - UTLD(comutil_minus), - UTLD(comutil_modulo), - UTLD(comutil_multiply), - UTLD(comutil_negative), - UTLD(comutil_plus), - UTLD(comutil_positive), - UTLD(comutil_quotient), - UTLD(comutil_remainder), - UTLD(comutil_zero), - UTLD(comutil_access), - UTLD(comp_access_restart), - UTLD(comutil_reference), - UTLD(comp_reference_restart), - UTLD(comutil_safe_reference), - UTLD(comp_safe_reference_restart), - UTLD(comutil_unassigned_p), - UTLD(comp_unassigned_p_restart), - UTLD(comutil_unbound_p), - UTLD(comp_unbound_p_restart), - UTLD(comutil_assignment), - UTLD(comp_assignment_restart), - UTLD(comutil_definition), - UTLD(comp_definition_restart), - UTLD(comutil_lookup_apply), - UTLD(comp_lookup_apply_restart), - UTLD(comutil_primitive_error), - UTLD(comp_error_restart), - UTLD(compiled_block_debugging_info), - UTLD(compiled_block_environment), - UTLD(compiled_entry_to_block_address), - UTLD(compiled_entry_to_block), - UTLD(compiled_entry_to_block_offset), - UTLD(block_address_closure_p), - UTLD(compiled_block_closure_p), - UTLD(compiled_entry_closure_p), - UTLD(compiled_closure_to_entry), - UTLD(compiled_entry_type), - UTLD(declare_compiled_code_block), - UTLD(store_variable_cache), - UTLD(extract_variable_cache), - UTLD(extract_uuo_link), - UTLD(store_uuo_link), - UTLD(fill_trampoline), - UTLD(make_trampoline), - UTLD(make_redirection_trampoline), - UTLD(make_apply_trampoline), - UTLD(make_uuo_link), - UTLD(make_fake_uuo_link), - UTLD(coerce_to_compiled), -#ifndef HAVE_BKPT_SUPPORT - UTLD(bkpt_install), - UTLD(bkpt_closure_install), - UTLD(bkpt_remove), - UTLD(bkpt_p), - UTLD(do_bkpt_proceed), -#endif - UTLD(bkpt_proceed), - UTLD(comutil_compiled_code_bkpt), - UTLD(comutil_compiled_closure_bkpt), - UTLD(comutil_reflect_to_interface), - UTLD(end_of_utils) -}; - -extern char * EXFUN (utility_index_to_name, (int)); -extern int EXFUN (pc_to_utility_index, (unsigned long)); - -#define UTIL_TABLE_PC_REF_REAL(index) \ - ((unsigned long) (utility_descriptor_table[index].pc)) - -#ifndef UTIL_TABLE_PC_REF -# define UTIL_TABLE_PC_REF(index) (UTIL_TABLE_PC_REF_REAL (index)) -#endif - -static int last_util_table_index = - (((sizeof (utility_descriptor_table)) / (sizeof (struct util_descriptor_s))) - - 1); - -char * -DEFUN (utility_index_to_name, (index), int index) -{ - if ((index < 0) || (index >= last_util_table_index)) - return ((char *) NULL); - else - return (utility_descriptor_table[index].name); -} - -int -DEFUN (pc_to_utility_index, (pc), unsigned long pc) -{ - /* Binary search */ - - extern int EXFUN (pc_to_builtin_index, (unsigned long)); - - if ((pc < (UTIL_TABLE_PC_REF (0))) - || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index)))) - return (-1); - else if (pc < (UTIL_TABLE_PC_REF (1))) - return (((pc_to_builtin_index (pc)) == -1) ? 0 : -1); - else - { - int low, high, middle; - - low = 0; - high = last_util_table_index; - while ((low + 1) < high) - { - middle = ((low + high) / 2); - if (pc < (UTIL_TABLE_PC_REF (middle))) - high = middle; - else if (pc > (UTIL_TABLE_PC_REF (middle))) - low = middle; - else - return (middle); } - return ((pc == (UTIL_TABLE_PC_REF (high))) ? high : low); - } } - -extern char * EXFUN (builtin_index_to_name, (int)); -extern void EXFUN (declare_builtin, (unsigned long, char *)); -extern int EXFUN (pc_to_builtin_index, (unsigned long)); -extern unsigned long * builtins; -static int n_builtins = 0; -static int s_builtins = 0; -unsigned long * builtins = ((unsigned long *) NULL); -char ** builtin_names = ((char **) NULL); - -void -DEFUN (declare_builtin, (builtin, name), - unsigned long builtin AND char * name) -{ - if (n_builtins == s_builtins) - { - if (s_builtins == 0) - { - s_builtins = 30; - builtins = ((unsigned long *) - (malloc (s_builtins * (sizeof (unsigned long))))); - builtin_names = ((char **) (malloc (s_builtins * (sizeof (char *))))); - } - else - { - s_builtins += s_builtins; - builtins = ((unsigned long *) - (realloc (builtins, - (s_builtins * (sizeof (unsigned long)))))); - builtin_names = ((char **) - (realloc (builtin_names, - (s_builtins * (sizeof (char *)))))); - } - if ((builtins == ((unsigned long *) NULL)) - || (builtin_names == ((char **) NULL))) - { - outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n", - s_builtins); - termination_init_error (); - } - } - { - unsigned int low = 0; - unsigned int high = n_builtins; - while (1) - { - if (low < high) - { - unsigned int middle = ((low + high) / 2); - if (builtin < (builtins[middle])) - high = middle; - else if (builtin > (builtins[middle])) - low = (middle + 1); - else - { - (builtin_names[middle]) = name; - return; - } - } - else - { - unsigned int scan = n_builtins; - while (low < scan) - { - (builtins [scan]) = (builtins [scan - 1]); - (builtin_names [scan]) = (builtin_names [scan - 1]); - scan -= 1; - } - (builtins [low]) = builtin; - (builtin_names [low]) = name; - return; - } - } - } -} - -char * -DEFUN (builtin_index_to_name, (index), int index) +DEFINE_TRAMPOLINE (comutil_operator_apply_trap) { - if ((index < 0) || (index >= n_builtins)) - return ((char *) NULL); - else - return (builtin_names[index]); + INIT_TRAMPOLINE_2 (procedure, frame_header); + TAIL_CALL_2 (comutil_apply, procedure, (OBJECT_DATUM (frame_header))); } -int -DEFUN (pc_to_builtin_index, (pc), unsigned long pc) +DEFINE_TRAMPOLINE (comutil_operator_primitive_trap) { - /* Binary search */ - - if ((builtins == ((unsigned long *) NULL)) - || (pc < (builtins[0])) - || (pc >= (builtins[n_builtins - 1]))) - return (-1); - else - { - int low, high, middle; - - low = 0; - high = (n_builtins - 1); - while ((low + 1) < high) - { - middle = ((low + high) / 2); - if (pc < (builtins[middle])) - high = middle; - else if (pc > (builtins[middle])) - low = middle; - else - return (middle); - } - return ((pc == (builtins[high])) ? high : low); - } + INIT_TRAMPOLINE_1 (primitive); + TAIL_CALL_1 (comutil_primitive_apply, primitive); } - -/* Initialization */ - -#define COMPILER_INTERFACE_VERSION 3 - -#ifndef COMPILER_REGBLOCK_N_FIXED -# define COMPILER_REGBLOCK_N_FIXED 16 -#endif - -#ifndef COMPILER_REGBLOCK_N_TEMPS -# define COMPILER_REGBLOCK_N_TEMPS 256 -#endif - -#ifndef COMPILER_REGBLOCK_EXTRA_SIZE -# define COMPILER_REGBLOCK_EXTRA_SIZE 0 -#endif - -#if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED) -# include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!" -#endif - -/* ((sizeof(SCHEME_OBJECT)) / (sizeof(SCHEME_OBJECT))) */ - -#define COMPILER_FIXED_SIZE 1 - -#ifndef COMPILER_TEMP_SIZE -# define COMPILER_TEMP_SIZE ((sizeof (double)) / (sizeof (SCHEME_OBJECT))) -#endif - -#define REGBLOCK_LENGTH \ - ((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) + \ - (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) + \ - COMPILER_REGBLOCK_EXTRA_SIZE) -#ifndef ASM_RESET_HOOK -# define ASM_RESET_HOOK() NOP() -#endif - -long - compiler_processor_type, - compiler_interface_version; - -SCHEME_OBJECT - compiler_utilities, - return_to_interpreter; - -#if !defined(REGBLOCK_ALLOCATED_BY_INTERFACE) && !defined(__WIN32__) -SCHEME_OBJECT Registers [REGBLOCK_LENGTH]; -#endif - -static void -DEFUN_VOID (compiler_reset_internal) +DEFINE_TRAMPOLINE (comutil_operator_lexpr_trap) { - long len; - SCHEME_OBJECT * block; - - /* Other stuff can be placed here. */ - - block = (OBJECT_ADDRESS (compiler_utilities)); - len = (OBJECT_DATUM (block[0])); - - return_to_interpreter = - (ENTRY_TO_OBJECT (((char *) block) - + ((unsigned long) (block [len - 1])))); - - reflect_to_interface = - (ENTRY_TO_OBJECT (((char *) block) - + ((unsigned long) (block [len])))); - - (Registers[REGBLOCK_CLOSURE_FREE]) = ((SCHEME_OBJECT) NULL); - (Registers[REGBLOCK_CLOSURE_SPACE]) = ((SCHEME_OBJECT) 0); - (Registers[REGBLOCK_REFLECT_TO_INTERFACE]) = reflect_to_interface; - - ASM_RESET_HOOK(); - - return; + INIT_TRAMPOLINE_2 (procedure, frame_header); + SET_LEXPR_ACTUALS (APPLY_FRAME_HEADER_N_ARGS (frame_header)); + TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure); } -#define COMPILER_UTILITIES_N_ENTRIES 2 -#define COMPILER_UTILITIES_LENGTH \ - ((COMPILER_UTILITIES_N_ENTRIES * (TRAMPOLINE_ENTRY_SIZE + 1)) + 2) +/* ARITY mismatch handling -C_UTILITY void -DEFUN (compiler_initialize, (fasl_p), long fasl_p) -{ - /* Start-up of whole interpreter */ - - (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F; - compiler_processor_type = COMPILER_PROCESSOR_TYPE; - compiler_interface_version = COMPILER_INTERFACE_VERSION; - if (fasl_p) - { - long len; - instruction * tramp1, * tramp2; - SCHEME_OBJECT * block; - extern SCHEME_OBJECT * EXFUN (copy_to_constant_space, - (SCHEME_OBJECT *, long)); - - len = COMPILER_UTILITIES_LENGTH; - if (GC_Check (len)) - { - outf_fatal ("compiler_initialize: Not enough space!\n"); - Microcode_Termination (TERM_NO_SPACE); - } + These receive the entry point as an argument and must fill the + Scheme stack with the missing default values. They are invoked by + TRAMPOLINE_K_n_m where n and m are the same as in the name of the + procedure. All the arguments are on the Scheme stack. */ - block = Free; - Free += len; - block[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len - 1))); - block[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - (COMPILER_UTILITIES_N_ENTRIES - * TRAMPOLINE_ENTRY_SIZE))); - - tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block))); - fill_trampoline (block, tramp1, - ((format_word) FORMAT_WORD_RETURN), - TRAMPOLINE_K_RETURN); - block[len - 2] = (((char *) tramp1) - ((char *) block)); - - tramp2 = ((instruction *) - (((char *) tramp1) - + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT))))); - fill_trampoline (block, tramp2, - ((format_word) FORMAT_WORD_RETURN), - TRAMPOLINE_K_REFLECT_TO_INTERFACE); - block[len - 1] = (((char *) tramp2) - ((char *) block)); - - block = (copy_to_constant_space (block, len)); - compiler_utilities = (MAKE_CC_BLOCK (block)); - compiler_reset_internal (); - } - else - { - /* Delay until after band-load, when compiler_reset will be invoked. */ - compiler_utilities = SHARP_F; - return_to_interpreter = SHARP_F; -#ifdef sonyrisc - /* On the Sony NEWS 3250, this procedure initializes the - floating-point CPU control register to enable the IEEE traps. - This is normally executed by `compiler_reset' from LOAD-BAND, - but the Sony operating system saves the control register in - `setjmp' and restores it on `longjmp', so we must initialize - the register before `setjmp' is called. */ - interface_initialize (); -#endif -#ifdef __OS2__ - /* Same as for Sony. */ - i386_interface_initialize (); -#endif - } - return; -} - -C_UTILITY void -DEFUN (compiler_reset, - (new_block), - SCHEME_OBJECT new_block) +DEFINE_TRAMPOLINE (comutil_operator_1_0_trap) { - /* Called after a disk restore */ - - if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK) - { - extern void EXFUN (compiler_reset_error, (void)); - -lose: - compiler_reset_error (); - return; - } - else if ((MEMORY_REF (new_block, 0)) - != (MAKE_OBJECT (TC_MANIFEST_VECTOR, - (COMPILER_UTILITIES_LENGTH - 1)))) - { - /* Backwards compatibility */ - if ((MEMORY_REF (new_block, 0)) - != (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - (COMPILER_UTILITIES_N_ENTRIES - * (TRAMPOLINE_ENTRY_SIZE + 1))))) - goto lose; - } - else if ((MEMORY_REF (new_block, 1)) - != (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - (COMPILER_UTILITIES_N_ENTRIES - * TRAMPOLINE_ENTRY_SIZE)))) - goto lose; - - compiler_utilities = new_block; - compiler_reset_internal (); - return; + INIT_TRAMPOLINE_1 (procedure); + STACK_PUSH (DEFAULT_OBJECT); + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -#ifndef NATIVE_CODE_IS_C - -SCHEME_OBJECT * -DEFUN (cons_c_code_table, (start, limit, length), - SCHEME_OBJECT * start - AND SCHEME_OBJECT * limit - AND long * length) +DEFINE_TRAMPOLINE (comutil_operator_2_0_trap) { - * length = 0; - return (start); + INIT_TRAMPOLINE_1 (procedure); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -Boolean -DEFUN (install_c_code_table, (table, length), - SCHEME_OBJECT * table AND long length) +DEFINE_TRAMPOLINE (comutil_operator_2_1_trap) { - return (length == 0); + INIT_TRAMPOLINE_1 (procedure); + { + SCHEME_OBJECT a1 = (STACK_POP ()); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (a1); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -#endif /* NATIVE_CODE_IS_C */ - -#else /* not HAS_COMPILER_SUPPORT */ - -/* Stubs for compiler utilities. - All entries error out or kill the microcode. - */ - -extern void EXFUN (Microcode_Termination, (int code)); -extern void EXFUN (compiler_reset_error, (void)); - -extern long - compiler_interface_version, - compiler_processor_type; - -extern SCHEME_OBJECT - compiler_utilities, - return_to_interpreter; - -extern long - EXFUN (enter_compiled_expression, (void)), - EXFUN (apply_compiled_procedure, (void)), - EXFUN (return_to_compiled_code, (void)), - EXFUN (make_fake_uuo_link, - (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)), - EXFUN (make_uuo_link, - (SCHEME_OBJECT value, SCHEME_OBJECT extension, - SCHEME_OBJECT block, long offset)), - EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)), - EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)), - EXFUN (coerce_to_compiled, - (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location)); - -extern SCHEME_OBJECT - EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)), - EXFUN (extract_variable_cache, - (SCHEME_OBJECT extension, long offset)), - EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)), - EXFUN (compiled_block_environment, (SCHEME_OBJECT block)), - EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)), - * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)), - EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)), - EXFUN (apply_compiled_from_primitive, (int)), - EXFUN (compiled_with_interrupt_mask, (unsigned long, - SCHEME_OBJECT, - unsigned long)), - EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)), - * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -extern Boolean - EXFUN (install_c_code_table, (SCHEME_OBJECT *, long)); - -extern void - EXFUN (compiler_reset, (SCHEME_OBJECT new_block)), - EXFUN (compiler_initialize, (long fasl_p)), - EXFUN (store_variable_cache, - (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)), - EXFUN (compiled_entry_type, (SCHEME_OBJECT entry, long *buffer)), - EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block)); - -/* Breakpoint stuff. */ - -extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR)); -extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR)); -extern Boolean EXFUN (bkpt_p, (PTR)); -extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT)); -extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT)); - -SCHEME_OBJECT -#ifndef __WIN32__ - Registers [REGBLOCK_MINIMUM_LENGTH], -#endif - compiler_utilities, - return_to_interpreter; - -long - compiler_interface_version, - compiler_processor_type; - -long -DEFUN_VOID (enter_compiled_expression) +DEFINE_TRAMPOLINE (comutil_operator_3_0_trap) { - return (ERR_EXECUTE_MANIFEST_VECTOR); + INIT_TRAMPOLINE_1 (procedure); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -long -DEFUN_VOID (apply_compiled_procedure) +DEFINE_TRAMPOLINE (comutil_operator_3_1_trap) { - return (ERR_INAPPLICABLE_OBJECT); + INIT_TRAMPOLINE_1 (procedure); + { + SCHEME_OBJECT a1 = (STACK_POP ()); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (a1); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } - -long -DEFUN_VOID (return_to_compiled_code) + +DEFINE_TRAMPOLINE (comutil_operator_3_2_trap) { - return (ERR_INAPPLICABLE_CONTINUATION); + INIT_TRAMPOLINE_1 (procedure); + { + SCHEME_OBJECT a1 = (STACK_POP ()); + SCHEME_OBJECT a2 = (STACK_POP ()); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (a2); + STACK_PUSH (a1); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -SCHEME_OBJECT -DEFUN (apply_compiled_from_primitive, (arity), int arity) +DEFINE_TRAMPOLINE (comutil_operator_4_0_trap) { - signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION); - /*NOTREACHED*/ + INIT_TRAMPOLINE_1 (procedure); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -SCHEME_OBJECT -DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask), - unsigned long old_mask - AND SCHEME_OBJECT receiver - AND unsigned long new_mask) +DEFINE_TRAMPOLINE (comutil_operator_4_1_trap) { - signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION); - /*NOTREACHED*/ + INIT_TRAMPOLINE_1 (procedure); + { + SCHEME_OBJECT a1 = (STACK_POP ()); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (a1); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -SCHEME_OBJECT -DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk) +DEFINE_TRAMPOLINE (comutil_operator_4_2_trap) { - signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION); - /*NOTREACHED*/ + INIT_TRAMPOLINE_1 (procedure); + { + SCHEME_OBJECT a1 = (STACK_POP ()); + SCHEME_OBJECT a2 = (STACK_POP ()); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (a2); + STACK_PUSH (a1); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); } -SCHEME_OBJECT * -DEFUN (cons_c_code_table, (start, limit, length), - SCHEME_OBJECT * start - AND SCHEME_OBJECT * limit - AND long * length) +DEFINE_TRAMPOLINE (comutil_operator_4_3_trap) { - * length = 0; - return (start); + INIT_TRAMPOLINE_1 (procedure); + { + SCHEME_OBJECT a1 = (STACK_POP ()); + SCHEME_OBJECT a2 = (STACK_POP ()); + SCHEME_OBJECT a3 = (STACK_POP ()); + STACK_PUSH (DEFAULT_OBJECT); + STACK_PUSH (a3); + STACK_PUSH (a2); + STACK_PUSH (a1); + } + RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); +} + +/* The linker either couldn't find a binding or the binding was + unassigned. This must report the correct name of the missing + variable and the environment in which the lookup begins for the + error cases. + + 'cache' is the linker object corresponding to the operator variable + (it contains the actual value cell, the name, and linker tables). + 'block' and 'offset' point to the cache cell in question. */ + +DEFINE_TRAMPOLINE (comutil_operator_lookup_trap) +{ + INIT_TRAMPOLINE_3 (cache, block, offset); + SCHEME_OBJECT * cache_addr = (MEMORY_LOC (block, (OBJECT_DATUM (offset)))); + unsigned long frame_size = (read_uuo_frame_size (cache_addr)); + SCHEME_OBJECT procedure; + long code = (compiler_operator_reference_trap (cache, (&procedure))); + if (code != PRIM_DONE) + { + STACK_PUSH (MAKE_CC_ENTRY (read_uuo_target_no_reloc (cache_addr))); + /* Next three for debugger. */ + STACK_PUSH (ULONG_TO_FIXNUM (frame_size)); + STACK_PUSH (cc_block_environment (block)); + STACK_PUSH + (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR)); + SAVE_LAST_RETURN_CODE (RC_COMP_OP_REF_TRAP_RESTART); + RETURN_TO_C (code); + } + TAIL_CALL_2 (comutil_apply, procedure, frame_size); } -Boolean -DEFUN (install_c_code_table, (table, length), - SCHEME_OBJECT * table AND long length) +/* Re-start after processing an error/interrupt encountered in the + previous utility. Extract the new trampoline or procedure (the + user may have defined the missing variable) and invoke it. */ + +DEFINE_SCHEME_ENTRY (comp_op_lookup_trap_restart) { - return (length == 0); + RESTORE_LAST_RETURN_CODE (); + /* Discard debugger info. */ + stack_pointer = (STACK_LOC (3)); + { + SCHEME_OBJECT * store + = (trampoline_storage (cc_entry_to_block_address (STACK_POP ()))); + SCHEME_OBJECT block = (store[1]); + unsigned long offset = (OBJECT_DATUM (store[2])); + ENTER_SCHEME (read_uuo_target_no_reloc (MEMORY_LOC (block, offset))); + } } -/* Bad entry points. */ +/* make_uuo_link is called by C and initializes a compiled procedure + cache at a location given by a block and an offset. */ long -DEFUN (make_fake_uuo_link, - (extension, block, offset), - SCHEME_OBJECT extension AND SCHEME_OBJECT block AND - long offset) +make_uuo_link (SCHEME_OBJECT procedure, + SCHEME_OBJECT cache, + SCHEME_OBJECT block, + unsigned long offset) +{ + SCHEME_OBJECT * cache_address = (MEMORY_LOC (block, offset)); + unsigned long frame_size = (read_uuo_frame_size (cache_address)); + SCHEME_OBJECT orig_proc; + trampoline_type_t kind; + long result; + SCHEME_OBJECT trampoline; + + if (REFERENCE_TRAP_P (procedure)) + return (make_fake_uuo_link (cache, block, offset)); + + orig_proc = procedure; + loop: + switch (OBJECT_TYPE (procedure)) + { + case TC_COMPILED_ENTRY: + { + insn_t * entry = (CC_ENTRY_ADDRESS (procedure)); + unsigned long nargs = (frame_size - 1); + cc_entry_type_t cet; + unsigned long nmin; + unsigned long nmax; + + if ((read_cc_entry_type ((&cet), entry)) + || ((cet.marker) != CET_PROCEDURE)) + return (ERR_COMPILED_CODE_ERROR); + nmin = (cet.args.for_procedure.n_required); + nmax = (nmin + (cet.args.for_procedure.n_optional)); + if (cet.args.for_procedure.rest_p) + kind = TRAMPOLINE_K_APPLY; + else if (nargs == nmax) + { + /* No defaulting is needed. */ + write_uuo_link (procedure, cache_address); + return (PRIM_DONE); + } + else if ((nargs < nmax) + && (nargs >= nmin) + && (nmin < nmax) + && (nmax <= TRAMPOLINE_TABLE_SIZE)) + { + /* We have optimized defaulting for this case. */ + kind + = (trampoline_arity_table + [(((nmax - 1) * TRAMPOLINE_TABLE_SIZE) + nargs)]); + assert (kind != TRAMPOLINE_K_APPLY); + frame_size = 0; + } + else + /* Use unoptimized defaulting. */ + kind = TRAMPOLINE_K_APPLY; + break; + } + + case TC_ENTITY: + { + SCHEME_OBJECT data = (MEMORY_REF (procedure, ENTITY_DATA)); + if ((VECTOR_P (data)) + && (frame_size < (VECTOR_LENGTH (data))) + && ((VECTOR_REF (data, frame_size)) != SHARP_F) + && ((VECTOR_REF (data, 0)) + == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))) + { + procedure = (VECTOR_REF (data, frame_size)); + goto loop; + } + kind = TRAMPOLINE_K_APPLY; + break; + } + + case TC_PRIMITIVE: + { + long arity = (PRIMITIVE_ARITY (procedure)); + if (arity == ((long) (frame_size - 1))) + { + kind = TRAMPOLINE_K_PRIMITIVE; + frame_size = 0; + } + else if (arity == LEXPR_PRIMITIVE_ARITY) + kind = TRAMPOLINE_K_LEXPR_PRIMITIVE; + else + kind = TRAMPOLINE_K_APPLY; + break; + } + + default: + kind = TRAMPOLINE_K_APPLY; + break; + } + result + = ((frame_size == 0) + ? (make_redirection_trampoline ((&trampoline), kind, procedure)) + : (make_apply_trampoline ((&trampoline), kind, procedure, frame_size))); + if (result == PRIM_DONE) + write_uuo_link (trampoline, cache_address); + return (result); +} + +static long +make_fake_uuo_link (SCHEME_OBJECT cache, + SCHEME_OBJECT block, + unsigned long offset) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + cc_entry_type_t cet; + SCHEME_OBJECT trampoline; + + make_cc_entry_type ((&cet), CET_TRAMPOLINE); + { + long result = (make_trampoline ((&trampoline), + (&cet), + TRAMPOLINE_K_LOOKUP, + 3, + cache, + block, + (ULONG_TO_FIXNUM (offset)))); + if (result != PRIM_DONE) + return (result); + } + { + SCHEME_OBJECT * cache_address = (MEMORY_LOC (block, offset)); + write_uuo_link (trampoline, cache_address); + } + return (PRIM_DONE); } long -DEFUN (make_uuo_link, - (value, extension, block, offset), - SCHEME_OBJECT value AND SCHEME_OBJECT extension AND - SCHEME_OBJECT block AND long offset) +coerce_to_compiled (SCHEME_OBJECT procedure, + unsigned int arity, + SCHEME_OBJECT * location) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + cc_entry_type_t cet; + + if (CC_ENTRY_P (procedure)) + { + if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (procedure)))) + return (ERR_COMPILED_CODE_ERROR); + if ((cet.marker) == CET_PROCEDURE) + { + (*location) = procedure; + return (PRIM_DONE); + } + } + make_compiled_procedure_type ((&cet), arity, 0, false); + return (make_trampoline (location, + (&cet), + TRAMPOLINE_K_APPLY, + 2, + procedure, + (ULONG_TO_FIXNUM (arity + 1)))); } + +static long +make_trampoline (SCHEME_OBJECT * slot, + cc_entry_type_t * cet, + trampoline_type_t kind, + unsigned int n_values, + ...) +{ + SCHEME_OBJECT h1; + SCHEME_OBJECT h2; + unsigned long n_words; + SCHEME_OBJECT * block; -SCHEME_OBJECT -DEFUN (extract_uuo_link, - (block, offset), - SCHEME_OBJECT block AND long offset) -{ - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + make_trampoline_headers (1, n_values, (&h1), (&h2), (&n_words)); + if (GC_NEEDED_P (n_words)) + { + REQUEST_GC (n_words); + return (PRIM_INTERRUPT); + } + block = Free; + Free += n_words; + (block[0]) = h1; + (block[1]) = h2; + if (fill_trampoline (block, 0, cet, kind)) + return (ERR_COMPILED_CODE_ERROR); + { + SCHEME_OBJECT * p = (trampoline_storage (block)); + va_list ap; + + va_start (ap, n_values); + while (n_values > 0) + { + (*p++) = (va_arg (ap, SCHEME_OBJECT)); + n_values -= 1; + } + va_end (ap); + } + (*slot) = (MAKE_CC_ENTRY (trampoline_entry_addr (block, 0))); + return (PRIM_DONE); } -void -DEFUN (store_variable_cache, - (extension, block, offset), - SCHEME_OBJECT extension AND SCHEME_OBJECT block AND - long offset) -{ - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ +static void +make_trampoline_headers (unsigned long n_entries, unsigned long n_store, + SCHEME_OBJECT * h1_r, SCHEME_OBJECT * h2_r, + unsigned long * n_words_r) +{ + unsigned long n1 = (trampoline_entry_size (n_entries)); + unsigned long n2 = (1 + n1 + n_store); + (*h1_r) = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER, n2)); + (*h2_r) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n1)); + (*n_words_r) = (1 + n2); +} + +static bool +fill_trampoline (SCHEME_OBJECT * block, + unsigned long index, + cc_entry_type_t * cet, + trampoline_type_t kind) +{ + insn_t * addr = (trampoline_entry_addr (block, index)); + if (write_cc_entry_type (cet, addr)) + return (true); + { + cc_entry_offset_t ceo; + (ceo.offset) = (addr - ((insn_t *) block)); + (ceo.continued_p) = false; + if (write_cc_entry_offset ((&ceo), addr)) + return (true); + } + return (store_trampoline_insns (addr, kind)); } -SCHEME_OBJECT -DEFUN (extract_variable_cache, - (block, offset), - SCHEME_OBJECT block AND - long offset) +SCHEME_OBJECT * +trampoline_storage (SCHEME_OBJECT * block) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + return (block + 2 + (OBJECT_DATUM (block[1]))); } -SCHEME_OBJECT -DEFUN (compiled_block_debugging_info, - (block), - SCHEME_OBJECT block) +static long +make_redirection_trampoline (SCHEME_OBJECT * slot, + trampoline_type_t kind, + SCHEME_OBJECT procedure) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + cc_entry_type_t cet; + make_cc_entry_type ((&cet), CET_TRAMPOLINE); + return (make_trampoline (slot, (&cet), kind, 1, procedure)); } -SCHEME_OBJECT -DEFUN (compiled_block_environment, - (block), - SCHEME_OBJECT block) +static long +make_apply_trampoline (SCHEME_OBJECT * slot, + trampoline_type_t kind, + SCHEME_OBJECT procedure, + unsigned long frame_size) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + cc_entry_type_t cet; + make_cc_entry_type ((&cet), CET_TRAMPOLINE); + return (make_trampoline (slot, + (&cet), + kind, + 2, + procedure, + (ULONG_TO_FIXNUM (frame_size)))); } + +/* Compiled-code breakpoints */ -long -DEFUN (compiled_block_closure_p, - (block), - SCHEME_OBJECT block) -{ - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ -} +#ifdef HAVE_BKPT_SUPPORT -SCHEME_OBJECT * -DEFUN (compiled_entry_to_block_address, - (entry), - SCHEME_OBJECT entry) +#define BKPT_PROCEED_FRAME_SIZE 3 + +SCHEME_OBJECT +bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + if (! ((CC_ENTRY_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) + && ((CC_ENTRY_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) == ep))) + error_external_return (); + PUSH_REFLECTION (REFLECT_CODE_CC_BKPT); + stack_pointer = (STACK_LOC (-BKPT_PROCEED_FRAME_SIZE)); + return (SHARP_F); } -long -DEFUN (compiled_entry_to_block_offset, - (entry), - SCHEME_OBJECT entry) +#else /* not HAVE_BKPT_SUPPORT */ + +SCHEME_OBJECT +bkpt_install (insn_t * ep) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + return (SHARP_F); } SCHEME_OBJECT -DEFUN (compiled_entry_to_block, - (entry), - SCHEME_OBJECT entry) +bkpt_closure_install (insn_t * ep) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + return (SHARP_F); } - void -DEFUN (compiled_entry_type, - (entry, buffer), - SCHEME_OBJECT entry AND long *buffer) +bkpt_remove (insn_t * ep, SCHEME_OBJECT handle) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + error_external_return (); } -long -DEFUN (compiled_entry_closure_p, - (entry), - SCHEME_OBJECT entry) +bool +bkpt_p (insn_t * ep) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + return (false); } SCHEME_OBJECT -DEFUN (compiled_closure_to_entry, (entry), SCHEME_OBJECT entry) +bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state) { - Microcode_Termination (TERM_COMPILER_DEATH); - /*NOTREACHED*/ + error_external_return (); + return (UNSPECIFIC); } -void -DEFUN (declare_compiled_code_block, (block), SCHEME_OBJECT block) +long +do_bkpt_proceed (insn_t ** addr_r) { - return; + return (ERR_EXTERNAL_RETURN); } -#define LOSING_RETURN_ADDRESS(name) \ -extern long EXFUN (name, (void)); \ -long \ -DEFUN_VOID (name) \ -{ \ - Microcode_Termination (TERM_COMPILER_DEATH); \ - /*NOTREACHED*/ \ -} - -LOSING_RETURN_ADDRESS (comp_interrupt_restart) -LOSING_RETURN_ADDRESS (comp_lookup_apply_restart) -LOSING_RETURN_ADDRESS (comp_reference_restart) -LOSING_RETURN_ADDRESS (comp_access_restart) -LOSING_RETURN_ADDRESS (comp_unassigned_p_restart) -LOSING_RETURN_ADDRESS (comp_unbound_p_restart) -LOSING_RETURN_ADDRESS (comp_assignment_restart) -LOSING_RETURN_ADDRESS (comp_definition_restart) -LOSING_RETURN_ADDRESS (comp_safe_reference_restart) -LOSING_RETURN_ADDRESS (comp_lookup_trap_restart) -LOSING_RETURN_ADDRESS (comp_assignment_trap_restart) -LOSING_RETURN_ADDRESS (comp_op_lookup_trap_restart) -LOSING_RETURN_ADDRESS (comp_cache_lookup_apply_restart) -LOSING_RETURN_ADDRESS (comp_safe_lookup_trap_restart) -LOSING_RETURN_ADDRESS (comp_unassigned_p_trap_restart) -LOSING_RETURN_ADDRESS (comp_link_caches_restart) -LOSING_RETURN_ADDRESS (comp_error_restart) +#endif /* not HAVE_BKPT_SUPPORT */ -/* NOP entry points */ - -void -DEFUN (compiler_reset, (new_block), SCHEME_OBJECT new_block) +DEFINE_SCHEME_UTILITY_2 (comutil_compiled_code_bkpt, entry_addr, state) { - extern void EXFUN (compiler_reset_error, (void)); + DECLARE_UTILITY_ARG (insn_t *, entry_addr); + DECLARE_UTILITY_ARG (void *, state); + SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr)); + cc_entry_type_t cet; + SCHEME_OBJECT to_save; + SCHEME_OBJECT stack_ptr; - if (new_block != SHARP_F) - compiler_reset_error (); - return; -} + /* Potential bug: This does not preserve the environment for IC + procedures. There is no way to tell that we have an IC procedure + in our hands. It is not safe to preserve it in general because + the contents of the register may be stale (predate the last GC). + However, the compiler no longer generates IC procedures, and will + probably never do it again. */ -void -DEFUN (compiler_initialize, (fasl_p), long fasl_p) -{ - (Registers[REGBLOCK_PRIMITIVE]) = SHARP_F; - compiler_processor_type = 0; - compiler_interface_version = 0; - compiler_utilities = SHARP_F; - return_to_interpreter = - (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE)); - return; -} + if (read_cc_entry_type ((&cet), entry_addr)) + to_save = SHARP_F; + else + switch (cet.marker) + { + case CET_CONTINUATION: + to_save = GET_VAL; + break; -/* Identity procedure */ + case CET_INTERNAL_CONTINUATION: + to_save = (MAKE_CC_STACK_ENV ((SCHEME_OBJECT *) state)); + break; -long -DEFUN (coerce_to_compiled, - (object, arity, location), - SCHEME_OBJECT object AND long arity AND SCHEME_OBJECT *location) -{ - *location = object; - return (PRIM_DONE); -} + case CET_RETURN_TO_INTERPRETER: + to_save = GET_VAL; + break; -extern char * EXFUN (utility_index_to_name, (int)); -extern void EXFUN (declare_builtin, (unsigned long)); -extern char * EXFUN (builtin_index_to_name, (int)); -extern int EXFUN (pc_to_utility_index, (unsigned long)); -extern int EXFUN (pc_to_builtin_index, (unsigned long)); + case CET_CLOSURE: + to_save = (MAKE_CC_ENTRY ((insn_t *) state)); + break; -char * -DEFUN (utility_index_to_name, (index), int index) -{ - return ((char *) NULL); -} + default: + to_save = SHARP_F; + break; + } -void -DEFUN (declare_builtin, (builtin), unsigned long builtin) -{ - return; + STACK_PUSH (entry); + stack_ptr = (MAKE_CC_STACK_ENV (stack_pointer)); + STACK_PUSH (to_save); + STACK_PUSH (stack_ptr); + STACK_PUSH (entry); + TAIL_CALL_2 (comutil_apply, + (VECTOR_REF (fixed_objects, CC_BKPT_PROCEDURE)), + 4); } -char * -DEFUN (builtin_index_to_name, (index), int index) +DEFINE_SCHEME_UTILITY_1 (comutil_compiled_closure_bkpt, entry_addr) { - return ((char *) NULL); -} + DECLARE_UTILITY_ARG (insn_t *, entry_addr); + SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr)); + SCHEME_OBJECT stack_ptr; -int -DEFUN (pc_to_utility_index, (pc), unsigned long pc) + STACK_PUSH (entry); + stack_ptr = (MAKE_CC_STACK_ENV (stack_pointer)); + STACK_PUSH (SHARP_F); + STACK_PUSH (stack_ptr); + STACK_PUSH (entry); + TAIL_CALL_2 (comutil_apply, + (VECTOR_REF (fixed_objects, CC_BKPT_PROCEDURE)), + 4); +} + +/* Utility table used by the assembly language interface to invoke the + SCHEME_UTILITY procedures that appear in this file. + + Important: Do NOT reorder this table without changing the indices + defined on the following page and the corresponding table in the + compiler. */ + +utility_proc_t * utility_table [] = +{ + comutil_return_to_interpreter, /* 0x0 */ + comutil_operator_apply_trap, /* 0x1 */ + comutil_operator_apply_trap, /* 0x2 */ + comutil_operator_apply_trap, /* 0x3 */ + comutil_operator_apply_trap, /* 0x4 */ + comutil_operator_lexpr_trap, /* 0x5 */ + comutil_operator_primitive_trap, /* 0x6 */ + comutil_operator_lookup_trap, /* 0x7 */ + comutil_operator_1_0_trap, /* 0x8 */ + comutil_operator_2_1_trap, /* 0x9 */ + comutil_operator_2_0_trap, /* 0xa */ + comutil_operator_3_2_trap, /* 0xb */ + comutil_operator_3_1_trap, /* 0xc */ + comutil_operator_3_0_trap, /* 0xd */ + comutil_operator_4_3_trap, /* 0xe */ + comutil_operator_4_2_trap, /* 0xf */ + comutil_operator_4_1_trap, /* 0x10 */ + comutil_operator_4_0_trap, /* 0x11 */ + comutil_primitive_apply, /* 0x12 */ + comutil_primitive_lexpr_apply, /* 0x13 */ + comutil_apply, /* 0x14 */ + comutil_error, /* 0x15 */ + comutil_lexpr_apply, /* 0x16 */ + comutil_link, /* 0x17 */ + comutil_interrupt_closure, /* 0x18 */ + comutil_interrupt_dlink, /* 0x19 */ + comutil_interrupt_procedure, /* 0x1a */ + comutil_interrupt_continuation, /* 0x1b */ + comutil_interrupt_ic_procedure, /* 0x1c */ + comutil_assignment_trap, /* 0x1d */ + comutil_cache_lookup_apply, /* 0x1e */ + comutil_lookup_trap, /* 0x1f */ + comutil_safe_lookup_trap, /* 0x20 */ + comutil_unassigned_p_trap, /* 0x21 */ + comutil_decrement, /* 0x22 */ + comutil_divide, /* 0x23 */ + comutil_equal, /* 0x24 */ + comutil_greater, /* 0x25 */ + comutil_increment, /* 0x26 */ + comutil_less, /* 0x27 */ + comutil_minus, /* 0x28 */ + comutil_multiply, /* 0x29 */ + comutil_negative, /* 0x2a */ + comutil_plus, /* 0x2b */ + comutil_positive, /* 0x2c */ + comutil_zero, /* 0x2d */ + 0, /* 0x2e */ + 0, /* 0x2f */ + 0, /* 0x30 */ + 0, /* 0x31 */ + 0, /* 0x32 */ + 0, /* 0x33 */ + 0, /* 0x34 */ + 0, /* 0x35 */ + comutil_primitive_error, /* 0x36 */ + comutil_quotient, /* 0x37 */ + comutil_remainder, /* 0x38 */ + comutil_modulo, /* 0x39 */ + comutil_reflect_to_interface, /* 0x3a */ + comutil_interrupt_continuation_2, /* 0x3b */ + comutil_compiled_code_bkpt, /* 0x3c */ + comutil_compiled_closure_bkpt /* 0x3d */ +}; + +unsigned long max_trampoline + = ((sizeof (utility_table)) / (sizeof (utility_proc_t *))); + +/* Support for trap handling. */ + +const char * +utility_index_to_name (unsigned int index) { - return (-1); + return (0); } int -DEFUN (pc_to_builtin_index, (pc), unsigned long pc) +pc_to_utility_index (unsigned long pc) { return (-1); } - -SCHEME_OBJECT -DEFUN (bkpt_install, (ep), PTR ep) -{ - return (SHARP_F); -} -SCHEME_OBJECT -DEFUN (bkpt_closure_install, (ep), PTR ep) -{ - return (SHARP_F); -} +static unsigned int n_builtins = 0; +static unsigned int s_builtins = 0; +static unsigned long * builtins = 0; +static const char ** builtin_names = 0; void -DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle) +declare_builtin (unsigned long builtin, const char * name) { - error_external_return (); + if (n_builtins == s_builtins) + { + if (s_builtins == 0) + { + s_builtins = 30; + builtins = (malloc (s_builtins * (sizeof (unsigned long)))); + builtin_names = (malloc (s_builtins * (sizeof (char *)))); + } + else + { + s_builtins += s_builtins; + builtins + = (realloc (builtins, (s_builtins * (sizeof (unsigned long))))); + builtin_names + = (realloc (builtin_names, (s_builtins * (sizeof (char *))))); + } + if ((builtins == 0) || (builtin_names == 0)) + { + outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n", + s_builtins); + termination_init_error (); + } + } + { + unsigned int low = 0; + unsigned int high = n_builtins; + while (1) + { + if (low < high) + { + unsigned int middle = ((low + high) / 2); + if (builtin < (builtins[middle])) + high = middle; + else if (builtin > (builtins[middle])) + low = (middle + 1); + else + { + (builtin_names[middle]) = name; + return; + } + } + else + { + unsigned int scan = n_builtins; + while (low < scan) + { + (builtins [scan]) = (builtins [scan - 1]); + (builtin_names [scan]) = (builtin_names [scan - 1]); + scan -= 1; + } + (builtins [low]) = builtin; + (builtin_names [low]) = name; + return; + } + } + } } -Boolean -DEFUN (bkpt_p, (ep), PTR ep) +const char * +builtin_index_to_name (unsigned int index) { - return (SHARP_F); + return ((index < n_builtins) ? (builtin_names[index]) : 0); } -SCHEME_OBJECT -DEFUN (bkpt_proceed, (ep, handle, state), - PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state) +int +pc_to_builtin_index (unsigned long pc) { - error_external_return (); + if (! ((builtins != 0) + && (pc >= (builtins[0])) + && (pc < (builtins [(n_builtins - 1)])))) + return (-1); + { + unsigned int low = 0; + unsigned int high = (n_builtins - 1); + while ((low + 1) < high) + { + unsigned int middle = ((low + high) / 2); + if (pc < (builtins[middle])) + high = middle; + else if (pc > (builtins[middle])) + low = middle; + else + return (middle); + } + return ((pc == (builtins[high])) ? high : low); + } } - -#endif /* HAS_COMPILER_SUPPORT */ #ifdef __WIN32__ #include "ntscmlib.h" extern unsigned long * win32_catatonia_block; -extern void EXFUN (win32_allocate_registers, (void)); -extern void EXFUN (win32_allocate_registers, (void)); #ifndef REGBLOCK_LENGTH # define REGBLOCK_LENGTH REGBLOCK_MINIMUM_LENGTH @@ -3923,37 +2828,30 @@ extern void EXFUN (win32_allocate_registers, (void)); typedef struct register_storage { /* The following must be allocated consecutively */ - unsigned long catatonia_block[3]; -#if (COMPILER_PROCESSOR_TYPE == COMPILER_IA32_TYPE) - void * Regstart[32]; /* Negative byte offsets from &Registers[0] */ -#endif + unsigned long catatonia_block [3]; + void * Regstart [32]; /* Negative byte offsets from &Registers[0] */ SCHEME_OBJECT Registers [REGBLOCK_LENGTH]; } REGMEM; -SCHEME_OBJECT * RegistersPtr = ((SCHEME_OBJECT *) NULL); -unsigned long * win32_catatonia_block = ((unsigned long *) NULL); +unsigned long * win32_catatonia_block = 0; static REGMEM regmem; void -DEFUN_VOID (win32_allocate_registers) +win32_allocate_registers (void) { - REGMEM * mem = & regmem; - - win32_catatonia_block = ((unsigned long *) &mem->catatonia_block[0]); - RegistersPtr = mem->Registers; - if (! (win32_system_utilities.lock_memory_area (mem, (sizeof (REGMEM))))) - { - outf_error ("Unable to lock registers\n"); - outf_flush_error (); - } - return; + win32_catatonia_block = (regmem.catatonia_block); + Registers = (regmem.Registers); + if (!win32_system_utilities.lock_memory_area ((®mem), (sizeof (regmem)))) + { + outf_error ("Unable to lock registers\n"); + outf_flush_error (); + } } void -DEFUN_VOID (win32_deallocate_registers) +win32_deallocate_registers (void) { - win32_system_utilities.unlock_memory_area (®mem, (sizeof (REGMEM))); - return; + win32_system_utilities.unlock_memory_area ((®mem), (sizeof (regmem))); } #endif /* __WIN32__ */ diff --git a/v7/src/microcode/cmpint.h b/v7/src/microcode/cmpint.h index 911450bee..48d03e70f 100644 --- a/v7/src/microcode/cmpint.h +++ b/v7/src/microcode/cmpint.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.h,v 10.14 2007/01/05 21:19:25 cph Exp $ +$Id: cmpint.h,v 10.15 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,255 +25,433 @@ USA. */ -/* Macros for the interface between compiled code and interpreted code. */ - -/* Stack Gap Operations: */ +/* Compiled-code interface */ -/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the - * top of the stack. Code must push Gap_Size objects. It executes Code - * with the stack pointer placed so that these objects will fill the gap. - */ +#ifndef SCM_CMPINT_H +#define SCM_CMPINT_H 1 -#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \ -{ \ - long size_to_move = (Gap_Position); \ - SCHEME_OBJECT * Destination = (STACK_LOC (- (Gap_Size))); \ - SCHEME_OBJECT * Saved_Destination = Destination; \ - while ((--size_to_move) >= 0) \ - (STACK_LOCATIVE_POP (Destination)) = (STACK_POP ()); \ - Code; \ - sp_register = Saved_Destination; \ -} - -/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the - * top of the stack. The contents of the gap are lost. - */ +#include "config.h" +#include "object.h" -#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \ -{ \ - long size_to_move; \ - SCHEME_OBJECT *Source; \ - \ - size_to_move = (Gap_Position); \ - Source = (STACK_LOC (size_to_move)); \ - sp_register = (STACK_LOC ((Gap_Size) + size_to_move)); \ - extra_code; \ - while (--size_to_move >= 0) \ - { \ - STACK_PUSH (STACK_LOCATIVE_PUSH (Source)); \ - } \ -} - -/* Going from interpreted code to compiled code */ +#define COMPILER_INTERFACE_VERSION 3 -/* Tail recursion is handled as follows: - if the return code is `reenter_compiled_code', it is discarded, - and the two contiguous interpreter segments on the stack are - merged. - */ +typedef struct cc_entry_type_s cc_entry_type_t; +typedef struct cc_entry_offset_s cc_entry_offset_t; -/* Apply interface: - calling a compiled procedure with a frame nslots long. - */ +#include "cmpintmd.h" -#define apply_compiled_setup(nslots) \ -{ \ - long frame_size; \ - \ - frame_size = (nslots); \ - if (STACK_REF(frame_size + CONTINUATION_RETURN_CODE) == \ - (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \ - { \ - /* Merge compiled code segments on the stack. */ \ - Close_Stack_Gap (CONTINUATION_SIZE, \ - frame_size, \ - { \ - long segment_size = \ - (OBJECT_DATUM \ - (STACK_REF \ - (CONTINUATION_EXPRESSION - \ - CONTINUATION_SIZE))); \ - last_return_code = (STACK_LOC (segment_size)); \ - }); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ - } \ - else \ - { \ - /* Make a new compiled code segment which includes this frame. */ \ - /* History need not be hacked here. */ \ - With_Stack_Gap(1, \ - frame_size, \ - { \ - last_return_code = (STACK_LOC (0)); \ - STACK_PUSH (return_to_interpreter); \ - }); \ - } \ -} +#ifdef NO_CC_SUPPORT_P +# undef CC_SUPPORT_P +#else +# define CC_SUPPORT_P 1 -/* Eval interface: - executing a compiled expression. - */ +/* The following code handles compiled entry points, where the + addresses point to the "middle" of the code vector. From the entry + address, the offset word can be extracted, and this offset allows + us to find the beginning of the block, so it can be copied as a + whole. The broken heart for the whole block lives in its usual + place (first word in the vector). + + The offset word contains an encoding of the offset and an encoding + of whether the resulting pointer points to the beginning of the + block or is another entry, so the process may have to be repeated. */ + +typedef enum +{ + CET_PROCEDURE, + CET_CONTINUATION, + CET_EXPRESSION, + CET_INTERNAL_PROCEDURE, + CET_INTERNAL_CONTINUATION, + CET_TRAMPOLINE, + CET_RETURN_TO_INTERPRETER, + CET_CLOSURE +} cc_entry_type_marker_t; + +struct cc_entry_type_s +{ + cc_entry_type_marker_t marker; + union + { + struct + { + unsigned int n_required; + unsigned int n_optional; + bool rest_p; + } for_procedure; + struct + { + /* This number is in insn_t units. A value of zero means + that the offset is unknown. */ + unsigned long offset; + } for_continuation; + } args; +}; + +extern void make_compiled_procedure_type + (cc_entry_type_t *, unsigned int, unsigned int, bool); +extern void make_compiled_continuation_type (cc_entry_type_t *, unsigned long); +extern void make_cc_entry_type (cc_entry_type_t *, cc_entry_type_marker_t); + +extern bool read_cc_entry_type (cc_entry_type_t *, insn_t *); +extern bool write_cc_entry_type (cc_entry_type_t *, insn_t *); + +extern bool decode_old_style_format_word (cc_entry_type_t *, unsigned short); +extern bool encode_old_style_format_word (cc_entry_type_t *, unsigned short *); + +/* If continued_p is false, then offset is the distance in insn_t + units between the entry and the CC block. Otherwise, offset is the + distance in insn_t units between this entry and a preceding one. + */ +struct cc_entry_offset_s +{ + unsigned long offset; + bool continued_p; +}; + +extern bool read_cc_entry_offset (cc_entry_offset_t *, insn_t *); +extern bool write_cc_entry_offset (cc_entry_offset_t *, insn_t *); + +#define CC_ENTRY_ADDRESS(obj) ((insn_t *) (OBJECT_ADDRESS (obj))) +#define MAKE_CC_ENTRY(addr) \ + (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (addr)))) + +#define CC_ENTRY_NEW_ADDRESS(entry, address) \ + (OBJECT_NEW_ADDRESS ((entry), ((insn_t *) (address)))) + +#define CC_ENTRY_NEW_BLOCK(entry, new_block, old_block) \ + (CC_ENTRY_NEW_ADDRESS ((entry), \ + (((insn_t *) (new_block)) \ + + ((CC_ENTRY_ADDRESS (entry)) \ + - ((insn_t *) (old_block)))))) + +#define MAKE_CC_BLOCK(address) \ + (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (address))) + +#define MAKE_CC_STACK_ENV(address) \ + (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, (address))) + +#define CC_BLOCK_LENGTH(block) (CC_BLOCK_ADDR_LENGTH (OBJECT_ADDRESS (block))) +#define CC_BLOCK_END(block) (CC_BLOCK_ADDR_END (OBJECT_ADDRESS (block))) +#define CC_BLOCK_ADDR_LENGTH(addr) ((OBJECT_DATUM (*addr)) + 1) +#define CC_BLOCK_ADDR_END(addr) ((addr) + (CC_BLOCK_ADDR_LENGTH (addr))) + +#define CC_ENTRY_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY) +#define CC_BLOCK_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_CODE_BLOCK) +#define CC_STACK_ENV_P(object) ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT) + +extern unsigned long cc_entry_to_block_offset (SCHEME_OBJECT); +extern SCHEME_OBJECT cc_entry_to_block (SCHEME_OBJECT); +extern SCHEME_OBJECT * cc_entry_to_block_address (SCHEME_OBJECT); +extern SCHEME_OBJECT * cc_entry_address_to_block_address (insn_t *); +extern int plausible_cc_block_p (SCHEME_OBJECT *); + +/* Linkage sections + + Linkage sections implement free-variable references in compiled + code. They are built to be very fast, and are customized to + particular uses of the free variables. + + If a compiled-code block has linkage sections, they appear at the + very beginning of the block's constants area (i.e. immediately + following the non-marked code segment). There are two basic kinds + of sections: (1) a reference section is used to read or write a + variable's value; and (2) an execution section is used to call a + variable's value. + + Each linkage section has a header word, with type + TC_LINKAGE_SECTION. The bottom 16 bits of the header word's datum + contains the number of words in the rest of the linkage section + (i.e. its length, as if it were a vector). The bits above that + contain the linkage section's type, which must be one of the values + listed below. + + Prior to linking, the header word has type TC_FIXNUM. Each entry + in a reference section is a symbol, which is the name of the free + variable being referred to. Each entry in an execution section has + two words: (1) a non-negative fixnum, which is the number of + arguments to be passed to the procedure; and (2) a symbol, which is + the name of the variable. + + After linking, the header word has type TC_LINKAGE_SECTION. Each + entry in a reference section is the address (SCHEME_OBJECT*) of a + TC_HUNK3 object. Each entry in an execution section is an + architecture-specific instruction sequence that jumps to the called + procedure (a "UUO link"). */ + +typedef enum +{ + LINKAGE_SECTION_TYPE_OPERATOR, + LINKAGE_SECTION_TYPE_REFERENCE, + LINKAGE_SECTION_TYPE_ASSIGNMENT, + LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR, + N_LINKAGE_SECTION_TYPES +} linkage_section_type_t; + +extern linkage_section_type_t linkage_section_type (SCHEME_OBJECT); +extern unsigned long linkage_section_count (SCHEME_OBJECT); +extern SCHEME_OBJECT make_linkage_section_marker + (linkage_section_type_t, unsigned long); + +extern long make_uuo_link + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); +extern long coerce_to_compiled (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT *); +extern SCHEME_OBJECT read_uuo_link (SCHEME_OBJECT, unsigned long); + +extern SCHEME_OBJECT read_uuo_symbol (SCHEME_OBJECT *); +extern insn_t * read_uuo_target_no_reloc (SCHEME_OBJECT *); +extern void write_uuo_target (insn_t *, SCHEME_OBJECT *); + +extern unsigned int read_uuo_frame_size (SCHEME_OBJECT *); + +extern void write_variable_cache (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); + +/* Compiled closures + + A manifest closure header is followed by a (positive) count N, + which is followed by N closure entries. Each entry consists of a + GC offset and a type followed by the machine code for the closure + (typically a call-like instruction). The entries are tightly + packed so that the end address of one entry is the start address of + the next. After the end address of the last entry there is + optional padding, followed by the closure's marked objects. + + When EMBEDDED_CLOSURE_ADDRS_P is defined, the target address of a + closure is embedded in the closure's code, and must be specially + managed by the garbage collector. When undefined, the targets are + stored in the marked objects section of the closure, and so need no + special treatment. + + When EMBEDDED_CLOSURE_ADDRS_P is defined, the following macros are + used to read and write closure targets. + + READ_COMPILED_CLOSURE_TARGET(start, ref) returns the target of + 'start' as a SCHEME_OBJECT, using 'ref' as the relocation + reference. */ + +/* Given the address of the word past the manifest closure header, + returns the number of closure entries in the block. The returned + value must be positive. */ +extern unsigned long compiled_closure_count (SCHEME_OBJECT *); + +/* Given the address of the word past the manifest closure header, + returns the address of the first closure entry in the block. */ +extern insn_t * compiled_closure_start (SCHEME_OBJECT *); + +/* Given the address of the word past the manifest closure header, + returns the address of the first marked object. */ +extern SCHEME_OBJECT * compiled_closure_objects (SCHEME_OBJECT *); + +/* Given the address of a closure entry, returns the invocation + address for the corresponding closure. */ +extern insn_t * compiled_closure_entry (insn_t *); + +/* Given the address of a closure entry, returns the address of the + next closure entry. (Which is also the end address of the given + closure entry.) */ +extern insn_t * compiled_closure_next (insn_t *); + +/* Given the address of the end of the last closure entry, returns the + address of the first marked object. */ +extern SCHEME_OBJECT * skip_compiled_closure_padding (insn_t *); + +/* Given the address of a closure entry, returns the compiled-code + entry that this closure invokes. */ +extern SCHEME_OBJECT compiled_closure_entry_to_target (insn_t *); + +/* Given a compiled-code entry point and the address of a closure + entry, modifies the closure to invoke the entry point. */ +extern void write_compiled_closure_target (insn_t *, insn_t *); + +/* Given a compiled-code block, returns true iff it is a closure's + block. */ +extern bool cc_block_closure_p (SCHEME_OBJECT); + +/* Given a compiled-code entry, returns true iff it is a closure. */ +extern bool cc_entry_closure_p (SCHEME_OBJECT); + +/* Given a compiled-code closure, returns the compiled-code entry that + it calls. */ +extern SCHEME_OBJECT cc_closure_to_entry (SCHEME_OBJECT); + +/* Trampolines -#define execute_compiled_setup() \ -{ \ - if (STACK_REF(CONTINUATION_RETURN_CODE) == \ - (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \ - { \ - /* Merge compiled code segments on the stack. */ \ - long segment_size; \ - \ - Restore_Cont(); \ - segment_size = OBJECT_DATUM (exp_register); \ - last_return_code = (STACK_LOC (segment_size)); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ - } \ - else \ - { \ - /* Make a new compiled code segment on the stack. */ \ - /* History need not be hacked here. */ \ - last_return_code = (STACK_LOC (0)); \ - STACK_PUSH (return_to_interpreter); \ - } \ -} - -/* Pop return interface: - Returning to compiled code from the interpreter. - */ + Trampolines are "closures" that call code in the compiled-code + interface rather than compiled code. They have an + architecture-specific calling sequence and a marked storage area. -#define compiled_code_restart() \ -{ \ - long segment_size = OBJECT_DATUM (exp_register); \ - last_return_code = (STACK_LOC (segment_size)); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ -} - -/* Going from compiled code to interpreted code */ + The architecture description must define TRAMPOLINE_ENTRY_SIZE to + be the number of words occupied by the instruction sequence, + including the compiled-code entry header. The instruction sequence + must be padded, if necessary, to use an integral number of words. -/* Tail recursion is handled in the following way: - if the return address is `return_to_interpreter', it is discarded, - and the two contiguous interpreter segments on the stack are - merged. - */ + Here is a diagram of a trampoline on a 32-bit machine: -/* Apply interface: - calling an interpreted procedure (or unsafe primitive) - with a frame nslots long. - */ + 0x00 TC_FIXNUM | 2 + trampoline_entry_size() + n + 0x04 TC_MANIFEST_NM_VECTOR | trampoline_entry_size() == k + 0x08 trampoline entry (k words) + 0x08+k*4 trampoline storage (n words) -#define compiler_apply_procedure(nslots) \ -{ \ - long frame_size = (nslots); \ - if ((STACK_REF (frame_size)) == return_to_interpreter) \ - { \ - Close_Stack_Gap(1, frame_size, {}); \ - /* Set up the current rib. */ \ - Compiler_New_Reduction (); \ - } \ - else \ - { /* Make a new interpreter segment which includes this frame. */ \ - With_Stack_Gap \ - (CONTINUATION_SIZE, \ - frame_size, \ - { \ - long segment_size = \ - (STACK_LOCATIVE_DIFFERENCE \ - (last_return_code, (STACK_LOC (0)))); \ - exp_register = (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \ - Store_Return (RC_REENTER_COMPILED_CODE); \ - Save_Cont (); \ - }); \ - /* Rotate history to a new subproblem. */ \ - Compiler_New_Subproblem (); \ - } \ -} - -/* Pop Return interface: - returning to the interpreter from compiled code. - Nothing needs to be done at this time. */ -#define compiled_code_done() - -/* Various handlers for backing out of compiled code. */ - -/* Backing out of apply. */ - -#define apply_compiled_backout() \ -{ \ - compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \ - OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));\ -} - -/* Backing out of eval. */ - -#define execute_compiled_backout() \ -{ \ - if ((STACK_REF (0)) == return_to_interpreter) \ - { \ - /* Set up the current rib. */ \ - Compiler_New_Reduction (); \ - } \ - else \ - { \ - long segment_size = \ - (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \ - exp_register = (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \ - Store_Return (RC_REENTER_COMPILED_CODE); \ - Save_Cont (); \ - /* Rotate history to a new subproblem. */ \ - Compiler_New_Subproblem (); \ - } \ -} - -/* Backing out because of special errors or interrupts. - The microcode has already setup a return code with a #F. - No tail recursion in this case. - *** - Is the history manipulation correct? - Does Microcode_Error do something special? - *** - */ +/* Given the number of trampoline entries, returns the number of words + needed to hold the instruction sequences for those entries. */ +extern unsigned long trampoline_entry_size (unsigned long); + +/* Given the address of a trampoline block and an entry index, returns + the address of the specified entry point. */ +extern insn_t * trampoline_entry_addr (SCHEME_OBJECT *, unsigned long); + +/* Given the address of a trampoline entry and the code for the + trampoline to be invoked, stores the appropriate instruction + sequence in the trampoline. */ +extern bool store_trampoline_insns (insn_t *, byte_t); + +/* Give the address of a trampoline block, returns a pointer to the + start of the trampoline's storage area. */ +extern SCHEME_OBJECT * trampoline_storage (SCHEME_OBJECT *); + +#ifndef UTILITY_RESULT_DEFINED +#ifdef CMPINT_USE_STRUCS + +typedef struct +{ + void * interface_dispatch; + union + { + long code_to_interpreter; + insn_t * entry_point; + } extra; +} utility_result_t; -#define compiled_error_backout() \ -{ \ - long segment_size; \ - \ - Restore_Cont(); \ - segment_size = \ - (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \ - exp_register = (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \ - /* The Store_Return is a NOP, the Save_Cont is done by the code \ - that follows. */ \ - /* Store_Return (OBJECT_DATUM (ret_register)); */ \ - /* Save_Cont (); */ \ - Compiler_New_Subproblem (); \ -} - -extern long EXFUN (apply_compiled_procedure, (void)); -extern long EXFUN (comp_access_restart, (void)); -extern long EXFUN (comp_assignment_restart, (void)); -extern long EXFUN (comp_assignment_trap_restart, (void)); -extern long EXFUN (comp_cache_lookup_apply_restart, (void)); -extern long EXFUN (comp_definition_restart, (void)); -extern long EXFUN (comp_error_restart, (void)); -extern long EXFUN (comp_interrupt_restart, (void)); -extern long EXFUN (comp_link_caches_restart, (void)); -extern long EXFUN (comp_lookup_apply_restart, (void)); -extern long EXFUN (comp_lookup_trap_restart, (void)); -extern long EXFUN (comp_op_lookup_trap_restart, (void)); -extern long EXFUN (comp_reference_restart, (void)); -extern long EXFUN (comp_safe_lookup_trap_restart, (void)); -extern long EXFUN (comp_safe_reference_restart, (void)); -extern long EXFUN (comp_unassigned_p_restart, (void)); -extern long EXFUN (comp_unassigned_p_trap_restart, (void)); -extern long EXFUN (comp_unbound_p_restart, (void)); -extern long EXFUN (enter_compiled_expression, (void)); -extern long EXFUN (return_to_compiled_code, (void)); - -extern SCHEME_OBJECT * EXFUN - (compiled_entry_to_block_address, (SCHEME_OBJECT)); - -extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *)); +#else + +typedef insn_t * utility_result_t; +extern long C_return_value; + +#endif +#endif + +typedef void utility_proc_t + (utility_result_t *, unsigned long, unsigned long, unsigned long, + unsigned long); +extern utility_proc_t * utility_table []; + +#ifndef FLUSH_I_CACHE +# define FLUSH_I_CACHE() do {} while (false) +#endif + +#if !defined(PUSH_D_CACHE_REGION) && defined(FLUSH_I_CACHE_REGION) +# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords) +#endif + +extern unsigned int compiler_interface_version; +extern cc_arch_t compiler_processor_type; +extern unsigned long max_trampoline; + +extern SCHEME_OBJECT compiler_utilities; +extern SCHEME_OBJECT return_to_interpreter; +extern SCHEME_OBJECT reflect_to_interface; + +extern SCHEME_OBJECT cc_block_debugging_info (SCHEME_OBJECT); +extern SCHEME_OBJECT cc_block_environment (SCHEME_OBJECT); + +extern long enter_compiled_expression (void); +extern void guarantee_cc_return (unsigned long); +extern void guarantee_interp_return (void); +extern long apply_compiled_procedure (void); +extern long return_to_compiled_code (void); + +extern long apply_compiled_from_primitive (unsigned long, SCHEME_OBJECT); +extern void compiled_with_interrupt_mask + (unsigned long, SCHEME_OBJECT, unsigned long); +extern void compiled_with_stack_marker (SCHEME_OBJECT); + +extern void compiler_initialize (bool); +extern void compiler_reset (SCHEME_OBJECT); + +extern void declare_compiled_code_block (SCHEME_OBJECT); + +extern void compiler_interrupt_common + (utility_result_t *, insn_t *, SCHEME_OBJECT); + +extern long comp_link_caches_restart (void); +extern long comp_op_lookup_trap_restart (void); +extern long comp_interrupt_restart (void); +extern long comp_assignment_trap_restart (void); +extern long comp_cache_lookup_apply_restart (void); +extern long comp_lookup_trap_restart (void); +extern long comp_safe_lookup_trap_restart (void); +extern long comp_unassigned_p_trap_restart (void); +extern long comp_error_restart (void); + +extern SCHEME_OBJECT bkpt_install (insn_t *); +extern SCHEME_OBJECT bkpt_closure_install (insn_t *); +extern bool bkpt_p (insn_t *); +extern SCHEME_OBJECT bkpt_proceed (insn_t *, SCHEME_OBJECT, SCHEME_OBJECT); +extern long do_bkpt_proceed (insn_t **); +extern void bkpt_remove (insn_t *, SCHEME_OBJECT); + +extern int pc_to_utility_index (unsigned long); +extern const char * utility_index_to_name (unsigned int); +extern int pc_to_builtin_index (unsigned long); +extern const char * builtin_index_to_name (unsigned int); +extern void declare_builtin (unsigned long, const char *); + +extern utility_proc_t comutil_return_to_interpreter; +extern utility_proc_t comutil_operator_apply_trap; +extern utility_proc_t comutil_operator_arity_trap; +extern utility_proc_t comutil_operator_entity_trap; +extern utility_proc_t comutil_operator_interpreted_trap; +extern utility_proc_t comutil_operator_lexpr_trap; +extern utility_proc_t comutil_operator_primitive_trap; +extern utility_proc_t comutil_operator_lookup_trap; +extern utility_proc_t comutil_operator_1_0_trap; +extern utility_proc_t comutil_operator_2_1_trap; +extern utility_proc_t comutil_operator_2_0_trap; +extern utility_proc_t comutil_operator_3_2_trap; +extern utility_proc_t comutil_operator_3_1_trap; +extern utility_proc_t comutil_operator_3_0_trap; +extern utility_proc_t comutil_operator_4_3_trap; +extern utility_proc_t comutil_operator_4_2_trap; +extern utility_proc_t comutil_operator_4_1_trap; +extern utility_proc_t comutil_operator_4_0_trap; +extern utility_proc_t comutil_primitive_apply; +extern utility_proc_t comutil_primitive_lexpr_apply; +extern utility_proc_t comutil_apply; +extern utility_proc_t comutil_error; +extern utility_proc_t comutil_lexpr_apply; +extern utility_proc_t comutil_link; +extern utility_proc_t comutil_interrupt_closure; +extern utility_proc_t comutil_interrupt_dlink; +extern utility_proc_t comutil_interrupt_procedure; +extern utility_proc_t comutil_interrupt_continuation; +extern utility_proc_t comutil_interrupt_ic_procedure; +extern utility_proc_t comutil_assignment_trap; +extern utility_proc_t comutil_cache_lookup_apply; +extern utility_proc_t comutil_lookup_trap; +extern utility_proc_t comutil_safe_lookup_trap; +extern utility_proc_t comutil_unassigned_p_trap; +extern utility_proc_t comutil_decrement; +extern utility_proc_t comutil_divide; +extern utility_proc_t comutil_equal; +extern utility_proc_t comutil_greater; +extern utility_proc_t comutil_increment; +extern utility_proc_t comutil_less; +extern utility_proc_t comutil_minus; +extern utility_proc_t comutil_multiply; +extern utility_proc_t comutil_negative; +extern utility_proc_t comutil_plus; +extern utility_proc_t comutil_positive; +extern utility_proc_t comutil_zero; +extern utility_proc_t comutil_primitive_error; +extern utility_proc_t comutil_quotient; +extern utility_proc_t comutil_remainder; +extern utility_proc_t comutil_modulo; +extern utility_proc_t comutil_reflect_to_interface; +extern utility_proc_t comutil_interrupt_continuation_2; +extern utility_proc_t comutil_compiled_code_bkpt; +extern utility_proc_t comutil_compiled_closure_bkpt; + +#endif /* !NO_CC_SUPPORT_P */ +#endif /* !SCM_CMPINT_H */ diff --git a/v7/src/microcode/cmpintmd/alpha.h b/v7/src/microcode/cmpintmd/alpha.h index cac4dc2b7..f278517cc 100644 --- a/v7/src/microcode/cmpintmd/alpha.h +++ b/v7/src/microcode/cmpintmd/alpha.h @@ -1,6 +1,6 @@ /* -*- C -*- -$Id: alpha.h,v 1.8 2007/01/05 21:19:26 cph Exp $ +$Id: alpha.h,v 1.9 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1992, 1993 Digital Equipment Corporation (D.E.C.) Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, @@ -44,10 +44,9 @@ case. */ * Specialized for the Alpha */ -#ifndef CMPINTMD_H_INCLUDED -#define CMPINTMD_H_INCLUDED +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED -#include "cmptype.h" /* Machine parameters to be set by the user. */ @@ -59,7 +58,7 @@ case. */ /* Processor type. Choose a number from the above list, or allocate your own. */ -#define COMPILER_PROCESSOR_TYPE COMPILER_ALPHA_TYPE +#define COMPILER_PROCESSOR_TYPE COMPILER_ALPHA_TYPE /* Size (in long words) of the contents of a floating point register if different from a double. For example, an MC68881 saves registers @@ -73,13 +72,6 @@ case. */ */ typedef unsigned short format_word; /* 16 bits */ - -/* PC alignment constraint. - Change PC_ZERO_BITS to be how many low order bits of the pc are - guaranteed to be 0 always because of PC alignment constraints. -*/ - -#define PC_ZERO_BITS 2 /* Utilities for manipulating absolute subroutine calls. On the ALPHA this is done with either @@ -110,14 +102,14 @@ typedef unsigned short format_word; /* 16 bits */ #define STORE_ABSOLUTE_ADDRESS(entry_point, address) \ alpha_store_absolute_address (((void *) entry_point), ((void *) address)) -extern void EXFUN(alpha_store_absolute_address, (void *, void *)); +extern void alpha_store_absolute_address(void *, void *); #define opJMP 0x1A #define fnJMP 0x00 #define JMP(linkage, dest, displacement) \ ((opJMP << 26) | ((linkage) << 21) | \ ((dest) << 16) | (fnJMP << 14) | \ - (((displacement)>>PC_ZERO_BITS) & ((1<<14)-1))) + (((displacement)>>2) & ((1<<14)-1))) /* Compiled Code Register Conventions */ /* This must match the compiler and cmpaux-alpha.m4 */ @@ -138,13 +130,12 @@ extern void EXFUN(alpha_store_absolute_address, (void *, void *)); #ifdef IN_CMPINT_C #define PC_FIELD_SIZE 21 -#define MAX_PC_DISPLACEMENT (1<<(PC_FIELD_SIZE+PC_ZERO_BITS-1)) +#define MAX_PC_DISPLACEMENT (1<<22) #define MIN_PC_DISPLACEMENT (-MAX_PC_DISPLACEMENT) #define opBR 0x30 void -DEFUN (alpha_store_absolute_address, (entry_point, address), - void *entry_point AND void *address) +alpha_store_absolute_address (void *entry_point, void *address) { extern void scheme_closure_hook (void); int *Instruction_Address = (int *) address; @@ -156,7 +147,7 @@ DEFUN (alpha_store_absolute_address, (entry_point, address), (offset >= MIN_PC_DISPLACEMENT)) *Instruction_Address = (opBR << 26) | (COMP_REG_LINKAGE << 21) | - ((offset>>PC_ZERO_BITS) & ((1L<>2) & ((1L< space) { SCHEME_OBJECT *ptr; @@ -595,21 +583,21 @@ DEFUN (allocate_closure, (size, this_block), */ } free_closure = Free; - if ((size <= closure_chunk) && (!(GC_Check (closure_chunk)))) + if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk))) { limit = (free_closure + closure_chunk); } else - { if (GC_Check (size)) - { if ((Heap_Top - Free) < size) + { if (GC_NEEDED_P (size)) + { if ((heap_end - Free) < size) { /* No way to back out -- die. */ fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size); Microcode_Termination (TERM_NO_SPACE); /* NOTREACHED */ } - Request_GC (0); + REQUEST_GC (0); } else if (size <= closure_chunk) - { Request_GC (0); + { REQUEST_GC (0); } limit = (free_closure + size); } @@ -627,9 +615,9 @@ DEFUN (allocate_closure, (size, this_block), wptr += 1; } PUSH_D_CACHE_REGION (free_closure, last_chunk_size); - Registers[REGBLOCK_CLOSURE_LIMIT] = (SCHEME_OBJECT) limit; + SET_CLOSURE_SPACE (limit); } - Registers[REGBLOCK_CLOSURE_FREE] = (SCHEME_OBJECT) (free_closure+size); + SET_CLOSURE_FREE (free_closure + size); return (((char *) free_closure)+CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT); } #endif /* IN_CMPINT_C */ @@ -647,29 +635,8 @@ DEFUN (allocate_closure, (size, this_block), #define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) #define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif - -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif - -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1) #define MAKE_OFFSET_WORD(entry, block, continue) \ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ @@ -748,4 +715,4 @@ DEFUN (allocate_closure, (size, this_block), #define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW #define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH -#endif /* CMPINTMD_H_INCLUDED */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/locks.h b/v7/src/microcode/cmpintmd/c-config.h similarity index 60% rename from v7/src/microcode/locks.h rename to v7/src/microcode/cmpintmd/c-config.h index 94e548ea4..66cd0bb56 100644 --- a/v7/src/microcode/locks.h +++ b/v7/src/microcode/cmpintmd/c-config.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: locks.h,v 9.30 2007/01/05 21:19:25 cph Exp $ +$Id: c-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,16 +25,12 @@ USA. */ -/* Contains everything needed to lock and unlock parts of - the heap, pure/constant space and the like. - It also contains intercommunication stuff as well. */ +#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED +#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1 -typedef long *Lock_Handle; /* Address of lock word */ -#define CONTENTION_DELAY 10 /* For "slow" locks, back off */ -#define Lock_Cell(Cell) NULL /* Start lock */ -#define Unlock_Cell(Cell) /* End lock */ -#define Initialize_Heap_Locks() /* Clear at start up */ -#define Do_Store_No_Lock(To, F) *(To) = F -#define Sleep(How_Long) { } /* Delay for locks, etc. */ +#define COMPILER_PROCESSOR_TYPE COMPILER_C_TYPE +#define CC_IS_C 1 +#define CC_IS_GENERIC 1 +#define NO_HEAP_IN_LOW_MEMORY 1 -#define LOCK_FIRST(cell1, cell2) (cell1 < cell2) +#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/c.c b/v7/src/microcode/cmpintmd/c.c new file mode 100644 index 000000000..dc48f35e1 --- /dev/null +++ b/v7/src/microcode/cmpintmd/c.c @@ -0,0 +1,167 @@ +/* -*-C-*- + +$Id: c.c,v 1.2 2007/04/22 16:31:24 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Compiled code interface for C "native" code. */ + +#include "cmpint.h" +#include "extern.h" +#include "errors.h" + +bool +read_cc_entry_type (cc_entry_type_t * cet, insn_t * address) +{ + uint32_t n = ((uint32_t) (address[-1])); + return (decode_old_style_format_word (cet, (n & 0x0000FFFF))); +} + +bool +write_cc_entry_type (cc_entry_type_t * cet, insn_t * address) +{ + uint16_t m; + if (!encode_old_style_format_word (cet, (&m))) + { + uint32_t n = ((uint32_t) (address[-1])); + (address[-1]) = ((insn_t) ((n & 0xFFFF0000) | m)); + return (false); + } + return (true); +} + +bool +read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) +{ + uint32_t n = ((uint32_t) (address[-1])); + uint16_t m = (n >> 16); + (ceo->offset) = (m >> 1); + (ceo->continued_p) = ((m & 1) == 1); + return (false); +} + +bool +write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) +{ + if ((ceo->offset) < 0x4000) + { + uint16_t m = (((ceo->offset) << 1) | ((ceo->continued_p) ? 1 : 0)); + uint32_t n = ((uint32_t) (address[-1])); + (address[-1]) = ((insn_t) ((n & 0x0000FFFF) | (m << 16))); + return (false); + } + return (true); +} + +insn_t * +read_compiled_closure_target (insn_t * start) +{ + return ((insn_t *) (start [CC_ENTRY_HEADER_SIZE + 1])); +} + +void +write_compiled_closure_target (insn_t * target, insn_t * start) +{ + (start [CC_ENTRY_HEADER_SIZE + 1]) = ((insn_t) target); +} + +SCHEME_OBJECT +compiled_closure_entry_to_target (insn_t * entry) +{ + return (MAKE_CC_ENTRY ((insn_t *) (entry[1]))); +} + +unsigned long +compiled_closure_count (SCHEME_OBJECT * block) +{ + uint32_t n = ((uint32_t) (*block)); + return (((n & 0xFFFF0000) == 0) ? (n & 0x0000FFFF) : 1); +} + +insn_t * +compiled_closure_start (SCHEME_OBJECT * block) +{ + uint32_t n = ((uint32_t) (*block)); + return (block + (((n & 0xFFFF0000) == 0) ? 1 : 0)); +} + +insn_t * +compiled_closure_entry (insn_t * start) +{ + return (start + CC_ENTRY_HEADER_SIZE); +} + +insn_t * +compiled_closure_next (insn_t * start) +{ + return (start + CC_ENTRY_HEADER_SIZE + 2); +} + +SCHEME_OBJECT * +skip_compiled_closure_padding (insn_t * start) +{ + return ((SCHEME_OBJECT *) start); +} + +SCHEME_OBJECT +read_uuo_symbol (SCHEME_OBJECT * saddr) +{ + return (saddr[0]); +} + +unsigned int +read_uuo_frame_size (SCHEME_OBJECT * saddr) +{ + return ((unsigned int) (saddr[1])); +} + +insn_t * +read_uuo_target (SCHEME_OBJECT * saddr) +{ + return ((insn_t *) (saddr[0])); +} + +insn_t * +read_uuo_target_no_reloc (SCHEME_OBJECT * saddr) +{ + return ((insn_t *) (saddr[0])); +} + +void +write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr) +{ + (saddr[0]) = ((SCHEME_OBJECT) target); +} + +unsigned long +trampoline_entry_size (unsigned long n_entries) +{ + return (n_entries * 2); +} + +insn_t * +trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return (((insn_t *) (block + 2 + (index * 2))) + CC_ENTRY_HEADER_SIZE); +} diff --git a/v7/src/microcode/cmpintmd/c.h b/v7/src/microcode/cmpintmd/c.h index b6afc76aa..2d8df987f 100644 --- a/v7/src/microcode/cmpintmd/c.h +++ b/v7/src/microcode/cmpintmd/c.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: c.h,v 1.12 2007/01/05 21:19:26 cph Exp $ +$Id: c.h,v 1.13 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,199 +25,127 @@ USA. */ -#ifndef CMPINTMD_H_INCLUDED -#define CMPINTMD_H_INCLUDED +/* Compiled code interface macros for C "native" code. */ + +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 + +/* + +Structure of code block (prior to link): + ++-----+-------------------------+ +| MV | length | ++-----+-------------------------+ +| NMV | 2N | ++-----+-------------------------+ +| format/offset1 | ++-------------------------------+ +| index1 | ++-------------------------------+ +. . +. . ++-------------------------------+ +| format/offsetN | ++-------------------------------+ +| indexN | ++-----+---------+---------------+ +| FIX | UUO | 2M | (not TC_LINKAGE_SECTION) ++-----+---------+---------------+ +| name1 | ++-------------------------------+ +| nargs1 | ++-------------------------------+ +. . +. . ++-------------------------------+ +| nameM | ++-------------------------------+ +| nargsM | ++-----+---------+---------------+ +| FIX | REFS | L | (not TC_LINKAGE_SECTION) ++-----+---------+---------------+ +| name1 | ++-------------------------------+ +. . +. . ++-------------------------------+ +| nameL | ++-----+---------+---------------+ +| FIX | ASNS | K | (not TC_LINKAGE_SECTION) ++-----+---------+---------------+ +| name1 | ++-------------------------------+ +. . +. . ++-------------------------------+ +| nameK | ++-----+---------+---------------+ +| FIX | GUUO | 2J | (not TC_LINKAGE_SECTION) ++-----+---------+---------------+ +| name1 | ++-------------------------------+ +| nargs1 | ++-------------------------------+ +. . +. . ++-------------------------------+ +| nameJ | ++-------------------------------+ +| nargsJ | ++-------------------------------+ +| const1 | ++-------------------------------+ +. . +. . ++-------------------------------+ +| constI | ++-------------------------------+ + +length = 2N + 2M + L + K + 2J + I + p(M) + p(L) + p(K) + p(J) + 1 + where p(x) = ((x > 0) ? 1 : 0) + +format/offset is raw integer, of which only LS 32 bits are used: + + 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 + 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 + +-----------------------------+-+---------------+---------------+ + | offset |C| fmthigh | fmtlow | + +-----------------------------+-+---------------+---------------+ + +offset field is in insn_t units. + +The indexes refer to entries in the compiled_entries array. -#include "limits.h" -#include "cmptype.h" - -#define COMPILER_PROCESSOR_TYPE COMPILER_LOSING_C_TYPE - -#ifndef NATIVE_CODE_IS_C -#define NATIVE_CODE_IS_C -#endif - -#define WRITE_LABEL_DESCRIPTOR(entry,kind,offset) do \ -{ \ - SCHEME_OBJECT * _ent = ((SCHEME_OBJECT *) (entry)); \ - \ - COMPILED_ENTRY_FORMAT_WORD (_ent) = (kind); \ - COMPILED_ENTRY_OFFSET_WORD (_ent) = \ - (WORD_OFFSET_TO_OFFSET_WORD (offset)); \ -} while (0) - -#define CC_BLOCK_DISTANCE(block,entry) \ - (((SCHEME_OBJECT *) (entry)) - ((SCHEME_OBJECT *) (block))) - -typedef unsigned short format_word; - -extern int pc_zero_bits; - -#define PC_ZERO_BITS pc_zero_bits - -/* arbitrary */ -#define ENTRY_PREFIX_LENGTH 2 - -#define ADJUST_CLOSURE_AT_CALL(entry_point, location) do { } while (0) - -#define COMPILED_CLOSURE_ENTRY_SIZE ((sizeof (SCHEME_OBJECT)) * 3) - -#define EXTRACT_CLOSURE_ENTRY_ADDRESS(output,location) do \ -{ \ - (output) = (((SCHEME_OBJECT *) (location))[1]); \ -} while (0) - -#define STORE_CLOSURE_ENTRY_ADDRESS(input,location) do \ -{ \ - ((SCHEME_OBJECT *) (location))[1] = ((SCHEME_OBJECT) (input)); \ -} while (0) - -#define MANIFEST_CLOSURE_COUNT(scan) \ -(((COMPILED_ENTRY_OFFSET_WORD (((SCHEME_OBJECT *) (scan)) + 1)) == 0) \ - ? (COMPILED_ENTRY_FORMAT_WORD (((SCHEME_OBJECT *) (scan)) + 1)) \ - : 1) - -#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \ -(((COMPILED_ENTRY_OFFSET_WORD (((SCHEME_OBJECT *) (scan)) + 1)) == 0) \ - ? ((char *) (((SCHEME_OBJECT *) (scan)) + 2)) \ - : ((char *) (((SCHEME_OBJECT *) (scan)) + 1))) - -/* Trampolines are implemented as tiny compiled code blocks that - invoke the constant C procedure indexed by the number 0. - */ - -#define TRAMPOLINE_ENTRY_SIZE 2 /* Words */ - -#define TRAMPOLINE_BLOCK_TO_ENTRY 3 - -#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ - (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) - -#define TRAMPOLINE_STORAGE(tramp_entry) \ - ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) - -/* This depends on knowledge that the trampoline block is the first - compiled code block. - */ - -#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \ -{ \ - ((SCHEME_OBJECT *) (entry_address))[0] = ((SCHEME_OBJECT) (index)); \ -} while (0) - -/* An execute cache contains a compiled entry for the callee, - and a number of arguments (+ 1). - */ - -#define EXECUTE_CACHE_ENTRY_SIZE 2 - -#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \ -{ \ - (target) = ((long) (((SCHEME_OBJECT *) (address))[1])); \ -} while (0) - -#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \ -{ \ - (target) = (((SCHEME_OBJECT *) (address))[0]); \ -} while (0) - -#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) do \ -{ \ - (target) = (((SCHEME_OBJECT *) (address)) [0]); \ -} while (0) - -#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) do \ -{ \ - ((SCHEME_OBJECT *) (address))[0] = ((SCHEME_OBJECT) (entry)); \ -} while (0) - -#define STORE_EXECUTE_CACHE_CODE(address) do { } while (0) - -extern void EXFUN (interface_initialize, (void)); - -#define ASM_RESET_HOOK() interface_initialize () - -/* Derived parameters and macros. - - These macros expect the above definitions to be meaningful. - If they are not, the macros below may have to be changed as well. - */ - -#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1]) -#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2]) - -/* The next one assumes 2's complement integers....*/ -#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) -#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) - -#define WORD_OFFSET_TO_OFFSET_WORD(words) ((words) << 1) - -#define BYTE_OFFSET_TO_OFFSET_WORD(bytes) \ - WORD_OFFSET_TO_OFFSET_WORD ((bytes) / (sizeof (SCHEME_OBJECT))) - -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((sizeof (SCHEME_OBJECT)) * ((CLEAR_LOW_BIT (offset_word)) >> 1)) - -#define MAKE_OFFSET_WORD(entry, block, continue) \ - ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ - ((char *) (block)))) | \ - ((continue) ? 1 : 0)) - -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 1) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 1) +*/ -/* The first entry in a cc block is preceeded by 2 headers (block and nmv), - a format word and a gc offset word. See the early part of the - TRAMPOLINE picture, above. - */ - -#define CC_BLOCK_FIRST_ENTRY_OFFSET \ - (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) - -/* Format words */ - -#define FORMAT_BYTE_EXPR 0xFF -#define FORMAT_BYTE_COMPLR 0xFE -#define FORMAT_BYTE_CMPINT 0xFD -#define FORMAT_BYTE_DLINK 0xFC -#define FORMAT_BYTE_RETURN 0xFB - -#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR)) -#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT)) -#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN)) - -/* This assumes that a format word is at least 16 bits, - and the low order field is always 8 bits. - */ +#define ASM_RESET_HOOK initialize_C_interface -#define MAKE_FORMAT_WORD(field1, field2) \ - (((field1) << 8) | ((field2) & 0xff)) +typedef SCHEME_OBJECT insn_t; -#define SIGN_EXTEND_FIELD(field, size) \ - (((field) & ((1 << (size)) - 1)) | \ - ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ - ((-1) << (size)))) +/* Number of insn_t units preceding entry address in which header + (type and offset info) is stored. */ +#define CC_ENTRY_HEADER_SIZE 1 -#define FORMAT_WORD_LOW_BYTE(word) \ - (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8)) +/* Number of insn_t units preceding entry header in which GC trap + instructions are stored. */ +#define CC_ENTRY_GC_TRAP_SIZE 0 -#define FORMAT_WORD_HIGH_BYTE(word) \ - (SIGN_EXTEND_FIELD \ - ((((unsigned long) (word)) >> 8), \ - (((sizeof (format_word)) * CHAR_BIT) - 8))) +/* Size of execution cache in SCHEME_OBJECTS. */ +#define UUO_LINK_SIZE 2 +#define READ_UUO_TARGET(a, r) read_uuo_target (a) -#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ - (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr))) +#undef CMPINT_USE_STRUCS -#define COMPILED_ENTRY_FORMAT_LOW(addr) \ - (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr))) +#define EMBEDDED_CLOSURE_ADDRS_P 1 +#define READ_COMPILED_CLOSURE_TARGET(a, r) (read_compiled_closure_target (a)) -#define FORMAT_BYTE_FRAMEMAX 0x7f +extern void initialize_C_interface (void); +extern insn_t * read_uuo_target (SCHEME_OBJECT *); +extern insn_t * read_compiled_closure_target (insn_t *); -#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW -#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH +extern unsigned long c_code_table_export_length (unsigned long *); +extern void export_c_code_table (SCHEME_OBJECT *); +extern bool import_c_code_table (SCHEME_OBJECT *, unsigned long); -#endif /* CMPINTMD_H_INCLUDED */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/hppa.h b/v7/src/microcode/cmpintmd/hppa.h index 1501dab44..6eb5af9de 100644 --- a/v7/src/microcode/cmpintmd/hppa.h +++ b/v7/src/microcode/cmpintmd/hppa.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hppa.h,v 1.56 2007/01/05 21:19:26 cph Exp $ +$Id: hppa.h,v 1.57 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,56 +25,45 @@ USA. */ -/* - * - * Compiled code interface macros. - * - * See cmpint.txt for a description of these fields. - * - * Specialized for the HP Precision Architecture (Spectrum) - */ +/* Compiled code interface macros, specialized for the HP Precision + Architecture. */ -#ifndef CMPINTMD_H_INCLUDED -#define CMPINTMD_H_INCLUDED +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 -#include "cmptype.h" #include "hppacach.h" - + /* Machine parameters to be set by the user. */ /* Until cmpaux-hppa.m4 is updated. */ #define CMPINT_USE_STRUCS -/* Processor type. Choose a number from the above list, or allocate your own. */ +/* Processor type. Choose a number from the above list, or allocate + your own. */ -#define COMPILER_PROCESSOR_TYPE COMPILER_SPECTRUM_TYPE +#define COMPILER_PROCESSOR_TYPE COMPILER_SPECTRUM_TYPE /* Size (in long words) of the contents of a floating point register if different from a double. For example, an MC68881 saves registers in 96 bit (3 longword) blocks. Default is fine for PA. - define COMPILER_TEMP_SIZE 3 -*/ + define COMPILER_TEMP_SIZE 3 + */ + +#define COMPILER_REGBLOCK_N_TEMPS 256 /* Descriptor size. This is the size of the offset field, and of the format field. - This definition probably does not need to be changed. - */ + This definition probably does not need to be changed. */ typedef unsigned short format_word; -/* PC alignment constraint. - Change PC_ZERO_BITS to be how many low order bits of the pc are - guaranteed to be 0 always because of PC alignment constraints. -*/ - -#define PC_ZERO_BITS 2 +typedef unsigned long insn_t; /* C function pointers are pairs of instruction addreses and data segment - pointers. We don't want that for the assembly language entry points. - */ + pointers. We don't want that for the assembly language entry points. */ -#define C_FUNC_PTR_IS_CLOSURE +#define C_FUNC_PTR_IS_CLOSURE 1 #ifndef C_FUNC_PTR_IS_CLOSURE # define interface_to_C ep_interface_to_C @@ -83,15 +72,12 @@ typedef unsigned short format_word; /* Utilities for manipulating absolute subroutine calls. On the PA the absolute address is "smeared out" over two - instructions, an LDIL and a BLE instruction. - */ + instructions, an LDIL and a BLE instruction. */ -extern unsigned long - EXFUN (hppa_extract_absolute_address, (unsigned long *)); +extern unsigned long hppa_extract_absolute_address (unsigned long *); -extern void - EXFUN (hppa_store_absolute_address, - (unsigned long *, unsigned long, unsigned long)); +extern void hppa_store_absolute_address + (unsigned long *, unsigned long, unsigned long); #define EXTRACT_ABSOLUTE_ADDRESS(target, address) \ { \ @@ -223,12 +209,12 @@ extern void #define TRAMPOLINE_STORAGE(tramp_entry) \ ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) + (2 + TRAMPOLINE_ENTRY_SIZE)) #define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \ { \ extern void \ - EXFUN (cache_flush_region, (PTR, long, unsigned int)); \ + cache_flush_region (void *, long, unsigned int); \ \ unsigned long *PC; \ \ @@ -367,42 +353,36 @@ extern void #define FLUSH_I_CACHE() do \ { \ - extern void \ - EXFUN (flush_i_cache, (void)); \ - \ + extern void flush_i_cache (void); \ flush_i_cache (); \ } while (0) /* This flushes a region of the I-cache. It is used after updating an execute cache while running. Not needed during GC because FLUSH_I_CACHE will be used. - */ + */ #define FLUSH_I_CACHE_REGION(address, nwords) do \ { \ - extern void \ - EXFUN (cache_flush_region, (PTR, long, unsigned int)); \ - \ - cache_flush_region (((PTR) (address)), ((long) (nwords)), \ + extern void cache_flush_region, (void *, long, unsigned int); \ + cache_flush_region (((void *) (address)), ((long) (nwords)), \ (D_CACHE | I_CACHE)); \ } while (0) /* This pushes a region of the D-cache back to memory. It is (typically) used after loading (and relocating) a piece of code into memory. - */ + */ #define PUSH_D_CACHE_REGION(address, nwords) do \ { \ - extern void \ - EXFUN (push_d_cache_region, (PTR, unsigned long)); \ - \ - push_d_cache_region (((PTR) (address)), \ + extern void push_d_cache_region (void *, unsigned long); \ + push_d_cache_region (((void *) (address)), \ ((unsigned long) (nwords))); \ } while (0) -extern void EXFUN (hppa_update_primitive_table, (int, int)); -extern Boolean EXFUN (hppa_grow_primitive_table, (int)); +extern void hppa_update_primitive_table (int, int); +extern bool hppa_grow_primitive_table (int); #define UPDATE_PRIMITIVE_TABLE_HOOK hppa_update_primitive_table #define GROW_PRIMITIVE_TABLE_HOOK hppa_grow_primitive_table @@ -428,55 +408,18 @@ extern Boolean EXFUN (hppa_grow_primitive_table, (int)); #define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) #define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif - -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif - -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1) #define MAKE_OFFSET_WORD(entry, block, continue) \ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ ((char *) (block)))) | \ ((continue) ? 1 : 0)) -#if (EXECUTE_CACHE_ENTRY_SIZE == 2) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 1) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 1) -#endif - -#if (EXECUTE_CACHE_ENTRY_SIZE == 4) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 2) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 2) -#endif - -#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) #define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ ((count) / EXECUTE_CACHE_ENTRY_SIZE) #define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ ((entries) * EXECUTE_CACHE_ENTRY_SIZE) -#endif /* The first entry in a cc block is preceeded by 2 headers (block and nmv), a format word and a gc offset word. See the early part of the @@ -604,7 +547,7 @@ union assemble_12_u }; long -DEFUN (assemble_17, (inst), union branch_inst inst) +assemble_17 (union branch_inst inst) { union assemble_17_u off; @@ -618,7 +561,7 @@ DEFUN (assemble_17, (inst), union branch_inst inst) } long -DEFUN (assemble_12, (inst), union branch_inst inst) +assemble_12 (union branch_inst inst) { union assemble_12_u off; @@ -633,7 +576,7 @@ DEFUN (assemble_12, (inst), union branch_inst inst) static unsigned long hppa_closure_hook = 0; static unsigned long -DEFUN (C_closure_entry_point, (C_closure), unsigned long C_closure) +C_closure_entry_point (unsigned long C_closure) { if ((C_closure & 0x3) != 0x2) return (C_closure); @@ -661,7 +604,7 @@ static unsigned short branch_opcodes[] = 0x30, 0x31, 0x32, 0x33, 0x38, 0x39, 0x3a }; -static Boolean +static bool branch_opcode_table[64]; static unsigned long @@ -679,19 +622,19 @@ static unsigned long #define FAHRENHEIT 451 static void -DEFUN_VOID (bkpt_init) +bkpt_init (void) { int i, this_size, max_size; union branch_inst instr; - extern void EXFUN (bkpt_normal_proceed, (void)); - extern void EXFUN (bkpt_plus_proceed, (void)); - extern void EXFUN (bkpt_minus_proceed_start, (void)); - extern void EXFUN (bkpt_minus_proceed, (void)); - extern void EXFUN (bkpt_closure_proceed, (void)); - extern void EXFUN (bkpt_closure_proceed_end, (void)); + extern void bkpt_normal_proceed (void); + extern void bkpt_plus_proceed (void); + extern void bkpt_minus_proceed_start (void); + extern void bkpt_minus_proceed (void); + extern void bkpt_closure_proceed (void); + extern void bkpt_closure_proceed_end (void); for (i = 0; - i < ((sizeof (branch_opcode_table)) / (sizeof (Boolean))); + i < ((sizeof (branch_opcode_table)) / (sizeof (bool))); i++) branch_opcode_table[i] = FALSE; @@ -747,7 +690,7 @@ DEFUN_VOID (bkpt_init) this_size = (bkpt_minus_proceed_thunk_start - bkpt_plus_proceed_thunk); if (this_size > max_size) max_size = this_size; - + bkpt_proceed_buffer = ((unsigned long *) (malloc (max_size * (sizeof (unsigned long))))); if (bkpt_proceed_buffer == ((unsigned long *) NULL)) @@ -765,11 +708,10 @@ DEFUN_VOID (bkpt_init) #define BKPT_KIND_BLE_INST 4 #define BKPT_KIND_CLOSURE_ENTRY 5 -extern void EXFUN (cache_flush_region, (PTR, long, unsigned int)); +extern void cache_flush_region (void *, long, unsigned int); static SCHEME_OBJECT -DEFUN (alloc_bkpt_handle, (kind, first_instr, entry_point), - int kind AND unsigned long first_instr AND PTR entry_point) +alloc_bkpt_handle (int kind, unsigned long first_instr, void * entry_point) { SCHEME_OBJECT * handle; Primitive_GC_If_Needed (5); @@ -781,12 +723,12 @@ DEFUN (alloc_bkpt_handle, (kind, first_instr, entry_point), handle[2] = ((SCHEME_OBJECT) (FIXNUM_ZERO + kind)); handle[3] = ((SCHEME_OBJECT) first_instr); handle[4] = (ENTRY_TO_OBJECT (entry_point)); - + return (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, handle)); } SCHEME_OBJECT -DEFUN (bkpt_install, (entry_point), PTR entry_point) +bkpt_install (void * entry_point) { unsigned long kind; SCHEME_OBJECT handle; @@ -796,7 +738,7 @@ DEFUN (bkpt_install, (entry_point), PTR entry_point) if ((COMPILED_ENTRY_FORMAT_WORD (entry_point)) == FORMAT_WORD_CLOSURE) { - /* This assumes that the first instruction is normal */ + /* This assumes that the first instruction is normal */ kind = BKPT_KIND_CLOSURE_ENTRY; new_instr = closure_entry_bkpt_instruction; } @@ -852,26 +794,25 @@ DEFUN (bkpt_install, (entry_point), PTR entry_point) handle = (alloc_bkpt_handle (kind, first_instr, entry_point)); (* ((unsigned long *) entry_point)) = new_instr; - cache_flush_region (((PTR) entry_point), 1, (D_CACHE | I_CACHE)); + cache_flush_region (((void *) entry_point), 1, (D_CACHE | I_CACHE)); return (handle); } SCHEME_OBJECT -DEFUN (bkpt_closure_install, (entry_point), PTR entry_point) +bkpt_closure_install (void * entry_point) { unsigned long * instrs = ((unsigned long *) entry_point); SCHEME_OBJECT handle; handle = (alloc_bkpt_handle (BKPT_KIND_CLOSURE, instrs[2], entry_point)); instrs[2] = closure_bkpt_instruction; - cache_flush_region (((PTR) &instrs[2]), 1, (D_CACHE | I_CACHE)); + cache_flush_region (((void *) &instrs[2]), 1, (D_CACHE | I_CACHE)); return (handle); } - + void -DEFUN (bkpt_remove, (entry_point, handle), - PTR entry_point AND SCHEME_OBJECT handle) +bkpt_remove (void * entry_point, SCHEME_OBJECT handle) { int offset; unsigned long * instrs = ((unsigned long *) entry_point); @@ -884,13 +825,13 @@ DEFUN (bkpt_remove, (entry_point, handle), else error_external_return (); - instrs[offset] = ((unsigned long) (FAST_MEMORY_REF (handle, 3))); - cache_flush_region (((PTR) &instrs[offset]), 1, (D_CACHE | I_CACHE)); + instrs[offset] = ((unsigned long) (MEMORY_REF (handle, 3))); + cache_flush_region (((void *) &instrs[offset]), 1, (D_CACHE | I_CACHE)); return; } -Boolean -DEFUN (bkpt_p, (entry_point), PTR entry_point) +bool +bkpt_p (void * entry_point) { unsigned long * instrs = ((unsigned long *) entry_point); @@ -898,140 +839,137 @@ DEFUN (bkpt_p, (entry_point), PTR entry_point) || (instrs[0] == closure_entry_bkpt_instruction) || (instrs[2] == closure_bkpt_instruction)); } - -Boolean -DEFUN (do_bkpt_proceed, (value), unsigned long * value) + +long +do_bkpt_proceed (insn_t ** addr_r) { - unsigned long * buffer = ((unsigned long *) bkpt_proceed_buffer); + insn_t * buffer = bkpt_proceed_buffer; SCHEME_OBJECT ep = (STACK_POP ()); SCHEME_OBJECT handle = (STACK_POP ()); SCHEME_OBJECT state = (STACK_POP ()); STACK_POP (); /* Pop duplicate entry point. */ - switch (OBJECT_DATUM (FAST_MEMORY_REF (handle, 2))) - { - case BKPT_KIND_CLOSURE: + switch (OBJECT_DATUM (MEMORY_REF (handle, 2))) { - int i, len; - unsigned long * clos_entry - = (OBJECT_ADDRESS (FAST_MEMORY_REF (handle, 4))); - SCHEME_OBJECT real_entry_point; - - EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry_point, clos_entry); - len = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk); - for (i = 0; i < (len - 2); i++) - buffer[i] = bkpt_closure_proceed_thunk[i]; - cache_flush_region (((PTR) buffer), (len - 2), (D_CACHE | I_CACHE)); - - buffer[len - 2] = ((unsigned long) clos_entry); - buffer[len - 1] = real_entry_point; - - val_register = SHARP_F; - * value = ((unsigned long) buffer); - return (TRUE); - } - + case BKPT_KIND_CLOSURE: + { + int i, len; + unsigned long * clos_entry + = (OBJECT_ADDRESS (MEMORY_REF (handle, 4))); + SCHEME_OBJECT real_entry_point; + + EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry_point, clos_entry); + len = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk); + for (i = 0; i < (len - 2); i++) + buffer[i] = bkpt_closure_proceed_thunk[i]; + cache_flush_region (((void *) buffer), (len - 2), (D_CACHE | I_CACHE)); + + buffer[len - 2] = ((unsigned long) clos_entry); + buffer[len - 1] = real_entry_point; + + SET_VAL (SHARP_F); + (*addr_r) = buffer; + return (PRIM_DONE); + } + case BKPT_KIND_NORMAL: - { - int i, len; + { + int i, len; - len = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk); - for (i = 0; i < (len - 2); i++) - buffer[i] = bkpt_normal_proceed_thunk[i]; - buffer[len - 2] = ((unsigned long) (FAST_MEMORY_REF (handle, 3))); + len = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk); + for (i = 0; i < (len - 2); i++) + buffer[i] = bkpt_normal_proceed_thunk[i]; + buffer[len - 2] = ((unsigned long) (MEMORY_REF (handle, 3))); - cache_flush_region (((PTR) buffer), (len - 1), (D_CACHE | I_CACHE)); - buffer[len - 1] = (((unsigned long) (OBJECT_ADDRESS (ep))) + 4); + cache_flush_region (((void *) buffer), (len - 1), (D_CACHE | I_CACHE)); + buffer[len - 1] = (((unsigned long) (OBJECT_ADDRESS (ep))) + 4); - val_register = state; - * value = ((unsigned long) buffer); - return (TRUE); - } + SET_VAL (state); + (*addr_r) = buffer; + return (PRIM_DONE); + } case BKPT_KIND_CLOSURE_ENTRY: - { - STACK_PUSH (state); /* closure object */ - * value = ((unsigned long) ((OBJECT_ADDRESS (ep)) + 2)); - return (TRUE); - } + { + STACK_PUSH (state); /* closure object */ + (*addr_r) = ((CC_ENTRY_ADDRESS (ep)) + 2); + return (PRIM_DONE); + } case BKPT_KIND_BL_INST: case BKPT_KIND_BLE_INST: default: STACK_PUSH (ep); - * value = ((unsigned long) ERR_EXTERNAL_RETURN); - return (FALSE); + return (ERR_EXTERNAL_RETURN); case BKPT_KIND_PC_REL_BRANCH: - { - long offset; - int i, len, clobber; - union branch_inst new, old; - unsigned long * instrs = ((unsigned long *) (OBJECT_ADDRESS (ep))); - unsigned long * block; - - old.inst = ((unsigned long) (FAST_MEMORY_REF (handle, 3))); - offset = (assemble_12 (old)); - if (offset >= 0) { - block = bkpt_plus_proceed_thunk; - len = (bkpt_minus_proceed_thunk_start - block); - clobber = 0; - } - else - { - block = bkpt_minus_proceed_thunk_start; - len = (bkpt_closure_proceed_thunk - block); - clobber = (bkpt_minus_proceed_thunk - block); + long offset; + int i, len, clobber; + union branch_inst new, old; + insn_t * instrs = (CC_ENTRY_ADDRESS (ep)); + unsigned long * block; + + old.inst = ((unsigned long) (MEMORY_REF (handle, 3))); + offset = (assemble_12 (old)); + if (offset >= 0) + { + block = bkpt_plus_proceed_thunk; + len = (bkpt_minus_proceed_thunk_start - block); + clobber = 0; + } + else + { + block = bkpt_minus_proceed_thunk_start; + len = (bkpt_closure_proceed_thunk - block); + clobber = (bkpt_minus_proceed_thunk - block); + } + + for (i = 0; i < (len - 2); i++) + buffer[i] = block[i]; + + new.inst = buffer[clobber]; + old.inst = ((unsigned long) (MEMORY_REF (handle, 3))); + old.fields.w2b = new.fields.w2b; + old.fields.w2a = new.fields.w2a; + old.fields.w0 = new.fields.w0; + buffer[clobber] = old.inst; + buffer[clobber + 1] = instrs[1]; + cache_flush_region (((void *) buffer), (len - 2), (D_CACHE | I_CACHE)); + + buffer[len - 2] = (((unsigned long) instrs) + 8); + buffer[len - 1] = ((((unsigned long) instrs) + 8) + + offset); + + SET_VAL (state); + (*addr_r) = (buffer + clobber); + return (PRIM_DONE); } - - for (i = 0; i < (len - 2); i++) - buffer[i] = block[i]; - - new.inst = buffer[clobber]; - old.inst = ((unsigned long) (FAST_MEMORY_REF (handle, 3))); - old.fields.w2b = new.fields.w2b; - old.fields.w2a = new.fields.w2a; - old.fields.w0 = new.fields.w0; - buffer[clobber] = old.inst; - buffer[clobber + 1] = instrs[1]; - cache_flush_region (((PTR) buffer), (len - 2), (D_CACHE | I_CACHE)); - - buffer[len - 2] = (((unsigned long) instrs) + 8); - buffer[len - 1] = ((((unsigned long) instrs) + 8) - + offset); - - val_register = state; - * value = ((unsigned long) &buffer[clobber]); - return (TRUE); } - } } static void -DEFUN (transform_procedure_entries, (len, otable, ntable), - long len AND PTR * otable AND PTR * ntable) +transform_procedure_entries (long len, void ** otable, void ** ntable) { long counter; - + for (counter = 0; counter < len; counter++) ntable[counter] = - ((PTR) (C_closure_entry_point ((unsigned long) (otable [counter])))); + ((void *) (C_closure_entry_point ((unsigned long) (otable [counter])))); return; -} +} -static PTR * -DEFUN (transform_procedure_table, (table_length, old_table), - long table_length AND PTR * old_table) +static void ** +transform_procedure_table (long table_length, void ** old_table) { - PTR * new_table; + void ** new_table; - new_table = ((PTR *) (malloc (table_length * (sizeof (PTR))))); - if (new_table == ((PTR *) NULL)) + new_table = ((void **) (malloc (table_length * (sizeof (void *))))); + if (new_table == ((void **) NULL)) { outf_fatal ("transform_procedure_table: malloc (%d) failed.\n", - (table_length * (sizeof (PTR)))); + (table_length * (sizeof (void *)))); exit (1); } transform_procedure_entries (table_length, old_table, new_table); @@ -1047,7 +985,7 @@ DEFUN (transform_procedure_table, (table_length, old_table), #endif void -DEFUN_VOID (change_vm_protection) +change_vm_protection (void) { #if 0 /* Thought I needed this under _BSD4_3 */ @@ -1057,8 +995,7 @@ DEFUN_VOID (change_vm_protection) unsigned long size; heap_start_page = (((unsigned long) Heap) & (pagesize - 1)); - size = (((((unsigned long) Highest_Allocated_Address) + (pagesize - 1)) - & (pagesize - 1)) + size = (((memory_block_end + (pagesize - 1)) & (pagesize - 1)) - heap_start_page); if ((mprotect (((caddr_t) heap_start_page), size, VM_PROT_SCHEME)) == -1) @@ -1070,7 +1007,6 @@ DEFUN_VOID (change_vm_protection) termination_init_error (); } #endif - return; } #include "option.h" @@ -1082,11 +1018,10 @@ DEFUN_VOID (change_vm_protection) static struct pdc_cache_dump cache_info; static void -DEFUN_VOID (flush_i_cache_initialize) +flush_i_cache_initialize (void) { - extern char * EXFUN (getenv, (const char *)); - CONST char * models_filename = - (search_path_for_file (0, MODELS_FILENAME, 1, 1)); + const char * models_filename = + (search_path_for_file (0, MODELS_FILENAME, true, true)); char * model; model = (getenv ("MITSCHEME_HPPA_MODEL")); @@ -1158,17 +1093,16 @@ DEFUN_VOID (flush_i_cache_initialize) It also changes the VM protection of the heap, if necessary. */ -extern PTR * hppa_utility_table; -extern PTR * hppa_primitive_table; +extern void ** hppa_utility_table; +extern void ** hppa_primitive_table; -PTR * hppa_utility_table = ((PTR *) NULL); +void ** hppa_utility_table = ((void **) NULL); static void -DEFUN (hppa_reset_hook, (utility_length, utility_table), - long utility_length AND PTR * utility_table) +hppa_reset_hook (long utility_length, void ** utility_table) { - extern void EXFUN (interface_initialize, (void)); - extern void EXFUN (cross_segment_call, (void)); + extern void interface_initialize (void); + extern void cross_segment_call (void); flush_i_cache_initialize (); interface_initialize (); @@ -1183,29 +1117,30 @@ DEFUN (hppa_reset_hook, (utility_length, utility_table), #define ASM_RESET_HOOK() do \ { \ bkpt_init (); \ - hppa_reset_hook (((sizeof (utility_table)) / (sizeof (PTR))), \ - ((PTR *) (&utility_table[0]))); \ + hppa_reset_hook (((sizeof (utility_table)) / (sizeof (void *))), \ + ((void **) (&utility_table[0]))); \ } while (0) -PTR * hppa_primitive_table = ((PTR *) NULL); +void ** hppa_primitive_table = ((void **) NULL); void -DEFUN (hppa_update_primitive_table, (low, high), int low AND int high) +hppa_update_primitive_table (int low, int high) { transform_procedure_entries ((high - low), - ((PTR *) (Primitive_Procedure_Table + low)), + ((void **) (Primitive_Procedure_Table + low)), (hppa_primitive_table + low)); return; } -Boolean -DEFUN (hppa_grow_primitive_table, (new_size), int new_size) +bool +hppa_grow_primitive_table (int new_size) { - PTR * new_table - = ((PTR *) (realloc (hppa_primitive_table, (new_size * (sizeof (PTR)))))); - if (new_table != ((PTR *) NULL)) + void ** new_table + = ((void **) + (realloc (hppa_primitive_table, (new_size * (sizeof (void *)))))); + if (new_table != ((void **) NULL)) hppa_primitive_table = new_table; - return (new_table != ((PTR *) NULL)); + return (new_table != ((void **) NULL)); } /* @@ -1221,7 +1156,7 @@ DEFUN (hppa_grow_primitive_table, (new_size), int new_size) */ unsigned long -DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr) +hppa_extract_absolute_address (unsigned long * addr) { union short_pointer result; union branch_inst ble; @@ -1244,9 +1179,8 @@ DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr) } void -DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p), - unsigned long * addr AND unsigned long sourcev - AND unsigned long nullify_p) +hppa_store_absolute_address (unsigned long * addr, unsigned long sourcev, + unsigned long nullify_p) { union short_pointer source; union ldil_inst ldil; @@ -1291,17 +1225,17 @@ DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p), */ extern void - EXFUN (flush_i_cache, (void)), - EXFUN (push_d_cache_region, (PTR, unsigned long)); + flush_i_cache (void), + push_d_cache_region (void *, unsigned long); void -DEFUN_VOID (flush_i_cache) +flush_i_cache (void) { extern void - EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *)); + cache_flush_all (unsigned int, struct pdc_cache_result *); struct pdc_cache_result * cache_desc; - + cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); /* The call can be interrupted in the middle of a set, so do it twice. @@ -1329,14 +1263,13 @@ DEFUN_VOID (flush_i_cache) } void -DEFUN (push_d_cache_region, (start_address, block_size), - PTR start_address AND unsigned long block_size) +push_d_cache_region (void * start_address, unsigned long block_size) { extern void - EXFUN (cache_flush_region, (PTR, long, unsigned int)); + cache_flush_region (void *, long, unsigned int); struct pdc_cache_result * cache_desc; - + cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); /* Note that the first and last words are also flushed from the I-cache @@ -1349,7 +1282,7 @@ DEFUN (push_d_cache_region, (start_address, block_size), { cache_flush_region (start_address, block_size, D_CACHE); cache_flush_region (start_address, 1, I_CACHE); - cache_flush_region (((PTR) + cache_flush_region (((void *) (((unsigned long *) start_address) + (block_size - 1))), 1, @@ -1383,4 +1316,4 @@ DEFUN (push_d_cache_region, (start_address, block_size), #endif /* IN_CMPINT_C */ -#endif /* CMPINTMD_H_INCLUDED */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/makegen/files-gc-std.scm b/v7/src/microcode/cmpintmd/i386-config.h similarity index 77% rename from v7/src/microcode/makegen/files-gc-std.scm rename to v7/src/microcode/cmpintmd/i386-config.h index fca1614ea..c61814fbd 100644 --- a/v7/src/microcode/makegen/files-gc-std.scm +++ b/v7/src/microcode/cmpintmd/i386-config.h @@ -1,6 +1,6 @@ -#| -*-Scheme-*- +/* -*-C-*- -$Id: files-gc-std.scm,v 1.6 2007/01/05 21:19:26 cph Exp $ +$Id: i386-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -23,12 +23,12 @@ along with MIT/GNU Scheme; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. -|# +*/ -;;;; C files for standard garbage collector. +#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED +#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1 -"fasdump" -"gcloop" -"memmag" -"purify" -"wabbit" +#define COMPILER_PROCESSOR_TYPE COMPILER_IA32_TYPE +#define CC_IS_NATIVE 1 + +#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/i386.c b/v7/src/microcode/cmpintmd/i386.c new file mode 100644 index 000000000..28b4129f3 --- /dev/null +++ b/v7/src/microcode/cmpintmd/i386.c @@ -0,0 +1,391 @@ +/* -*-C-*- + +$Id: i386.c,v 1.2 2007/04/22 16:31:24 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Compiled code interface for Intel IA-32. */ + +#include "cmpint.h" +#include "extern.h" +#include "outf.h" +#include "errors.h" + +extern void * tospace_to_newspace (void *); + +bool +read_cc_entry_type (cc_entry_type_t * cet, insn_t * address) +{ + return (decode_old_style_format_word (cet, (((uint16_t *) address) [-2]))); +} + +bool +write_cc_entry_type (cc_entry_type_t * cet, insn_t * address) +{ + return (encode_old_style_format_word (cet, ((uint16_t *) address) - 2)); +} + +bool +read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) +{ + uint16_t n = (((uint16_t *) address) [-1]); + (ceo->offset) = (n >> 1); + (ceo->continued_p) = ((n & 1) != 0); + return (false); +} + +bool +write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) +{ + if (! ((ceo->offset) < 0x4000)) + return (true); + (((uint16_t *) address) [-1]) + = (((ceo->offset) << 1) | ((ceo->continued_p) ? 1 : 0)); + return (false); +} + +/* Compiled closures */ + +void +start_closure_relocation (SCHEME_OBJECT * scan, reloc_ref_t * ref) +{ + (ref->old_addr) = (CC_ENTRY_ADDRESS (* ((CC_BLOCK_ADDR_END (scan)) - 1))); + (ref->new_addr) + = (tospace_to_newspace + (compiled_closure_entry (compiled_closure_start (scan + 1)))); +} + +insn_t * +read_compiled_closure_target (insn_t * start, reloc_ref_t * ref) +{ + insn_t * addr = (start + CC_ENTRY_HEADER_SIZE + 1); + return (((((insn_t *) (tospace_to_newspace (addr + 4))) + - (ref->new_addr)) + + (ref->old_addr)) + + (* ((long *) addr))); +} + +void +write_compiled_closure_target (insn_t * target, insn_t * start) +{ + insn_t * addr = (start + CC_ENTRY_HEADER_SIZE + 1); + (* ((long *) addr)) + = (target - ((insn_t *) (tospace_to_newspace (addr + 4)))); +} + +#define SINGLE_CLOSURE_OFFSET \ + (((sizeof (SCHEME_OBJECT)) + CC_ENTRY_HEADER_SIZE) << 1) + +unsigned long +compiled_closure_count (SCHEME_OBJECT * block) +{ + unsigned short * addr = ((unsigned short *) block); + return (((addr[1]) == SINGLE_CLOSURE_OFFSET) ? 1 : (addr[0])); +} + +insn_t * +compiled_closure_start (SCHEME_OBJECT * block) +{ + unsigned short * addr = ((unsigned short *) block); + return + (((insn_t *) block) + + (((addr[1]) == SINGLE_CLOSURE_OFFSET) + ? 0 + : CC_ENTRY_HEADER_SIZE)); +} + +insn_t * +compiled_closure_entry (insn_t * start) +{ + return (start + CC_ENTRY_HEADER_SIZE); +} + +insn_t * +compiled_closure_next (insn_t * start) +{ + return (start + CC_ENTRY_HEADER_SIZE + 6); +} + +SCHEME_OBJECT * +skip_compiled_closure_padding (insn_t * start) +{ + return + ((SCHEME_OBJECT *) + ((((unsigned long) start) + ((sizeof (SCHEME_OBJECT)) - 1)) + &~ ((sizeof (SCHEME_OBJECT)) - 1))); +} + +SCHEME_OBJECT +compiled_closure_entry_to_target (insn_t * entry) +{ + insn_t * addr = (entry + 1); + return (MAKE_CC_ENTRY ((addr + 4) + (* ((long *) addr)))); +} + +/* Execution caches (UUO links) + + An execution cache is a region of memory that lives in the + constants section of a compiled-code block. It is an indirection + for calling external procedures that allows the linker to control + the calling process without having to find and change all the + places in the compiled code that refer to it. + + Prior to linking, the execution cache has two pieces of + information: (1) the name of the procedure being called (a symbol), + and (2) the number of arguments that will be passed to the + procedure. */ + +SCHEME_OBJECT +read_uuo_symbol (SCHEME_OBJECT * saddr) +{ + return (saddr[1]); +} + +unsigned int +read_uuo_frame_size (SCHEME_OBJECT * saddr) +{ + return (* ((unsigned short *) saddr)); +} + +void +start_operator_relocation (SCHEME_OBJECT * saddr, reloc_ref_t * ref) +{ + insn_t * nsaddr = (tospace_to_newspace (saddr)); + (ref->old_addr) = (* ((insn_t **) saddr)); + (ref->new_addr) = nsaddr; + (* ((insn_t **) saddr)) = nsaddr; +} + +insn_t * +read_uuo_target (SCHEME_OBJECT * saddr, reloc_ref_t * ref) +{ + insn_t * addr = (((insn_t *) saddr) + 4); + insn_t * base = (tospace_to_newspace (addr + 4)); + return (((ref == 0) + ? base + : ((base - (ref->new_addr)) + (ref->old_addr))) + + (* ((long *) addr))); +} + +insn_t * +read_uuo_target_no_reloc (SCHEME_OBJECT * saddr) +{ + return (read_uuo_target (saddr, 0)); +} + +void +write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr) +{ + insn_t * addr = (((insn_t *) saddr) + 3); + (*addr++) = 0xE9; /* JMP rel32 */ + (* ((long *) addr)) + = (target - ((insn_t *) (tospace_to_newspace (addr + 4)))); +} + +#define TRAMPOLINE_ENTRY_SIZE 3 + +#define ESI_TRAMPOLINE_TO_INTERFACE_OFFSET \ + ((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) \ + * SIZEOF_SCHEME_OBJECT) + +unsigned long +trampoline_entry_size (unsigned long n_entries) +{ + return (n_entries * TRAMPOLINE_ENTRY_SIZE); +} + +insn_t * +trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return (((insn_t *) (block + 2 + (index * TRAMPOLINE_ENTRY_SIZE))) + + CC_ENTRY_HEADER_SIZE); +} + +bool +store_trampoline_insns (insn_t * entry, byte_t code) +{ + (*entry++) = 0xB0; /* MOV AL,code */ + (*entry++) = code; + (*entry++) = 0xFF; /* CALL /2 disp32(ESI) */ + (*entry++) = 0x96; + (* ((unsigned long *) entry)) = ESI_TRAMPOLINE_TO_INTERFACE_OFFSET; + IA32_CACHE_SYNCHRONIZE (); + return (false); +} + +#ifdef _MACH_UNIX +# include +# define VM_PROT_SCHEME (VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE) +#endif + +#define SETUP_REGISTER(hook) do \ +{ \ + (* ((unsigned long *) (esi_value + offset))) \ + = ((unsigned long) (hook)); \ + offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \ + declare_builtin (((unsigned long) hook), #hook); \ +} while (0) + +void +i386_reset_hook (void) +{ + unsigned int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT))); + unsigned char * esi_value = ((unsigned char *) Registers); + bool fp_support_present = (i386_interface_initialize ()); + + /* These must match machines/i386/lapgen.scm */ + + SETUP_REGISTER (asm_scheme_to_interface); /* 0 */ + SETUP_REGISTER (asm_scheme_to_interface_call); /* 1 */ + + if (offset != ESI_TRAMPOLINE_TO_INTERFACE_OFFSET) + { + outf_fatal ("\ni386_reset_hook: ESI_TRAMPOLINE_TO_INTERFACE_OFFSET\n"); + Microcode_Termination (TERM_EXIT); + } + SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */ + + SETUP_REGISTER (asm_interrupt_procedure); /* 3 */ + SETUP_REGISTER (asm_interrupt_continuation); /* 4 */ + SETUP_REGISTER (asm_interrupt_closure); /* 5 */ + SETUP_REGISTER (asm_interrupt_dlink); /* 6 */ + SETUP_REGISTER (asm_primitive_apply); /* 7 */ + SETUP_REGISTER (asm_primitive_lexpr_apply); /* 8 */ + SETUP_REGISTER (asm_assignment_trap); /* 9 */ + SETUP_REGISTER (asm_reference_trap); /* 10 */ + SETUP_REGISTER (asm_safe_reference_trap); /* 11 */ + SETUP_REGISTER (asm_link); /* 12 */ + SETUP_REGISTER (asm_error); /* 13 */ + SETUP_REGISTER (asm_primitive_error); /* 14 */ + SETUP_REGISTER (asm_short_primitive_apply); /* 15 */ + + /* No more room for positive offsets without going to 32-bit + offsets! */ + + /* This is a hack to make all the hooks be addressable with byte + offsets (instead of longword offsets). The register block + extends to negative offsets as well, so all the following hooks + are accessed with negative offsets, and all fit in a byte. */ + + offset = -128; + if (fp_support_present) + { + SETUP_REGISTER (asm_generic_add); /* -32 */ + SETUP_REGISTER (asm_generic_subtract); /* -31 */ + SETUP_REGISTER (asm_generic_multiply); /* -30 */ + SETUP_REGISTER (asm_generic_divide); /* -29 */ + SETUP_REGISTER (asm_generic_equal); /* -28 */ + SETUP_REGISTER (asm_generic_less); /* -27 */ + SETUP_REGISTER (asm_generic_greater); /* -26 */ + SETUP_REGISTER (asm_generic_increment); /* -25 */ + SETUP_REGISTER (asm_generic_decrement); /* -24 */ + SETUP_REGISTER (asm_generic_zero); /* -23 */ + SETUP_REGISTER (asm_generic_positive); /* -22 */ + SETUP_REGISTER (asm_generic_negative); /* -21 */ + SETUP_REGISTER (asm_generic_quotient); /* -20 */ + SETUP_REGISTER (asm_generic_remainder); /* -19 */ + SETUP_REGISTER (asm_generic_modulo); /* -18 */ + } + else + { + SETUP_REGISTER (asm_nofp_add); /* -32 */ + SETUP_REGISTER (asm_nofp_subtract); /* -31 */ + SETUP_REGISTER (asm_nofp_multiply); /* -30 */ + SETUP_REGISTER (asm_nofp_divide); /* -29 */ + SETUP_REGISTER (asm_nofp_equal); /* -28 */ + SETUP_REGISTER (asm_nofp_less); /* -27 */ + SETUP_REGISTER (asm_nofp_greater); /* -26 */ + SETUP_REGISTER (asm_nofp_increment); /* -25 */ + SETUP_REGISTER (asm_nofp_decrement); /* -24 */ + SETUP_REGISTER (asm_nofp_zero); /* -23 */ + SETUP_REGISTER (asm_nofp_positive); /* -22 */ + SETUP_REGISTER (asm_nofp_negative); /* -21 */ + SETUP_REGISTER (asm_nofp_quotient); /* -20 */ + SETUP_REGISTER (asm_nofp_remainder); /* -19 */ + SETUP_REGISTER (asm_nofp_modulo); /* -18 */ + } + + SETUP_REGISTER (asm_sc_apply); /* -17 */ + SETUP_REGISTER (asm_sc_apply_size_1); /* -16 */ + SETUP_REGISTER (asm_sc_apply_size_2); /* -15 */ + SETUP_REGISTER (asm_sc_apply_size_3); /* -14 */ + SETUP_REGISTER (asm_sc_apply_size_4); /* -13 */ + SETUP_REGISTER (asm_sc_apply_size_5); /* -12 */ + SETUP_REGISTER (asm_sc_apply_size_6); /* -11 */ + SETUP_REGISTER (asm_sc_apply_size_7); /* -10 */ + SETUP_REGISTER (asm_sc_apply_size_8); /* -9 */ + SETUP_REGISTER (asm_interrupt_continuation_2); /* -8 */ + if (ia32_cpuid_needed) + SETUP_REGISTER (asm_serialize_cache); /* -7 */ + else + SETUP_REGISTER (asm_dont_serialize_cache); /* -7 */ + +#ifdef _MACH_UNIX + { + vm_address_t addr; + vm_size_t size; + vm_prot_t prot; + vm_prot_t max_prot; + vm_inherit_t inheritance; + boolean_t shared; + port_t object; + vm_offset_t offset; + + addr = ((vm_address_t) Heap); + if ((vm_region ((task_self ()), &addr, &size, &prot, &max_prot, + &inheritance, &shared, &object, &offset)) + != KERN_SUCCESS) + { + outf_fatal ( "compiler_reset: vm_region() failed.\n"); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ + } + if ((prot & VM_PROT_SCHEME) != VM_PROT_SCHEME) + { + if ((max_prot & VM_PROT_SCHEME) != VM_PROT_SCHEME) + { + outf_fatal ( + "compiler_reset: inadequate protection for Heap.\n"); + outf_fatal ( "maximum = 0x%lx; desired = 0x%lx\n", + ((unsigned long) (max_prot & VM_PROT_SCHEME)), + ((unsigned long) VM_PROT_SCHEME)); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ + } + if ((vm_protect ((task_self ()), ((vm_address_t) Heap), + (((char *) constant_end) - ((char *) Heap)), + 0, VM_PROT_SCHEME)) + != KERN_SUCCESS) + { + outf_fatal ("Unable to change protection for Heap.\n"); + outf_fatal ("actual = 0x%lx; desired = 0x%lx\n", + ((unsigned long) (prot & VM_PROT_SCHEME)), + ((unsigned long) VM_PROT_SCHEME)); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ + } + } + } +#endif /* _MACH_UNIX */ +} diff --git a/v7/src/microcode/cmpintmd/i386.h b/v7/src/microcode/cmpintmd/i386.h index 37b7674eb..b1fcb1d76 100644 --- a/v7/src/microcode/cmpintmd/i386.h +++ b/v7/src/microcode/cmpintmd/i386.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: i386.h,v 1.39 2007/01/05 21:19:26 cph Exp $ +$Id: i386.h,v 1.40 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,69 +25,38 @@ USA. */ -/* - * - * Compiled code interface macros. - * - * See cmpint.txt for a description of these fields. - * - * Specialized for the Intel 386 (and successors) architecture. - */ - -#ifndef SCM_CMPINTMD_H -#define SCM_CMPINTMD_H - -#include "cmptype.h" - -/* Until cmpaux-i386.m4 is updated. */ -#define CMPINT_USE_STRUCS - -/* Hack for OS/2 calling-convention type: */ - -#if defined(__OS2__) && (defined(__IBMC__) || defined(__WATCOMC__)) -# define ASM_ENTRY_POINT(name) (_System name) -#else -# if defined(__WIN32__) && defined(__WATCOMC__) -# define ASM_ENTRY_POINT(name) (__cdecl name) -# else -# define ASM_ENTRY_POINT(name) name -# endif -#endif - -extern void EXFUN (ia32_cache_synchronize, (void)); -extern int ia32_cpuid_needed; - -#define IA32_CACHE_SYNCHRONIZE() \ -{ \ - if (ia32_cpuid_needed) \ - ia32_cache_synchronize (); \ -} +/* Compiled code interface macros for Intel IA-32. */ +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 + /* - Problems with i386 ISA (instruction set architecture) +Problems with the IA-32 instruction set architecture +==================================================== -<1> Code space is separate from data space. The only way to obtain a -code space address is to do a CALL and use the return address on the -stack. +1. Code space is separate from data space. The only way to obtain a + code space address is to do a CALL and use the return address on + the stack. Problem: References to the constants vector in compiled code. Fix: Just as on RISC machines. Use CALL when necessary, and cache the -result in the assembly language. + result in the assembly language. -<2> Jumps are PC-relative. There are absolute jumps, assuming the PC -is in a data location, or with immediate destinations that include a -segment descriptor (16 bits). The short forms have a PC-relative -offset defined with respect to the immediately following instruction. +2. Jumps are PC-relative. There are absolute jumps, assuming the PC + is in a data location, or with immediate destinations that include + a segment descriptor (16 bits). The short forms have a PC-relative + offset defined with respect to the immediately following + instruction. Problem: Closures and execute caches need their address in old space -in order to be relocated correctly. + in order to be relocated correctly. -Fix: +Fix: - For execute caches we can define a new linker field, called +For execute caches we can define a new linker field, called load-relocation-address which on every GC/relocation stores the new address and the old contents into global variables and stores the new address in the field. Alternatively the difference between the new @@ -95,21 +64,23 @@ address and the old contents can be stored into a single global variable, and this can be used, together with the new address of each cache, to find the old code. - For closures the code that reads the header (manifest closure) can -do the same. +For closures the code that reads the header (manifest closure) can do +the same. -<3> The stack pointer register (ESP) cannot be used as the base in -(base + displacement) addressing mode. +3. The stack pointer register (ESP) cannot be used as the base in + (base + displacement) addressing mode. Problem: Common operation in the compiler, which assumes direct access -to the stack. + to the stack. Fix: Use base + indexed mode, which allows specification of ESP as -base and nullification of the index (by using ESP again). -This is one byte longer than otherwise, but... - - Register assignments + base and nullification of the index (by using ESP again). This is + one byte longer than otherwise, but... + + +Register assignments +==================== EAX (0) Unassigned ECX (1) Unassigned @@ -132,13 +103,14 @@ The pointer to register block is not held in EBP (the processor's "frame" register is typically used) because its most common use, (EBP) (address syllable for memory memtop) takes more bytes than (ESI). - Encodings and layout of various control features: +Encodings and layout of various control features +================================================ Assumptions: - The processor will be in 32-bit address and operand mode. -Thus instructions use 32-bit operands, and displacements for -addressing modes and jump instructions are all 32-bits by default. +The processor will be in 32-bit address and operand mode. Thus +instructions use 32-bit operands, and displacements for addressing +modes and jump instructions are all 32 bits by default. Offset Contents Encoding @@ -161,7 +133,7 @@ entry 3 JMP opcode 0x39 4 32-bit offset 8 -Arity stays in place because the i386 is a little-endian architecture. +Arity stays in place because the IA-32 is a little-endian architecture. - Closure entry encoding: @@ -211,604 +183,153 @@ magic = ([TC_COMPILED_ENTRY | 0] - (offset + length_of_CALL_instruction)) */ -#define COMPILER_PROCESSOR_TYPE COMPILER_IA32_TYPE - -/* The i387 coprocessor and i486 use 80-bit extended format internally. */ - -#define COMPILER_TEMP_SIZE 3 - -typedef unsigned short format_word; - -/* i386 instructions can be aligned on any byte boundary. */ - -#define PC_ZERO_BITS 0 +#define ASM_RESET_HOOK i386_reset_hook +#define FPE_RESET_TRAPS i386_interface_initialize -/* See the encodings above. */ +#define CMPINT_USE_STRUCS 1 -#define ENTRY_PREFIX_LENGTH 3 +/* These next definitions must agree with "cmpauxmd/i386.m4", which is + where the register block is allocated. */ +#define COMPILER_REGBLOCK_N_FIXED 16 +/* Big enough to hold 80-bit floating-point value: */ +#define COMPILER_TEMP_SIZE 3 +#define COMPILER_REGBLOCK_N_TEMPS 256 +#define COMPILER_REGBLOCK_N_HOOKS 80 +#define COMPILER_HOOK_SIZE 1 -# define COMPILED_CLOSURE_ENTRY_SIZE \ - ((2 * (sizeof (format_word))) + 6) +#define COMPILER_REGBLOCK_EXTRA_SIZE \ + (COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE) -# define ADJUST_CLOSURE_AT_CALL(entry_point, location) \ -do { \ - long magic_constant; \ - \ - magic_constant = (* ((long *) (((char *) (entry_point)) + 3))); \ - (location) = ((SCHEME_OBJECT) \ - ((((long) (OBJECT_ADDRESS (location))) + 5) + \ - magic_constant)); \ -} while (0) - -/* For the relocation of PC-relative JMP and CALL instructions. - This is used during GC/relocation, when the displacement - is incorrect, since it was computed with respect to the - location in old space. - */ +#define REGBLOCK_ALLOCATED_BY_INTERFACE true -extern long i386_pc_displacement_relocation; +typedef byte_t insn_t; -#define EXTRACT_ADDRESS_FROM_DISPLACEMENT(var, instr_addr) do \ -{ \ - long displacement_address, new_displacement; \ - \ - displacement_address = (((long) (instr_addr)) + 1); \ - new_displacement = ((* ((long *) displacement_address)) \ - + i386_pc_displacement_relocation); \ - (* ((long *) displacement_address)) = new_displacement; \ - (var) = ((SCHEME_OBJECT) \ - ((ADDR_TO_SCHEME_ADDR (displacement_address + 4)) \ - + new_displacement)); \ -} while (0) - -#define STORE_DISPLACEMENT_FROM_ADDRESS(target, instr_address) do \ -{ \ - long displacement_address = (((long) (instr_address)) + 1); \ - (* ((long *) displacement_address)) = \ - (((long) (target)) \ - - (ADDR_TO_SCHEME_ADDR (displacement_address + 4))); \ -} while (0) +/* Number of insn_t units preceding entry address in which header + (type and offset info) is stored. */ +#define CC_ENTRY_HEADER_SIZE (CC_ENTRY_TYPE_SIZE + CC_ENTRY_OFFSET_SIZE) +#define CC_ENTRY_TYPE_SIZE 2 +#define CC_ENTRY_OFFSET_SIZE 2 -#define BCH_EXTRACT_ADDRESS_FROM_DISPLACEMENT(var, v_addr, p_addr) do \ -{ \ - long displacement_address, new_displacement; \ - \ - displacement_address = (((long) (p_addr)) + 1); \ - new_displacement = ((* ((long *) displacement_address)) \ - + i386_pc_displacement_relocation); \ - (* ((long *) displacement_address)) = new_displacement; \ - (var) = ((SCHEME_OBJECT) \ - ((ADDR_TO_SCHEME_ADDR (((long) (v_addr)) + 5)) \ - + new_displacement)); \ -} while (0) - -#define BCH_STORE_DISPLACEMENT_FROM_ADDRESS(target, v_addr, p_addr) do \ -{ \ - long displacement_address = (((long) (p_addr)) + 1); \ - (* ((long *) displacement_address)) \ - = (((long) (target)) \ - - (ADDR_TO_SCHEME_ADDR (((long) (v_addr)) + 5))); \ -} while (0) - -#define START_CLOSURE_RELOCATION(scan) do \ -{ \ - SCHEME_OBJECT * _block, * _old; \ - char * _new; \ - \ - _block = ((SCHEME_OBJECT *) (scan)); \ - _old = (OBJECT_ADDRESS (_block[(OBJECT_DATUM (*_block))])); \ - _new = ((char *) (FIRST_MANIFEST_CLOSURE_ENTRY (_block + 1))); \ - \ - i386_pc_displacement_relocation = (((long) _old) - ((long) _new)); \ -} while (0) - -#define END_CLOSURE_RELOCATION(scan) i386_pc_displacement_relocation = 0 -#define EXTRACT_CLOSURE_ENTRY_ADDRESS EXTRACT_ADDRESS_FROM_DISPLACEMENT -#define STORE_CLOSURE_ENTRY_ADDRESS STORE_DISPLACEMENT_FROM_ADDRESS - -#define BCH_START_CLOSURE_RELOCATION(scan) do \ -{ \ - SCHEME_OBJECT * _scan, * _block, _old_obj, * _old; \ - char * _new; \ - \ - _scan = ((SCHEME_OBJECT *) (scan)); \ - _block = ((SCHEME_OBJECT *) \ - (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_scan))); \ - READ_NEWSPACE_ADDRESS (_old_obj, \ - (_block + (OBJECT_DATUM (* _scan)))); \ - _old = (OBJECT_ADDRESS (_old_obj)); \ - _new = ((char *) (FIRST_MANIFEST_CLOSURE_ENTRY (_scan + 1))); \ - \ - i386_pc_displacement_relocation \ - = (((long) _old) \ - - ((long) (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_new)))); \ -} while (0) - -#define BCH_END_CLOSURE_RELOCATION END_CLOSURE_RELOCATION - -#define BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS(var, p_addr) do \ -{ \ - SCHEME_OBJECT * _p_addr, * _v_addr; \ - \ - _p_addr = ((SCHEME_OBJECT *) (p_addr)); \ - _v_addr = ((SCHEME_OBJECT *) \ - (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \ - \ - BCH_EXTRACT_ADDRESS_FROM_DISPLACEMENT (var, _v_addr, _p_addr); \ -} while (0) - -#define BCH_STORE_CLOSURE_ENTRY_ADDRESS(target, p_addr) do \ -{ \ - SCHEME_OBJECT * _p_addr, * _v_addr; \ - \ - _p_addr = ((SCHEME_OBJECT *) (p_addr)); \ - _v_addr = ((SCHEME_OBJECT *) \ - (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \ - \ - BCH_STORE_DISPLACEMENT_FROM_ADDRESS (target, _v_addr, _p_addr); \ -} while (0) +/* Number of insn_t units preceding entry header in which GC trap + instructions are stored. */ +#define CC_ENTRY_GC_TRAP_SIZE 3 -#define EXECUTE_CACHE_ENTRY_SIZE 2 +#define EMBEDDED_CLOSURE_ADDRS_P 1 -#define FIRST_OPERATOR_LINKAGE_OFFSET 2 - -#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \ -{ \ - (target) = ((long) (* ((unsigned short *) (address)))); \ -} while (0) +typedef struct +{ + insn_t * old_addr; + insn_t * new_addr; +} reloc_ref_t; -#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \ -{ \ - (target) = (* (((SCHEME_OBJECT *) (address)) + 1)); \ -} while (0) +#define DECLARE_RELOCATION_REFERENCE(name) reloc_ref_t name -/* This is used during GC/relocation. - The displacement stored in the instruction refers to the old space - location. - */ +#define START_CLOSURE_RELOCATION(scan, ref) \ + start_closure_relocation ((scan), (&ref)) -#define EXTRACT_OPERATOR_LINKAGE_ADDRESS(target, address) do \ +#define START_OPERATOR_RELOCATION(scan, ref) do \ { \ - EXTRACT_ADDRESS_FROM_DISPLACEMENT (target, \ - (((long) (address)) + 3)); \ -} while (0) + start_operator_relocation ((scan), (&ref)); \ + (scan) += 1; \ +} while (false) -/* This is used when not relocating. - The displacement refers to the current location of the instruction. - */ +#define READ_COMPILED_CLOSURE_TARGET(a, r) \ + read_compiled_closure_target ((a), (&r)) -#define EXTRACT_EXECUTE_CACHE_ADDRESS(loc, cache_addr) do \ -{ \ - long displacement_address, displacement; \ - \ - displacement_address = (((long) (cache_addr)) + 4); \ - displacement = (* ((long *) displacement_address)); \ - (loc) = ((SCHEME_OBJECT) \ - ((displacement_address + 4) + displacement)); \ -} while (0) - -#define STORE_EXECUTE_CACHE_ADDRESS(address, entry_address) do \ -{ \ - STORE_DISPLACEMENT_FROM_ADDRESS (entry_address, \ - (((long) (address)) + 3)); \ -} while (0) +/* Size of execution cache in SCHEME_OBJECTS. */ +#define UUO_LINK_SIZE 2 -#define STORE_EXECUTE_CACHE_CODE(address) do \ -{ \ - /* Store a opcode. */ \ - (* (((unsigned char *) (address)) + 3)) = 0xe9; \ -} while (0) +#define UUO_WORDS_TO_COUNT(nw) (((nw) - 1) / UUO_LINK_SIZE) +#define UUO_COUNT_TO_WORDS(nc) (((nc) * UUO_LINK_SIZE) + 1) -#define START_OPERATOR_RELOCATION(scan) do \ -{ \ - SCHEME_OBJECT * _scan, * _old, _loc; \ - \ - _scan = (((SCHEME_OBJECT *) (scan)) + 1); \ - _old = ((SCHEME_OBJECT *) (* _scan)); \ - _loc = (ADDR_TO_SCHEME_ADDR (_scan)); \ - \ - (* _scan) = _loc; \ - i386_pc_displacement_relocation = (((long) _old) - ((long) _loc)); \ -} while (0) - -#define END_OPERATOR_RELOCATION(scan) i386_pc_displacement_relocation = 0 - -#define BCH_START_OPERATOR_RELOCATION(scan) do \ -{ \ - SCHEME_OBJECT * _scan, * _old, _loc; \ - \ - _scan = (((SCHEME_OBJECT *) (scan)) + 1); \ - _old = ((SCHEME_OBJECT *) (* _scan)); \ - _loc = (ADDR_TO_SCHEME_ADDR \ - (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_scan))); \ - \ - * _scan = _loc; \ - i386_pc_displacement_relocation = (((long) _old) - ((long) _loc)); \ -} while (0) - -#define BCH_END_OPERATOR_RELOCATION END_OPERATOR_RELOCATION - -#define BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS(var, p_addr) do \ -{ \ - SCHEME_OBJECT * _p_addr, * _v_addr; \ - \ - _p_addr = ((SCHEME_OBJECT *) (((long) (p_addr)) + 3)); \ - _v_addr = ((SCHEME_OBJECT *) \ - (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \ - \ - BCH_EXTRACT_ADDRESS_FROM_DISPLACEMENT (var, _v_addr, _p_addr); \ -} while (0) - -#define BCH_STORE_OPERATOR_LINKAGE_ADDRESS(e_addr, p_addr) do \ -{ \ - SCHEME_OBJECT * _p_addr, * _v_addr; \ - \ - _p_addr = ((SCHEME_OBJECT *) (((long) (p_addr)) + 3)); \ - _v_addr = ((SCHEME_OBJECT *) \ - (SCAN_POINTER_TO_NEWSPACE_ADDRESS (_p_addr))); \ - \ - BCH_STORE_DISPLACEMENT_FROM_ADDRESS (e_addr, _v_addr, _p_addr); \ -} while (0) - -#define TRAMPOLINE_ENTRY_SIZE 3 -#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* MNV to MOV instr. */ - -#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \ -{ \ - unsigned char *PC = ((unsigned char *) (entry_address)); \ - \ - *PC++ = 0xb0; /* MOV AL,byte */ \ - *PC++ = ((unsigned char) (index)); /* byte value */ \ - *PC++ = 0xff; /* CALL */ \ - *PC++ = 0x96; /* /2 disp32(ESI) */ \ - (* ((unsigned long *) PC)) = ESI_TRAMPOLINE_TO_INTERFACE_OFFSET; \ - IA32_CACHE_SYNCHRONIZE (); \ -} while (0) - -#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ - (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) - -#define TRAMPOLINE_STORAGE(tramp_entry) \ - ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) - -#define FLUSH_I_CACHE() do \ -{ \ - IA32_CACHE_SYNCHRONIZE (); \ -} while (0) +#define READ_UUO_TARGET(a, r) read_uuo_target ((a), (&r)) -#define FLUSH_I_CACHE_REGION(address, nwords) do \ -{ \ - IA32_CACHE_SYNCHRONIZE (); \ -} while (0) +#define FLUSH_I_CACHE() IA32_CACHE_SYNCHRONIZE () +#define FLUSH_I_CACHE_REGION(address, nwords) IA32_CACHE_SYNCHRONIZE () +#define PUSH_D_CACHE_REGION(address, nwords) IA32_CACHE_SYNCHRONIZE () -#define PUSH_D_CACHE_REGION(address, nwords) do \ +#define IA32_CACHE_SYNCHRONIZE() do \ { \ - IA32_CACHE_SYNCHRONIZE (); \ -} while (0) - + if (ia32_cpuid_needed) \ + ia32_cache_synchronize (); \ +} while (false) -/* These must aggree with cmpaux-i386.m4! - The register block is actually allocated there. - */ - -#define COMPILER_REGBLOCK_N_FIXED 16 - -#define COMPILER_REGBLOCK_N_HOOKS 80 - - /* A hook is the address (offset) of an assembly-language routine. */ - -#define COMPILER_HOOK_SIZE 1 - -#define COMPILER_REGBLOCK_EXTRA_SIZE \ - (COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE) - -#define REGBLOCK_ALLOCATED_BY_INTERFACE - -#define ESI_TRAMPOLINE_TO_INTERFACE_OFFSET \ - ((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) * \ - (sizeof (SCHEME_OBJECT))) - -#ifdef IN_CMPINT_C - -#ifdef _MACH_UNIX -# include -# define VM_PROT_SCHEME (VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE) -#endif - -long i386_pc_displacement_relocation = 0; - -#define ASM_RESET_HOOK i386_reset_hook - -#ifndef HOOK_TO_SCHEME_OFFSET -# define HOOK_TO_SCHEME_OFFSET(hook) ((unsigned long) (hook)) -#endif - -#ifdef HAVE_STDC -# define STRINGIFY(x) #x +#if defined(__OS2__) && (defined(__IBMC__) || defined(__WATCOMC__)) +# define ASM_ENTRY_POINT(name) (_System name) +#elif defined(__WIN32__) && defined(__WATCOMC__) +# define ASM_ENTRY_POINT(name) (__cdecl name) #else -# define STRINGIFY(x) "x" -#endif - -#define SETUP_REGISTER(hook) do \ -{ \ - extern void hook (); \ - \ - (* ((unsigned long *) (esi_value + offset))) = \ - (HOOK_TO_SCHEME_OFFSET (hook)); \ - offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \ - declare_builtin (((unsigned long) hook), (STRINGIFY (hook))); \ -} while (0) - -void -DEFUN_VOID (i386_reset_hook) -{ - extern int EXFUN (ASM_ENTRY_POINT(i386_interface_initialize), (void)); - extern void EXFUN (declare_builtin, (unsigned long, char *)); - int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT))); - unsigned char * esi_value = ((unsigned char *) (&Registers[0])); - int fp_support_present = (i386_interface_initialize ()); - - /* These must match machines/i386/lapgen.scm */ - - SETUP_REGISTER (asm_scheme_to_interface); /* 0 */ - SETUP_REGISTER (asm_scheme_to_interface_call); /* 1 */ - - if (offset != ESI_TRAMPOLINE_TO_INTERFACE_OFFSET) - { - outf_fatal ("\ni386_reset_hook: ESI_TRAMPOLINE_TO_INTERFACE_OFFSET\n"); - Microcode_Termination (TERM_EXIT); - } - SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */ - - SETUP_REGISTER (asm_interrupt_procedure); /* 3 */ - SETUP_REGISTER (asm_interrupt_continuation); /* 4 */ - SETUP_REGISTER (asm_interrupt_closure); /* 5 */ - SETUP_REGISTER (asm_interrupt_dlink); /* 6 */ - - SETUP_REGISTER (asm_primitive_apply); /* 7 */ - SETUP_REGISTER (asm_primitive_lexpr_apply); /* 8 */ - SETUP_REGISTER (asm_assignment_trap); /* 9 */ - SETUP_REGISTER (asm_reference_trap); /* 10 */ - SETUP_REGISTER (asm_safe_reference_trap); /* 11 */ - SETUP_REGISTER (asm_link); /* 12 */ - SETUP_REGISTER (asm_error); /* 13 */ - SETUP_REGISTER (asm_primitive_error); /* 14 */ - SETUP_REGISTER (asm_short_primitive_apply); /* 15 */ - - /* No more room for positive offsets without going to 32-bit - offsets! - */ - - /* This is a hack to make all the hooks be addressable - with byte offsets (instead of longword offsets). - The register block extends to negative offsets as well, - so all the following hooks are accessed with negative - offsets, and all fit in a byte. - */ - - offset = -128; - - if (fp_support_present != 0) - { - SETUP_REGISTER (asm_generic_add); /* -32 */ - SETUP_REGISTER (asm_generic_subtract); /* -31 */ - SETUP_REGISTER (asm_generic_multiply); /* -30 */ - SETUP_REGISTER (asm_generic_divide); /* -29 */ - SETUP_REGISTER (asm_generic_equal); /* -28 */ - SETUP_REGISTER (asm_generic_less); /* -27 */ - SETUP_REGISTER (asm_generic_greater); /* -26 */ - SETUP_REGISTER (asm_generic_increment); /* -25 */ - SETUP_REGISTER (asm_generic_decrement); /* -24 */ - SETUP_REGISTER (asm_generic_zero); /* -23 */ - SETUP_REGISTER (asm_generic_positive); /* -22 */ - SETUP_REGISTER (asm_generic_negative); /* -21 */ - SETUP_REGISTER (asm_generic_quotient); /* -20 */ - SETUP_REGISTER (asm_generic_remainder); /* -19 */ - SETUP_REGISTER (asm_generic_modulo); /* -18 */ - } - else - { - SETUP_REGISTER (asm_nofp_add); /* -32 */ - SETUP_REGISTER (asm_nofp_subtract); /* -31 */ - SETUP_REGISTER (asm_nofp_multiply); /* -30 */ - SETUP_REGISTER (asm_nofp_divide); /* -29 */ - SETUP_REGISTER (asm_nofp_equal); /* -28 */ - SETUP_REGISTER (asm_nofp_less); /* -27 */ - SETUP_REGISTER (asm_nofp_greater); /* -26 */ - SETUP_REGISTER (asm_nofp_increment); /* -25 */ - SETUP_REGISTER (asm_nofp_decrement); /* -24 */ - SETUP_REGISTER (asm_nofp_zero); /* -23 */ - SETUP_REGISTER (asm_nofp_positive); /* -22 */ - SETUP_REGISTER (asm_nofp_negative); /* -21 */ - SETUP_REGISTER (asm_nofp_quotient); /* -20 */ - SETUP_REGISTER (asm_nofp_remainder); /* -19 */ - SETUP_REGISTER (asm_nofp_modulo); /* -18 */ - } - - SETUP_REGISTER (asm_sc_apply); /* -17 */ - SETUP_REGISTER (asm_sc_apply_size_1); /* -16 */ - SETUP_REGISTER (asm_sc_apply_size_2); /* -15 */ - SETUP_REGISTER (asm_sc_apply_size_3); /* -14 */ - SETUP_REGISTER (asm_sc_apply_size_4); /* -13 */ - SETUP_REGISTER (asm_sc_apply_size_5); /* -12 */ - SETUP_REGISTER (asm_sc_apply_size_6); /* -11 */ - SETUP_REGISTER (asm_sc_apply_size_7); /* -10 */ - SETUP_REGISTER (asm_sc_apply_size_8); /* -9 */ - SETUP_REGISTER (asm_interrupt_continuation_2); /* -8 */ - if (ia32_cpuid_needed) - { - SETUP_REGISTER (asm_serialize_cache); /* -7 */ - } - else - { - SETUP_REGISTER (asm_dont_serialize_cache); /* -7 */ - } - -#ifdef _MACH_UNIX - { - vm_address_t addr; - vm_size_t size; - vm_prot_t prot; - vm_prot_t max_prot; - vm_inherit_t inheritance; - boolean_t shared; - port_t object; - vm_offset_t offset; - - addr = ((vm_address_t) Heap); - if ((vm_region ((task_self ()), &addr, &size, &prot, &max_prot, - &inheritance, &shared, &object, &offset)) - != KERN_SUCCESS) - { - outf_fatal ( "compiler_reset: vm_region() failed.\n"); - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - } - if ((prot & VM_PROT_SCHEME) != VM_PROT_SCHEME) - { - if ((max_prot & VM_PROT_SCHEME) != VM_PROT_SCHEME) - { - outf_fatal ( - "compiler_reset: inadequate protection for Heap.\n"); - outf_fatal ( "maximum = 0x%lx; desired = 0x%lx\n", - ((unsigned long) (max_prot & VM_PROT_SCHEME)), - ((unsigned long) VM_PROT_SCHEME)); - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - } - if ((vm_protect ((task_self ()), ((vm_address_t) Heap), - (((char *) Constant_Top) - ((char *) Heap)), - 0, VM_PROT_SCHEME)) - != KERN_SUCCESS) - { - outf_fatal ( - "compiler_reset: unable to change protection for Heap.\n"); - outf_fatal ( "actual = 0x%lx; desired = 0x%lx\n", - ((unsigned long) (prot & VM_PROT_SCHEME)), - ((unsigned long) VM_PROT_SCHEME)); - Microcode_Termination (TERM_EXIT); - /*NOTREACHED*/ - } - } - } -#endif /* _MACH_UNIX */ -} - -#endif /* IN_CMPINT_C */ - -/* Derived parameters and macros. - These macros expect the above definitions to be meaningful. - If they are not, the macros below may have to be changed as well. - */ - -#define COMPILED_ENTRY_OFFSET_WORD(entry) \ - (((format_word *) (entry))[-1]) -#define COMPILED_ENTRY_FORMAT_WORD(entry) \ - (((format_word *) (entry))[-2]) - -/* The next one assumes 2's complement integers....*/ -#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) -#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) - -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif - -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif - -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) +# define ASM_ENTRY_POINT(name) name #endif -#define MAKE_OFFSET_WORD(entry, block, continue) \ - ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ - ((char *) (block)))) | \ - ((continue) ? 1 : 0)) - -#if (EXECUTE_CACHE_ENTRY_SIZE == 2) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 1) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 1) -#endif - -#if (EXECUTE_CACHE_ENTRY_SIZE == 4) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 2) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 2) -#endif - -#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) / EXECUTE_CACHE_ENTRY_SIZE) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) * EXECUTE_CACHE_ENTRY_SIZE) -#endif - -/* The first entry in a cc block is preceeded by 2 headers (block and nmv), - a format word and a gc offset word. See the early part of the - TRAMPOLINE picture, above. - */ +extern int ASM_ENTRY_POINT (i386_interface_initialize) (void); + +extern void ASM_ENTRY_POINT (asm_assignment_trap) (void); +extern void ASM_ENTRY_POINT (asm_dont_serialize_cache) (void); +extern void ASM_ENTRY_POINT (asm_error) (void); +extern void ASM_ENTRY_POINT (asm_generic_add) (void); +extern void ASM_ENTRY_POINT (asm_generic_decrement) (void); +extern void ASM_ENTRY_POINT (asm_generic_divide) (void); +extern void ASM_ENTRY_POINT (asm_generic_equal) (void); +extern void ASM_ENTRY_POINT (asm_generic_greater) (void); +extern void ASM_ENTRY_POINT (asm_generic_increment) (void); +extern void ASM_ENTRY_POINT (asm_generic_less) (void); +extern void ASM_ENTRY_POINT (asm_generic_modulo) (void); +extern void ASM_ENTRY_POINT (asm_generic_multiply) (void); +extern void ASM_ENTRY_POINT (asm_generic_negative) (void); +extern void ASM_ENTRY_POINT (asm_generic_positive) (void); +extern void ASM_ENTRY_POINT (asm_generic_quotient) (void); +extern void ASM_ENTRY_POINT (asm_generic_remainder) (void); +extern void ASM_ENTRY_POINT (asm_generic_subtract) (void); +extern void ASM_ENTRY_POINT (asm_generic_zero) (void); +extern void ASM_ENTRY_POINT (asm_interrupt_closure) (void); +extern void ASM_ENTRY_POINT (asm_interrupt_continuation) (void); +extern void ASM_ENTRY_POINT (asm_interrupt_continuation_2) (void); +extern void ASM_ENTRY_POINT (asm_interrupt_dlink) (void); +extern void ASM_ENTRY_POINT (asm_interrupt_procedure) (void); +extern void ASM_ENTRY_POINT (asm_link) (void); +extern void ASM_ENTRY_POINT (asm_nofp_add) (void); +extern void ASM_ENTRY_POINT (asm_nofp_decrement) (void); +extern void ASM_ENTRY_POINT (asm_nofp_divide) (void); +extern void ASM_ENTRY_POINT (asm_nofp_equal) (void); +extern void ASM_ENTRY_POINT (asm_nofp_greater) (void); +extern void ASM_ENTRY_POINT (asm_nofp_increment) (void); +extern void ASM_ENTRY_POINT (asm_nofp_less) (void); +extern void ASM_ENTRY_POINT (asm_nofp_modulo) (void); +extern void ASM_ENTRY_POINT (asm_nofp_multiply) (void); +extern void ASM_ENTRY_POINT (asm_nofp_negative) (void); +extern void ASM_ENTRY_POINT (asm_nofp_positive) (void); +extern void ASM_ENTRY_POINT (asm_nofp_quotient) (void); +extern void ASM_ENTRY_POINT (asm_nofp_remainder) (void); +extern void ASM_ENTRY_POINT (asm_nofp_subtract) (void); +extern void ASM_ENTRY_POINT (asm_nofp_zero) (void); +extern void ASM_ENTRY_POINT (asm_primitive_apply) (void); +extern void ASM_ENTRY_POINT (asm_primitive_error) (void); +extern void ASM_ENTRY_POINT (asm_primitive_lexpr_apply) (void); +extern void ASM_ENTRY_POINT (asm_reference_trap) (void); +extern void ASM_ENTRY_POINT (asm_safe_reference_trap) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_1) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_2) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_3) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_4) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_5) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_6) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_7) (void); +extern void ASM_ENTRY_POINT (asm_sc_apply_size_8) (void); +extern void ASM_ENTRY_POINT (asm_scheme_to_interface) (void); +extern void ASM_ENTRY_POINT (asm_scheme_to_interface_call) (void); +extern void ASM_ENTRY_POINT (asm_serialize_cache) (void); +extern void ASM_ENTRY_POINT (asm_short_primitive_apply) (void); +extern void ASM_ENTRY_POINT (asm_trampoline_to_interface) (void); + +extern void ia32_cache_synchronize (void); +extern void start_closure_relocation (SCHEME_OBJECT *, reloc_ref_t *); +extern insn_t * read_compiled_closure_target (insn_t *, reloc_ref_t *); +extern void start_operator_relocation (SCHEME_OBJECT *, reloc_ref_t *); +extern insn_t * read_uuo_target (SCHEME_OBJECT *, reloc_ref_t *); +extern void i386_reset_hook (void); -#define CC_BLOCK_FIRST_ENTRY_OFFSET \ - (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) - -/* Format words */ - -#define FORMAT_BYTE_EXPR 0xFF -#define FORMAT_BYTE_COMPLR 0xFE -#define FORMAT_BYTE_CMPINT 0xFD -#define FORMAT_BYTE_DLINK 0xFC -#define FORMAT_BYTE_RETURN 0xFB - -#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR)) -#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT)) -#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN)) - -/* This assumes that a format word is at least 16 bits, - and the low order field is always 8 bits. - */ - -#define MAKE_FORMAT_WORD(field1, field2) \ - (((field1) << 8) | ((field2) & 0xff)) - -#define SIGN_EXTEND_FIELD(field, size) \ - (((field) & ((1 << (size)) - 1)) | \ - ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ - ((-1) << (size)))) - -#define FORMAT_WORD_LOW_BYTE(word) \ - (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8)) - -#define FORMAT_WORD_HIGH_BYTE(word) \ - (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \ - (((sizeof (format_word)) * CHAR_BIT) - 8))) - -#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ - (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) - -#define COMPILED_ENTRY_FORMAT_LOW(addr) \ - (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) - -#define FORMAT_BYTE_FRAMEMAX 0x7f - -#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW -#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH +extern int ia32_cpuid_needed; -#endif /* not SCM_CMPINTMD_H */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/mc68k.h b/v7/src/microcode/cmpintmd/mc68k.h index 89de71be2..3ddd54b97 100644 --- a/v7/src/microcode/cmpintmd/mc68k.h +++ b/v7/src/microcode/cmpintmd/mc68k.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: mc68k.h,v 1.40 2007/01/05 21:19:26 cph Exp $ +$Id: mc68k.h,v 1.41 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -34,10 +34,8 @@ USA. * Specialized for the Motorola 68K family. */ -#ifndef CMPINTMD_H_INCLUDED -#define CMPINTMD_H_INCLUDED - -#include "cmptype.h" +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 /* Machine parameters to be set by the user. */ @@ -64,13 +62,6 @@ USA. typedef unsigned short format_word; -/* PC alignment constraint. - Change PC_ZERO_BITS to be how many low order bits of the pc are - guaranteed to be 0 always because of PC alignment constraints. -*/ - -#define PC_ZERO_BITS 1 - /* The length of the GC recovery code that precedes an entry. On the 68K a "jsr n(a6)" instruction. */ @@ -81,7 +72,7 @@ typedef unsigned short format_word; #ifdef _NEXTOS -extern void EXFUN (NeXT_cacheflush, (void)); +extern void NeXT_cacheflush (void); # ifdef IN_CMPINT_C @@ -92,7 +83,7 @@ extern void EXFUN (NeXT_cacheflush, (void)); */ void -DEFUN_VOID (NeXT_cacheflush) +NeXT_cacheflush (void) { asm ("trap #2"); return; @@ -122,7 +113,7 @@ DEFUN_VOID (NeXT_cacheflush) # ifdef SWITZERLAND -extern void EXFUN (swiss_cachectl, (int, void *, unsigned long)); +extern void swiss_cachectl (int, void *, unsigned long); # define FLUSH_CACHE_INITIALIZE() swiss_cachectl_init_p = 0 @@ -133,20 +124,19 @@ static int swiss_cachectl_flush_p = 0; void -DEFUN (swiss_cachectl, - (mode, base, count), - int mode AND PTR base AND unsigned long count) +swiss_cachectl (int mode, void * base, unsigned long count) { if (swiss_cachectl_init_p == 0) { int length; char *string, *posn; - extern char * EXFUN (strstr, (char *, char *)); - extern int EXFUN (getcontext, (char *, int)); + extern char * strstr (char *, char *); + extern int getcontext (char *, int); string = ((char *) Free); length = (getcontext (string, - ((MemTop - Free) * (sizeof (SCHEME_OBJECT))))); + ((heap_alloc_limit - Free) + * (sizeof (SCHEME_OBJECT))))); swiss_cachectl_flush_p = (((strstr (string, "HP-MC68040")) == ((char *) NULL)) ? 0 : 1); swiss_cachectl_init_p = 1; @@ -164,7 +154,7 @@ DEFUN (swiss_cachectl, # endif /* SWITZERLAND */ extern void - EXFUN (operate_on_cache_region, (int, char *, unsigned long)); + operate_on_cache_region (int, char *, unsigned long); # define SPLIT_CACHES @@ -186,21 +176,19 @@ do \ ((char *) \ (((unsigned long *) base) + (len - 1))), \ 1); \ -} while (0) +} while (0) # ifdef IN_CMPINT_C -void -DEFUN (operate_on_cache_region, - (cachecmd, bptr, nwords), - int cachecmd AND char * bptr AND unsigned long nwords) +void +operate_on_cache_region (int cachecmd, char * bptr, unsigned long nwords) { char * eptr; unsigned long nbytes, quantum; if (nwords == 0) return; - + nbytes = (nwords * (sizeof (long))); eptr = (bptr + (nbytes - 1)); quantum = ((nbytes <= 0x40) ? 0x10 : 0x1000); @@ -215,16 +203,16 @@ DEFUN (operate_on_cache_region, # endif /* IN_CMPINT_C */ # else /* S2DATA_WT */ -# define FLUSH_I_CACHE() NOP() +# define FLUSH_I_CACHE() do {} while (0) # endif /* S2DATA_WT */ #endif /* __hpux */ #ifndef FLUSH_CACHE_INITIALIZE -# define FLUSH_CACHE_INITIALIZE() NOP() +# define FLUSH_CACHE_INITIALIZE() do {} while (0) #endif /* FLUSH_CACHE_INITIALIZE */ #ifndef FLUSH_I_CACHE_REGION -# define FLUSH_I_CACHE_REGION(addr, nwords) NOP() +# define FLUSH_I_CACHE_REGION(addr, nwords) do {} while (0) #endif /* not FLUSH_I_CACHE_REGION */ #ifndef PUSH_D_CACHE_REGION @@ -259,12 +247,12 @@ do { \ magic_constant)); \ } while (0) -/* Manifest closure entry block size. +/* Manifest closure entry block size. Size in bytes of a compiled closure's header excluding the TC_MANIFEST_CLOSURE header. On the 68k, this is the format word and gc offset word and 6 bytes - more for the jsr instruction. + more for the jsr instruction. */ # define COMPILED_CLOSURE_ENTRY_SIZE \ @@ -302,9 +290,9 @@ do { \ /* On the MC68040, closure entry points are aligned, so this is a NOP. */ -# define ADJUST_CLOSURE_AT_CALL(entry_point, location) NOP() +# define ADJUST_CLOSURE_AT_CALL(entry_point, location) do {} while (0) -/* Manifest closure entry block size. +/* Manifest closure entry block size. Size in bytes of a compiled closure's header excluding the TC_MANIFEST_CLOSURE header. @@ -455,6 +443,7 @@ do { \ "cmpint.c". */ #define COMPILER_REGBLOCK_N_FIXED 16 +#define COMPILER_REGBLOCK_N_TEMPS 256 #define COMPILER_REGBLOCK_START_HOOKS COMPILER_REGBLOCK_N_FIXED #define COMPILER_REGBLOCK_N_HOOKS 80 @@ -491,7 +480,7 @@ do { \ #define SETUP_REGISTER(hook) do \ { \ - extern void EXFUN (hook, (void)); \ + extern void hook, (void); \ (* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \ (* ((unsigned long *) \ (((unsigned short *) (a6_value + offset)) + 1))) = \ @@ -502,9 +491,9 @@ do { \ #endif void -DEFUN_VOID (mc68k_reset_hook) +mc68k_reset_hook (void) { - extern void EXFUN (interface_initialize, (void)); + extern void interface_initialize (void); unsigned char * a6_value = ((unsigned char *) (&Registers[0])); int offset = (COMPILER_REGBLOCK_START_HOOKS * (sizeof (SCHEME_OBJECT))); @@ -600,7 +589,7 @@ static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS); static long last_chunk_size; SCHEME_OBJECT * -DEFUN (allocate_closure, (size), long size) +allocate_closure (long size) { long space; SCHEME_OBJECT *result; @@ -612,8 +601,8 @@ DEFUN (allocate_closure, (size), long size) #else /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */ - space = ((long) (Registers[REGBLOCK_CLOSURE_SPACE])); - result = ((SCHEME_OBJECT *) (Registers[REGBLOCK_CLOSURE_FREE])); + space = ((long) GET_CLOSURE_SPACE); + result = GET_CLOSURE_FREE; if (size > space) { @@ -639,16 +628,16 @@ DEFUN (allocate_closure, (size), long size) */ } - if ((size <= closure_chunk) && (!(GC_Check (closure_chunk)))) + if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk))) { start = Free; eptr = (start + closure_chunk); } else { - if (GC_Check (size)) + if (GC_NEEDED_P (size)) { - if ((Heap_Top - Free) < size) + if ((heap_end - Free) < size) { /* No way to back out -- die. */ @@ -656,11 +645,11 @@ DEFUN (allocate_closure, (size), long size) Microcode_Termination (TERM_NO_SPACE); /* NOTREACHED */ } - Request_GC (0); + REQUEST_GC (0); } else if (size <= closure_chunk) { - Request_GC (0); + REQUEST_GC (0); } start = Free; eptr = (start + size); @@ -683,8 +672,8 @@ DEFUN (allocate_closure, (size), long size) PUSH_D_CACHE_REGION (start, space); } - Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (result + size)); - Registers[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) (space - size)); + SET_CLOSURE_FREE (result + size); + SET_CLOSURE_SPACE (space - size); return (result); #endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */ @@ -764,29 +753,9 @@ DEFUN (allocate_closure, (size), long size) #define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) #define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif - -#if (PC_ZERO_BITS == 1) /* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif - -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) +#define OFFSET_WORD_TO_BYTE_OFFSET(word) (CLEAR_LOW_BIT (word)) #define MAKE_OFFSET_WORD(entry, block, continue) \ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ @@ -864,4 +833,4 @@ DEFUN (allocate_closure, (size), long size) #define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW #define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH -#endif /* CMPINTMD_H_INCLUDED */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/mips.h b/v7/src/microcode/cmpintmd/mips.h index 4d3f9e35d..3817f717d 100644 --- a/v7/src/microcode/cmpintmd/mips.h +++ b/v7/src/microcode/cmpintmd/mips.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: mips.h,v 1.27 2007/01/05 21:19:26 cph Exp $ +$Id: mips.h,v 1.28 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -34,10 +34,8 @@ USA. * Specialized for the MIPS R2000/R3000 */ -#ifndef CMPINTMD_H_INCLUDED -#define CMPINTMD_H_INCLUDED - -#include "cmptype.h" +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 #ifdef _IRIX @@ -98,7 +96,7 @@ extern void syscall(); /* Processor type. Choose a number from the above list, or allocate your own. */ -#define COMPILER_PROCESSOR_TYPE COMPILER_MIPS_TYPE +#define COMPILER_PROCESSOR_TYPE COMPILER_MIPS_TYPE /* Size (in long words) of the contents of a floating point register if different from a double. For example, an MC68881 saves registers @@ -107,19 +105,14 @@ extern void syscall(); define COMPILER_TEMP_SIZE 3 */ +#define COMPILER_REGBLOCK_N_TEMPS 256 + /* Descriptor size. This is the size of the offset field, and of the format field. This definition probably does not need to be changed. */ typedef unsigned short format_word; - -/* PC alignment constraint. - Change PC_ZERO_BITS to be how many low order bits of the pc are - guaranteed to be 0 always because of PC alignment constraints. -*/ - -#define PC_ZERO_BITS 2 /* Utilities for manipulating absolute subroutine calls. On the MIPS this is done with: @@ -199,7 +192,7 @@ typedef unsigned short format_word; SLT $at,$FREE,$MEMTOP BEQ $at,$0,interrupt LW $MEMTOP,REG_BLOCK - + For a closure LUI $at,FROB(TC_CLOSURE) ; temp <- closure tag @@ -225,7 +218,7 @@ do { \ On the MIPS this is 2 format_words for the format word and gc offset words, and 8 more bytes for 2 instructions. - + The two instructions are JAL destination @@ -236,7 +229,7 @@ do { \ not always work, thus closures are allocated from a pre-initialized pool where the entries have been initialized to contain the following instructions. - + JALR LINKAGE,CLOSURE_HOOK ADDI LINKAGE,LINKAGE,-8 @@ -320,7 +313,7 @@ do { \ #define TRAMPOLINE_STORAGE(tramp_entry) \ ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) + (2 + TRAMPOLINE_ENTRY_SIZE)) #define SPECIAL_OPCODE 000 #define ADDI_OPCODE 010 @@ -361,7 +354,7 @@ do { \ arguments in the lower 16 bits. */ -#define EXECUTE_CACHE_ENTRY_SIZE 2 +#define EXECUTE_CACHE_ENTRY_SIZE 2 /* Execute cache destructuring. */ @@ -467,15 +460,15 @@ do { \ #define FLUSH_I_CACHE() do \ { \ - FLUSH_BOTH (Constant_Space, \ - (((unsigned long) Heap_Top) \ - - ((unsigned long) Constant_Space))); \ + FLUSH_BOTH (constant_start, \ + (((unsigned long) heap_end) \ + - ((unsigned long) constant_start))); \ } while (0) /* This flushes a region of the I-cache. It is used after updating an execute cache while running. Not needed during GC because FLUSH_I_CACHE will be used. - */ + */ #define FLUSH_I_CACHE_REGION(address, nwords) do \ { \ @@ -502,9 +495,9 @@ do { \ { \ unsigned long _addr = ((unsigned long) (address)); \ unsigned long _nbytes = ((sizeof (long)) * (nwords)); \ - cacheflush (((PTR) _addr), _nbytes, DCACHE); \ - cacheflush (((PTR) _addr), 1, ICACHE); \ - cacheflush (((PTR) (_addr + (_nbytes - 1))), 1, ICACHE); \ + cacheflush (((void *) _addr), _nbytes, DCACHE); \ + cacheflush (((void *) _addr), 1, ICACHE); \ + cacheflush (((void *) (_addr + (_nbytes - 1))), 1, ICACHE); \ } while (0) #endif /* not USE_MPROTECT_CACHE_FLUSH */ @@ -512,9 +505,9 @@ do { \ #ifdef IN_CMPINT_C static void -DEFUN_VOID (interface_initialize_C) +interface_initialize_C (void) { - extern void EXFUN (interface_initialize, (void)); + extern void interface_initialize (void); /* Prevent the OS from "fixing" unaligned accesses. Within Scheme, they are a BUG, and should fault. @@ -539,7 +532,7 @@ static void * mprotect_start; static unsigned long mprotect_size; static void -DEFUN (call_mprotect_1, (start, size), void * start AND unsigned long size) +call_mprotect_1 (void * start, unsigned long size) { if ((mprotect (start, size, VM_PROT_SCHEME)) != 0) { @@ -553,7 +546,7 @@ DEFUN (call_mprotect_1, (start, size), void * start AND unsigned long size) #ifdef USE_MPROTECT_CACHE_FLUSH void -DEFUN (call_mprotect, (start, size), void * start AND unsigned long size) +call_mprotect (void * start, unsigned long size) { unsigned long pagesize = (getpagesize ()); unsigned long istart = ((unsigned long) start); @@ -563,7 +556,7 @@ DEFUN (call_mprotect, (start, size), void * start AND unsigned long size) #endif /* USE_MPROTECT_CACHE_FLUSH */ void * -DEFUN (irix_heap_malloc, (size), long size) +irix_heap_malloc (long size) { int pagesize = (getpagesize ()); void * area = (malloc (size + pagesize)); @@ -586,17 +579,15 @@ DEFUN (irix_heap_malloc, (size), long size) static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS); -#define REGBLOCK_CLOSURE_LIMIT REGBLOCK_CLOSURE_SPACE - /* The apparently random instances of the number 3 below arise from the convention that free_closure always points to a JAL instruction with (at least) 3 unused words preceding it. In this way, if there is enough space, we can use free_closure as the address of a new uni- or multi-closure. - + The code below (in the initialization loop) depends on knowing that CLOSURE_ENTRY_WORDS is 3. - + Random hack: ADDI instructions look like TC_TRUE objects, thus of the pre-initialized words, only the JALR looks like a pointer object (an SCODE-QUOTE). Since there is exactly one JALR of waste between @@ -608,13 +599,13 @@ static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS); /* size in Scheme objects of the block we need to allocate. */ void -DEFUN (allocate_closure, (size), long size) +allocate_closure (long size) { long space; SCHEME_OBJECT * free_closure, * limit; - free_closure = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_FREE]); - limit = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_LIMIT]); + free_closure = GET_CLOSURE_FREE; + limit = GET_CLOSURE_SPACE; space = ((limit - free_closure) + 3); /* Bump up to a multiple of CLOSURE_ENTRY_WORDS. @@ -632,28 +623,28 @@ DEFUN (allocate_closure, (size), long size) /* Make the heap be parseable forward by protecting the waste in the last chunk. */ - + if ((space > 0) && (free_closure != ((SCHEME_OBJECT *) NULL))) free_closure[-3] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (space - 1))); free_closure = Free; - if ((size <= closure_chunk) && (!(GC_Check (closure_chunk)))) + if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk))) limit = (free_closure + closure_chunk); else { - if (GC_Check (size)) + if (GC_NEEDED_P (size)) { - if ((Heap_Top - Free) < size) + if ((heap_end - Free) < size) { /* No way to back out -- die. */ fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size); Microcode_Termination (TERM_NO_SPACE); /* NOTREACHED */ } - Request_GC (0); + REQUEST_GC (0); } else if (size <= closure_chunk) - Request_GC (0); + REQUEST_GC (0); limit = (free_closure + size); } Free = limit; @@ -667,10 +658,9 @@ DEFUN (allocate_closure, (size), long size) *ptr++ = SHARP_F; } PUSH_D_CACHE_REGION (free_closure, chunk_size); - Registers[REGBLOCK_CLOSURE_LIMIT] = ((SCHEME_OBJECT) limit); - Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (free_closure + 3)); + SET_CLOSURE_SPACE (limit); + SET_CLOSURE_FREE (free_closure + 3); } - return; } #endif /* IN_CMPINT_C */ @@ -688,55 +678,18 @@ DEFUN (allocate_closure, (size), long size) #define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) #define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif - -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif - -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1) #define MAKE_OFFSET_WORD(entry, block, continue) \ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ ((char *) (block)))) | \ ((continue) ? 1 : 0)) -#if (EXECUTE_CACHE_ENTRY_SIZE == 2) #define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ ((count) >> 1) #define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ ((entries) << 1) -#endif - -#if (EXECUTE_CACHE_ENTRY_SIZE == 4) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 2) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 2) -#endif - -#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) / EXECUTE_CACHE_ENTRY_SIZE) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) * EXECUTE_CACHE_ENTRY_SIZE) -#endif /* The first entry in a cc block is preceeded by 2 headers (block and nmv), a format word and a gc offset word. See the early part of the @@ -789,4 +742,4 @@ DEFUN (allocate_closure, (size), long size) #define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW #define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH -#endif /* CMPINTMD_H_INCLUDED */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/starbasx.c b/v7/src/microcode/cmpintmd/none-config.h similarity index 58% rename from v7/src/microcode/starbasx.c rename to v7/src/microcode/cmpintmd/none-config.h index 9b085a930..46685995f 100644 --- a/v7/src/microcode/starbasx.c +++ b/v7/src/microcode/cmpintmd/none-config.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: starbasx.c,v 1.10 2007/01/05 21:19:25 cph Exp $ +$Id: none-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,25 +25,10 @@ USA. */ -/* Starbase/X11 interface */ - -#include "scheme.h" -#include "prims.h" -#include "x11.h" -#include - -DEFINE_PRIMITIVE ("X11-WINDOW-STARBASE-FILENAME", Prim_x11_window_starbase_filename, 1, 1, - "Given a window, returns the name of a file which can be opened\n\ -as a Starbase graphics device.") -{ - PRIMITIVE_HEADER (1); - { - struct xwindow * xw = (x_window_arg (1)); - char * starbase_filename = - (make_X11_gopen_string ((XW_DISPLAY (xw)), (XW_WINDOW (xw)))); - PRIMITIVE_RETURN - ((starbase_filename == 0) - ? SHARP_F - : (char_pointer_to_string (starbase_filename))); - } -} +#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED +#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1 + +#define COMPILER_PROCESSOR_TYPE COMPILER_NONE_TYPE +#define NO_CC_SUPPORT_P 1 + +#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */ diff --git a/v7/src/microcode/makegen/files-gc-bch.scm b/v7/src/microcode/cmpintmd/none.c similarity index 84% rename from v7/src/microcode/makegen/files-gc-bch.scm rename to v7/src/microcode/cmpintmd/none.c index 2b0325216..a9e484e01 100644 --- a/v7/src/microcode/makegen/files-gc-bch.scm +++ b/v7/src/microcode/cmpintmd/none.c @@ -1,6 +1,6 @@ -#| -*-Scheme-*- +/* -*-C-*- -$Id: files-gc-bch.scm,v 1.6 2007/01/05 21:19:26 cph Exp $ +$Id: none.c,v 1.2 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -23,12 +23,6 @@ along with MIT/GNU Scheme; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. -|# +*/ -;;;; C files for one-heap garbage-collector. - -"bchdmp" -"bchgcl" -"bchmmg" -"bchpur" -"bchutl" +/* Compiled code interface stub. */ diff --git a/v7/src/microcode/cmpintmd/none.h b/v7/src/microcode/cmpintmd/none.h new file mode 100644 index 000000000..b7c418a3f --- /dev/null +++ b/v7/src/microcode/cmpintmd/none.h @@ -0,0 +1,47 @@ +/* -*-C-*- + +$Id: none.h,v 1.2 2007/04/22 16:31:24 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Compiled code interface stub. */ + +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 + +typedef byte_t insn_t; + +#define compiler_interface_version (0UL) +#define compiler_processor_type COMPILER_PROCESSOR_TYPE +#define compiler_utilities SHARP_F + +#define return_to_interpreter SHARP_F +#define reflect_to_interface SHARP_F + +#define compiler_initialize(faslp) do {} while (false) +#define guarantee_interp_return() do {} while (false) + +#define CC_ENTRY_P(object) (false) + +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/svm1-config.h b/v7/src/microcode/cmpintmd/svm1-config.h new file mode 100644 index 000000000..a4f0b3b06 --- /dev/null +++ b/v7/src/microcode/cmpintmd/svm1-config.h @@ -0,0 +1,35 @@ +/* -*-C-*- + +$Id: svm1-config.h,v 1.2 2007/04/22 16:31:24 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED +#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1 + +#define COMPILER_PROCESSOR_TYPE COMPILER_SVM_TYPE +#define CC_IS_SVM 1 +#define CC_IS_GENERIC 1 + +#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/svm1.c b/v7/src/microcode/cmpintmd/svm1.c new file mode 100644 index 000000000..c79ad8016 --- /dev/null +++ b/v7/src/microcode/cmpintmd/svm1.c @@ -0,0 +1,421 @@ +/* -*-C-*- + +$Id: svm1.c,v 1.2 2007/04/22 16:31:24 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Compiled code interface for SVM v1. */ + +#include "cmpint.h" +#include "extern.h" +#include "errors.h" +#include "svm1-defns.h" + +static unsigned int cc_entry_reference_offset (insn_t *); + +bool +read_cc_entry_type (cc_entry_type_t * cet, insn_t * address) +{ + unsigned int n + = ((((unsigned int) (address[-3])) << 8) + | ((unsigned int) (address[-4]))); + if (n < 0x8000) + make_compiled_procedure_type + (cet, + (n & 0x007F), + ((n & 0x3F80) >> 7), + ((n & 0x4000) != 0)); + else if (n < 0xFFF8) + make_compiled_continuation_type (cet, (n - 0x8000)); + else + switch (n - 0xFFF8) + { + case 7: + make_cc_entry_type (cet, CET_EXPRESSION); + break; + + case 6: + make_cc_entry_type (cet, CET_INTERNAL_PROCEDURE); + break; + + case 5: + make_cc_entry_type (cet, CET_INTERNAL_CONTINUATION); + break; + + case 4: + make_cc_entry_type (cet, CET_TRAMPOLINE); + break; + + case 3: + make_cc_entry_type (cet, CET_RETURN_TO_INTERPRETER); + break; + + case 2: + make_cc_entry_type (cet, CET_CLOSURE); + break; + + default: + return (true); + } + return (false); +} + +bool +write_cc_entry_type (cc_entry_type_t * cet, insn_t * address) +{ + unsigned int n; + + switch (cet->marker) + { + case CET_PROCEDURE: + if (! (((cet->args.for_procedure.n_required) < 0x80) + && ((cet->args.for_procedure.n_optional) < 0x80))) + return (true); + n = ((cet->args.for_procedure.n_required) + | ((cet->args.for_procedure.n_optional) << 7) + | ((cet->args.for_procedure.rest_p) ? 0x4000 : 0)); + break; + + case CET_CONTINUATION: + if (! ((cet->args.for_continuation.offset) < 0x7FF8)) + return (true); + n = ((cet->args.for_continuation.offset) + 0x8000); + break; + + case CET_EXPRESSION: + n = (0xFFF8 + 7); + break; + + case CET_INTERNAL_PROCEDURE: + n = (0xFFF8 + 6); + break; + + case CET_INTERNAL_CONTINUATION: + n = (0xFFF8 + 5); + break; + + case CET_TRAMPOLINE: + n = (0xFFF8 + 4); + break; + + case CET_RETURN_TO_INTERPRETER: + n = (0xFFF8 + 3); + break; + + case CET_CLOSURE: + n = (0xFFF8 + 2); + break; + + default: + return (true); + } + (address[-4]) = (n & 0x00FF); + (address[-3]) = (n >> 8); + return (false); +} + +/* The offset is encoded as two bytes. It's relative to its own + address, _not_ relative to the entry address. In the case of a + closure, the offset points to the start of the first entry in the + block. For other entry types, it points to the first non-marked + word in the block. */ + +bool +read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) +{ + unsigned int n + = ((((unsigned int) (address[-1])) << 8) + | ((unsigned int) (address[-2]))); + if (n < 0x8000) + { + (ceo->offset) = (n + (cc_entry_reference_offset (address))); + (ceo->continued_p) = false; + } + else + { + (ceo->offset) = (n - 0x8000); + (ceo->continued_p) = true; + } + return (false); +} + +bool +write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) +{ + unsigned long offset = (ceo->offset); + if (ceo->continued_p) + { + offset -= (cc_entry_reference_offset (address)); + if (! (offset < 0x8000)) + return (true); + } + else + { + if (! (offset < 0x8000)) + return (true); + offset += 0x8000; + } + (address[-2]) = (offset & 0x00FF); + (address[-1]) = (offset >> 8); + return (false); +} + +static unsigned int +cc_entry_reference_offset (insn_t * address) +{ + cc_entry_type_t cet; +#ifdef ENABLE_DEBUGGING_TOOLS + bool ok_p = (read_cc_entry_type ((&cet), address)); + assert (ok_p); +#else + read_cc_entry_type ((&cet), address); +#endif + return + (CC_ENTRY_OFFSET_SIZE + + (((cet.marker) == CET_CLOSURE) + ? ((sizeof (SCHEME_OBJECT)) + 2) + : (2 * (sizeof (SCHEME_OBJECT))))); +} + +/* Compiled closures + + A compiled-closure block starts with a single GC header + (TC_MANIFEST_CLOSURE), followed by a 2-byte positive count, + followed by the closure entries (as specified by the count). For + example, on a 32-bit machine with count == 2 and 4 value cells: + + 0x00 TC_MANIFEST_CLOSURE | n_words == 10 + 0x04 (count - 1) == 1 + + 0x06 type == CET_CLOSURE + 0x08 (offset - 6) == 2 + 0x0A SVM1_INST_ICALL_U8 + 0x0B offset == 8 + + 0x0C type == CET_CLOSURE + 0x0E (offset - 6) == 8 + 0x10 SVM1_INST_ICALL_U8 + 0x11 offset == 6 + + 0x12 2 padding bytes + + 0x14 code entry 0 + 0x18 code entry 1 + + 0x1C value cell 0 + 0x20 value cell 1 + 0x24 value cell 2 + 0x28 value cell 3 + + */ + +unsigned long +compiled_closure_count (SCHEME_OBJECT * block) +{ + return + (((((unsigned long) (((byte_t *) block) [1])) << 8) + | ((unsigned long) (((byte_t *) block) [0]))) + + 1); +} + +insn_t * +compiled_closure_start (SCHEME_OBJECT * block) +{ + return (((insn_t *) block) + 2); +} + +insn_t * +compiled_closure_entry (insn_t * start) +{ + return (start + CC_ENTRY_HEADER_SIZE); +} + +insn_t * +compiled_closure_next (insn_t * start) +{ + insn_t * entry = (compiled_closure_entry (start)); + switch (*entry) + { + case SVM1_INST_ICALL_U8: return (entry + 2); + case SVM1_INST_ICALL_U16: return (entry + 3); + case SVM1_INST_ICALL_U32: return (entry + 5); + default: + Microcode_Termination (TERM_COMPILER_DEATH); + return (0); + } +} + +SCHEME_OBJECT * +skip_compiled_closure_padding (insn_t * start) +{ + return + ((SCHEME_OBJECT *) + ((((unsigned long) start) + ((sizeof (SCHEME_OBJECT)) - 1)) + &~ ((sizeof (SCHEME_OBJECT)) - 1))); +} + +SCHEME_OBJECT +compiled_closure_entry_to_target (insn_t * entry) +{ + unsigned long offset; + switch (entry[0]) + { + case SVM1_INST_ICALL_U8: + offset = (((unsigned long) (entry[1])) + 2); + break; + + case SVM1_INST_ICALL_U16: + offset + = (((((unsigned long) (entry[2])) << 8) + | ((unsigned long) (entry[1]))) + + 3); + break; + + case SVM1_INST_ICALL_U32: + offset + = (((((unsigned long) (entry[4])) << 24) + | (((unsigned long) (entry[3])) << 16) + | (((unsigned long) (entry[2])) << 8) + | ((unsigned long) (entry[1]))) + + 5); + break; + + default: + Microcode_Termination (TERM_COMPILER_DEATH); + return (0); + } + return (* ((SCHEME_OBJECT *) (entry + offset))); +} + +/* Execution caches (UUO links) + + An execution cache is a region of memory that lives in the + constants section of a compiled-code block. It is an indirection + for calling external procedures that allows the linker to control + the calling process without having to find and change all the + places in the compiled code that refer to it. + + Prior to linking, the execution cache has two pieces of + information: (1) the name of the procedure being called (a symbol), + and (2) the number of arguments that will be passed to the + procedure. It is laid out in memory like this (on a 32-bit + machine): + + 0x00 n-args encoded as fixnum + 0x04 name encoded as symbol + + After linking, the cache is changed as follows: + + 0x00 n-args + 0x02 SVM1_INST_IJUMP_U8 + 0x03 offset = 0 + 0x04 32-bit address + + On a 64-bit machine, the post-linking layout is: + + 0x00 n-args + 0x02 4 padding bytes + 0x06 SVM1_INST_IJUMP_U8 + 0x07 offset = 0 + 0x08 64-bit address + + */ + +unsigned int +read_uuo_frame_size (SCHEME_OBJECT * saddr) +{ + insn_t * address = ((insn_t *) saddr); + return + ((((unsigned int) (address[1])) << 8) + | ((unsigned int) (address[0]))); +} + +insn_t * +read_uuo_target (SCHEME_OBJECT * saddr) +{ + insn_t * addr = ((insn_t *) (saddr + 2)); + insn_t * end = ((insn_t *) (saddr + 1)); + unsigned long eaddr = 0; + + while (true) + { + eaddr |= (*--addr); + if (addr == end) + return (eaddr); + eaddr <<= 8; + } +} + +insn_t * +read_uuo_target_no_reloc (SCHEME_OBJECT * saddr) +{ + return (read_uuo_target (saddr)); +} + +void +write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr) +{ + unsigned long eaddr = ((unsigned long) target); + unsigned long frame_size = (OBJECT_DATUM (saddr[0])); + insn_t * addr = ((insn_t *) saddr); + insn_t * end = ((insn_t *) (saddr + 1)); + + (*addr++) = (frame_size & 0x00FF); + (*addr++) = ((frame_size & 0xFF00) >> 8); + while (addr < (end - 2)) + (*addr++) = 0; + (*addr++) = SVM1_INST_IJUMP_U8; + (*addr++) = 0; + + end = ((insn_t *) (saddr + 2)); + while (true) + { + (*addr++) = (eaddr & 0xFF); + if (addr == end) + break; + eaddr >>= 8; + } +} + +unsigned long +trampoline_entry_size (unsigned long n_entries) +{ + return (BYTES_TO_WORDS (n_entries * (CC_ENTRY_HEADER_SIZE + 2))); +} + +insn_t * +trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return (((insn_t *) (block + 2)) + + (index * (CC_ENTRY_HEADER_SIZE + 2)) + + CC_ENTRY_HEADER_SIZE); +} + +bool +store_trampoline_insns (insn_t * entry, byte_t code) +{ + (entry[0]) = SVM1_INST_TRAP_TRAP_0; + (entry[1]) = code; + return (false); +} diff --git a/v7/src/microcode/cmpintmd/svm1.h b/v7/src/microcode/cmpintmd/svm1.h new file mode 100644 index 000000000..520636020 --- /dev/null +++ b/v7/src/microcode/cmpintmd/svm1.h @@ -0,0 +1,81 @@ +/* -*-C-*- + +$Id: svm1.h,v 1.2 2007/04/22 16:31:24 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Compiled code interface macros for SVM v1. */ + +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 + +#define ASM_RESET_HOOK initialize_svm1 + +#define COMPILER_REGBLOCK_N_FIXED 512 + +typedef byte_t insn_t; + +/* Number of insn_t units preceding entry address in which header + (type and offset info) is stored. */ +#define CC_ENTRY_HEADER_SIZE (CC_ENTRY_TYPE_SIZE + CC_ENTRY_OFFSET_SIZE) +#define CC_ENTRY_TYPE_SIZE 2 +#define CC_ENTRY_OFFSET_SIZE 2 + +/* Number of insn_t units preceding entry header in which GC trap + instructions are stored. */ +#define CC_ENTRY_GC_TRAP_SIZE 0 + +/* Size of execution cache in SCHEME_OBJECTS. */ +#define UUO_LINK_SIZE 2 +#define READ_UUO_TARGET(a, r) read_uuo_target (a) + +#define UTILITY_RESULT_DEFINED 1 + +typedef struct +{ + bool scheme_p; + union { long interpreter_code; insn_t * new_pc; } arg; +} utility_result_t; + +#define RETURN_TO_C(code) do \ +{ \ + (DSU_result->scheme_p) = false; \ + ((DSU_result->arg) . interpreter_code) = (code); \ + return; \ +} while (false) + +#define RETURN_TO_SCHEME(ep) do \ +{ \ + (DSU_result->scheme_p) = true; \ + ((DSU_result->arg) . new_pc) = (ep); \ + return; \ +} while (false) + +#define ENTER_SCHEME(ep) return (C_to_interface (ep)) + +extern long C_to_interface (void *); +extern void initialize_svm1 (void); +extern insn_t * read_uuo_target (SCHEME_OBJECT *); + +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/cmpintmd/vax.h b/v7/src/microcode/cmpintmd/vax.h index 0d4468db9..48b207027 100644 --- a/v7/src/microcode/cmpintmd/vax.h +++ b/v7/src/microcode/cmpintmd/vax.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: vax.h,v 1.13 2007/01/05 21:19:26 cph Exp $ +$Id: vax.h,v 1.14 2007/04/22 16:31:24 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -34,10 +34,8 @@ USA. * Specialized for the Vax architecture. */ -#ifndef CMPNTMD_H_INCLUDED -#define CMPNTMD_H_INCLUDED - -#include "cmptype.h" +#ifndef SCM_CMPINTMD_H_INCLUDED +#define SCM_CMPINTMD_H_INCLUDED 1 /* Machine parameters to be set by the user. */ @@ -46,7 +44,7 @@ USA. /* Processor type. Choose a number from the above list, or allocate your own. */ -#define COMPILER_PROCESSOR_TYPE COMPILER_VAX_TYPE +#define COMPILER_PROCESSOR_TYPE COMPILER_VAX_TYPE /* Size (in long words) of the contents of a floating point register if different from a double. Default is fine. @@ -61,13 +59,6 @@ USA. */ typedef unsigned short format_word; - -/* PC alignment constraint. - Change PC_ZERO_BITS to be how many low order bits of the pc are - guaranteed to be 0 always because of PC alignment constraints. -*/ - -#define PC_ZERO_BITS 0 /* The length of the GC recovery code that precedes an entry. On the Vax a "movl s^code,r0; jsb b^n(r10)" sequence. @@ -101,12 +92,12 @@ do { \ magic_constant)); \ } while (0) -/* Manifest closure entry block size. +/* Manifest closure entry block size. Size in bytes of a compiled closure's header excluding the TC_MANIFEST_CLOSURE header. On the Vax, this is the format word and gc offset word and 6 bytes - more for the jsb instruction. + more for the jsb instruction. */ #define COMPILED_CLOSURE_ENTRY_SIZE \ @@ -144,7 +135,7 @@ do { \ contains the callee's name instead of the jump code. */ -#define EXECUTE_CACHE_ENTRY_SIZE 2 +#define EXECUTE_CACHE_ENTRY_SIZE 2 /* Execute cache destructuring. */ @@ -211,6 +202,7 @@ do { \ */ #define COMPILER_REGBLOCK_N_FIXED 16 +#define COMPILER_REGBLOCK_N_TEMPS 256 #define COMPILER_REGBLOCK_N_HOOKS 40 #define COMPILER_HOOK_SIZE 2 /* jsb @& + pad */ @@ -243,7 +235,7 @@ do { \ #define SETUP_REGISTER(hook) \ { \ - extern void EXFUN (hook, (void)); \ + extern void hook (void); \ (* ((unsigned short *) (r10_value + offset))) = \ ((unsigned short) 0x9f17); \ (* ((unsigned long *) \ @@ -255,7 +247,7 @@ do { \ #endif void -DEFUN_VOID (vax_reset_hook) +vax_reset_hook (void) { unsigned char * r10_value = ((unsigned char *) (&Registers[0])); int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT))); @@ -345,7 +337,7 @@ DEFUN_VOID (vax_reset_hook) #define TRAMPOLINE_STORAGE(tramp_entry) \ ((((SCHEME_OBJECT *) tramp_entry) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) + (2 + TRAMPOLINE_ENTRY_SIZE)) #define STORE_TRAMPOLINE_ENTRY(entry_address, code) \ { \ @@ -377,55 +369,17 @@ DEFUN_VOID (vax_reset_hook) #define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) #define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -#if (PC_ZERO_BITS == 0) /* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif - -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif - -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) >> 1) #define MAKE_OFFSET_WORD(entry, block, continue) \ ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ ((char *) (block)))) | \ ((continue) ? 1 : 0)) -#if (EXECUTE_CACHE_ENTRY_SIZE == 2) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 1) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 1) -#endif - -#if (EXECUTE_CACHE_ENTRY_SIZE == 4) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 2) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 2) -#endif - -#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) / EXECUTE_CACHE_ENTRY_SIZE) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) * EXECUTE_CACHE_ENTRY_SIZE) -#endif +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) ((count) >> 1) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) ((entries) << 1) /* The first entry in a cc block is preceeded by 2 headers (block and nmv), a format word and a gc offset word. See the early part of the @@ -477,4 +431,4 @@ DEFUN_VOID (vax_reset_hook) #define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW #define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH -#endif /* CMPNTMD_H_INCLUDED */ +#endif /* !SCM_CMPINTMD_H_INCLUDED */ diff --git a/v7/src/microcode/cmptype.h b/v7/src/microcode/cmptype.h deleted file mode 100644 index d0c1a7856..000000000 --- a/v7/src/microcode/cmptype.h +++ /dev/null @@ -1,118 +0,0 @@ -/* -*-C-*- - -$Id: cmptype.h,v 1.8 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Processor type definitions */ - -#ifndef SCM_CMPTYPE_H -#define SCM_CMPTYPE_H 1 - -/* This file contains the associations between processor numbers and - their descriptions. This file should only be modified by the - Scheme project at MIT, to avoid conflicts. - - These numbers are the numbers stored in Scheme images (bands) so - that the microcode can detect whether the compiled code in the band - is compatible with it. - - These _are not_ the same numbers as the PROC_TYPE_XXX used to - configure the microcode under Unix (cf.h)---they probably should - be. - - -Number Description -______ ___________ - -0 No compiled code support - -1 Motorola MC68020 with MC68881 floating point coprocessor, - or MC68030 (not MC68040). - Examples: HP series 9000 models 320, 350, 370, 375 - Sun models 340, 360 - -2 DEC Vax - Examples: Vax-11 750 - MicroVax II - VaxStation 3100 - -3 HP Precision architecture (version 1.0 and later). - Examples: HP series 9000 models 850, 835, 720, 750, 710, 877. - -4 MIPS R2000/R3000 with cache line <= 16 bytes. - Examples: DecStation 3100, 2100, 5000/200. - Sony News 3250 - -5 Motorola MC68020-MC68040 - Examples: HP series 9000 models 320-380, models 400+ - All Next computers (up to Aug. 1992). - -6 Sun Sparc - Examples: Sun 4, SparcStation 2, IPC, ELC. - Solbourne ? - -7 IBM POWER and POWER/PC architecture. - Examples: IBM RS6000 model 560. - -8 Motorola 88000 architecture (88100 and 88110). - Examples: ? - -9 Intel IA-32 architecture. - Examples: IBM PC AT clones with 386+ processors. - -10 DEC Alpha architecture - Examples: DEC AXP 500 - -11 MIPS R200-R4000 (32 bit) with arbitrary cache line size. - Examples: DecStation 2100, 3100, 5000/200, 5000/240 - Sony News 3250 - Silicon Graphics Predator, Indigo, and Crimson - -12 Virtual C processor. - The Scheme compiler produces C to be compiled by the - same C compiler as the microcode. - -13 Scheme Virtual Machine - The compiler produces code for a virtual machine that is - written in C and embedded in the microcode. - -*/ - -#define COMPILER_NONE_TYPE 0 -#define COMPILER_MC68020_TYPE 1 -#define COMPILER_VAX_TYPE 2 -#define COMPILER_SPECTRUM_TYPE 3 -#define COMPILER_OLD_MIPS_TYPE 4 -#define COMPILER_MC68040_TYPE 5 -#define COMPILER_SPARC_TYPE 6 -#define COMPILER_RS6000_TYPE 7 -#define COMPILER_MC88K_TYPE 8 -#define COMPILER_IA32_TYPE 9 -#define COMPILER_ALPHA_TYPE 10 -#define COMPILER_MIPS_TYPE 11 -#define COMPILER_LOSING_C_TYPE 12 -#define COMPILER_SVM_TYPE 13 - -#endif /* SCM_CMPTYPE_H */ diff --git a/v7/src/microcode/comlin.c b/v7/src/microcode/comlin.c index b4b961657..d35aabe7e 100644 --- a/v7/src/microcode/comlin.c +++ b/v7/src/microcode/comlin.c @@ -1,5 +1,7 @@ /* -*-C-*- +$Id: comlin.c,v 1.15 2007/04/22 16:31:22 cph Exp $ + Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Massachusetts Institute of Technology @@ -23,15 +25,11 @@ USA. */ -/* $Id: comlin.c,v 1.14 2007/01/05 21:19:25 cph Exp $ - * - * This file contains the scheme command parser. - * - */ +/* The scheme command parser. */ #include #ifndef toupper -#include +# include #endif #include "comlin.h" @@ -39,51 +37,41 @@ USA. /* Some string utilities */ char * -DEFUN (remove_initial_substring, (sub, str), - register char * sub - AND register char * str) +remove_initial_substring (char * sub, char * str) { for ( ; *sub != '\0'; sub++, str++) - { - if (*sub != *str) { - return ((char *) NULL); + if (*sub != *str) + return (0); } - } return (str); } -boolean -DEFUN (STREQUAL, (s1, s2), - register char * s1 - AND register char * s2) +bool +STREQUAL (char * s1, char * s2) { for ( ; *s1 != '\0'; s1++, s2++) - { - if (toupper(*s1) != toupper(*s2)) { - return (false); + if (toupper(*s1) != toupper(*s2)) + return (false); } - } return (*s2 == '\0'); } /* Usage information */ void -DEFUN (print_usage_and_exit, (options, val), - struct keyword_struct * options - AND int val) +print_usage_and_exit (struct keyword_struct * options, int val) { - register int i; + int i; fprintf(stderr, "usage: %s", program_name); if ((options[0].type_tag) == LAST_KYWRD) - { - fprintf(stderr, "\n"); - exit(val); - } + { + fprintf(stderr, "\n"); + exit(val); + } fprintf(stderr, " [args]\n"); fprintf(stderr, " where args are as follows:\n"); @@ -91,35 +79,33 @@ DEFUN (print_usage_and_exit, (options, val), for (i = 0; ((options[i].type_tag) != LAST_KYWRD); i++) - { - switch (options[i].type_tag) { - case BOOLEAN_KYWRD: - fprintf(stderr, " %s={true,false}\n", - options[i].keyword); - break; + switch (options[i].type_tag) + { + case BOOLEAN_KYWRD: + fprintf(stderr, " %s={true,false}\n", + options[i].keyword); + break; - case INT_KYWRD: - case DOUBLE_KYWRD: - fprintf(stderr, " %s=%s\n", - options[i].keyword, options[i].format); - break; + case INT_KYWRD: + case DOUBLE_KYWRD: + fprintf(stderr, " %s=%s\n", + options[i].keyword, options[i].format); + break; - case STRING_KYWRD: - fprintf(stderr, " %s=%%s\n", - options[i].keyword); - break; + case STRING_KYWRD: + fprintf(stderr, " %s=%%s\n", + options[i].keyword); + break; + } } - } exit(val); } void -DEFUN (supply, (options, j), - struct keyword_struct * options - AND int j) +supply (struct keyword_struct * options, int j) { - if (options[j].supplied_p != ((boolean *) NULL)) + if (options[j].supplied_p != 0) { if (*(options[j].supplied_p)) { @@ -138,20 +124,17 @@ DEFUN (supply, (options, j), char * program_name; -/* This parser assumes that no keyword is an initial - substring of another. - */ +/* This parser assumes that no keyword is an initial substring of + another. */ void -DEFUN (parse_keywords, - (argc, argv, options, allow_others_p), - int argc - AND char **argv - AND struct keyword_struct * options - AND boolean allow_others_p) +parse_keywords (int argc, + char **argv, + struct keyword_struct * options, + bool allow_others_p) { - register int i, j, length; - char *argument; + int i, j, length; + char * argument; program_name = argv[0]; argv += 1; @@ -163,11 +146,11 @@ DEFUN (parse_keywords, ((options[length].type_tag) != LAST_KYWRD); length++) { - if (options[length].supplied_p != ((boolean *) NULL)) + if (options[length].supplied_p != 0) { *(options[length].supplied_p) = false; } - + switch (options[length].type_tag) { case BOOLEAN_KYWRD: @@ -204,7 +187,7 @@ DEFUN (parse_keywords, exit(1); } } - + for (i = 0; i < argc; i++) { for (j = 0; j < length; j++) @@ -217,7 +200,7 @@ DEFUN (parse_keywords, case BOOLEAN_KYWRD: { - boolean value = false; + bool value = false; if (*argument != '\0') { @@ -227,6 +210,8 @@ DEFUN (parse_keywords, "parse_keywords: unrecognized parameter: %s\n", argv[i]); print_usage_and_exit(&options[0], 1); + /*NOTREACHED*/ + value = false; } else { @@ -247,6 +232,8 @@ DEFUN (parse_keywords, "parse_keywords: Invalid boolean value: %s\n", argv[i]); print_usage_and_exit(&options[0], 1); + /*NOTREACHED*/ + value = false; } } } @@ -258,7 +245,7 @@ DEFUN (parse_keywords, *(BOOLEAN_LVALUE(options[j])) = value; break; } - + case INT_KYWRD: if (*argument != '=') { @@ -292,7 +279,7 @@ DEFUN (parse_keywords, supply(options, j); sscanf(&argument[1], options[j].format, DOUBLE_LVALUE(options[j])); break; - + case STRING_KYWRD: if (*argument != '=') { @@ -321,5 +308,4 @@ DEFUN (parse_keywords, print_usage_and_exit(&options[0], 1); } } - return; } diff --git a/v7/src/microcode/comlin.h b/v7/src/microcode/comlin.h index bfc2060d2..d1dd0bff4 100644 --- a/v7/src/microcode/comlin.h +++ b/v7/src/microcode/comlin.h @@ -1,5 +1,7 @@ /* -*-C-*- +$Id: comlin.h,v 1.12 2007/04/22 16:31:22 cph Exp $ + Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Massachusetts Institute of Technology @@ -23,17 +25,11 @@ USA. */ -/* $Id: comlin.h,v 1.11 2007/01/05 21:19:25 cph Exp $ - * - * This file contains definitions for the scheme command parser. - * - */ +/* The scheme command parser. */ #ifndef COMLIN_H_INCLUDED #define COMLIN_H_INCLUDED -#include "ansidecl.h" - #ifndef boolean # define boolean int #endif @@ -63,32 +59,24 @@ struct keyword_struct { int type_tag; string keyword; - long *data; + void *data; string format; boolean *supplied_p; }; -#define KEYWORD(str, var, type, format, sup) \ -{ \ - type, \ - ((string) str), \ - ((long *) var), \ - format, \ - sup \ -} +#define KEYWORD(str, var, type, format, sup) { type, str, var, format, sup } -#define END_KEYWORD() KEYWORD("", NULL, LAST_KYWRD, NULL, NULL) +#define END_KEYWORD() KEYWORD ("", 0, LAST_KYWRD, 0, 0) /* Fake boolean and string formats */ -#define BFRMT ((string) NULL) -#define SFRMT ((string) NULL) +#define BFRMT (0) +#define SFRMT (0) /* Exports */ -extern char *program_name; +extern char * program_name; -extern void EXFUN (parse_keywords, - (int, char **, struct keyword_struct *, boolean)); +extern void parse_keywords (int, char **, struct keyword_struct *, boolean); #endif /* COMLIN_H_INCLUDED */ diff --git a/v7/src/microcode/comutl.c b/v7/src/microcode/comutl.c index b8f6ab91d..2e36dbf5b 100644 --- a/v7/src/microcode/comutl.c +++ b/v7/src/microcode/comutl.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: comutl.c,v 1.37 2007/01/12 03:45:55 cph Exp $ +$Id: comutl.c,v 1.38 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,150 +30,175 @@ USA. #include "scheme.h" #include "prims.h" -extern SCHEME_OBJECT - * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT)); - -extern long - EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT)), - EXFUN (coerce_to_compiled, (SCHEME_OBJECT, long, SCHEME_OBJECT *)); - -extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *)); - -DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block, 1, 1, - "Given a compiled code address, return its compiled code block.") +DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block, + 1, 1, "(ADDRESS)\n\ +Given a compiled-code entry ADDRESS, return its block.") { PRIMITIVE_HEADER (1); - - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); - PRIMITIVE_RETURN - (MAKE_POINTER_OBJECT - (TC_COMPILED_CODE_BLOCK, - (compiled_entry_to_block_address (ARG_REF (1))))); + CHECK_ARG (1, CC_ENTRY_P); + PRIMITIVE_RETURN (cc_entry_to_block (ARG_REF (1))); } -DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", Prim_comp_code_address_offset, 1, 1, - "Given a compiled code address, return its offset into its block.") +DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", + Prim_comp_code_address_offset, 1, 1, "(ADDRESS)\n\ +Given a compiled-code entry ADDRESS, return its offset into its block.") { PRIMITIVE_HEADER (1); - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); - PRIMITIVE_RETURN - (LONG_TO_FIXNUM (compiled_entry_to_block_offset (ARG_REF (1)))); + CHECK_ARG (1, CC_ENTRY_P); + PRIMITIVE_RETURN (ULONG_TO_FIXNUM (cc_entry_to_block_offset (ARG_REF (1)))); } -#ifndef USE_STACKLETS - DEFINE_PRIMITIVE ("STACK-TOP-ADDRESS", Prim_stack_top_address, 0, 0, 0) { PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN (long_to_integer ((long) (ADDRESS_TO_DATUM (Stack_Top)))); + PRIMITIVE_RETURN (ulong_to_integer (ADDRESS_TO_DATUM (STACK_BOTTOM))); } DEFINE_PRIMITIVE ("STACK-ADDRESS-OFFSET", Prim_stack_address_offset, 1, 1, 0) { PRIMITIVE_HEADER (1); - CHECK_ARG (1, STACK_ADDRESS_P); - PRIMITIVE_RETURN - (long_to_integer - (STACK_LOCATIVE_DIFFERENCE ((Stack_Top), - (OBJECT_ADDRESS (ARG_REF (1)))))); + CHECK_ARG (1, CC_STACK_ENV_P); + { + SCHEME_OBJECT * address = (OBJECT_ADDRESS (ARG_REF (1))); + if (!ADDRESS_IN_STACK_P (address)) + error_bad_range_arg (1); + PRIMITIVE_RETURN + (ulong_to_integer (SP_TO_N_PUSHED (address, stack_start, stack_end))); + } } - -#endif /* USE_STACKLETS */ - -DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_type, 1, 1, 0) + +DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_kind, 1, 1, 0) { PRIMITIVE_HEADER (1); - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); + CHECK_ARG (1, CC_ENTRY_P); { - long results [3]; - compiled_entry_type ((ARG_REF (1)), results); + cc_entry_type_t cet; + unsigned long kind = 4; + unsigned long field1 = 0; + long field2 = 0; + + if (!read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (ARG_REF (1))))) + switch (cet.marker) + { + case CET_PROCEDURE: + kind = 0; + field1 = (1 + (cet.args.for_procedure.n_required)); + field2 = (field1 + (cet.args.for_procedure.n_optional)); + if (cet.args.for_procedure.rest_p) + field2 = (- (field2 + 1)); + break; + + case CET_CONTINUATION: + kind = 1; + field1 = 0; + field2 = (cet.args.for_continuation.offset); + break; + + case CET_EXPRESSION: + kind = 2; + field1 = 0; + field2 = 0; + break; + + case CET_INTERNAL_CONTINUATION: + kind = 1; + field1 = 1; + field2 = (-1); + break; + + case CET_INTERNAL_PROCEDURE: + case CET_TRAMPOLINE: + kind = 3; + field1 = 1; + field2 = 0; + break; + + case CET_RETURN_TO_INTERPRETER: + kind = 1; + field1 = 2; + field2 = ((ARG_REF (1)) != return_to_interpreter); + break; + + case CET_CLOSURE: + kind = 3; + field1 = 0; + field2 = 0; + break; + } PRIMITIVE_RETURN - (hunk3_cons ((LONG_TO_FIXNUM (results [0])), - (LONG_TO_FIXNUM (results [1])), - (LONG_TO_FIXNUM (results [2])))); + (hunk3_cons ((ULONG_TO_FIXNUM (kind)), + (ULONG_TO_FIXNUM (field1)), + (LONG_TO_FIXNUM (field2)))); } } -DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2, 0) +DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2, + 0) { - SCHEME_OBJECT temp; - long result; - PRIMITIVE_HEADER(2); - result = (coerce_to_compiled ((ARG_REF (1)), (arg_integer (2)), &temp)); - switch(result) + PRIMITIVE_HEADER (2); { - case PRIM_DONE: - PRIMITIVE_RETURN(temp); - - case PRIM_INTERRUPT: - Primitive_GC(10); - /*NOTREACHED*/ - - default: - error_bad_range_arg (2); - /*NOTREACHED*/ - return (0); + SCHEME_OBJECT temp; + long result + = (coerce_to_compiled ((ARG_REF (1)), (arg_ulong_integer (2)), (&temp))); + switch (result) + { + case PRIM_DONE: + break; + + case PRIM_INTERRUPT: + Primitive_GC (10); + /*NOTREACHED*/ + break; + + default: + error_bad_range_arg (2); + /*NOTREACHED*/ + break; + } + PRIMITIVE_RETURN (temp); } } -DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_compiled_closure_to_entry, 1, 1, +DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_cc_closure_to_entry, 1, 1, "Given a compiled closure, return the entry point which it invokes.") { - long entry_type [3]; - SCHEME_OBJECT closure; - extern long EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT)); - extern SCHEME_OBJECT EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT)); PRIMITIVE_HEADER (1); - - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); - closure = (ARG_REF (1)); - compiled_entry_type (closure, (& (entry_type [0]))); - if (! (((entry_type [0]) == 0) && (compiled_entry_closure_p (closure)))) + CHECK_ARG (1, CC_ENTRY_P); + if (!cc_entry_closure_p (ARG_REF (1))) error_bad_range_arg (1); - PRIMITIVE_RETURN (compiled_closure_to_entry (closure)); + PRIMITIVE_RETURN (cc_closure_to_entry (ARG_REF (1))); } - -DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1, - "Given an integer, return the name of the corresponding compiled code utility.") + +DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1, 0) { - extern char * EXFUN (utility_index_to_name, (int)); - char * result; PRIMITIVE_HEADER (1); - - result = (utility_index_to_name (arg_integer (1))); - if (result == ((char *) NULL)) - PRIMITIVE_RETURN (SHARP_F); - else - PRIMITIVE_RETURN (char_pointer_to_string (result)); + { + const char * name = (utility_index_to_name (arg_ulong_integer (1))); + PRIMITIVE_RETURN ((name == 0) ? SHARP_F : (char_pointer_to_string (name))); + } } -DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1, - "Given an integer, return the name of the corresponding compiled code utility.") +DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1, 0) { - extern char * EXFUN (builtin_index_to_name, (int)); - char * result; PRIMITIVE_HEADER (1); - - result = (builtin_index_to_name (arg_integer (1))); - if (result == ((char *) NULL)) - PRIMITIVE_RETURN (SHARP_F); - else - PRIMITIVE_RETURN (char_pointer_to_string (result)); + { + const char * name = (builtin_index_to_name (arg_ulong_integer (1))); + PRIMITIVE_RETURN ((name == 0) ? SHARP_F : (char_pointer_to_string (name))); + } } -/* This is only meaningful for the C back end. */ +#ifdef CC_IS_C + extern SCHEME_OBJECT initialize_C_compiled_block (int, const char *); +#endif DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK", Prim_initialize_C_compiled_block, 1, 1, "Given the tag of a compiled object, return the object.") { -#ifdef NATIVE_CODE_IS_C - extern SCHEME_OBJECT EXFUN (initialize_C_compiled_block, (int, char *)); - SCHEME_OBJECT val; - - val = (initialize_C_compiled_block (1, (STRING_ARG (1)))); - PRIMITIVE_RETURN (val); + PRIMITIVE_HEADER (1); +#ifdef CC_IS_C + PRIMITIVE_RETURN (initialize_C_compiled_block (1, (STRING_ARG (1)))); #else PRIMITIVE_RETURN (SHARP_F); #endif @@ -183,43 +208,36 @@ DEFINE_PRIMITIVE ("DECLARE-COMPILED-CODE-BLOCK", Prim_declare_compiled_code_block, 1, 1, "Ensure cache coherence for a compiled-code block newly constructed.") { - extern void EXFUN (declare_compiled_code_block, (SCHEME_OBJECT)); - SCHEME_OBJECT new_cc_block; PRIMITIVE_HEADER (1); - - new_cc_block = (ARG_REF (1)); - if ((OBJECT_TYPE (new_cc_block)) != TC_COMPILED_CODE_BLOCK) - error_wrong_type_arg (1); - declare_compiled_code_block (new_cc_block); - PRIMITIVE_RETURN (SHARP_T); + { + SCHEME_OBJECT new_cc_block = (ARG_REF (1)); + if (!CC_BLOCK_P (new_cc_block)) + error_wrong_type_arg (1); + declare_compiled_code_block (new_cc_block); + PRIMITIVE_RETURN (SHARP_T); + } } -extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR)); -extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR)); -extern Boolean EXFUN (bkpt_p, (PTR)); -extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT)); -extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT)); - DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1, "(compiled-entry-object)\n\ Install a breakpoint trap in a compiled code object.\n\ Returns false or a handled needed by REMOVE-BKPT and ONE-STEP-PROCEED.") { PRIMITIVE_HEADER (1); - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); + CHECK_ARG (1, CC_ENTRY_P); { SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1))); SCHEME_OBJECT * block; - if (bkpt_p ((PTR) entry)) + if (bkpt_p ((void *) entry)) error_bad_range_arg (1); - block = (compiled_entry_to_block_address (ARG_REF (1))); + block = (cc_entry_to_block_address (ARG_REF (1))); if ((OBJECT_TYPE (block[0])) == TC_MANIFEST_CLOSURE) - PRIMITIVE_RETURN (bkpt_closure_install ((PTR) entry)); + PRIMITIVE_RETURN (bkpt_closure_install ((void *) entry)); else - PRIMITIVE_RETURN (bkpt_install ((PTR) entry)); + PRIMITIVE_RETURN (bkpt_install ((void *) entry)); } } @@ -228,16 +246,16 @@ DEFINE_PRIMITIVE ("BKPT/REMOVE", Prim_remove_bkpt, 2, 2, Remove a breakpoint trap installed by INSTALL-BKPT.") { PRIMITIVE_HEADER (2); - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); + CHECK_ARG (1, CC_ENTRY_P); CHECK_ARG (2, NON_MARKED_VECTOR_P); { SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1))); SCHEME_OBJECT handle = (ARG_REF (2)); - if (! (bkpt_p ((PTR) entry))) + if (! (bkpt_p ((void *) entry))) error_bad_range_arg (1); - bkpt_remove (((PTR) entry), handle); + bkpt_remove (((void *) entry), handle); PRIMITIVE_RETURN (UNSPECIFIC); } } @@ -247,10 +265,10 @@ DEFINE_PRIMITIVE ("BKPT?", Prim_bkpt_p, 1, 1, True if there is a breakpoint trap in compiled-entry-object.") { PRIMITIVE_HEADER (1); - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); + CHECK_ARG (1, CC_ENTRY_P); PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT - (bkpt_p ((PTR) (OBJECT_ADDRESS (ARG_REF (1)))))); + (bkpt_p ((void *) (OBJECT_ADDRESS (ARG_REF (1)))))); } DEFINE_PRIMITIVE ("BKPT/PROCEED", Prim_bkpt_proceed, 3, 3, @@ -258,10 +276,10 @@ DEFINE_PRIMITIVE ("BKPT/PROCEED", Prim_bkpt_proceed, 3, 3, Proceed the computation from the current breakpoint.") { PRIMITIVE_HEADER (3); - CHECK_ARG (1, COMPILED_CODE_ADDRESS_P); + CHECK_ARG (1, CC_ENTRY_P); CHECK_ARG (2, NON_MARKED_VECTOR_P); - PRIMITIVE_RETURN (bkpt_proceed (((PTR) (OBJECT_ADDRESS (ARG_REF (1)))), + PRIMITIVE_RETURN (bkpt_proceed (((void *) (OBJECT_ADDRESS (ARG_REF (1)))), (ARG_REF (2)), (ARG_REF (3)))); } diff --git a/v7/src/microcode/config.sub b/v7/src/microcode/config.sub index a73819825..8e9ab106b 100755 --- a/v7/src/microcode/config.sub +++ b/v7/src/microcode/config.sub @@ -4,7 +4,7 @@ # 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, # Inc. -timestamp='2006-07-02' +timestamp='2007-04-22' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software diff --git a/v7/src/microcode/configure.ac b/v7/src/microcode/configure.ac index d4fbb948a..abe35cc02 100644 --- a/v7/src/microcode/configure.ac +++ b/v7/src/microcode/configure.ac @@ -1,7 +1,7 @@ dnl Process this file with autoconf to produce a configure script. -AC_INIT([MIT/GNU Scheme microcode], [14.18], [bug-mit-scheme@gnu.org], [mit-scheme]) -AC_REVISION([$Id: configure.ac,v 1.39 2007/04/04 05:08:19 riastradh Exp $]) +AC_INIT([MIT/GNU Scheme microcode], [15.0], [bug-mit-scheme@gnu.org], [mit-scheme]) +AC_REVISION([$Id: configure.ac,v 1.40 2007/04/22 16:31:22 cph Exp $]) AC_CONFIG_SRCDIR([boot.c]) AC_CONFIG_HEADERS([config.h]) AC_PROG_MAKE_SET @@ -189,18 +189,51 @@ LIARC_RULES=/dev/null dnl Checks for programs. AC_PROG_CC -AC_PROG_GCC_TRADITIONAL +AC_C_BACKSLASH_A +AC_C_BIGENDIAN +AC_C_CONST +AC_C_RESTRICT +AC_C_VOLATILE +AC_C_INLINE +AC_C_STRINGIZE +AC_C_PROTOTYPES AC_PROG_INSTALL AC_PROG_LN_S AC_PROG_MAKE_SET if test ${GCC} = yes; then if test ${enable_debugging} = no; then - CFLAGS="-fPIC -O3" + CFLAGS="-O3" else - CFLAGS="-fPIC -O0 -g" + CFLAGS="-O0 -g -DENABLE_DEBUGGING_TOOLS" LDFLAGS="${LDFLAGS} -g" fi - CFLAGS="${CFLAGS} -Wall" + if test ${enable_native_code} = c; then + CFLAGS="-fPIC ${CFLAGS}" + fi + CFLAGS="${CFLAGS} -Wall -Wundef -Wpointer-arith -Winline" + CFLAGS="${CFLAGS} -Wstrict-prototypes -Wnested-externs -Wredundant-decls" + + AC_MSG_CHECKING([for GCC>=4]) + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[ + #if __GNUC__ >= 4 + ; + #else + #error "gcc too old" + #endif + ]], + [[]] + )], + [ + AC_MSG_RESULT([yes]) + CFLAGS="${CFLAGS} -Wextra -Wno-sign-compare -Wno-unused-parameter" + CFLAGS="${CFLAGS} -Wold-style-definition" + ], + [AC_MSG_RESULT([no])]) + + # other possibilities: + # -Wmissing-prototypes -Wunreachable-code -Wwrite-strings fi FOO=`${INSTALL} --help 2> /dev/null | fgrep -e --preserve-timestamps` if test "x${FOO}" != x; then @@ -597,6 +630,9 @@ if test "${with_mhash}" != no; then [ AC_DEFINE([HAVE_LIBMHASH], [1], [Define to 1 if you have the `mhash' library (-lmhash).]) + if test ${enable_debugging} != no; then + LIBS="-lmhash ${LIBS}" + fi MODULE_LIBS="-lmhash ${MODULE_LIBS}" MODULE_BASES="${MODULE_BASES} prmhash" if test "x${PRMD5_LIBS}" = x; then @@ -820,8 +856,8 @@ if test ${DO_GCC_TESTS} = yes; then fi AC_MSG_CHECKING([for native-code support]) -OPTIONAL_BASES="${OPTIONAL_BASES} cmpint" -GC_HEAD_FILES="gccode.h cmpgc.h" +OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl" +GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h" SCM_ARCH=none ECN_WARNP=no @@ -857,6 +893,9 @@ yes) c) SCM_ARCH=c ;; +svm) + SCM_ARCH=svm1 + ;; no|none) ;; *) @@ -870,8 +909,6 @@ none) ;; c) AC_MSG_RESULT([yes, using portable C code]) - AC_DEFINE([NATIVE_CODE_IS_C], [1], - [Define that the compiler outputs C code instead of binaries.]) AC_CONFIG_LINKS([cmpauxmd.c:cmpauxmd/c.c]) AC_DEFINE([COMPILE_FOR_STATIC_LINKING], [1], [Define to 1 for static compilation of C native code.]) @@ -879,6 +916,10 @@ c) LIARC_VARS=liarc-vars LIARC_RULES=liarc-rules ;; +svm1) + AC_MSG_RESULT([yes, using portable SVM code]) + OPTIONAL_BASES="${OPTIONAL_BASES} svm1-interp" + ;; *) AC_MSG_RESULT([yes, for ${SCM_ARCH}]) AC_CONFIG_LINKS([cmpauxmd.m4:cmpauxmd/${SCM_ARCH}.m4]) @@ -891,12 +932,11 @@ if test ${ECN_WARNP} = yes; then AC_MSG_WARN([illegal --enable-native-code value: ${enable_native_code}]) fi -if test ${SCM_ARCH} != none; then - AC_DEFINE([HAS_COMPILER_SUPPORT], [1], - [Define if architecture has native-code compiler support.]) - AC_CONFIG_LINKS([cmpintmd.h:cmpintmd/${SCM_ARCH}.h]) - GC_HEAD_FILES="${GC_HEAD_FILES} cmpintmd.h" -fi +AC_CONFIG_LINKS([ + cmpintmd.h:cmpintmd/${SCM_ARCH}.h + cmpintmd.c:cmpintmd/${SCM_ARCH}.c + cmpintmd-config.h:cmpintmd/${SCM_ARCH}-config.h + ]) for base in ${OPTIONAL_BASES}; do OPTIONAL_SOURCES="${OPTIONAL_SOURCES} ${base}.c" diff --git a/v7/src/microcode/confshared.h b/v7/src/microcode/confshared.h index 928ed4201..a2ebe0f67 100644 --- a/v7/src/microcode/confshared.h +++ b/v7/src/microcode/confshared.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: confshared.h,v 11.11 2007/01/05 21:19:25 cph Exp $ +$Id: confshared.h,v 11.12 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -29,41 +29,110 @@ USA. #ifndef SCM_CONFSHARED_H #define SCM_CONFSHARED_H + +#ifndef __STDC__ +# include "error: compiler must support ANSI C" +#endif -#include "ansidecl.h" - -/* To enable the STEPPER. Incompatible with futures. */ -#define COMPILE_STEPPER - -/* Some configuration consistency testing */ +/* Enable the stepper. */ +#define COMPILE_STEPPER 1 -#ifdef COMPILE_STEPPER -# ifdef COMPILE_FUTURES -# include "Error: The stepper doesn't work with futures." +#ifdef ENABLE_DEBUGGING_TOOLS +# undef NDEBUG /* for assert() */ +# define WHEN_DEBUGGING(code) do { code } while (0) +# define ENABLE_PRIMITIVE_PROFILING +#else +# define NDEBUG 1 /* for assert() */ +# define WHEN_DEBUGGING(code) do {} while (0) +# undef ENABLE_PRIMITIVE_PROFILING +#endif + +/* For use in the C pre-processor, not in code! */ +#define FALSE 0 +#define TRUE 1 + +#include +#include + +#if STDC_HEADERS +# include +# include +# include +# include +# include +# include +# include +# include +#else +# ifdef HAVE_LIMITS_H +# include +# endif +# ifdef HAVE_FLOAT_H +# include +# else +# include "float.h" +# endif +# ifdef HAVE_ASSERT_H +# include +# endif +# ifdef HAVE_MALLOC_H +# include # endif -# ifdef USE_STACKLETS -# include "Error: The stepper doesn't work with stacklets." +# if !HAVE_STRCHR +# define strchr index +# define strrchr rindex # endif + extern char * strchr (); + extern char * strrchr (); +# if !HAVE_MEMCPY +# define memcpy(d, s, n) bcopy ((s), (d), (n)) +# define memmove(d, s, n) bcopy ((s), (d), (n)) +# endif +#endif + +#if HAVE_STDBOOL_H +# include +#else +# if !HAVE__BOOL +# ifdef __cplusplus + typedef bool _Bool; +# else + typedef unsigned char _Bool; +# endif +# endif +# define bool _Bool +# define false 0 +# define true 1 +# define __bool_true_false_are_defined 1 #endif -/* For use in the C pre-processor, not in code! */ -#define FALSE 0 -#define TRUE 1 +#ifdef HAVE_STDINT_H +# include +#endif -/* These C type definitions are needed by everybody. - They should not be here, but it is unavoidable. */ -typedef char Boolean; -#define true ((Boolean) TRUE) -#define false ((Boolean) FALSE) +#if (CHAR_BIT != 8) +# include "error: characters must be 8 bits wide" +#endif -/* This is the Scheme object type. - The various fields are defined in "object.h". */ -typedef unsigned long SCHEME_OBJECT; -#define OBJECT_LENGTH (CHAR_BIT * SIZEOF_UNSIGNED_LONG) +#if (FLT_RADIX != 2) +# include "error: floating-point radix must be 2" +#endif + +#if (SIZEOF_UINTPTR_T > SIZEOF_UNSIGNED_LONG) +# include "error: pointers must fit in 'unsigned long'" +#endif + +#if ((defined (__GNUC__)) && (__GNUC__ >= 3)) +# define ATTRIBUTE(x) __attribute__ (x) +# define NORETURN __attribute__ ((__noreturn__)) +#else +# define ATTRIBUTE(x) +# define NORETURN +#endif /* Operating System / Machine dependencies: - For each implementation, be sure to specify FASL_INTERNAL_FORMAT. + For each implementation, be sure to specify CURRENT_FASL_ARCH. Make sure that there is an appropriate FASL_. If there isn't, add one to the list below. @@ -96,8 +165,8 @@ typedef unsigned long SCHEME_OBJECT; available memory and thus all addresses will fit in the datum portion of a Scheme object. The datum portion of a Scheme object is 8 bits less than the length of a C long. */ - -/* Possible values for FASL_INTERNAL_FORMAT. For the most part this + +/* Possible values for CURRENT_FASL_ARCH. For the most part this means the processor type, so for example there are several aliases for 68000 family processors. This scheme allows sharing of compiled code on machines with the same processor type. Probably @@ -105,38 +174,67 @@ typedef unsigned long SCHEME_OBJECT; files when we introduce new differences, such as whether or not a 68881 coprocessor is installed. */ -#define FASL_UNKNOWN 0 -#define FASL_PDP10 1 -#define FASL_VAX 2 -#define FASL_68020 3 -#define FASL_68000 4 -#define FASL_HP_9000_500 5 -#define FASL_IA32 6 -#define FASL_BFLY 7 -#define FASL_CYBER 8 -#define FASL_CELERITY 9 -#define FASL_HP_SPECTRUM 10 -#define FASL_UMAX 11 -#define FASL_PYR 12 -#define FASL_ALLIANT 13 -#define FASL_SPARC 14 -#define FASL_MIPS 15 -#define FASL_APOLLO_68K 16 -#define FASL_APOLLO_PRISM 17 -#define FASL_ALPHA 18 -#define FASL_RS6000 19 -#define FASL_PPC32 20 -#define FASL_X86_64 21 -#define FASL_PPC64 22 -#define FASL_IA64 23 +typedef enum +{ + FASL_UNKNOWN, + FASL_PDP10, + FASL_VAX, + FASL_68020, + FASL_68000, + FASL_HP_9000_500, + FASL_IA32, + FASL_BFLY, + FASL_CYBER, + FASL_CELERITY, + FASL_HP_SPECTRUM, + FASL_UMAX, + FASL_PYR, + FASL_ALLIANT, + FASL_SPARC, + FASL_MIPS, + FASL_APOLLO_68K, + FASL_APOLLO_PRISM, + FASL_ALPHA, + FASL_RS6000, + FASL_PPC32, + FASL_X86_64, + FASL_PPC64, + FASL_IA64 +} fasl_arch_t; + +/* Possible values for COMPILER_PROCESSOR_TYPE. This identifies the + processor for which native-code support is provided. This is + related to the fasl_arch_t types above, but can also take on values + that are independent of the host architecture. */ + +typedef enum +{ + COMPILER_NONE_TYPE, + COMPILER_MC68020_TYPE, + COMPILER_VAX_TYPE, + COMPILER_SPECTRUM_TYPE, + COMPILER_OLD_MIPS_TYPE, + COMPILER_MC68040_TYPE, + COMPILER_SPARC_TYPE, + COMPILER_RS6000_TYPE, + COMPILER_MC88K_TYPE, + COMPILER_IA32_TYPE, + COMPILER_ALPHA_TYPE, + COMPILER_MIPS_TYPE, + COMPILER_C_TYPE, + COMPILER_SVM_TYPE +} cc_arch_t; + +#include "cmpintmd-config.h" #ifdef vax /* Amazingly unix and vms agree on all these */ #define MACHINE_TYPE "vax" -#define FASL_INTERNAL_FORMAT FASL_VAX -#define HEAP_IN_LOW_MEMORY +#define CURRENT_FASL_ARCH FASL_VAX +#define PC_ZERO_BITS 0 +#define HEAP_IN_LOW_MEMORY 1 /* Not on these, however */ @@ -193,7 +291,8 @@ typedef unsigned long SCHEME_OBJECT; #else #define MACHINE_TYPE "hp9000s800" #endif -#define FASL_INTERNAL_FORMAT FASL_HP_SPECTRUM +#define CURRENT_FASL_ARCH FASL_HP_SPECTRUM +#define PC_ZERO_BITS 2 #define FLOATING_ALIGNMENT 0x7 /* Heap resides in data space, pointed at by space register 5. @@ -232,39 +331,37 @@ typedef unsigned long SCHEME_OBJECT; #endif /* hp9000s800 */ #if defined(hp9000s300) || defined(__hp9000s300) + #if defined(hp9000s400) || defined(__hp9000s400) -#define MACHINE_TYPE "hp9000s400" +# define MACHINE_TYPE "hp9000s400" #else -#define MACHINE_TYPE "hp9000s300" +# define MACHINE_TYPE "hp9000s300" #endif + #ifdef MC68010 -#define FASL_INTERNAL_FORMAT FASL_68000 +# define CURRENT_FASL_ARCH FASL_68000 #else -#define FASL_INTERNAL_FORMAT FASL_68020 +# define CURRENT_FASL_ARCH FASL_68020 #endif -#define HEAP_IN_LOW_MEMORY + +#define PC_ZERO_BITS 1 +#define HEAP_IN_LOW_MEMORY 1 #endif /* hp9000s300 */ #ifdef hp9000s500 #define MACHINE_TYPE "hp9000s500" -#define FASL_INTERNAL_FORMAT FASL_HP_9000_500 +#define CURRENT_FASL_ARCH FASL_HP_9000_500 /* An unfortunate fact of life on this machine: the C heap is in high memory thus HEAP_IN_LOW_MEMORY is not defined and the whole thing runs slowly. */ -/* C Compiler bug when constant folding and anchor pointing */ -#define And2(x, y) ((x) ? (y) : false) -#define And3(x, y, z) ((x) ? ((y) ? (z) : false) : false) -#define Or2(x, y) ((x) ? true : (y)) -#define Or3(x, y, z) ((x) ? true : ((y) ? true : (z))) - #endif /* hp9000s500 */ #ifdef sparc # define MACHINE_TYPE "sun4" -# define FASL_INTERNAL_FORMAT FASL_SPARC +# define CURRENT_FASL_ARCH FASL_SPARC # define FLOATING_ALIGNMENT 0x7 # define HEAP_IN_LOW_MEMORY # define HAVE_DOUBLE_TO_LONG_BUG @@ -272,21 +369,21 @@ typedef unsigned long SCHEME_OBJECT; #ifdef sun3 # define MACHINE_TYPE "sun3" -# define FASL_INTERNAL_FORMAT FASL_68020 +# define CURRENT_FASL_ARCH FASL_68020 # define HEAP_IN_LOW_MEMORY # define HAVE_DOUBLE_TO_LONG_BUG #endif #ifdef sun2 # define MACHINE_TYPE "sun2" -# define FASL_INTERNAL_FORMAT FASL_68000 +# define CURRENT_FASL_ARCH FASL_68000 # define HEAP_IN_LOW_MEMORY # define HAVE_DOUBLE_TO_LONG_BUG #endif #ifdef NeXT # define MACHINE_TYPE "next" -# define FASL_INTERNAL_FORMAT FASL_68020 +# define CURRENT_FASL_ARCH FASL_68020 # define HEAP_IN_LOW_MEMORY #endif @@ -296,8 +393,9 @@ typedef unsigned long SCHEME_OBJECT; #ifdef __IA32__ -#define FASL_INTERNAL_FORMAT FASL_IA32 -#define HEAP_IN_LOW_MEMORY +#define CURRENT_FASL_ARCH FASL_IA32 +#define PC_ZERO_BITS 0 +#define HEAP_IN_LOW_MEMORY 1 #ifdef sequent # define MACHINE_TYPE "sequent386" @@ -311,20 +409,17 @@ typedef unsigned long SCHEME_OBJECT; # define MACHINE_TYPE "IA-32" #endif -#ifdef NATIVE_CODE_IS_C -#undef HEAP_IN_LOW_MEMORY -#endif - #endif /* __IA32__ */ #ifdef mips #define MACHINE_TYPE "mips" -#define FASL_INTERNAL_FORMAT FASL_MIPS +#define CURRENT_FASL_ARCH FASL_MIPS +#define PC_ZERO_BITS 2 #define FLOATING_ALIGNMENT 0x7 -#if defined(_IRIX6) && defined(HAS_COMPILER_SUPPORT) && !defined(NATIVE_CODE_IS_C) - extern void * irix_heap_malloc (long); +#ifdef _IRIX6 + extern void * irix_heap_malloc (unsigned long); # define HEAP_MALLOC irix_heap_malloc #endif @@ -342,46 +437,32 @@ typedef unsigned long SCHEME_OBJECT; ((SCHEME_OBJECT) (((unsigned long) (address)) & (~(MIPS_DATA_BIT)))) /* MIPS compiled binaries are large! */ -#ifdef HAS_COMPILER_SUPPORT - #ifndef DEFAULT_SMALL_CONSTANT -#define DEFAULT_SMALL_CONSTANT 700 +# define DEFAULT_SMALL_CONSTANT 700 #endif #ifndef DEFAULT_LARGE_CONSTANT -#define DEFAULT_LARGE_CONSTANT 1500 +# define DEFAULT_LARGE_CONSTANT 1500 #endif -#endif /* HAS_COMPILER_SUPPORT */ - #endif /* mips */ #ifdef __alpha -#define MACHINE_TYPE "Alpha" -#define FASL_INTERNAL_FORMAT FASL_ALPHA -#define TYPE_CODE_LENGTH 8 - -/* The ASCII character set is used. */ -#define HEAP_IN_LOW_MEMORY 1 +#define MACHINE_TYPE "Alpha" +#define CURRENT_FASL_ARCH FASL_ALPHA +#define PC_ZERO_BITS 2 +#define HEAP_IN_LOW_MEMORY 1 /* Flonums have no special alignment constraints. */ -#define FLONUM_MANTISSA_BITS 53 -#define FLONUM_EXPT_SIZE 10 -#define MAX_FLONUM_EXPONENT 1023 +#define FLONUM_MANTISSA_BITS 53 +#define FLONUM_EXPT_SIZE 10 +#define MAX_FLONUM_EXPONENT 1023 /* Floating point representation uses hidden bit. */ -#if defined(HAS_COMPILER_SUPPORT) && !defined(NATIVE_CODE_IS_C) - extern void * alpha_heap_malloc (long); -# define HEAP_MALLOC alpha_heap_malloc -#endif +extern void * alpha_heap_malloc (unsigned long); +#define HEAP_MALLOC alpha_heap_malloc #endif /* __alpha */ - -#if defined(USE_MMAP_HEAP_MALLOC) && defined(HEAP_IN_LOW_MEMORY) - extern void * mmap_heap_malloc (unsigned long); -# define HEAP_MALLOC mmap_heap_malloc -# define HEAP_FREE(address) -#endif #ifdef __OS2__ @@ -404,11 +485,13 @@ extern void OS2_stack_reset (void); extern int OS2_stack_overflowed_p (void); #define STACK_OVERFLOWED_P OS2_stack_overflowed_p +#define CC_ARCH_INITIALIZE i386_interface_initialize + #endif /* __OS2__ */ #ifdef __WIN32__ -extern void EXFUN (win32_stack_reset, (void)); +extern void win32_stack_reset (void); #define STACK_RESET win32_stack_reset #define HEAP_MALLOC(size) (WIN32_ALLOCATE_HEAP ((size), (&scheme_heap_handle))) @@ -426,7 +509,7 @@ extern void EXFUN (win32_stack_reset, (void)); #ifdef pdp10 #define MACHINE_TYPE "pdp10" -#define FASL_INTERNAL_FORMAT FASL_PDP10 +#define CURRENT_FASL_ARCH FASL_PDP10 #define HEAP_IN_LOW_MEMORY #define CHAR_BIT 36 / * Ugh! Supposedly fixed in newer Cs * / #define UNSIGNED_SHIFT_BUG @@ -434,7 +517,7 @@ extern void EXFUN (win32_stack_reset, (void)); #ifdef nu #define MACHINE_TYPE "nu" -#define FASL_INTERNAL_FORMAT FASL_68000 +#define CURRENT_FASL_ARCH FASL_68000 #define HEAP_IN_LOW_MEMORY #define UNSIGNED_SHIFT_BUG #endif @@ -443,14 +526,14 @@ extern void EXFUN (win32_stack_reset, (void)); #ifdef butterfly #define MACHINE_TYPE "butterfly" -#define FASL_INTERNAL_FORMAT FASL_BFLY +#define CURRENT_FASL_ARCH FASL_BFLY #define HEAP_IN_LOW_MEMORY #include #endif #ifdef cyber180 #define MACHINE_TYPE "cyber180" -#define FASL_INTERNAL_FORMAT FASL_CYBER +#define CURRENT_FASL_ARCH FASL_CYBER #define HEAP_IN_LOW_MEMORY #define UNSIGNED_SHIFT_BUG /* The Cyber180 C compiler manifests a bug in hairy conditional expressions */ @@ -459,73 +542,77 @@ extern void EXFUN (win32_stack_reset, (void)); #ifdef celerity #define MACHINE_TYPE "celerity" -#define FASL_INTERNAL_FORMAT FASL_CELERITY +#define CURRENT_FASL_ARCH FASL_CELERITY #define HEAP_IN_LOW_MEMORY #endif #ifdef umax #define MACHINE_TYPE "umax" -#define FASL_INTERNAL_FORMAT FASL_UMAX +#define CURRENT_FASL_ARCH FASL_UMAX #define HEAP_IN_LOW_MEMORY #endif #ifdef pyr #define MACHINE_TYPE "pyramid" -#define FASL_INTERNAL_FORMAT FASL_PYR +#define CURRENT_FASL_ARCH FASL_PYR #define HEAP_IN_LOW_MEMORY #endif #ifdef alliant #define MACHINE_TYPE "alliant" -#define FASL_INTERNAL_FORMAT FASL_ALLIANT +#define CURRENT_FASL_ARCH FASL_ALLIANT #define HEAP_IN_LOW_MEMORY #endif #ifdef apollo #if _ISP__M68K #define MACHINE_TYPE "Apollo 68k" -#define FASL_INTERNAL_FORMAT FASL_APOLLO_68K +#define CURRENT_FASL_ARCH FASL_APOLLO_68K #else #define MACHINE_TYPE "Apollo Prism" -#define FASL_INTERNAL_FORMAT FASL_APOLLO_PRISM +#define CURRENT_FASL_ARCH FASL_APOLLO_PRISM #endif #define HEAP_IN_LOW_MEMORY #endif #ifdef _IBMR2 #define MACHINE_TYPE "IBM RS6000" -#define FASL_INTERNAL_FORMAT FASL_RS6000 +#define CURRENT_FASL_ARCH FASL_RS6000 /* Heap is not in Low Memory. */ #define FLONUM_MANTISSA_BITS 53 #define FLONUM_EXPT_SIZE 10 #define MAX_FLONUM_EXPONENT 1023 #endif - + #ifdef __ppc__ -#define MACHINE_TYPE "PowerPC-32" -#define FASL_INTERNAL_FORMAT FASL_PPC32 -#define FLOATING_ALIGNMENT 0x7 +# define MACHINE_TYPE "PowerPC-32" +# define CURRENT_FASL_ARCH FASL_PPC32 +# define FLOATING_ALIGNMENT 0x7 #endif #ifdef __ppc64__ -#define MACHINE_TYPE "PowerPC-64" -#define FASL_INTERNAL_FORMAT FASL_PPC64 +# define MACHINE_TYPE "PowerPC-64" +# define CURRENT_FASL_ARCH FASL_PPC64 #endif #ifdef __x86_64__ -#define MACHINE_TYPE "x86-64" -#define FASL_INTERNAL_FORMAT FASL_X86_64 +# define MACHINE_TYPE "x86-64" +# define CURRENT_FASL_ARCH FASL_X86_64 #endif #ifdef __ia64__ -#define MACHINE_TYPE "ia64" -#define FASL_INTERNAL_FORMAT FASL_IA64 +# define MACHINE_TYPE "ia64" +# define CURRENT_FASL_ARCH FASL_IA64 #endif -#ifdef NATIVE_CODE_IS_C -# ifndef HAS_COMPILER_SUPPORT -# define HAS_COMPILER_SUPPORT -# endif +#ifdef sonyrisc + /* On the Sony NEWS 3250, this procedure initializes the + floating-point CPU control register to enable the IEEE traps. + This is normally executed by 'compiler_reset' from LOAD-BAND, + but the Sony operating system saves the control register in + 'setjmp' and restores it on 'longjmp', so we must initialize + the register before 'setjmp' is called. */ +#define CC_ARCH_INITIALIZE interface_initialize #endif /* Make sure that some definition applies. If this error occurs, and @@ -535,16 +622,23 @@ extern void EXFUN (win32_stack_reset, (void)); # include "Error: confshared.h: Unknown configuration." #endif +#ifndef PC_ZERO_BITS +# ifdef CC_IS_NATIVE +# include "Error: confshared.h: Unknown PC alignment." +# else +# define PC_ZERO_BITS 0 +# endif +#endif + +#define PC_ALIGNED_P(pc) \ + ((((unsigned long) (pc)) & ((1 << PC_ZERO_BITS) - 1)) == 0) + /* Virtually all machines have 8-bit characters these days, so don't explicitly specify this value unless it is different. */ #ifndef CHAR_BIT # define CHAR_BIT 8 #endif -#ifndef TYPE_CODE_LENGTH -# define TYPE_CODE_LENGTH 6 -#endif - /* The GNU C compiler does not have any of these bugs. */ #ifdef __GNUC__ # undef HAVE_DOUBLE_TO_LONG_BUG @@ -552,4 +646,14 @@ extern void EXFUN (win32_stack_reset, (void)); # undef Conditional_Bug #endif +#ifdef NO_HEAP_IN_LOW_MEMORY +# undef HEAP_IN_LOW_MEMORY +#endif + +#if defined(USE_MMAP_HEAP_MALLOC) && defined(HEAP_IN_LOW_MEMORY) + extern void * mmap_heap_malloc (unsigned long); +# define HEAP_MALLOC mmap_heap_malloc +# define HEAP_FREE(address) +#endif + #endif /* SCM_CONFSHARED_H */ diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h index c9cda5617..755e08cd5 100644 --- a/v7/src/microcode/const.h +++ b/v7/src/microcode/const.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: const.h,v 9.55 2007/01/05 21:19:25 cph Exp $ +$Id: const.h,v 9.56 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -27,78 +27,38 @@ USA. /* Named constants used throughout the interpreter */ -#if (CHAR_BIT != 8) -#define MAX_CHAR ((1< 0) { - if ((FAST_PAIR_CAR (*bucket)) == SHARP_T) + if ((PAIR_CAR (*bucket)) == SHARP_T) splice_and_rehash_bucket ((PAIR_CDR_LOC (*bucket)), (ARG_REF (2)), table_size); else diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index cedbbc294..6616e81a0 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: debug.c,v 9.60 2007/01/05 21:19:25 cph Exp $ +$Id: debug.c,v 9.61 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -32,19 +32,47 @@ USA. #include "trap.h" #include "lookup.h" -static void EXFUN (do_printing, (outf_channel, SCHEME_OBJECT, Boolean)); -static Boolean EXFUN (print_primitive_name, (outf_channel, SCHEME_OBJECT)); -static void EXFUN (print_expression, (outf_channel, SCHEME_OBJECT, char *)); +#ifdef CC_SUPPORT_P + static SCHEME_OBJECT compiled_entry_debug_filename (SCHEME_OBJECT); + static SCHEME_OBJECT compiled_block_debug_filename (SCHEME_OBJECT); +#endif + +static void do_printing (outf_channel, SCHEME_OBJECT, bool); +static bool print_primitive_name (outf_channel, SCHEME_OBJECT); +static void print_expression (outf_channel, SCHEME_OBJECT, char *); /* Compiled Code Debugging */ +#ifdef CC_SUPPORT_P + +char * +compiled_entry_filename (SCHEME_OBJECT entry) +{ + SCHEME_OBJECT result = (compiled_entry_debug_filename (entry)); + return + ((STRING_P (result)) + ? (STRING_POINTER (result)) + : (PAIR_P (result)) + ? (STRING_POINTER (PAIR_CAR (result))) + : "**** filename not known ****"); +} + static SCHEME_OBJECT -DEFUN (compiled_block_debug_filename, (block), SCHEME_OBJECT block) +compiled_entry_debug_filename (SCHEME_OBJECT entry) +{ + return + (compiled_block_debug_filename + (cc_entry_to_block ((cc_entry_closure_p (entry)) + ? (cc_closure_to_entry (entry)) + : entry))); +} + +static SCHEME_OBJECT +compiled_block_debug_filename (SCHEME_OBJECT block) { - extern SCHEME_OBJECT EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT)); SCHEME_OBJECT info; - info = (compiled_block_debugging_info (block)); + info = (cc_block_debugging_info (block)); return (((STRING_P (info)) || ((PAIR_P (info)) && @@ -54,122 +82,10 @@ DEFUN (compiled_block_debug_filename, (block), SCHEME_OBJECT block) : SHARP_F); } -extern void - EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *)); - -extern long - EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT)), - EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT)); - -extern SCHEME_OBJECT - * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT)), - EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT)); - -#define COMPILED_ENTRY_TO_BLOCK(entry) \ -(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, \ - (compiled_entry_to_block_address (entry)))) - -static SCHEME_OBJECT -DEFUN (compiled_entry_debug_filename, (entry), SCHEME_OBJECT entry) -{ - long results [3]; - - compiled_entry_type (entry, (& (results [0]))); - if (((results [0]) == 0) && (compiled_entry_closure_p (entry))) - entry = (compiled_closure_to_entry (entry)); - return (compiled_block_debug_filename (COMPILED_ENTRY_TO_BLOCK (entry))); -} - -char * -DEFUN (compiled_entry_filename, (entry), SCHEME_OBJECT entry) -{ - SCHEME_OBJECT result; - - result = (compiled_entry_debug_filename (entry)); - if (STRING_P (result)) - return ((char *) (STRING_LOC ((result), 0))); - else if (PAIR_P (result)) - return ((char *) (STRING_LOC ((PAIR_CAR (result)), 0))); - else - return ("**** filename not known ****"); -} +#endif /* CC_SUPPORT_P */ void -DEFUN_VOID (Show_Pure) -{ - SCHEME_OBJECT *Obj_Address; - long Pure_Size, Total_Size; - - Obj_Address = Constant_Space; - while (true) - { - if (Obj_Address > Free_Constant) - { - outf_console ("Past end of area.\n"); - return; - } - if (Obj_Address == Free_Constant) - { - outf_console ("Done.\n"); - return; - } - Pure_Size = OBJECT_DATUM (*Obj_Address); - Total_Size = OBJECT_DATUM (Obj_Address[1]); - outf_console ("0x%lx: pure=0x%lx, total=0x%lx\n", - ((long) Obj_Address), ((long) Pure_Size), ((long) Total_Size)); - if (OBJECT_TYPE (*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR) - { - outf_console ("Missing initial SNMV.\n"); - return; - } - if (OBJECT_TYPE (Obj_Address[1]) != PURE_PART) - { - outf_console ("Missing subsequent pure header.\n"); - } - if (OBJECT_TYPE (Obj_Address[Pure_Size-1]) != - TC_MANIFEST_SPECIAL_NM_VECTOR) - { - outf_console ("Missing internal SNMV.\n"); - return; - } - if (OBJECT_TYPE (Obj_Address[Pure_Size]) != CONSTANT_PART) - { - outf_console ("Missing constant header.\n"); - return; - } - if (((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))) != Pure_Size) - { - outf_console ("Pure size mismatch 0x%lx.\n", - ((long) (OBJECT_DATUM (Obj_Address[Pure_Size])))); - } - if (OBJECT_TYPE (Obj_Address[Total_Size-1]) != - TC_MANIFEST_SPECIAL_NM_VECTOR) - { - outf_console ("Missing ending SNMV.\n"); - return; - } - if (OBJECT_TYPE (Obj_Address[Total_Size]) != END_OF_BLOCK) - { - outf_console ("Missing ending header.\n"); - return; - } - if (((long) (OBJECT_DATUM (Obj_Address[Total_Size]))) != Total_Size) - { - outf_console ("Total size mismatch 0x%lx.\n", - ((long) (OBJECT_DATUM (Obj_Address[Total_Size])))); - } - Obj_Address += Total_Size+1; -#ifdef FLOATING_ALIGNMENT - while (*Obj_Address == MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)) - { - Obj_Address += 1; - } -#endif - } -} - -void -DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) +Show_Env (SCHEME_OBJECT The_Env) { SCHEME_OBJECT *name_ptr, procedure, *value_ptr, extension; long count, i; @@ -180,7 +96,7 @@ DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) if (FRAME_EXTENSION_P (procedure)) { extension = procedure; - procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE); + procedure = MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE); } else extension = SHARP_F; @@ -188,7 +104,7 @@ DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) if ((OBJECT_TYPE (procedure) != TC_PROCEDURE) && (OBJECT_TYPE (procedure) != TC_EXTENDED_PROCEDURE)) { - outf_console ("Not created by a procedure"); + outf_error ("Not created by a procedure"); return; } name_ptr = MEMORY_LOC (procedure, PROCEDURE_LAMBDA_EXPR); @@ -200,11 +116,11 @@ DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) { Print_Expression (*name_ptr++, "Name "); Print_Expression (*value_ptr++, " Value "); - outf_console ("\n"); + outf_error ("\n"); } if (extension != SHARP_F) { - outf_console ("Auxiliary Variables\n"); + outf_error ("Auxiliary Variables\n"); count = (GET_FRAME_EXTENSION_LENGTH (extension)); for (i = 0, name_ptr = (GET_FRAME_EXTENSION_BINDINGS (extension)); i < count; @@ -212,13 +128,13 @@ DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env) { Print_Expression ((PAIR_CAR (*name_ptr)), "Name "); Print_Expression ((PAIR_CDR (*name_ptr)), " Value "); - outf_console ("\n"); + outf_error ("\n"); } } } static void -DEFUN (print_list, (stream, pair), outf_channel stream AND SCHEME_OBJECT pair) +print_list (outf_channel stream, SCHEME_OBJECT pair) { int count; @@ -245,40 +161,34 @@ DEFUN (print_list, (stream, pair), outf_channel stream AND SCHEME_OBJECT pair) } } outf (stream, ")"); - return; } static void -DEFUN (print_return_name, (stream, Ptr), outf_channel stream AND SCHEME_OBJECT Ptr) +print_return_name (outf_channel stream, SCHEME_OBJECT Ptr) { - long index; - char * name; - - index = (OBJECT_DATUM (Ptr)); + unsigned long index = (OBJECT_DATUM (Ptr)); if (index <= MAX_RETURN) { - name = (Return_Names [index]); - if ((name != ((char *) 0)) && - ((name [0]) != '\0')) + const char * name = (Return_Names[index]); + if ((name != 0) && ((name[0]) != '\0')) { outf (stream, "%s", name); return; } } outf (stream, "[0x%lx]", index); - return; } void -DEFUN (Print_Return, (String), char * String) +Print_Return (char * String) { - outf_console ("%s: ", String); - print_return_name (console_output, ret_register); - outf_console ("\n"); + outf_error ("%s: ", String); + print_return_name (ERROR_OUTPUT, GET_RET); + outf_error ("\n"); } static void -DEFUN (print_string, (stream, string), outf_channel stream AND SCHEME_OBJECT string) +print_string (outf_channel stream, SCHEME_OBJECT string) { long length; long i; @@ -287,7 +197,7 @@ DEFUN (print_string, (stream, string), outf_channel stream AND SCHEME_OBJECT str outf (stream, "\""); length = (STRING_LENGTH (string)); - next = ((char *) (STRING_LOC (string, 0))); + next = (STRING_POINTER (string)); for (i = 0; (i < length); i += 1) { this = (*next++); @@ -317,28 +227,36 @@ DEFUN (print_string, (stream, string), outf_channel stream AND SCHEME_OBJECT str } } outf (stream, "\""); - return; } static void -DEFUN (print_symbol, (stream, symbol), outf_channel stream AND SCHEME_OBJECT symbol) +print_symbol (outf_channel stream, SCHEME_OBJECT symbol) { SCHEME_OBJECT string; - long length; - long i; + unsigned long length; + unsigned long limit; + unsigned long i; char * next; string = (MEMORY_REF (symbol, SYMBOL_NAME)); length = (STRING_LENGTH (string)); - next = ((char *) (STRING_LOC (string, 0))); - for (i = 0; (i < length); i += 1) - outf(stream, "%c", *next++); /*should use %s? */ - return; + limit = ((length > 64) ? 64 : length); + next = (STRING_POINTER (string)); + for (i = 0; (i < limit); i += 1) + { + int c = (*next++); + if (c < 0x80) + outf (stream, "%c", c); + else + outf (stream, "\\x%02x", c); + } + if (limit < length) + outf (stream, "..."); } +#ifdef CC_SUPPORT_P static void -DEFUN (print_filename, (stream, filename), - outf_channel stream AND SCHEME_OBJECT filename) +print_filename (outf_channel stream, SCHEME_OBJECT filename) { long length; char * scan; @@ -346,23 +264,22 @@ DEFUN (print_filename, (stream, filename), char * slash; length = (STRING_LENGTH (filename)); - scan = ((char *) (STRING_LOC (filename, 0))); + scan = (STRING_POINTER (filename)); end = (scan + length); slash = scan; while (scan < end) if ((*scan++) == '/') slash = scan; outf (stream, "\"%s\"", slash); - return; } +#endif static void -DEFUN (print_object, (object), SCHEME_OBJECT object) +print_object (SCHEME_OBJECT object) { - do_printing (console_output, object, true); - outf_console ("\n"); - outf_flush_console(); - return; + do_printing (ERROR_OUTPUT, object, true); + outf_error ("\n"); + outf_flush_error(); } DEFINE_PRIMITIVE ("DEBUGGING-PRINTER", Prim_debugging_printer, 1, 1, @@ -375,8 +292,7 @@ DEFINE_PRIMITIVE ("DEBUGGING-PRINTER", Prim_debugging_printer, 1, 1, } static void -DEFUN (print_objects, (objects, n), - SCHEME_OBJECT * objects AND int n) +print_objects (SCHEME_OBJECT * objects, int n) { SCHEME_OBJECT * scan; SCHEME_OBJECT * end; @@ -385,12 +301,11 @@ DEFUN (print_objects, (objects, n), end = (objects + n); while (scan < end) { - outf_console ("%4x: ", (((char *) scan) - ((char *) objects))); - do_printing (console_output, (*scan++), true); - outf_console ("\n"); + outf_error ("%4x: ", (((char *) scan) - ((char *) objects))); + do_printing (ERROR_OUTPUT, (*scan++), true); + outf_error ("\n"); } - outf_flush_console(); - return; + outf_flush_error(); } /* This is useful because `do_printing' doesn't print the contents of @@ -399,47 +314,50 @@ DEFUN (print_objects, (objects, n), be printed out explicitly. */ void -DEFUN (Print_Vector, (vector), SCHEME_OBJECT vector) +Print_Vector (SCHEME_OBJECT vector) { print_objects ((MEMORY_LOC (vector, 1)), (OBJECT_DATUM (VECTOR_LENGTH (vector)))); } static void -DEFUN (print_expression, (stream, expression, string), - outf_channel stream AND SCHEME_OBJECT expression AND char * string) +print_expression (outf_channel stream, SCHEME_OBJECT expression, char * string) { if ((string [0]) != 0) outf (stream, "%s: ", string); do_printing (stream, expression, true); - return; } void -DEFUN (Print_Expression, (expression, string), - SCHEME_OBJECT expression AND char * string) +Print_Expression (SCHEME_OBJECT expression, char * string) { - print_expression (console_output, expression, string); - return; + print_expression (ERROR_OUTPUT, expression, string); } -extern char * Type_Names []; - static void -DEFUN (do_printing, (stream, Expr, Detailed), - outf_channel stream AND SCHEME_OBJECT Expr AND Boolean Detailed) +do_printing (outf_channel stream, SCHEME_OBJECT Expr, bool Detailed) { - long Temp_Address; - Boolean handled_p; - - Temp_Address = (OBJECT_DATUM (Expr)); - handled_p = false; + long Temp_Address = (OBJECT_DATUM (Expr)); + bool handled_p = false; if (EMPTY_LIST_P (Expr)) { outf (stream, "()"); return; } else if (Expr == SHARP_F) { outf (stream, "#F"); return; } else if (Expr == SHARP_T) { outf (stream, "#T"); return; } else if (Expr == UNSPECIFIC) { outf (stream, "[UNSPECIFIC]"); return; } + else if (Expr == return_to_interpreter) + { + outf (stream, "[RETURN_TO_INTERPRETER]"); + return; + } + + else if (Expr == reflect_to_interface) + { + outf (stream, "[REFLECT_TO_INTERFACE]"); + return; + } + + switch (OBJECT_TYPE (Expr)) { case TC_ACCESS: @@ -467,7 +385,7 @@ DEFUN (do_printing, (stream, Expr, Detailed), Expr = (MEMORY_REF (Expr, DEFINE_NAME)); goto SPrint; - case_TC_FIXNUMs: + case TC_FIXNUM: outf (stream, "%ld", ((long) (FIXNUM_TO_LONG (Expr)))); return; @@ -615,44 +533,62 @@ DEFUN (do_printing, (stream, Expr, Detailed), case TC_CONSTANT: break; +#ifdef CC_SUPPORT_P case TC_COMPILED_ENTRY: { - long results [3]; - char * type_string; + SCHEME_OBJECT entry = Expr; + bool closure_p = false; + cc_entry_type_t cet; + const char * type_string; SCHEME_OBJECT filename; - SCHEME_OBJECT entry; - Boolean closure_p; - - entry = Expr; - closure_p = false; - compiled_entry_type (entry, (& (results [0]))); - switch (results [0]) - { - case 0: - if (compiled_entry_closure_p (entry)) - { - type_string = "COMPILED_CLOSURE"; - entry = (compiled_closure_to_entry (entry)); - closure_p = true; - } - else - type_string = "COMPILED_PROCEDURE"; - break; - case 1: - type_string = "COMPILED_RETURN_ADDRESS"; - break; - case 2: - type_string = "COMPILED_EXPRESSION"; - break; - default: - type_string = "COMPILED_ENTRY"; - break; - } - outf (stream, "[%s offset: 0x%lx entry: 0x%lx", - type_string, - ((long) (compiled_entry_to_block_offset (entry))), - ((long) (OBJECT_DATUM (entry)))); + if (read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (entry)))) + type_string = "UNKNOWN"; + else + switch (cet.marker) + { + case CET_PROCEDURE: + case CET_CLOSURE: + if (cc_entry_closure_p (entry)) + { + type_string = "COMPILED_CLOSURE"; + entry = (cc_closure_to_entry (entry)); + closure_p = true; + } + else + type_string = "COMPILED_PROCEDURE"; + break; + + case CET_CONTINUATION: + type_string = "COMPILED_RETURN_ADDRESS"; + break; + + case CET_EXPRESSION: + type_string = "COMPILED_EXPRESSION"; + break; + + case CET_INTERNAL_CONTINUATION: + type_string = "COMPILED_RETURN_ADDRESS"; + break; + + case CET_INTERNAL_PROCEDURE: + case CET_TRAMPOLINE: + type_string = "COMPILED_ENTRY"; + break; + + case CET_RETURN_TO_INTERPRETER: + type_string = "COMPILED_RETURN_ADDRESS"; + break; + + default: + type_string = "COMPILED_ENTRY"; + break; + } + + outf (stream, "[%s offset: %#lx entry: %#lx", + type_string, + (cc_entry_to_block_offset (entry)), + (OBJECT_DATUM (entry))); if (closure_p) outf (stream, " address: 0x%lx", ((long) Temp_Address)); @@ -672,141 +608,127 @@ DEFUN (do_printing, (stream, Expr, Detailed), outf (stream, "]"); return; } +#endif default: break; } - if (! handled_p) + if (!handled_p) { - if ((OBJECT_TYPE (Expr)) <= LAST_TYPE_CODE) - outf (stream, "[%s", (Type_Names [OBJECT_TYPE (Expr)])); + unsigned int type = (OBJECT_TYPE (Expr)); + const char * name = 0; + if ((OBJECT_TYPE (Expr)) < TYPE_CODE_LIMIT) + name = (type_names[type]); + if (name != 0) + outf (stream, "[%s", name); else - outf (stream, "[0x%02x", (OBJECT_TYPE (Expr))); + outf (stream, "[%#02x", type); } - outf (stream, " 0x%lx]", ((long) Temp_Address)); - return; + outf (stream, " %#lx]", ((unsigned long) Temp_Address)); } extern void -DEFUN (Debug_Print, (Expr, Detailed), - SCHEME_OBJECT Expr AND Boolean Detailed) +Debug_Print (SCHEME_OBJECT Expr, bool Detailed) { - do_printing(console_output, Expr, Detailed); - outf_flush_console (); - return; + do_printing (ERROR_OUTPUT, Expr, Detailed); + outf_error ("\n"); + outf_flush_error (); } -static Boolean -DEFUN (print_one_continuation_frame, (stream, Temp), - outf_channel stream AND SCHEME_OBJECT Temp) +static bool +print_one_continuation_frame (outf_channel stream, SCHEME_OBJECT Temp) { SCHEME_OBJECT Expr; + outf (stream, "\n "); print_expression (stream, Temp, "Return code"); - outf (stream, "\n"); + outf (stream, "\n "); Expr = (STACK_POP ()); print_expression (stream, Expr, "Expression"); outf (stream, "\n"); - if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) || - ((OBJECT_DATUM (Temp)) == RC_HALT)) + if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) + || ((OBJECT_DATUM (Temp)) == RC_HALT)) return (true); if ((OBJECT_DATUM (Temp)) == RC_JOIN_STACKLETS) - sp_register = (Previous_Stack_Pointer (Expr)); + stack_pointer = (control_point_start (Expr)); return (false); } -extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT)); +extern bool Print_One_Continuation_Frame (SCHEME_OBJECT); -Boolean -DEFUN (Print_One_Continuation_Frame, (Temp), SCHEME_OBJECT Temp) +bool +Print_One_Continuation_Frame (SCHEME_OBJECT Temp) { - return (print_one_continuation_frame (console_output, Temp)); + return (print_one_continuation_frame (ERROR_OUTPUT, Temp)); } -/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the - stack; (b) Save_Cont pushes the expression first. - */ +/* Back_Trace relies on (a) only a call to SAVE_CONT puts a return code on the + stack; (b) SAVE_CONT pushes the expression first. */ void -DEFUN (Back_Trace, (stream), outf_channel stream) +Back_Trace (outf_channel stream) { SCHEME_OBJECT Temp, * Old_Stack; - Back_Trace_Entry_Hook(); - Old_Stack = sp_register; + Old_Stack = stack_pointer; while (true) - { - if ((STACK_LOCATIVE_DIFFERENCE (Stack_Top, (STACK_LOC (0)))) <= 0) - { - if ((STACK_LOC (0)) == Old_Stack) - outf (stream, "\n[Invalid stack pointer.]\n"); - else - outf (stream, "\n[Stack ends abruptly.]\n"); - break; - } - if (Return_Hook_Address == (STACK_LOC (0))) { +#if 0 + /* Not useful since this code prints the contents of control + points as well. */ + if (!ADDRESS_IN_STACK_P (stack_pointer)) + { + if (stack_pointer == Old_Stack) + outf (stream, "\n[Invalid stack pointer.]\n"); + else + outf (stream, "\n[Stack ends abruptly.]\n"); + break; + } +#endif Temp = (STACK_POP ()); - if (Temp != (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT))) - { - outf (stream, "\n--> Return trap is missing here <--\n"); - } + outf (stream, "{%#lx}", ((unsigned long) stack_pointer)); + if (RETURN_CODE_P (Temp)) + { + if (print_one_continuation_frame (stream, Temp)) + break; + } else - { - outf (stream, "\n[Return trap found here as expected]\n"); - Temp = Old_Return_Code; - } - } - else - { - Temp = (STACK_POP ()); - } - if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE) - { - outf (stream, "{0x%x}", STACK_LOC(0)); - if (print_one_continuation_frame (stream, Temp)) - break; - } - else - { - outf (stream, "{0x%x}", STACK_LOC(0)); - print_expression (stream, Temp, " ..."); - if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR) - { - sp_register = (STACK_LOC (- ((long) (OBJECT_DATUM (Temp))))); - outf (stream, " (skipping)"); - } - outf (stream, "\n"); + { + print_expression (stream, Temp, " ..."); + if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR) + { + outf (stream, " (skipping)"); + stack_pointer = (STACK_LOC (OBJECT_DATUM (Temp))); + } + outf (stream, "\n"); + } } - } - sp_register = Old_Stack; - Back_Trace_Exit_Hook(); + stack_pointer = Old_Stack; outf_flush (stream); } void -DEFUN (print_stack, (sp), SCHEME_OBJECT * sp) +print_stack (SCHEME_OBJECT * sp) { - SCHEME_OBJECT * saved_sp = sp_register; - sp_register = sp; - Back_Trace (console_output); - sp_register = saved_sp; + SCHEME_OBJECT * saved_sp = stack_pointer; + stack_pointer = sp; + Back_Trace (ERROR_OUTPUT); + stack_pointer = saved_sp; } extern void -DEFUN_VOID(Debug_Stack_Trace) +Debug_Stack_Trace(void) { print_stack(STACK_LOC(0)); } -static Boolean -DEFUN (print_primitive_name, (stream, primitive), - outf_channel stream AND SCHEME_OBJECT primitive) +static bool +print_primitive_name (outf_channel stream, SCHEME_OBJECT primitive) { - CONST char * name = (PRIMITIVE_NAME (primitive)); + const char * name = (PRIMITIVE_NAME (primitive)); if (name == 0) { - outf (stream, "Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive)); + outf (stream, "Unknown primitive %#08lx", (PRIMITIVE_NUMBER (primitive))); return false; } else @@ -817,33 +739,32 @@ DEFUN (print_primitive_name, (stream, primitive), } void -DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive) +Print_Primitive (SCHEME_OBJECT primitive) { char buffer[40]; int NArgs, i; - outf_console ("Primitive: "); - if (print_primitive_name (console_output, primitive)) + outf_error ("Primitive: "); + if (print_primitive_name (ERROR_OUTPUT, primitive)) NArgs = (PRIMITIVE_ARITY (primitive)); else NArgs = 3; /* Unknown primitive */ - outf_console ("\n"); + outf_error ("\n"); for (i = 0; i < NArgs; i++) { sprintf (buffer, "...Arg %ld", ((long) (i + 1))); - print_expression (console_output, (STACK_REF (i)), buffer); - outf_console ("\n"); + print_expression (ERROR_OUTPUT, (STACK_REF (i)), buffer); + outf_error ("\n"); } - return; } /* Code for interactively setting and clearing the interpreter debugging flags. Invoked via the "D" command to the ^C handler or during each FASLOAD. */ -#ifdef ENABLE_DEBUGGING_FLAGS +#ifdef ENABLE_DEBUGGING_TOOLS #ifndef MORE_DEBUG_FLAG_CASES #define MORE_DEBUG_FLAG_CASES() @@ -876,14 +797,13 @@ DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive) #define D_TRACE_ON_ERROR 12 #define D_PER_FILE 13 #define D_BIGNUM 14 -#define D_FLUIDS 15 #ifndef LAST_SWITCH -#define LAST_SWITCH D_FLUIDS +#define LAST_SWITCH D_BIGNUM #endif -static Boolean * -DEFUN (find_flag, (flag_number), int flag_number) +static bool * +find_flag (int flag_number) { switch (flag_number) { @@ -902,14 +822,13 @@ DEFUN (find_flag, (flag_number), int flag_number) case D_TRACE_ON_ERROR: return (&Trace_On_Error); case D_PER_FILE: return (&Per_File); case D_BIGNUM: return (&Bignum_Debug); - case D_FLUIDS: return (&Fluids_Debug); MORE_DEBUG_FLAG_CASES (); default: return (0); } } static char * -DEFUN (flag_name, (flag_number), int flag_number) +flag_name (int flag_number) { switch (flag_number) { @@ -928,31 +847,29 @@ DEFUN (flag_name, (flag_number), int flag_number) case D_TRACE_ON_ERROR: return ("Trace_On_Error"); case D_PER_FILE: return ("Per_File"); case D_BIGNUM: return ("Bignum_Debug"); - case D_FLUIDS: return ("Fluids_Debug"); MORE_DEBUG_FLAG_NAMES (); default: return ("Unknown Debug Flag"); } } static void -DEFUN (show_flags, (all), int all) +show_flags (int all) { - int i; + unsigned int i; for (i = 0; (i <= LAST_SWITCH); i += 1) { int value = (* (find_flag (i))); if (all || value) - outf (console_output, "Flag %ld (%s) is %s.\n", - ((long) i), (flag_name (i)), (value ? "set" : "clear")); + outf_error ("Flag %u (%s) is %s.\n", + i, (flag_name (i)), (value ? "set" : "clear")); } - outf_flush_console(); - return; + outf_flush_error(); } static int -DEFUN (set_flag, (flag_number, value), int flag_number AND int value) +set_flag (int flag_number, int value) { - Boolean * flag = (find_flag (flag_number)); + bool * flag = (find_flag (flag_number)); if (flag == 0) show_flags (1); else @@ -964,23 +881,23 @@ DEFUN (set_flag, (flag_number, value), int flag_number AND int value) } static int -DEFUN (debug_getdec, (string), CONST char * string) +debug_getdec (const char * string) { int result; - sscanf (string, "%ld", (&result)); + sscanf (string, "%d", (&result)); return (result); } void -DEFUN_VOID (debug_edit_flags) +debug_edit_flags (void) { char input_line [256]; show_flags (0); while (1) { - outf_console("Clear, Set, Done, ?, or Halt: "); - outf_flush_console(); + outf_error("Clear, Set, Done, ?, or Halt: "); + outf_flush_error(); { fgets (input_line, (sizeof (input_line)), stdin); switch (input_line[0]) @@ -1008,28 +925,27 @@ DEFUN_VOID (debug_edit_flags) } } -#else /* not ENABLE_DEBUGGING_FLAGS */ +#else /* not ENABLE_DEBUGGING_TOOLS */ void -DEFUN_VOID (debug_edit_flags) +debug_edit_flags (void) { outf_error ("Not a debugging version. No flags to handle.\n"); outf_flush_error(); - return; } static int -DEFUN (set_flag, (flag_number, value), int flag_number AND int value) +set_flag (int flag_number, int value) { signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE); /*NOTREACHED*/ return (0); } -#endif /* not ENABLE_DEBUGGING_FLAGS */ +#endif /* not ENABLE_DEBUGGING_TOOLS */ DEFINE_PRIMITIVE("SET-DEBUG-FLAGS!", Prim_set_debug_flags, 2, 2, - "(SET-DEBUG-FLAGS! flag_number boolean)") + "(FLAG_NUMBER BOOLEAN)") { PRIMITIVE_HEADER (2); set_flag ((arg_integer (1)), (BOOLEAN_ARG (2))); diff --git a/v7/src/microcode/default.h b/v7/src/microcode/default.h deleted file mode 100644 index da44216eb..000000000 --- a/v7/src/microcode/default.h +++ /dev/null @@ -1,219 +0,0 @@ -/* -*-C-*- - -$Id: default.h,v 9.49 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains default definitions for some hooks which - various machines require. These machines define these hooks - in CONFIG.H and this file defines them only if they remain - undefined. */ - -/* Compiler bug fixes. */ - -#ifndef And2 -#define And2(x, y) ((x) && (y)) -#define And3(x, y, z) ((x) && (y) && (z)) -#define Or2(x, y) ((x) || (y)) -#define Or3(x, y, z) ((x) || (y) || (z)) -#endif - -#ifndef MEMORY_FETCH -/* These definitions allow a true multi-processor with shared memory - but no atomic longword operations (Butterfly and Concert, - for example) to supply their own atomic operators in config.h. */ -#define MEMORY_FETCH(locative) (locative) -#define MEMORY_STORE(locative, object) (locative) = (object) -#endif - -#ifndef Get_Fixed_Obj_Slot -#define Get_Fixed_Obj_Slot(N) FAST_VECTOR_REF (Fixed_Objects, N) -#define Set_Fixed_Obj_Slot(N,S) FAST_VECTOR_SET (Fixed_Objects, N, S) -#define Update_FObj_Slot(N, S) Set_Fixed_Obj_Slot(N, S) -#define Declare_Fixed_Objects() SCHEME_OBJECT Fixed_Objects -#define Valid_Fixed_Obj_Vector() (VECTOR_P (Fixed_Objects)) -#define Save_Fixed_Obj(Save_FO) \ - Save_FO = Fixed_Objects; \ - Fixed_Objects = SHARP_F; -#define Restore_Fixed_Obj(Save_FO) \ - Fixed_Objects = Save_FO -#endif - -/* Atomic swapping hook. Used extensively. */ - -#ifndef SWAP_POINTERS -#define SWAP_POINTERS(locative, object, target) do \ -{ \ - (target) = (* (locative)); \ - (* (locative)) = (object); \ -} while (0) -#endif - -#ifndef INITIALIZE_STACK -#define INITIALIZE_STACK() do \ -{ \ - sp_register = Stack_Top; \ - SET_STACK_GUARD (Stack_Bottom + STACK_GUARD_SIZE); \ - * Stack_Bottom \ - = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Bottom)); \ -} while (0) -#endif - -#ifndef STACK_ALLOCATION_SIZE -#define STACK_ALLOCATION_SIZE(Stack_Blocks) (Stack_Blocks) -#endif - -#ifndef STACK_OVERFLOWED_P -#define STACK_OVERFLOWED_P() \ - ((* Stack_Bottom) != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Bottom))) -#endif - -#ifndef STACK_SANITY_CHECK -#define STACK_SANITY_CHECK(name) do \ -{ \ - extern void EXFUN (stack_death, (CONST char *)); \ - \ - if (STACK_OVERFLOWED_P ()) \ - stack_death (name); \ - /*NOTREACHED */ \ -} while (0) -#endif - -#ifndef SET_CONSTANT_TOP -#define SET_CONSTANT_TOP() do \ -{ \ - ALIGN_FLOAT (Free_Constant); \ - SEAL_CONSTANT_SPACE (); \ -} while (0) -#endif - -#ifndef TEST_CONSTANT_TOP -#define TEST_CONSTANT_TOP(New_Top) ((New_Top) <= Constant_Top) -#endif - -#ifndef CONSTANT_AREA_END -#define CONSTANT_AREA_END() Free_Constant -#endif - -#ifndef CONSTANT_AREA_START -#define CONSTANT_AREA_START() sp_register -#endif /* CONSTANT_AREA_START */ - -#ifndef SEAL_CONSTANT_SPACE -#define SEAL_CONSTANT_SPACE() do \ -{ \ - * Free_Constant = \ - (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant)); \ -} while (0) -#endif - -/* Used in debug.c */ - -#ifndef Back_Trace_Entry_Hook -#define Back_Trace_Entry_Hook() -#endif - -#ifndef Back_Trace_Exit_Hook -#define Back_Trace_Exit_Hook() -#endif - -/* Used in extern.h */ - -#ifndef More_Debug_Flag_Externs -#define More_Debug_Flag_Externs() -#endif - -/* Used in fasdump.c */ - -#ifndef Band_Dump_Permitted -#define Band_Dump_Permitted() -#endif - -#ifndef Band_Load_Hook -#define Band_Load_Hook() -#endif - -#ifndef Band_Dump_Exit_Hook -#define Band_Dump_Exit_Hook() -#endif - -#ifndef Fasdump_Exit_Hook -#define Fasdump_Exit_Hook() -#endif - -#ifndef Fasdump_Free_Calc -#define Fasdump_Free_Calc(NewFree, NewMemtop) do \ -{ \ - NewFree = Unused_Heap_Bottom; \ - NewMemTop = Unused_Heap_Top; \ -} while (0) -#endif - -/* Used in interpret.c */ - -#ifndef Eval_Ucode_Hook -#define Eval_Ucode_Hook() -#endif - -#ifndef Pop_Return_Ucode_Hook -#define Pop_Return_Ucode_Hook() -#endif - -#ifndef Apply_Ucode_Hook -#define Apply_Ucode_Hook() -#endif - -#ifndef End_GC_Hook -#define End_GC_Hook() -#endif - -/* Used in storage.c */ - -#ifndef More_Debug_Flag_Allocs -#define More_Debug_Flag_Allocs() -#endif - -/* Used in utils.c */ - -#ifndef Global_Interrupt_Hook -#define Global_Interrupt_Hook() -#endif - -#ifndef Error_Exit_Hook -#define Error_Exit_Hook() -#endif - -/* Common Lisp Hooks */ - -#ifndef SITE_EXPRESSION_DISPATCH_HOOK -#define SITE_EXPRESSION_DISPATCH_HOOK() -#endif - -#ifndef SITE_RETURN_DISPATCH_HOOK -#define SITE_RETURN_DISPATCH_HOOK() -#endif - -#ifndef FASLOAD_RELOCATE_HOOK -#define FASLOAD_RELOCATE_HOOK(heap_low, heap_high, constant_low, constant_high) -#endif diff --git a/v7/src/microcode/dfloat.c b/v7/src/microcode/dfloat.c index 0a6f3d5a0..6b48eeabd 100644 --- a/v7/src/microcode/dfloat.c +++ b/v7/src/microcode/dfloat.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: dfloat.c,v 1.10 2007/01/05 21:19:25 cph Exp $ +$Id: dfloat.c,v 1.11 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -40,7 +40,7 @@ DEFINE_PRIMITIVE ("FLOATING-VECTOR-CONS", Prim_floating_vector_cons, 1, 1, 0) long length = (arg_nonnegative_integer (1)); long length_in_words = (length * FLONUM_SIZE); SCHEME_OBJECT result; - fast double *vect; + double *vect; ALIGN_FLOAT (Free); Primitive_GC_If_Needed (length_in_words + 1); @@ -66,7 +66,7 @@ DEFINE_PRIMITIVE ("FLOATING-VECTOR-REF", Prim_floating_vector_ref, 2, 2, 0) } } -extern double EXFUN (arg_flonum, (int)); +extern double arg_flonum (int); DEFINE_PRIMITIVE ("FLOATING-VECTOR-SET!", Prim_floating_vector_set, 3, 3, 0) { diff --git a/v7/src/microcode/dmpwrld.c b/v7/src/microcode/dmpwrld.c deleted file mode 100644 index eeaa62da0..000000000 --- a/v7/src/microcode/dmpwrld.c +++ /dev/null @@ -1,247 +0,0 @@ -/* -*-C-*- - -$Id: dmpwrld.c,v 9.45 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains a primitive to dump an executable version of Scheme. - It uses unexec.c from GNU Emacs. - Look at unexec.c for more information. */ - -#include "scheme.h" -#include "prims.h" - -#ifndef __unix__ -#include "Error: dumpworld.c does not work on non-unix machines." -#endif - -#include "ux.h" -#include "osfs.h" -#include - -/* Compatibility definitions for GNU Emacs's unexec.c. - Taken from the various m-*.h and s-*.h files for GNU Emacs. -*/ - -#define CANNOT_UNEXEC - -#if defined (vax) -#undef CANNOT_UNEXEC -#endif - -#if defined (hp9000s300) || defined (__hp9000s300) -#undef CANNOT_UNEXEC -#define ADJUST_EXEC_HEADER \ - hdr.a_magic = ((ohdr.a_magic.file_type == OLDMAGIC.file_type) ? \ - NEWMAGIC : ohdr.a_magic); -#endif - -#if defined (hp9000s800) || defined (__hp9000s800) -#undef CANNOT_UNEXEC -#endif - -#if defined (sun3) -#undef CANNOT_UNEXEC -#define SEGMENT_MASK (SEGSIZ - 1) -#define A_TEXT_OFFSET(HDR) sizeof (HDR) -#define TEXT_START (PAGSIZ + (sizeof(struct exec))) -#endif - -/* I haven't tried any below this point. */ - -#if defined (umax) -#undef CANNOT_UNEXEC -#define HAVE_GETPAGESIZE -#define COFF -#define UMAX -#define SECTION_ALIGNMENT pagemask -#define SEGMENT_MASK (64 * 1024 - 1) -#endif - -#if defined (celerity) -#undef CANNOT_UNEXEC -#endif - -#if defined (sun2) -#undef CANNOT_UNEXEC -#define SEGMENT_MASK (SEGSIZ - 1) -#endif - -#if defined (pyr) -#undef CANNOT_UNEXEC -#define SEGMENT_MASK (2048-1) /* ZMAGIC format */ - /* man a.out for info */ -#endif - -#ifdef CANNOT_UNEXEC -#include "Error: dmpwrld.c only works on a few machines." -#endif - -#ifndef TEXT_START -#define TEXT_START 0 -#endif - -#ifndef SEGMENT_MASK -#define DATA_START (&etext) -#else -#define DATA_START \ -(((((unsigned) &etext) - 1) & ~SEGMENT_MASK) + (SEGMENT_MASK + 1)) -#endif - -#if defined (__HPUX__) -#define USG -#define HPUX -#endif - -/* More compatibility definitions for unexec. */ - -extern int end, etext, edata; - -char -*start_of_text() -{ - return ((char *) TEXT_START); -} - -char -*start_of_data() -{ - return ((char *) DATA_START); -} - -#if defined (USG) || defined (NO_BZERO) - -#define bzero(b,len) (memset((b), 0, (len))) - -#else - -extern void bzero(); - -#endif - -#define static - -#if defined (hp9000s800) || defined (__hp9000s800) -#include "unexhp9k800.c" -#else -#include "unexec.c" -#endif - -#undef static - -void -DEFUN (unix_find_pathname, (program_name, target), - CONST char * program_name AND char * target) -{ - int length; - char - * path, - * next; - extern char * - EXFUN (index, (char * path AND char srchr)); - extern void - EXFUN (strcpy, (char * target AND CONST char * source)); - - /* Attempt first in the connected directory */ - - if (((program_name[0]) == '/') - || (OS_file_access (program_name, X_OK)) - || ((path = ((char *) (getenv ("PATH")))) == ((char *) NULL))) - { - strcpy (target, program_name); - return; - } - for (next = (index (path, ':')); - path != ((char *) NULL); - path = (next + 1), - next = (index (path, ':'))) - { - length = ((next == ((char *) NULL)) - ? (strlen (path)) - : (next-path)); - strncpy (target, path, length); - target[length] = '/'; - target[length + 1] = '\0'; - strcpy ((target + (length + 1)), program_name); - if (OS_file_access (target, X_OK)) - { - return; - } - } - strcpy (target, program_name); - return; -} - -/* The primitive visible from Scheme. */ - -extern Boolean scheme_dumped_p; - -DEFINE_PRIMITIVE ("DUMP-WORLD", Prim_dump_world, 1, 1, 0) -{ - int result; - SCHEME_OBJECT arg; - Boolean saved_dumped_p; - char - * fname, - path_buffer[FILE_NAME_LENGTH]; - PRIMITIVE_HEADER (1); - - PRIMITIVE_CANONICALIZE_CONTEXT(); - - arg = (ARG_REF (1)); - fname = (STRING_ARG (1)); - - /* Set up for restore */ - - saved_dumped_p = scheme_dumped_p; - - scheme_dumped_p = true; - val_register = SHARP_T; - POP_PRIMITIVE_FRAME (1); - - /* Dump! */ - - unix_find_pathname (scheme_program_name, path_buffer); - result = (unexec (fname, - path_buffer, - ((unsigned) 0), /* default */ - ((unsigned) 0), /* default */ - ((unsigned) start_of_text()))); - - /* Restore State */ - - val_register = SHARP_F; - scheme_dumped_p = saved_dumped_p; - - /* IO: Restoring cached input for this job. */ - - if (result != 0) - { - STACK_PUSH (arg); - error_external_return (); - } - - PRIMITIVE_ABORT (PRIM_POP_RETURN); - /*NOTREACHED*/ -} diff --git a/v7/src/microcode/dstack.h b/v7/src/microcode/dstack.h index cf310c045..811956b99 100644 --- a/v7/src/microcode/dstack.h +++ b/v7/src/microcode/dstack.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: dstack.h,v 1.15 2007/01/05 21:19:25 cph Exp $ +$Id: dstack.h,v 1.16 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -29,61 +29,53 @@ USA. #define __DSTACK_H__ #include "config.h" -#include "ansidecl.h" #include -#ifdef STDC_HEADERS -# include -#endif - -extern void EXFUN (dstack_initialize, (void)); +extern void dstack_initialize (void); /* Call this once to initialize the stack. */ -extern void EXFUN (dstack_reset, (void)); +extern void dstack_reset (void); /* Call this once to reset the stack. */ -extern PTR EXFUN (dstack_alloc, (unsigned int length)); +extern void * dstack_alloc (unsigned int length); /* Allocate a chunk of `length' bytes of space on the stack and return a pointer to it. */ -extern void EXFUN - (dstack_protect, - (void EXFUN ((*protector), (PTR environment)), PTR environment)); +extern void dstack_protect + (void (*protector) (void * environment), void * environment); /* Create an unwind protection frame that invokes `protector' when the stack is unwound. `environment' is passed to `protector' as its sole argument when it is invoked. */ -extern void EXFUN - (dstack_alloc_and_protect, - (unsigned int length, - void EXFUN ((*initializer), (PTR environment)), - void EXFUN ((*protector), (PTR environment)))); +extern void dstack_alloc_and_protect + (unsigned int length, + void (*initializer) (void * environment), + void (*protector) (void * environment)); /* Allocate a chunk of `length' bytes of space, call `initializer' to initialize that space, and create an unwind protection frame that invokes `protector' when the stack is unwound. */ -extern PTR dstack_position; +extern void * dstack_position; /* The current stack pointer. */ -extern void EXFUN (dstack_set_position, (PTR position)); +extern void dstack_set_position (void * position); /* Unwind the stack to `position', which must be a previous value of `dstack_position'. */ -extern void EXFUN (dstack_bind, (PTR location, PTR value)); +extern void dstack_bind (void * location, void * value); /* Dynamically bind `location' to `value'. `location' is treated as - `PTR*' -- it is declared `PTR' for programming convenience. */ + `void **' -- it is declared `void *' for programming convenience. */ enum transaction_action_type { tat_abort, tat_commit, tat_always }; -extern void EXFUN (transaction_initialize, (void)); -extern void EXFUN (transaction_begin, (void)); -extern void EXFUN (transaction_abort, (void)); -extern void EXFUN (transaction_commit, (void)); -extern void EXFUN - (transaction_record_action, - (enum transaction_action_type type, - void EXFUN ((*procedure), (PTR environment)), - PTR environment)); +extern void transaction_initialize (void); +extern void transaction_begin (void); +extern void transaction_abort (void); +extern void transaction_commit (void); +extern void transaction_record_action + (enum transaction_action_type type, + void (*procedure) (void * environment), + void * environment); typedef unsigned long Tptrvec_index; typedef unsigned long Tptrvec_length; @@ -91,7 +83,7 @@ typedef unsigned long Tptrvec_length; struct struct_ptrvec { Tptrvec_length length; - PTR * elements; + void ** elements; }; typedef struct struct_ptrvec * Tptrvec; @@ -101,20 +93,18 @@ typedef struct struct_ptrvec * Tptrvec; #define PTRVEC_START(ptrvec) (PTRVEC_LOC ((ptrvec), 0)) #define PTRVEC_END(ptrvec) (PTRVEC_LOC ((ptrvec), (PTRVEC_LENGTH (ptrvec)))) -extern Tptrvec EXFUN (ptrvec_allocate, (Tptrvec_length length)); -extern void EXFUN (ptrvec_deallocate, (Tptrvec ptrvec)); -extern void EXFUN (ptrvec_set_length, (Tptrvec ptrvec, Tptrvec_length length)); -extern Tptrvec EXFUN (ptrvec_copy, (Tptrvec ptrvec)); -extern void EXFUN (ptrvec_adjoin, (Tptrvec ptrvec, PTR element)); -extern int EXFUN (ptrvec_memq, (Tptrvec ptrvec, PTR element)); -extern void EXFUN - (ptrvec_move_left, - (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end, - Tptrvec target, Tptrvec_index target_start)); -extern void EXFUN - (ptrvec_move_right, - (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end, - Tptrvec target, Tptrvec_index target_start)); +extern Tptrvec ptrvec_allocate (Tptrvec_length length); +extern void ptrvec_deallocate (Tptrvec ptrvec); +extern void ptrvec_set_length (Tptrvec ptrvec, Tptrvec_length length); +extern Tptrvec ptrvec_copy (Tptrvec ptrvec); +extern void ptrvec_adjoin (Tptrvec ptrvec, void * element); +extern int ptrvec_memq (Tptrvec ptrvec, void * element); +extern void ptrvec_move_left + (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end, + Tptrvec target, Tptrvec_index target_start); +extern void ptrvec_move_right + (Tptrvec source, Tptrvec_index source_start, Tptrvec_index source_end, + Tptrvec target, Tptrvec_index target_start); typedef struct condition_type * Tcondition_type; typedef struct condition * Tcondition; @@ -123,9 +113,9 @@ typedef struct condition_restart * Tcondition_restart; struct condition_type { unsigned long index; - PTR name; + void * name; Tptrvec generalizations; - void EXFUN ((*reporter), (Tcondition)); + void (*reporter) (Tcondition); }; #define CONDITION_TYPE_INDEX(type) ((type) -> index) #define CONDITION_TYPE_NAME(type) ((type) -> name) @@ -142,55 +132,52 @@ struct condition struct condition_restart { - PTR name; + void * name; Tcondition_type type; - void EXFUN ((*procedure), (PTR)); + void (*procedure) (void *); }; #define CONDITION_RESTART_NAME(restart) ((restart) -> name) #define CONDITION_RESTART_TYPE(restart) ((restart) -> type) #define CONDITION_RESTART_PROCEDURE(restart) ((restart) -> procedure) /* Allocate and return a new condition type object. */ -extern Tcondition_type EXFUN - (condition_type_allocate, - (PTR name, +extern Tcondition_type condition_type_allocate + (void * name, Tptrvec generalizations, - void EXFUN ((*reporter), (Tcondition condition)))); + void (*reporter) (Tcondition condition)); /* Deallocate the condition type object `type'. */ -extern void EXFUN (condition_type_deallocate, (Tcondition_type type)); +extern void condition_type_deallocate (Tcondition_type type); /* Allocate and return a new condition object. */ -extern Tcondition EXFUN - (condition_allocate, (Tcondition_type type, Tptrvec irritants)); +extern Tcondition condition_allocate + (Tcondition_type type, Tptrvec irritants); /* Deallocate the condition object `condition'. */ -extern void EXFUN (condition_deallocate, (Tcondition condition)); +extern void condition_deallocate (Tcondition condition); /* Bind a handler for the condition type object `type'. */ -extern void EXFUN - (condition_handler_bind, - (Tcondition_type type, void EXFUN ((*handler), (Tcondition condition)))); +extern void condition_handler_bind + (Tcondition_type type, void (*handler) (Tcondition condition)); /* Signal `condition'. */ -extern void EXFUN (condition_signal, (Tcondition condition)); +extern void condition_signal (Tcondition condition); /* Bind a restart called `name' for the condition type object `type'. Invoking the restart causes `restart_procedure' to be executed. */ -extern void EXFUN - (condition_restart_bind, - (PTR name, +extern void condition_restart_bind + (void * name, Tcondition_type type, - void EXFUN ((*procedure), (PTR argument)))); + void (*procedure) (void * argument)); /* Find a restart called `name' that matches `condition'. If `condition' is 0, any restart called `name' will do. If no such restart exists, 0 is returned. */ -extern Tcondition_restart EXFUN - (condition_restart_find, (PTR name, Tcondition condition)); +extern Tcondition_restart condition_restart_find + (void * name, Tcondition condition); /* Return a ptrvec of the restarts that match `condition'. If `condition' is 0, all restarts are returned. */ -extern Tptrvec EXFUN (condition_restarts, (Tcondition condition)); +extern Tptrvec condition_restarts (Tcondition condition); #endif /* __DSTACK_H__ */ diff --git a/v7/src/microcode/dump.c b/v7/src/microcode/dump.c deleted file mode 100644 index a80ac89a3..000000000 --- a/v7/src/microcode/dump.c +++ /dev/null @@ -1,238 +0,0 @@ -/* -*-C-*- - -$Id: dump.c,v 9.44 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains common code for dumping internal format binary files. */ - -#ifndef PSBMAP_H_INCLUDED -extern long - compiler_interface_version, - compiler_processor_type; - -extern SCHEME_OBJECT - compiler_utilities; -#endif /* PSBMAP_H_INCLUDED */ - -void -DEFUN (prepare_dump_header, (Buffer, Dumped_Object, - Heap_Count, Heap_Relocation, - Constant_Count, Constant_Relocation, - prim_table_length, prim_table_size, - c_table_length, c_table_size, - cc_code_p, band_p), - SCHEME_OBJECT * Buffer - AND SCHEME_OBJECT * Dumped_Object - AND long Heap_Count - AND SCHEME_OBJECT * Heap_Relocation - AND long Constant_Count - AND SCHEME_OBJECT * Constant_Relocation - AND long prim_table_length - AND long prim_table_size - AND long c_table_length - AND long c_table_size - AND Boolean cc_code_p - AND Boolean band_p) -{ - long i; - -#ifdef DEBUG - -#ifndef HEAP_IN_LOW_MEMORY - fprintf(stderr, "\nmemory_base = 0x%lx\n", ((long) memory_base)); -#endif /* HEAP_IN_LOW_MEMORY */ - - fprintf(stderr, "\nHeap_Relocation=0x%lx, dumped as 0x%lx\n", - ((long) Heap_Relocation), - ((long) (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Heap_Relocation)))); - fprintf(stderr, "\nDumped object=0x%lx, dumped as 0x%lx\n", - ((long) Dumped_Object), - ((long) (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Dumped_Object)))); -#endif /* DEBUG */ - - Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER; - Buffer[FASL_Offset_Heap_Count] = - MAKE_OBJECT (TC_BROKEN_HEART, Heap_Count); - Buffer[FASL_Offset_Heap_Base] = - MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Heap_Relocation); - Buffer[FASL_Offset_Dumped_Obj] = - MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Dumped_Object); - Buffer[FASL_Offset_Const_Count] = - MAKE_OBJECT (TC_BROKEN_HEART, Constant_Count); - Buffer[FASL_Offset_Const_Base] = - MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Constant_Relocation); - Buffer[FASL_Offset_Version] = - Make_Version(FASL_FORMAT_VERSION, - FASL_SUBVERSION, FASL_INTERNAL_FORMAT); - Buffer[FASL_Offset_Stack_Top] = -#ifdef USE_STACKLETS - MAKE_OBJECT (TC_BROKEN_HEART, 0); /* Nothing in stack area */ -#else - MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top); -#endif /* USE_STACKLETS */ - - Buffer[FASL_Offset_Prim_Length] = - MAKE_OBJECT (TC_BROKEN_HEART, prim_table_length); - Buffer[FASL_Offset_Prim_Size] = - MAKE_OBJECT (TC_BROKEN_HEART, prim_table_size); - - if (cc_code_p) - { - Buffer[FASL_Offset_Ci_Version] = - MAKE_CI_VERSION(band_p, - compiler_interface_version, - compiler_processor_type); - Buffer[FASL_Offset_Ut_Base] = compiler_utilities; - } - else - { - /* If there is no compiled code in the file, - flag it as if dumped without compiler support, so - it can be loaded anywhere. - */ - Buffer[FASL_Offset_Ci_Version] = (MAKE_CI_VERSION (band_p, 0, 0)); - Buffer[FASL_Offset_Ut_Base] = SHARP_F; - } - - Buffer[FASL_Offset_C_Length] = - MAKE_OBJECT (TC_BROKEN_HEART, c_table_length); - Buffer[FASL_Offset_C_Size] = - MAKE_OBJECT (TC_BROKEN_HEART, c_table_size); - -#ifdef HEAP_IN_LOW_MEMORY - Buffer[FASL_Offset_Mem_Base] = ((SCHEME_OBJECT) 0); -#else /* not HEAP_IN_LOW_MEMORY */ - Buffer[FASL_Offset_Mem_Base] = ((SCHEME_OBJECT) memory_base); -#endif /* HEAP_IN_LOW_MEMORY */ - - Buffer[FASL_Offset_Check_Sum] = SHARP_F; - for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++) - Buffer[i] = SHARP_F; - return; -} - -extern unsigned long - EXFUN (checksum_area, (unsigned long *, long, unsigned long)); - -Boolean -DEFUN (Write_File, (Dumped_Object, Heap_Count, Heap_Relocation, - Constant_Count, Constant_Relocation, - prim_table_start, prim_table_length, prim_table_size, - c_table_start, c_table_length, c_table_size, - cc_code_p, band_p), - SCHEME_OBJECT * Dumped_Object - AND long Heap_Count - AND SCHEME_OBJECT * Heap_Relocation - AND long Constant_Count - AND SCHEME_OBJECT * Constant_Relocation - AND SCHEME_OBJECT * prim_table_start - AND long prim_table_length - AND long prim_table_size - AND SCHEME_OBJECT * c_table_start - AND long c_table_length - AND long c_table_size - AND Boolean cc_code_p - AND Boolean band_p) -{ - SCHEME_OBJECT Buffer[FASL_HEADER_LENGTH]; - unsigned long checksum; - - prepare_dump_header (Buffer, Dumped_Object, - Heap_Count, Heap_Relocation, - Constant_Count, Constant_Relocation, - prim_table_length, prim_table_size, - c_table_length, c_table_size, - cc_code_p, band_p); - - /* This is not done in prepare_dump_header because it doesn't - work when prepare_dump_header is invoked from bchdmp. - The areas don't really have these values. - For the time being, bchdmp does not dump checksums. - */ - - checksum = (checksum_area (((unsigned long *) (&Buffer[0])), - ((long) FASL_Offset_Check_Sum), - ((unsigned long) 0L))); - checksum = (checksum_area (((unsigned long *) - (&Buffer[FASL_Offset_Check_Sum + 1])), - ((long) ((FASL_HEADER_LENGTH - 1) - - FASL_Offset_Check_Sum)), - checksum)); - checksum = (checksum_area (((unsigned long *) Heap_Relocation), - Heap_Count, - checksum)); - checksum = (checksum_area (((unsigned long *) Constant_Relocation), - Constant_Count, - checksum)); - checksum = (checksum_area (((unsigned long *) prim_table_start), - prim_table_size, - checksum)); - checksum = (checksum_area (((unsigned long *) c_table_start), - c_table_size, - checksum)); - - Buffer[FASL_Offset_Check_Sum] = checksum; - - if ((Write_Data (FASL_HEADER_LENGTH, Buffer)) - != FASL_HEADER_LENGTH) - return (false); - - if ((Heap_Count != 0) - && ((Write_Data (Heap_Count, Heap_Relocation)) - != Heap_Count)) - return (false); - - if ((Constant_Count != 0) - && ((Write_Data (Constant_Count, Constant_Relocation)) - != Constant_Count)) - return (false); - - if ((prim_table_size != 0) - && ((Write_Data (prim_table_size, prim_table_start)) - != prim_table_size)) - return (false); - - if ((c_table_size != 0) - && ((Write_Data (c_table_size, c_table_start)) - != c_table_size)) - return (false); - - return (true); -} - -unsigned long -DEFUN (checksum_area, (start, count, initial_value), - register unsigned long * start - AND register long count - AND unsigned long initial_value) -{ - register unsigned long value; - - value = initial_value; - while ((--count) >= 0) - value = (value ^ (*start++)); - return (value); -} - diff --git a/v7/src/microcode/edwin.h b/v7/src/microcode/edwin.h index e0e298894..2a0e7e249 100644 --- a/v7/src/microcode/edwin.h +++ b/v7/src/microcode/edwin.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: edwin.h,v 1.14 2007/04/01 17:33:07 riastradh Exp $ +$Id: edwin.h,v 1.15 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -29,19 +29,14 @@ USA. This MUST match the definitions in the Edwin source code. */ #define GROUP_P VECTOR_P -#define GROUP_TEXT(group) (VECTOR_REF ((group), 1)) -#define GROUP_TEXT_LOC(group, offset) \ - (((unsigned char *) (integer_to_ulong (GROUP_TEXT (group)))) + (offset)) +#define GROUP_TEXT(group, len_r) \ + (lookup_external_string ((VECTOR_REF ((group), 1)), (len_r))) -#define GROUP_GAP_START(group) \ - (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 2))) - -#define GROUP_GAP_LENGTH(group) \ - (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 3))) - -#define GROUP_GAP_END(group) \ - (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 4))) +#define GROUP_TEXT_LOC(group, offset) ((GROUP_TEXT ((group), 0)) + (offset)) +#define GROUP_GAP_START(group) (FIXNUM_TO_ULONG (VECTOR_REF ((group), 2))) +#define GROUP_GAP_LENGTH(group) (FIXNUM_TO_ULONG (VECTOR_REF ((group), 3))) +#define GROUP_GAP_END(group) (FIXNUM_TO_ULONG (VECTOR_REF ((group), 4))) #define GROUP_START_MARK(group) (VECTOR_REF ((group), 6)) #define GROUP_END_MARK(group) (VECTOR_REF ((group), 7)) diff --git a/v7/src/microcode/error.c b/v7/src/microcode/error.c index e35575dcd..4f46bee99 100644 --- a/v7/src/microcode/error.c +++ b/v7/src/microcode/error.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: error.c,v 1.12 2007/01/05 21:19:25 cph Exp $ +$Id: error.c,v 1.13 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,33 +25,18 @@ USA. */ -#include +#include "config.h" #include "outf.h" #include "dstack.h" +#include "os.h" -static PTR -DEFUN (xmalloc, (length), unsigned int length) -{ -#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__) -#else - extern PTR EXFUN (malloc, (unsigned int length)); -#endif - - PTR result = (malloc (length)); - if (result == 0) - { - outf_fatal ("malloc: memory allocation failed\n"); - outf_flush_fatal (); - abort (); - } - return (result); -} +static Tptrvec generalizations_union (Tptrvec); struct handler_record { struct handler_record * next; Tcondition_type type; - void EXFUN ((*handler), (Tcondition)); + void (*handler) (Tcondition); }; struct restart_record @@ -65,7 +50,7 @@ static struct handler_record * current_handler_record; static struct restart_record * current_restart_record; void -DEFUN_VOID (initialize_condition_system) +initialize_condition_system (void) { next_condition_type_index = 0; current_handler_record = 0; @@ -73,13 +58,11 @@ DEFUN_VOID (initialize_condition_system) } Tcondition_type -DEFUN (condition_type_allocate, (name, generalizations, reporter), - PTR name AND - Tptrvec generalizations AND - void EXFUN ((*reporter), (Tcondition condition))) +condition_type_allocate (void * name, + Tptrvec generalizations, + void (*reporter) (Tcondition condition)) { - Tptrvec EXFUN (generalizations_union, (Tptrvec generalizations)); - Tcondition_type type = (xmalloc (sizeof (struct condition_type))); + Tcondition_type type = (OS_malloc (sizeof (struct condition_type))); Tptrvec g = (generalizations_union (generalizations)); ptrvec_adjoin (g, type); (CONDITION_TYPE_INDEX (type)) = (next_condition_type_index++); @@ -90,42 +73,41 @@ DEFUN (condition_type_allocate, (name, generalizations, reporter), } void -DEFUN (condition_type_deallocate, (type), Tcondition_type type) +condition_type_deallocate (Tcondition_type type) { ptrvec_deallocate (CONDITION_TYPE_GENERALIZATIONS (type)); free (type); } Tcondition -DEFUN (condition_allocate, (type, irritants), - Tcondition_type type AND +condition_allocate (Tcondition_type type, Tptrvec irritants) { - Tcondition condition = (xmalloc (sizeof (struct condition))); + Tcondition condition = (OS_malloc (sizeof (struct condition))); (CONDITION_TYPE (condition)) = type; (CONDITION_IRRITANTS (condition)) = irritants; return (condition); } void -DEFUN (condition_deallocate, (condition), Tcondition condition) +condition_deallocate (Tcondition condition) { ptrvec_deallocate (CONDITION_IRRITANTS (condition)); free (condition); } static Tptrvec -DEFUN (generalizations_union_2, (x, y), Tptrvec x AND Tptrvec y) +generalizations_union_2 (Tptrvec x, Tptrvec y) { - PTR * scan_x = (PTRVEC_START (x)); - PTR * end_x = (scan_x + (PTRVEC_LENGTH (x))); - PTR * scan_y = (PTRVEC_START (y)); - PTR * end_y = (scan_y + (PTRVEC_LENGTH (y))); + void ** scan_x = (PTRVEC_START (x)); + void ** end_x = (scan_x + (PTRVEC_LENGTH (x))); + void ** scan_y = (PTRVEC_START (y)); + void ** end_y = (scan_y + (PTRVEC_LENGTH (y))); Tptrvec_length length = 0; unsigned long ix; unsigned long iy; Tptrvec result; - PTR * scan_result; + void ** scan_result; while (1) { if (scan_x == end_x) @@ -172,7 +154,7 @@ DEFUN (generalizations_union_2, (x, y), Tptrvec x AND Tptrvec y) } Tptrvec -DEFUN (generalizations_union, (generalizations), Tptrvec generalizations) +generalizations_union (Tptrvec generalizations) { Tptrvec_length length = (PTRVEC_LENGTH (generalizations)); if (length == 0) @@ -180,8 +162,8 @@ DEFUN (generalizations_union, (generalizations), Tptrvec generalizations) if (length == 1) return (ptrvec_copy (PTRVEC_REF (generalizations, 0))); { - PTR * scan = (PTRVEC_START (generalizations)); - PTR * end = (scan + length); + void ** scan = (PTRVEC_START (generalizations)); + void ** end = (scan + length); Tptrvec result = ((Tptrvec) (*scan++)); result = (generalizations_union_2 (result, ((Tptrvec) (*scan++)))); while (scan < end) @@ -195,9 +177,8 @@ DEFUN (generalizations_union, (generalizations), Tptrvec generalizations) } void -DEFUN (condition_handler_bind, (type, handler), - Tcondition_type type AND - void EXFUN ((*handler), (Tcondition condition))) +condition_handler_bind (Tcondition_type type, + void (*handler) (Tcondition condition)) { struct handler_record * record = (dstack_alloc (sizeof (struct handler_record))); @@ -211,7 +192,7 @@ DEFUN (condition_handler_bind, (type, handler), (CONDITION_TYPE_GENERALIZATIONS (CONDITION_TYPE (condition))) void -DEFUN (condition_signal, (condition), Tcondition condition) +condition_signal (Tcondition condition) { Tptrvec generalizations = (GENERALIZATIONS (condition)); struct handler_record * record = current_handler_record; @@ -220,7 +201,7 @@ DEFUN (condition_signal, (condition), Tcondition condition) Tcondition_type type = (record -> type); if ((type == 0) || (ptrvec_memq (generalizations, type))) { - PTR position = dstack_position; + void * position = dstack_position; dstack_bind ((¤t_handler_record), (record -> next)); (* (record -> handler)) (condition); dstack_set_position (position); @@ -230,10 +211,9 @@ DEFUN (condition_signal, (condition), Tcondition condition) } void -DEFUN (condition_restart_bind, (name, type, procedure), - PTR name AND - Tcondition_type type AND - void EXFUN ((*procedure), (PTR argument))) +condition_restart_bind (void * name, + Tcondition_type type, + void (*procedure) (void * argument)) { struct restart_record * record = (dstack_alloc (sizeof (struct restart_record))); @@ -245,8 +225,7 @@ DEFUN (condition_restart_bind, (name, type, procedure), } Tcondition_restart -DEFUN (condition_restart_find, (name, condition), - PTR name AND +condition_restart_find (void * name, Tcondition condition) { struct restart_record * record = current_restart_record; @@ -272,13 +251,13 @@ DEFUN (condition_restart_find, (name, condition), } Tptrvec -DEFUN (condition_restarts, (condition), Tcondition condition) +condition_restarts (Tcondition condition) { struct restart_record * record = current_restart_record; Tptrvec_length length = 0; Tptrvec generalizations = 0; Tptrvec result; - PTR * scan_result; + void ** scan_result; if (condition == 0) while (record != 0) { diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h index b92d70325..19f10c147 100644 --- a/v7/src/microcode/errors.h +++ b/v7/src/microcode/errors.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: errors.h,v 9.48 2007/01/05 21:19:25 cph Exp $ +$Id: errors.h,v 9.49 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,10 +30,9 @@ USA. #ifndef SCM_ERRORS_H #define SCM_ERRORS_H -/* All error and termination codes must be positive - * to allow primitives to return either an error code - * or a primitive flow control value (see const.h) - */ +/* All error and termination codes must be positive to allow + primitives to return either an error code or a primitive flow + control value (see const.h). */ #define ERR_BAD_ERROR_CODE 0x00 #define ERR_UNBOUND_VARIABLE 0x01 @@ -55,15 +54,13 @@ USA. #define ERR_ARG_2_BAD_RANGE 0x11 #define ERR_ARG_3_BAD_RANGE 0x12 #define ERR_MACRO_BINDING 0x13 -/* #define ERR_FASDUMP_OVERFLOW 0x14 */ -#define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */ +#define ERR_FASDUMP_OBJECT_TOO_LARGE 0x14 +/* #define ERR_BAD_INTERRUPT_CODE 0x15 */ /* #define ERR_NO_ERRORS 0x16 */ #define ERR_FASL_FILE_TOO_BIG 0x17 #define ERR_FASL_FILE_BAD_DATA 0x18 -#define ERR_IMPURIFY_OUT_OF_SPACE 0x19 - -/* The following do not exist in the 68000 version */ -#define ERR_WRITE_INTO_PURE_SPACE 0x1A +/* #define ERR_IMPURIFY_OUT_OF_SPACE 0x19 */ +/* #define ERR_WRITE_INTO_PURE_SPACE 0x1A */ /* #define ERR_LOSING_SPARE_HEAP 0x1B */ /* #define ERR_NO_HASH_TABLE 0x1C */ #define ERR_BAD_SET 0x1D @@ -71,8 +68,6 @@ USA. #define ERR_ARG_2_FAILED_COERCION 0x1F #define ERR_OUT_OF_FILE_HANDLES 0x20 /* #define ERR_SHELL_DIED 0x21 */ - -/* Late additions to both 68000 and C world */ #define ERR_ARG_4_BAD_RANGE 0x22 #define ERR_ARG_5_BAD_RANGE 0x23 #define ERR_ARG_6_BAD_RANGE 0x24 @@ -103,10 +98,8 @@ USA. #define ERR_STACK_HAS_SLIPPED 0x3D #define ERR_CANNOT_RECURSE 0x3E -/* - If you add any error codes here, add them to - the table below and to utabmd.scm as well. - */ +/* If you add any error codes here, add them to the table below and to + utabmd.scm as well. */ #define MAX_ERROR 0x3E @@ -116,8 +109,8 @@ USA. /* 0x01 */ "UNBOUND-VARIABLE", \ /* 0x02 */ "UNASSIGNED-VARIABLE", \ /* 0x03 */ "INAPPLICABLE-OBJECT", \ -/* 0x04 */ "OUT-OF-HASH-NUMBERS", \ -/* 0x05 */ "ENVIRONMENT-CHAIN-TOO-DEEP", \ +/* 0x04 */ "ERROR-IN-SYSTEM-CALL", \ +/* 0x05 */ "ERROR-WITH-ARGUMENT", \ /* 0x06 */ "BAD-FRAME", \ /* 0x07 */ "BROKEN-COMPILED-VARIABLE", \ /* 0x08 */ "UNDEFINED-USER-TYPE", \ @@ -131,21 +124,21 @@ USA. /* 0x10 */ "ARG-1-BAD-RANGE", \ /* 0x11 */ "ARG-2-BAD-RANGE", \ /* 0x12 */ "ARG-3-BAD-RANGE", \ -/* 0x13 */ "BAD-COMBINATION", \ -/* 0x14 */ "FASDUMP-OVERFLOW", \ -/* 0x15 */ "BAD-INTERRUPT-CODE", \ -/* 0x16 */ "NO-ERRORS", \ +/* 0x13 */ "MACRO-BINDING", \ +/* 0x14 */ "FASDUMP-OBJECT-TOO-LARGE", \ +/* 0x15 */ 0, \ +/* 0x16 */ 0, \ /* 0x17 */ "FASL-FILE-TOO-BIG", \ /* 0x18 */ "FASL-FILE-BAD-DATA", \ -/* 0x19 */ "IMPURIFY-OUT-OF-SPACE", \ +/* 0x19 */ 0, \ /* 0x1A */ "WRITE-INTO-PURE-SPACE", \ -/* 0x1B */ "LOSING-SPARE-HEAP", \ -/* 0x1C */ "NO-HASH-TABLE", \ +/* 0x1B */ 0, \ +/* 0x1C */ 0, \ /* 0x1D */ "BAD-SET", \ /* 0x1E */ "ARG-1-FAILED-COERCION", \ /* 0x1F */ "ARG-2-FAILED-COERCION", \ /* 0x20 */ "OUT-OF-FILE-HANDLES", \ -/* 0x21 */ "SHELL-DIED", \ +/* 0x21 */ 0, \ /* 0x22 */ "ARG-4-BAD-RANGE", \ /* 0x23 */ "ARG-5-BAD-RANGE", \ /* 0x24 */ "ARG-6-BAD-RANGE", \ @@ -202,7 +195,7 @@ USA. #define TERM_GC_OUT_OF_SPACE 0x14 #define TERM_NO_SPACE 0x15 #define TERM_SIGNAL 0x16 -#define TERM_TOUCH 0x17 +/* #define TERM_ 0x17 */ #define TERM_SAVE_AND_EXIT 0x18 #define TERM_TRAP 0x19 #define TERM_BAD_BACK_OUT 0x1a @@ -270,10 +263,10 @@ USA. /* 0x14 */ "Out of space after garbage collection", \ /* 0x15 */ "Out of memory: Available memory exceeded", \ /* 0x16 */ "Unhandled signal received", \ -/* 0x17 */ "Touch without futures support", \ +/* 0x17 */ 0, \ /* 0x18 */ "Halt requested by external source", \ /* 0x19 */ "User requested termination after trap", \ -/* 0x1a */ "Backing out of non-primitive" \ +/* 0x1A */ "Backing out of non-primitive" \ } #endif /* SCM_ERRORS_H */ diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c index 2a0c0773e..0095cd74b 100644 --- a/v7/src/microcode/extern.c +++ b/v7/src/microcode/extern.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: extern.c,v 9.43 2007/01/12 03:45:55 cph Exp $ +$Id: extern.c,v 9.44 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -70,8 +70,8 @@ a machine ADDRESS and a TYPE-CODE (either return code or primitive\n\ procedure), it finds the number for the external representation for\n\ the internal address.") { - fast SCHEME_OBJECT tc; - fast SCHEME_OBJECT address; + SCHEME_OBJECT tc; + SCHEME_OBJECT address; PRIMITIVE_HEADER (2); tc = (arg_nonnegative_integer (1)); address = (ARG_REF (2)); @@ -81,7 +81,7 @@ the internal address.") { case TC_RETURN_CODE: { - fast long number = (OBJECT_DATUM (address)); + long number = (OBJECT_DATUM (address)); if (number > MAX_RETURN_CODE) error_bad_range_arg (2); PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (number)); @@ -103,7 +103,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-ARITY", Prim_primitive_procedure_arity, 1 PRIMITIVE_HEADER (1); CHECK_ARG (1, PRIMITIVE_P); { - fast SCHEME_OBJECT primitive = (ARG_REF (1)); + SCHEME_OBJECT primitive = (ARG_REF (1)); if ((PRIMITIVE_NUMBER (primitive)) > ((unsigned long) (NUMBER_OF_PRIMITIVES ()))) error_bad_range_arg (1); @@ -123,7 +123,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-DOCUMENTATION", > ((unsigned long) (NUMBER_OF_PRIMITIVES ()))) error_bad_range_arg (1); { - CONST char * answer = (PRIMITIVE_DOCUMENTATION (primitive)); + const char * answer = (PRIMITIVE_DOCUMENTATION (primitive)); PRIMITIVE_RETURN ((answer == 0) ? SHARP_F @@ -148,11 +148,11 @@ DEFINE_PRIMITIVE ("GET-PRIMITIVE-NAME", Prim_get_primitive_name, 1, 1, { PRIMITIVE_HEADER (1); { - fast SCHEME_OBJECT primitive = (ARG_REF (1)); + SCHEME_OBJECT primitive = (ARG_REF (1)); if (! ((PRIMITIVE_P (primitive)) || (FIXNUM_P (primitive)))) error_wrong_type_arg (1); { - fast long number = (PRIMITIVE_NUMBER (primitive)); + long number = (PRIMITIVE_NUMBER (primitive)); if ((number < 0) || (number > (NUMBER_OF_PRIMITIVES ()))) error_bad_range_arg (1); PRIMITIVE_RETURN (char_pointer_to_string (PRIMITIVE_NAME (primitive))); @@ -168,16 +168,14 @@ even if the name already exists.\n\ If ARITY is an integer, a primitive object will always be returned,\n\ whether the corresponding primitive is implemented or not.") { - fast SCHEME_OBJECT name; - fast SCHEME_OBJECT arity_arg; - extern SCHEME_OBJECT EXFUN - (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int)); - Boolean intern_p, allow_p; + SCHEME_OBJECT name; + SCHEME_OBJECT arity_arg; + bool intern_p, allow_p; long arity; PRIMITIVE_HEADER (2); CHECK_ARG (1, SYMBOL_P); name = (ARG_REF (1)); - TOUCH_IN_PRIMITIVE ((ARG_REF (2)), arity_arg); + arity_arg = (ARG_REF (2)); if (arity_arg == SHARP_F) { allow_p = false; @@ -199,5 +197,5 @@ whether the corresponding primitive is implemented or not.") } PRIMITIVE_RETURN (find_primitive - ((FAST_MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity)); + ((MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity)); } diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h index 2a3555434..cf9bbd1da 100644 --- a/v7/src/microcode/extern.h +++ b/v7/src/microcode/extern.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: extern.h,v 9.68 2007/01/12 03:45:55 cph Exp $ +$Id: extern.h,v 9.69 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -28,259 +28,315 @@ USA. /* External Declarations */ #ifndef SCM_EXTERN_H -#define SCM_EXTERN_H - -#ifdef ENABLE_DEBUGGING_TOOLS - -extern Boolean Eval_Debug; -extern Boolean Hex_Input_Debug; -extern Boolean Cont_Debug; -extern Boolean File_Load_Debug; -extern Boolean Reloc_Debug; -extern Boolean Intern_Debug; -extern Boolean Primitive_Debug; -extern Boolean Define_Debug; -extern Boolean Lookup_Debug; -extern Boolean GC_Debug; -extern Boolean Upgrade_Debug; -extern Boolean Trace_On_Error; -extern Boolean Dump_Debug; -extern Boolean Per_File; -extern Boolean Bignum_Debug; -extern Boolean Fluids_Debug; - -extern sp_record_list SP_List; -extern void EXFUN (Pop_Return_Break_Point, (void)); -extern int debug_slotno; -extern int debug_nslots; -extern int local_slotno; -extern int local_nslots; -extern int debug_circle []; -extern int local_circle []; - -#else /* not ENABLE_DEBUGGING_TOOLS */ - -#define Eval_Debug false -#define Hex_Input_Debug false -#define File_Load_Debug false -#define Reloc_Debug false -#define Intern_Debug false -#define Cont_Debug false -#define Primitive_Debug false -#define Lookup_Debug false -#define Define_Debug false -#define GC_Debug false -#define Upgrade_Debug false -#define Trace_On_Error false -#define Dump_Debug false -#define Per_File false -#define Bignum_Debug false -#define Fluids_Debug false - -#endif /* ENABLE_DEBUGGING_TOOLS */ +#define SCM_EXTERN_H 1 +#include "outf.h" + /* The register block */ -#ifdef __WIN32__ -extern SCHEME_OBJECT *RegistersPtr; -#define Registers RegistersPtr -#else extern SCHEME_OBJECT Registers []; + +#define GET_REG_O(i) (Registers[REGBLOCK_##i]) +#define GET_REG_P(i) ((SCHEME_OBJECT *) (Registers[REGBLOCK_##i])) +#define GET_REG_N(i) ((unsigned long) (Registers[REGBLOCK_##i])) + +#define SET_REG_O(i, v) ((Registers[REGBLOCK_##i]) = (v)) +#define SET_REG_P(i, v) (set_ptr_register ((REGBLOCK_##i), (v))) +#define SET_REG_N(i, v) (set_ulong_register ((REGBLOCK_##i), (v))) + +extern void set_ptr_register (unsigned int, SCHEME_OBJECT *); +extern void set_ulong_register (unsigned int, unsigned long); + +#define GET_MEMTOP GET_REG_P (MEMTOP) +#define GET_INT_MASK GET_REG_N (INT_MASK) +#define GET_VAL GET_REG_O (VAL) +#define GET_ENV GET_REG_O (ENV) +#define GET_CC_TEMP GET_REG_O (CC_TEMP) +#define GET_EXP GET_REG_O (EXPR) +#define GET_RET GET_REG_O (RETURN) +#define GET_LEXPR_ACTUALS GET_REG_N (LEXPR_ACTUALS) +#define GET_PRIMITIVE GET_REG_O (PRIMITIVE) +#define GET_CLOSURE_FREE GET_REG_P (CLOSURE_FREE) +#define GET_CLOSURE_SPACE GET_REG_P (CLOSURE_SPACE) +#define GET_STACK_GUARD GET_REG_P (STACK_GUARD) +#define GET_INT_CODE GET_REG_N (INT_CODE) +#define GET_REFLECTOR GET_REG_O (REFLECT_TO_INTERFACE) + +#define SET_MEMTOP(v) SET_REG_P (MEMTOP, v) +#define SET_INT_MASK(v) SET_REG_N (INT_MASK, v) +#define SET_VAL(v) SET_REG_O (VAL, v) +#define SET_ENV(v) SET_REG_O (ENV, v) +#define SET_CC_TEMP(v) SET_REG_O (COMPILER_TEMP, v) +#define SET_EXP(v) SET_REG_O (EXPR, v) +#define SET_RET(v) SET_REG_O (RETURN, v) +#define SET_LEXPR_ACTUALS(v) SET_REG_N (LEXPR_ACTUALS, v) +#define SET_PRIMITIVE(v) SET_REG_O (PRIMITIVE, v) +#define SET_CLOSURE_FREE(v) SET_REG_P (CLOSURE_FREE, v) +#define SET_CLOSURE_SPACE(v) SET_REG_P (CLOSURE_SPACE, v) +#define SET_STACK_GUARD(v) SET_REG_P (STACK_GUARD, v) +#define SET_INT_CODE(v) SET_REG_N (INT_CODE, v) +#define SET_REFLECTOR(v) SET_REG_O (REFLECT_TO_INTERFACE, v) + +#define PUSH_ENV() STACK_PUSH (GET_ENV) +#define PUSH_VAL() STACK_PUSH (GET_VAL) +#define PUSH_EXP() STACK_PUSH (GET_EXP) +#define PUSH_RET() STACK_PUSH (GET_RET) + +#define POP_ENV() SET_ENV (STACK_POP ()) +#define POP_VAL() SET_VAL (STACK_POP ()) +#define POP_EXP() SET_EXP (STACK_POP ()) +#define POP_RET() SET_RET (STACK_POP ()) + +#define GET_RC (OBJECT_DATUM (GET_RET)) +#define SET_RC(code) SET_RET (MAKE_OBJECT (TC_RETURN_CODE, (code))) +#define PUSH_RC(code) STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, (code))) + +#ifdef ENABLE_DEBUGGING_TOOLS + extern bool Eval_Debug; + extern bool Hex_Input_Debug; + extern bool Cont_Debug; + extern bool File_Load_Debug; + extern bool Reloc_Debug; + extern bool Intern_Debug; + extern bool Primitive_Debug; + extern bool Define_Debug; + extern bool Lookup_Debug; + extern bool GC_Debug; + extern bool Upgrade_Debug; + extern bool Trace_On_Error; + extern bool Dump_Debug; + extern bool Per_File; + extern bool Bignum_Debug; + + extern void Pop_Return_Break_Point (void); + extern unsigned int debug_slotno; + extern unsigned int debug_nslots; + extern unsigned int local_slotno; + extern unsigned int local_nslots; + extern unsigned int debug_circle []; + extern unsigned int local_circle []; +#else +# define Eval_Debug 0 +# define Hex_Input_Debug 0 +# define File_Load_Debug 0 +# define Reloc_Debug 0 +# define Intern_Debug 0 +# define Cont_Debug 0 +# define Primitive_Debug 0 +# define Lookup_Debug 0 +# define Define_Debug 0 +# define GC_Debug 0 +# define Upgrade_Debug 0 +# define Trace_On_Error 0 +# define Dump_Debug 0 +# define Per_File 0 +# define Bignum_Debug 0 #endif -extern SCHEME_OBJECT - * MemTop, /* Top of free space available */ - * Free, /* Next free word in heap */ - * Heap_Top, /* Top of current heap */ - * Heap_Bottom, /* Bottom of current heap */ - * Unused_Heap_Top, /* Top of unused heap */ - * Unused_Heap_Bottom, /* Bottom of unused heap */ - * Stack_Guard, /* Guard area at end of stack */ - * sp_register, /* Next available slot in control stack */ - * Stack_Bottom, /* Bottom of control stack */ - * Stack_Top, /* Top of control stack */ - * Free_Constant, /* Next free word in constant space */ - * Constant_Space, /* Bottom of constant+pure space */ - * Constant_Top, /* Top of constant+pure space */ - * Local_Heap_Base, /* Per-processor CONSing area */ - * Free_Stacklets, /* Free list of stacklets */ - * history_register, /* History register */ - Current_State_Point, /* Dynamic state point */ - Fluid_Bindings; /* Fluid bindings AList */ +extern SCHEME_OBJECT * Free; +extern SCHEME_OBJECT * heap_alloc_limit; +extern SCHEME_OBJECT * heap_start; +extern SCHEME_OBJECT * heap_end; + +extern SCHEME_OBJECT * stack_pointer; +extern SCHEME_OBJECT * stack_guard; +extern SCHEME_OBJECT * stack_start; +extern SCHEME_OBJECT * stack_end; + +extern SCHEME_OBJECT * constant_alloc_next; +extern SCHEME_OBJECT * constant_start; +extern SCHEME_OBJECT * constant_end; + +extern SCHEME_OBJECT current_state_point; /* Address of the most recent return code in the stack. This is - only meaningful while in compiled code. *** This must be changed - when stacklets are used. *** */ + only meaningful while in compiled code. */ extern SCHEME_OBJECT * last_return_code; +extern SCHEME_OBJECT fixed_objects; -/* Return code/address used by the compiled code interface to make - compiled code return to the interpreter. */ -extern SCHEME_OBJECT return_to_interpreter; +extern char * CONT_PRINT_RETURN_MESSAGE; +extern char * CONT_PRINT_EXPR_MESSAGE; +extern char * RESTORE_CONT_RETURN_MESSAGE; +extern char * RESTORE_CONT_EXPR_MESSAGE; -extern Declare_Fixed_Objects (); +extern unsigned long MAX_RETURN; -extern long - temp_long, /* temporary for sign extension */ - GC_Reserve, /* Scheme pointer overflow space in heap */ - GC_Space_Needed; /* Amount of space needed when GC triggered */ +extern const char * Return_Names []; +extern const char * type_names []; +extern const char * Abort_Names []; +extern const char * Error_Names []; +extern const char * Term_Names []; +extern const char * term_messages []; -extern char * Return_Names []; -extern long MAX_RETURN; +extern bool trapping; -extern char - * CONT_PRINT_RETURN_MESSAGE, - * CONT_PRINT_EXPR_MESSAGE, - * RESTORE_CONT_RETURN_MESSAGE, - * RESTORE_CONT_EXPR_MESSAGE; - -extern int GC_Type_Map []; +extern const char * scheme_program_name; +extern const char * OS_Name; +extern const char * OS_Variant; +extern struct obstack scratch_obstack; -extern Boolean Trapping; -extern SCHEME_OBJECT Old_Return_Code; -extern SCHEME_OBJECT * Return_Hook_Address; +extern unsigned long n_heap_blocks; +extern unsigned long n_constant_blocks; +extern unsigned long n_stack_blocks; -extern SCHEME_OBJECT * Prev_Restore_History_Stacklet; -extern long Prev_Restore_History_Offset; +extern SCHEME_OBJECT * memory_block_start; +extern SCHEME_OBJECT * memory_block_end; -extern CONST char * scheme_program_name; -extern CONST char * OS_Name; -extern CONST char * OS_Variant; -extern struct obstack scratch_obstack; +extern unsigned long heap_reserved; -extern long Heap_Size; -extern long Constant_Size; -extern long Stack_Size; -extern SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address; +/* Amount of space needed when GC requested */ +extern unsigned long gc_space_needed; /* Arithmetic utilities */ -extern long EXFUN (fixnum_to_long, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (double_to_fixnum, (double)); -extern SCHEME_OBJECT EXFUN (double_to_flonum, (double)); -extern Boolean EXFUN (integer_to_long_p, (SCHEME_OBJECT)); -extern long EXFUN (integer_to_long, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (long_to_integer, (long)); -extern Boolean EXFUN (integer_to_ulong_p, (SCHEME_OBJECT)); -extern unsigned long EXFUN (integer_to_ulong, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (ulong_to_integer, (unsigned long)); -extern Boolean EXFUN (integer_to_double_p, (SCHEME_OBJECT)); -extern double EXFUN (integer_to_double, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (double_to_integer, (double)); -extern double EXFUN (double_truncate, (double)); -extern Boolean EXFUN (real_number_to_double_p, (SCHEME_OBJECT)); -extern double EXFUN (real_number_to_double, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (bignum_to_fixnum, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (bignum_to_integer, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (bignum_to_flonum, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (flonum_floor, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (flonum_ceiling, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (flonum_round, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (flonum_normalize, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (flonum_denormalize, - (SCHEME_OBJECT, SCHEME_OBJECT)); -extern Boolean EXFUN (integer_zero_p, (SCHEME_OBJECT)); -extern Boolean EXFUN (integer_negative_p, (SCHEME_OBJECT)); -extern Boolean EXFUN (integer_positive_p, (SCHEME_OBJECT)); -extern Boolean EXFUN (integer_equal_p, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern Boolean EXFUN (integer_less_p, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_negate, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_add, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_add_1, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_subtract, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_subtract_1, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_multiply, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern Boolean EXFUN (integer_divide, - (SCHEME_OBJECT, SCHEME_OBJECT, - SCHEME_OBJECT *, SCHEME_OBJECT *)); -extern SCHEME_OBJECT EXFUN (integer_quotient, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_remainder, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (integer_length_in_bits, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN - (integer_shift_left, (SCHEME_OBJECT, SCHEME_OBJECT)); +extern SCHEME_OBJECT Mul (SCHEME_OBJECT, SCHEME_OBJECT); +extern long fixnum_to_long (SCHEME_OBJECT); +extern SCHEME_OBJECT double_to_fixnum (double); +extern bool integer_to_long_p (SCHEME_OBJECT); +extern long integer_to_long (SCHEME_OBJECT); +extern SCHEME_OBJECT long_to_integer (long); +extern bool integer_to_ulong_p (SCHEME_OBJECT); +extern unsigned long integer_to_ulong (SCHEME_OBJECT); +extern SCHEME_OBJECT ulong_to_integer (unsigned long); +extern bool integer_to_double_p (SCHEME_OBJECT); +extern double integer_to_double (SCHEME_OBJECT); +extern SCHEME_OBJECT double_to_integer (double); +extern double double_truncate (double); +extern double double_round (double); +extern SCHEME_OBJECT bignum_to_fixnum (SCHEME_OBJECT); +extern SCHEME_OBJECT bignum_to_integer (SCHEME_OBJECT); +extern SCHEME_OBJECT bignum_to_flonum (SCHEME_OBJECT); +extern bool flonum_integer_p (SCHEME_OBJECT); +extern SCHEME_OBJECT flonum_floor (SCHEME_OBJECT); +extern SCHEME_OBJECT flonum_ceiling (SCHEME_OBJECT); +extern SCHEME_OBJECT flonum_round (SCHEME_OBJECT); +extern SCHEME_OBJECT flonum_normalize (SCHEME_OBJECT); +extern SCHEME_OBJECT flonum_denormalize (SCHEME_OBJECT, SCHEME_OBJECT); +extern bool integer_zero_p (SCHEME_OBJECT); +extern bool integer_negative_p (SCHEME_OBJECT); +extern bool integer_positive_p (SCHEME_OBJECT); +extern bool integer_equal_p (SCHEME_OBJECT, SCHEME_OBJECT); +extern bool integer_less_p (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT integer_negate (SCHEME_OBJECT); +extern SCHEME_OBJECT integer_add (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT integer_add_1 (SCHEME_OBJECT); +extern SCHEME_OBJECT integer_subtract (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT integer_subtract_1 (SCHEME_OBJECT); +extern SCHEME_OBJECT integer_multiply (SCHEME_OBJECT, SCHEME_OBJECT); +extern bool integer_divide + (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT *); +extern SCHEME_OBJECT integer_quotient (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT integer_remainder (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT integer_length_in_bits (SCHEME_OBJECT); +extern SCHEME_OBJECT integer_shift_left (SCHEME_OBJECT, unsigned long); + +extern SCHEME_OBJECT double_to_flonum (double); +extern bool real_number_to_double_p (SCHEME_OBJECT); +extern double real_number_to_double (SCHEME_OBJECT); /* Character utilities */ -extern long EXFUN (char_downcase, (long)); -extern long EXFUN (char_upcase, (long)); +extern long char_downcase (long); +extern long char_upcase (long); /* Allocation utilities */ -extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (system_pair_cons, - (long, SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (hunk3_cons, - (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (allocate_non_marked_vector, (int, long, Boolean)); -extern SCHEME_OBJECT EXFUN (allocate_marked_vector, (int, long, Boolean)); -extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean)); -extern SCHEME_OBJECT EXFUN (allocate_string, (unsigned long)); -extern SCHEME_OBJECT EXFUN (allocate_string_no_gc, (unsigned long)); -extern SCHEME_OBJECT EXFUN (memory_to_string, (unsigned long, CONST void *)); -extern SCHEME_OBJECT EXFUN - (memory_to_string_no_gc, (unsigned long, CONST void *)); -extern SCHEME_OBJECT EXFUN (char_pointer_to_string, (CONST char *)); -extern SCHEME_OBJECT EXFUN (char_pointer_to_string_no_gc, (CONST char *)); -extern CONST char * EXFUN (arg_symbol, (int)); -extern CONST char * EXFUN (arg_interned_symbol, (int)); -extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (CONST char *)); -extern SCHEME_OBJECT EXFUN (memory_to_symbol, (unsigned long, CONST char *)); -extern SCHEME_OBJECT EXFUN (find_symbol, (unsigned long, CONST char *)); - +extern SCHEME_OBJECT cons (SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT system_pair_cons (long, SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT hunk3_cons (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT); +extern SCHEME_OBJECT allocate_vector + (unsigned int, unsigned int, unsigned long, SCHEME_OBJECT **); +extern SCHEME_OBJECT allocate_non_marked_vector + (unsigned int, unsigned long, bool); +extern SCHEME_OBJECT allocate_marked_vector + (unsigned int, unsigned long, bool); +extern SCHEME_OBJECT make_vector (unsigned long, SCHEME_OBJECT, bool); +extern SCHEME_OBJECT allocate_string (unsigned long); +extern SCHEME_OBJECT allocate_string_no_gc (unsigned long); +extern SCHEME_OBJECT memory_to_string (unsigned long, const void *); +extern SCHEME_OBJECT memory_to_string_no_gc (unsigned long, const void *); +extern SCHEME_OBJECT char_pointer_to_string (const char *); +extern SCHEME_OBJECT char_pointer_to_string_no_gc (const char *); +extern SCHEME_OBJECT allocate_bit_string (unsigned long); +extern const char * arg_symbol (int); +extern const char * arg_interned_symbol (int); +extern SCHEME_OBJECT intern_symbol (SCHEME_OBJECT); +extern SCHEME_OBJECT string_to_symbol (SCHEME_OBJECT); +extern SCHEME_OBJECT char_pointer_to_symbol (const char *); +extern SCHEME_OBJECT memory_to_symbol (unsigned long, const void *); +extern SCHEME_OBJECT find_symbol (unsigned long, const char *); /* Random and OS utilities */ -extern Boolean EXFUN (Restore_History, (SCHEME_OBJECT)); -extern Boolean EXFUN (interpreter_applicable_p, (SCHEME_OBJECT)); -extern void EXFUN - (add_reload_cleanup, (void EXFUN ((*cleanup_procedure), (void)))); +extern int strcmp_ci (const char *, const char *); +extern bool interpreter_applicable_p (SCHEME_OBJECT); +extern void add_reload_cleanup (void (*) (void)); +extern void execute_reload_cleanups (void); +extern void clear_bit_string (SCHEME_OBJECT); +extern void bit_string_set (SCHEME_OBJECT, long, int); +extern unsigned char * lookup_external_string (SCHEME_OBJECT, unsigned long *); /* Memory management utilities */ - -extern Boolean EXFUN (Pure_Test, (SCHEME_OBJECT *)); +extern bool object_in_constant_space_p (SCHEME_OBJECT); +extern SCHEME_OBJECT * copy_to_constant_space (SCHEME_OBJECT *, unsigned long); + +extern void setup_memory (unsigned long, unsigned long, unsigned long); +extern void reset_memory (void); + +/* Utilities for primitives */ + +typedef struct +{ + unsigned long * internal; + unsigned long * external; + unsigned long next_code; +} prim_renumber_t; + +extern prim_renumber_t * make_prim_renumber (void); +extern SCHEME_OBJECT renumber_primitive (SCHEME_OBJECT, prim_renumber_t *); +extern unsigned long renumbered_primitives_export_length (prim_renumber_t *); +extern void export_renumbered_primitives (SCHEME_OBJECT *, prim_renumber_t *); +extern unsigned long primitive_table_export_length (void); +extern void export_primitive_table (SCHEME_OBJECT *); + +extern void import_primitive_table + (SCHEME_OBJECT *, unsigned long, SCHEME_OBJECT *); + +extern void initialize_primitives (void); +extern SCHEME_OBJECT make_primitive (const char *, int); +extern SCHEME_OBJECT find_primitive (SCHEME_OBJECT, bool, bool, int); /* Interpreter utilities */ -extern void EXFUN (Microcode_Termination, (int code)); -extern void EXFUN (termination_normal, (CONST int)); -extern void EXFUN (termination_init_error, (void)); -extern void EXFUN (termination_end_of_computation, (void)); -extern void EXFUN (termination_trap, (void)); -extern void EXFUN (termination_no_error_handler, (void)); -extern void EXFUN (termination_gc_out_of_space, (void)); -extern void EXFUN (termination_eof, (void)); -extern void EXFUN (termination_signal, (CONST char * signal_name)); - -extern void EXFUN (Setup_Interrupt, (long Masked_Interrupts)); -extern void EXFUN (preserve_interrupt_mask, (void)); -extern void EXFUN (back_out_of_primitive, (void)); - -extern void EXFUN (Interpret, (int)); -extern void EXFUN (Do_Micro_Error, (long, Boolean)); -extern void EXFUN (Translate_To_Point, (SCHEME_OBJECT)); -extern void EXFUN (Stop_History, (void)); -extern void EXFUN (Stack_Death, (void)); - -extern SCHEME_OBJECT * EXFUN (Make_Dummy_History, (void)); -extern SCHEME_OBJECT EXFUN (Find_State_Space, (SCHEME_OBJECT)); +extern void Microcode_Termination (int code) NORETURN; +extern void termination_normal (const int) NORETURN; +extern void termination_init_error (void) NORETURN; +extern void termination_end_of_computation (void) NORETURN; +extern void termination_trap (void) NORETURN; +extern void termination_no_error_handler (void) NORETURN; +extern void termination_gc_out_of_space (void) NORETURN; +extern void termination_eof (void) NORETURN; +extern void termination_signal (const char * signal_name) NORETURN; + +extern void setup_interrupt (unsigned long); +extern void preserve_interrupt_mask (void); +extern void canonicalize_primitive_context (void); +extern void back_out_of_primitive (void); + +extern void Interpret (void); +extern void Do_Micro_Error (long, bool); +extern void Translate_To_Point (SCHEME_OBJECT); +extern void Stack_Death (void) NORETURN; +extern SCHEME_OBJECT * control_point_start (SCHEME_OBJECT); +extern SCHEME_OBJECT * control_point_end (SCHEME_OBJECT); +extern void unpack_control_point (SCHEME_OBJECT); + +extern SCHEME_OBJECT Find_State_Space (SCHEME_OBJECT); /* Debugging utilities */ -extern void EXFUN (debug_edit_flags, (void)); - -extern void EXFUN (Back_Trace, (outf_channel)); -extern void EXFUN (Debug_Stack_Trace, (void)); -extern void EXFUN (Debug_Print, (SCHEME_OBJECT, Boolean)); -extern void EXFUN (Show_Env, (SCHEME_OBJECT)); -extern void EXFUN (Show_Pure, (void)); -extern void EXFUN (Print_Return, (char *)); -extern void EXFUN (Print_Expression, (SCHEME_OBJECT, char *)); -extern void EXFUN (Print_Primitive, (SCHEME_OBJECT)); - -/* Conditional utilities */ - -#ifdef USE_STACKLETS -extern void EXFUN (Allocate_New_Stacklet, (long)); -#endif - -#if FALSE -extern void EXFUN (Clear_Perfinfo_Data, (void)); -#endif +extern void Back_Trace (outf_channel); +extern void Debug_Stack_Trace (void); +extern void Debug_Print (SCHEME_OBJECT, bool); +extern void Show_Env (SCHEME_OBJECT); +extern void Print_Return (char *); +extern void Print_Expression (SCHEME_OBJECT, char *); +extern void Print_Primitive (SCHEME_OBJECT); #endif /* not SCM_EXTERN_H */ diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 874c1770d..fe938c643 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasdump.c,v 9.70 2007/01/05 21:19:25 cph Exp $ +$Id: fasdump.c,v 9.71 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -38,573 +38,608 @@ USA. #include "trap.h" #include "lookup.h" #include "fasl.h" +#include -static Tchannel dump_channel; - -#define Write_Data(size, buffer) \ - ((long) \ - ((OS_channel_write_dump_file \ - (dump_channel, \ - ((char *) (buffer)), \ - ((size) * (sizeof (SCHEME_OBJECT))))) \ - / (sizeof (SCHEME_OBJECT)))) - -#include "dump.c" - -extern SCHEME_OBJECT - EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)), - * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)), - * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)), - * EXFUN (cons_whole_primitive_table, - (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)), - * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -/* Some statics used freely in this file */ +#ifdef ENABLE_GC_DEBUGGING_TOOLS +# define SAVE_GC_VARS save_gc_vars + static void save_gc_vars (void); +# define COMPARE_GC_VARS compare_gc_vars + static void compare_gc_vars (void); +# ifdef HAVE_MHASH_H +# include +# define SAVE_MEMORY_CHECKSUM save_memory_checksum + static void save_memory_checksum (void); +# define COMPARE_MEMORY_CHECKSUM compare_memory_checksum + static void compare_memory_checksum (void); + static void * compute_memory_checksum (void); +# endif +#else +# define SAVE_GC_VARS() do {} while (false) +# define COMPARE_GC_VARS() do {} while (false) +#endif -static SCHEME_OBJECT *NewFree, *NewMemTop, *Fixup; -static Boolean compiled_code_present_p; -static CONST char * dump_file_name = ((char *) 0); +#ifndef SAVE_MEMORY_CHECKSUM +# define SAVE_MEMORY_CHECKSUM() do {} while (false) +# define COMPARE_MEMORY_CHECKSUM() do {} while (false) +#endif -/* FASDUMP: +typedef enum { FE_ERROR, FE_DUMP, FE_DROP_CC } env_mode_t; - Hair squared! ... in order to dump an object it must be traced (as - in a garbage collection), but with some significant differences. - First, the copy must have the global value cell of symbols set to - UNBOUND and variables uncompiled. Second, and worse, all the - broken hearts created during the process must be restored to their - original values. This last is done by growing the copy of the - object in the bottom of spare heap, keeping track of the locations - of broken hearts and original contents at the top of the spare - heap. - - FASDUMP is called with three arguments: - Argument 1: Object to dump. - Argument 2: File name. - Argument 3: Flag. - Currently, flag is ignored. -*/ +typedef struct +{ + const char * filename; + fasl_file_handle_t handle; +} fasl_file_info_t; + +static void close_fasl_file (void *); +static gc_walk_proc_t save_tospace_write; + +static fasl_header_t fasl_header; +static fasl_header_t * fh; +static env_mode_t current_env_mode; +static prim_renumber_t * current_pr; +static bool cc_seen_p; + +static gc_table_t * fasdump_table (void); +static gc_handler_t handle_primitive; +static gc_handler_t handle_manifest_closure; +static gc_handler_t handle_linkage_section; +static gc_handler_t handle_symbol; +static gc_handler_t handle_broken_heart; +static gc_handler_t handle_variable; +static gc_handler_t handle_environment; + +static gc_object_handler_t fasdump_cc_entry; +static gc_precheck_from_t fasdump_precheck_from; +static gc_transport_words_t fasdump_transport_words; + +static void initialize_fixups (void); +static void add_fixup (SCHEME_OBJECT *); +static void run_fixups (void *); + +static void initialize_fasl_header (bool); +static bool write_fasl_file + (SCHEME_OBJECT *, SCHEME_OBJECT *, fasl_file_handle_t); -/* - Copy of GCLoop, except (a) copies out of constant space into the - object to be dumped; (b) changes symbols and variables as - described; (c) keeps track of broken hearts and their original - contents (e) To_Pointer is now NewFree. -*/ - -#define Setup_Pointer_for_Dump(Extra_Code) \ - Dump_Pointer (Fasdump_Setup_Pointer (Extra_Code, \ - Normal_BH (false, continue))) - -#define Dump_Pointer(Code) \ - Old = (OBJECT_ADDRESS (Temp)); \ - Code +/* FASDUMP: -#define DUMP_RAW_POINTER(Code) \ - Old = (SCHEME_ADDR_TO_ADDR (Temp)); \ - Code + In order to dump an object it must be traced (as in a garbage + collection), but with some significant differences. First, the + copy must have the global value cell of symbols set to UNBOUND. + Second, and worse, all the broken hearts created during the process + must be restored to their original values. This last is done by + growing the copy of the object in the bottom of spare heap, keeping + track of the locations of broken hearts and original contents at + the top of the spare heap. */ + +DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, + "(OBJECT NAMESTRING FLAG)\n\ +Writes a binary representation of OBJECT to the file NAMESTRING.\n\ +Returns #T if the operation is successful, or #F otherwise.\n\ +\n\ +FLAG specifies how to handle environment objects that OBJECT points\n\ +to: #F means generate an error; #T means write them as ordinary\n\ +objects; any other value is like #F except that environments pointed\n\ +at by compiled code are ignored (and discarded).") +{ + fasl_file_info_t ff_info; + SCHEME_OBJECT * new_heap_start; + SCHEME_OBJECT * prim_table_start; + unsigned long prim_table_length; + bool ok; + PRIMITIVE_HEADER (3); -/* This depends on the fact that the last word in a compiled code block - contains the environment, and that To will be pointing to the word - immediately after that! - */ + SAVE_GC_VARS (); + SAVE_MEMORY_CHECKSUM (); + + transaction_begin (); /* 1 */ + (ff_info . filename) = (STRING_ARG (2)); + if (!open_fasl_output_file ((ff_info . filename), (& (ff_info . handle)))) + error_bad_range_arg (2); + transaction_record_action (tat_always, close_fasl_file, (&ff_info)); + + open_tospace (heap_start); + initialize_fixups (); + + new_heap_start = (get_newspace_ptr ()); + add_to_tospace (ARG_REF (1)); + + transaction_begin (); /* 2 */ + + current_gc_table = (fasdump_table ()); + current_env_mode + = (((ARG_REF (3)) == SHARP_F) + ? FE_ERROR + : ((ARG_REF (3)) == SHARP_T) + ? FE_DUMP + : FE_DROP_CC); + current_pr = (make_prim_renumber ()); + cc_seen_p = false; + gc_scan_tospace (new_heap_start, 0); + + prim_table_start = (get_newspace_ptr ()); + prim_table_length = (renumbered_primitives_export_length (current_pr)); + increment_tospace_ptr (prim_table_length); + export_renumbered_primitives + ((newspace_to_tospace (prim_table_start)), current_pr); + + transaction_commit (); /* 2 */ + + initialize_fasl_header (cc_seen_p); + (FASLHDR_BAND_P (fh)) = false; + (FASLHDR_CONSTANT_START (fh)) = new_heap_start; + (FASLHDR_CONSTANT_END (fh)) = new_heap_start; + (FASLHDR_HEAP_START (fh)) = new_heap_start; + (FASLHDR_HEAP_END (fh)) = prim_table_start; + (FASLHDR_ROOT_POINTER (fh)) = new_heap_start; + (FASLHDR_N_PRIMITIVES (fh)) = (current_pr->next_code); + (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)) = prim_table_length; + + ok = ((write_fasl_header (fh, (ff_info . handle))) + && (save_tospace (save_tospace_write, (&ff_info)))); + transaction_commit (); /* 1 */ + + COMPARE_GC_VARS (); + COMPARE_MEMORY_CHECKSUM (); + + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (ok)); +} -#define Fasdump_Transport_Compiled() \ -{ \ - Transport_Compiled (); \ - if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \ - *(To - 1) = SHARP_F; \ +static void +close_fasl_file (void * p) +{ + fasl_file_info_t * ff_info = p; + if (!close_fasl_output_file (ff_info->handle)) + OS_file_remove (ff_info->filename); } -#define FASDUMP_TRANSPORT_RAW_COMPILED() \ -{ \ - TRANSPORT_RAW_COMPILED (); \ - if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \ - *(To - 1) = SHARP_F; \ +static bool +save_tospace_write (SCHEME_OBJECT * start, SCHEME_OBJECT * end, void * p) +{ + fasl_file_info_t * ff_info = p; + return (write_to_fasl_file (start, (end - start), (ff_info->handle))); } + +#ifdef ENABLE_GC_DEBUGGING_TOOLS -#define Dump_Compiled_Entry(label) \ -{ \ - Dump_Pointer \ - (Fasdump_Setup_Aligned (Fasdump_Transport_Compiled (), \ - Compiled_BH (false, goto label))); \ +static SCHEME_OBJECT * fasdump_saved_Free; +static SCHEME_OBJECT * fasdump_saved_heap_alloc_limit; +static SCHEME_OBJECT * fasdump_saved_heap_start; +static SCHEME_OBJECT * fasdump_saved_heap_end; +static SCHEME_OBJECT * fasdump_saved_stack_pointer; +static SCHEME_OBJECT * fasdump_saved_stack_guard; +static SCHEME_OBJECT * fasdump_saved_stack_start; +static SCHEME_OBJECT * fasdump_saved_stack_end; +static SCHEME_OBJECT * fasdump_saved_constant_alloc_next; +static SCHEME_OBJECT * fasdump_saved_constant_start; +static SCHEME_OBJECT * fasdump_saved_constant_end; + +#define SAVE_GC_VAR(name) fasdump_saved_##name = name + +static void +save_gc_vars (void) +{ + SAVE_GC_VAR (Free); + SAVE_GC_VAR (heap_alloc_limit); + SAVE_GC_VAR (heap_start); + SAVE_GC_VAR (heap_end); + SAVE_GC_VAR (stack_pointer); + SAVE_GC_VAR (stack_guard); + SAVE_GC_VAR (stack_start); + SAVE_GC_VAR (stack_end); + SAVE_GC_VAR (constant_alloc_next); + SAVE_GC_VAR (constant_start); + SAVE_GC_VAR (constant_end); } -#define DUMP_RAW_COMPILED_ENTRY(label) \ +#define COMPARE_GC_VAR(name) do \ { \ - DUMP_RAW_POINTER \ - (Fasdump_Setup_Aligned (FASDUMP_TRANSPORT_RAW_COMPILED (), \ - RAW_COMPILED_BH (false, \ - goto label))); \ + if (fasdump_saved_##name != name) \ + outf_error ("GC variable changed: " #name ": %p -> %p\n", \ + fasdump_saved_##name, name); \ +} while (false) + +static void +compare_gc_vars (void) +{ + COMPARE_GC_VAR (Free); + COMPARE_GC_VAR (heap_alloc_limit); + COMPARE_GC_VAR (heap_start); + COMPARE_GC_VAR (heap_end); + COMPARE_GC_VAR (stack_pointer); + COMPARE_GC_VAR (stack_guard); + COMPARE_GC_VAR (stack_start); + COMPARE_GC_VAR (stack_end); + COMPARE_GC_VAR (constant_alloc_next); + COMPARE_GC_VAR (constant_start); + COMPARE_GC_VAR (constant_end); } -/* Should be big enough for the largest fixed size object (a Quad) - and 2 for the Fixup. - */ +#ifdef HAVE_MHASH_H -#define FASDUMP_FIX_BUFFER 10 +static void * fasdump_original_digest; -long -DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode) +static void +save_memory_checksum (void) { - fast SCHEME_OBJECT *To, *Old, Temp, New_Address, *Fixes; - long result; -#ifdef ENABLE_GC_DEBUGGING_TOOLS - SCHEME_OBJECT object_referencing; -#endif - - To = NewFree; - Fixes = Fixup; + fasdump_original_digest = (compute_memory_checksum ()); + if (fasdump_original_digest == 0) + outf_error ("Unable to compute fasdump memory checksum."); +} - for ( ; Scan != To; Scan++) - { - Temp = *Scan; -#ifdef ENABLE_GC_DEBUGGING_TOOLS - object_referencing = Temp; -#endif - - Switch_by_GC_Type (Temp) +static void +compare_memory_checksum (void) +{ + if (fasdump_original_digest != 0) { - case TC_PRIMITIVE: - case TC_PCOMB0: - * Scan = (dump_renumber_primitive (* Scan)); - break; - - case TC_BROKEN_HEART: - if ((OBJECT_DATUM (Temp)) != 0) - { - sprintf (gc_death_message_buffer, - "dumploop: broken heart (0x%lx) in scan", - ((long) Temp)); - gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To); - /*NOTREACHED*/ - } - break; - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Scan += (OBJECT_DATUM (Temp)); - break; - - /* Compiled code relocation. */ - - case_compiled_entry_point: - compiled_code_present_p = true; - Dump_Compiled_Entry (after_entry); - after_entry: - * Scan = Temp; - break; - - case TC_MANIFEST_CLOSURE: - { - fast long count; - fast char * word_ptr; - SCHEME_OBJECT * area_end; - - compiled_code_present_p = true; - START_CLOSURE_RELOCATION (Scan); - Scan += 1; - count = (MANIFEST_CLOSURE_COUNT (Scan)); - word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan)); - area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1); - - while ((--count) >= 0) - { - Scan = ((SCHEME_OBJECT *) (word_ptr)); - word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); - EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan); - DUMP_RAW_COMPILED_ENTRY (after_closure); - after_closure: - STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan); - } - Scan = area_end; - END_CLOSURE_RELOCATION (Scan); - break; - } - - case TC_LINKAGE_SECTION: - { - compiled_code_present_p = true; - switch (READ_LINKAGE_KIND (Temp)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - /* Assumes that all others are objects of type TC_QUAD without - their type codes. - */ - - fast long count; - - Scan++; - for (count = (READ_CACHE_LINKAGE_COUNT (Temp)); - --count >= 0; - Scan += 1) - { - Temp = (* Scan); - DUMP_RAW_POINTER (Fasdump_Setup_Pointer - (TRANSPORT_RAW_TRIPLE (), - RAW_BH (false, continue))); - } - Scan -= 1; - break; - } - - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: - { - fast long count; - fast char * word_ptr; - SCHEME_OBJECT * end_scan; - - START_OPERATOR_RELOCATION (Scan); - count = (READ_OPERATOR_LINKAGE_COUNT (Temp)); - word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan)); - end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count)); - - while (--count >= 0) - { - Scan = ((SCHEME_OBJECT *) (word_ptr)); - word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); - EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); - DUMP_RAW_COMPILED_ENTRY (after_operator); - after_operator: - STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); - } - Scan = end_scan; - END_OPERATOR_RELOCATION (Scan); - break; - } - - case CLOSURE_PATTERN_LINKAGE_KIND: - Scan += (READ_CACHE_LINKAGE_COUNT (Temp)); - break; - - default: - { - gc_death (TERM_EXIT, - "fasdump: Unknown compiler linkage kind.", - Scan, Free); - /*NOTREACHED*/ - } - } - break; - } - - case_Cell: - Setup_Pointer_for_Dump (Transport_Cell ()); - break; - - case TC_REFERENCE_TRAP: - if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) + void * digest = (compute_memory_checksum ()); + if (digest == 0) + outf_error ("Unable to recompute fasdump memory checksum."); + else { - /* It is a non pointer. */ - break; + if ((memcmp (digest, + fasdump_original_digest, + (mhash_get_block_size (MHASH_MD5)))) + != 0) + outf_error ("Memory mismatch after fasdump."); + free (digest); } - /* Fall through. */ + free (fasdump_original_digest); + } +} - case TC_WEAK_CONS: - case_Fasdump_Pair: - Setup_Pointer_for_Dump (Transport_Pair ()); - break; +static void * +compute_memory_checksum (void) +{ + MHASH ctx = (mhash_init (MHASH_MD5)); + if (ctx == MHASH_FAILED) + return (0); + (void) mhash (ctx, + fasdump_saved_constant_start, + ((fasdump_saved_constant_alloc_next + - fasdump_saved_constant_start) + * SIZEOF_SCHEME_OBJECT)); + (void) mhash (ctx, + fasdump_saved_heap_start, + ((fasdump_saved_Free - fasdump_saved_heap_start) + * SIZEOF_SCHEME_OBJECT)); + return (mhash_end (ctx)); +} - case TC_INTERNED_SYMBOL: - Setup_Pointer_for_Dump (Fasdump_Symbol (BROKEN_HEART_ZERO)); - break; +#endif /* HAVE_MHASH_H */ +#endif /* ENABLE_GC_DEBUGGING_TOOLS */ + +static gc_table_t * +fasdump_table (void) +{ + static bool initialized_p = false; + static gc_table_t table; - case TC_UNINTERNED_SYMBOL: - Setup_Pointer_for_Dump (Fasdump_Symbol (UNBOUND_OBJECT)); - break; + if (!initialized_p) + { + initialize_gc_table ((&table), true); + + (GCT_CC_ENTRY ((&table))) = fasdump_cc_entry; + (GCT_PRECHECK_FROM ((&table))) = fasdump_precheck_from; + (GCT_TRANSPORT_WORDS ((&table))) = fasdump_transport_words; + + (GCT_ENTRY ((&table), TC_PRIMITIVE)) = handle_primitive; + (GCT_ENTRY ((&table), TC_PCOMB0)) = handle_primitive; + (GCT_ENTRY ((&table), TC_MANIFEST_CLOSURE)) = handle_manifest_closure; + (GCT_ENTRY ((&table), TC_LINKAGE_SECTION)) = handle_linkage_section; + (GCT_ENTRY ((&table), TC_INTERNED_SYMBOL)) = handle_symbol; + (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = handle_broken_heart; + (GCT_ENTRY ((&table), TC_UNINTERNED_SYMBOL)) = handle_symbol; + (GCT_ENTRY ((&table), TC_VARIABLE)) = handle_variable; + (GCT_ENTRY ((&table), TC_ENVIRONMENT)) = handle_environment; + (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair; + + initialized_p = true; + } + return (&table); +} - case_Triple: - Setup_Pointer_for_Dump (Transport_Triple ()); - break; +static +DEFINE_GC_OBJECT_HANDLER (fasdump_cc_entry) +{ +#ifdef CC_SUPPORT_P + SCHEME_OBJECT * old_addr; + SCHEME_OBJECT * new_addr; + unsigned long length; + SCHEME_OBJECT * eptr; + + cc_seen_p = true; + old_addr = (cc_entry_to_block_address (object)); + if (old_addr == (OBJECT_ADDRESS (compiler_utilities))) + return (object); + new_addr = (GC_PRECHECK_FROM (old_addr)); + if (new_addr == 0) + { + length = (OBJECT_DATUM (*old_addr)); + new_addr = (GC_TRANSPORT_WORDS (old_addr, (1 + length), true)); + eptr = (new_addr + length); + if ((current_env_mode == FE_DROP_CC) + && ((OBJECT_TYPE (read_tospace (eptr))) == TC_ENVIRONMENT)) + write_tospace (eptr, SHARP_F); + } + return (CC_ENTRY_NEW_BLOCK (object, new_addr, old_addr)); +#else + gc_no_cc_support (); + return (object); +#endif +} - case TC_VARIABLE: - Setup_Pointer_for_Dump (Fasdump_Variable ()); - break; - - case_Quadruple: - Setup_Pointer_for_Dump (Transport_Quadruple ()); - break; - - case_Aligned_Vector: - Dump_Pointer (Fasdump_Setup_Aligned (goto Move_Vector, - Normal_BH (false, continue))); - break; - - case_Purify_Vector: - process_vector: - Setup_Pointer_for_Dump (Transport_Vector ()); - break; - - case TC_ENVIRONMENT: - if (mode == 1) - goto process_vector; - /* Make fasdump fail */ - result = ERR_FASDUMP_ENVIRONMENT; - goto exit_dumploop; - - case TC_FUTURE: - Setup_Pointer_for_Dump (Transport_Future ()); - break; - - default: - GC_BAD_TYPE ("dumploop", Temp); - /* Fall Through */ - - case TC_STACK_ENVIRONMENT: - case_Fasload_Non_Pointer: - break; - } - } - result = PRIM_DONE; +static +DEFINE_GC_PRECHECK_FROM (fasdump_precheck_from) +{ + return ((BROKEN_HEART_P (*from)) ? (OBJECT_ADDRESS (*from)) : 0); +} -exit_dumploop: - NewFree = To; - Fixup = Fixes; - return (result); +static +DEFINE_GC_TRANSPORT_WORDS (fasdump_transport_words) +{ + /* Signal error here if insufficient space -- otherwise + gc_transport_words() might terminate the microcode. */ + if (!tospace_available_p (n_words)) + signal_error_from_primitive (ERR_FASDUMP_OBJECT_TOO_LARGE); + add_fixup (from); + return (gc_transport_words (from, n_words, align_p)); } -#define DUMPLOOP(obj, mode) \ -{ \ - long value; \ - \ - value = (DumpLoop (obj, mode)); \ - if (value != PRIM_DONE) \ - { \ - PRIMITIVE_RETURN (Fasdump_Exit (value, false)); \ - } \ +static +DEFINE_GC_HANDLER (handle_primitive) +{ + (*scan) = (renumber_primitive (object, current_pr)); + return (scan + 1); } -#define FASDUMP_INTERRUPT() \ -{ \ - PRIMITIVE_RETURN (Fasdump_Exit (PRIM_INTERRUPT, false)); \ +static +DEFINE_GC_HANDLER (handle_manifest_closure) +{ + cc_seen_p = true; + return (gc_handle_manifest_closure (scan, object)); } -SCHEME_OBJECT -DEFUN (Fasdump_Exit, (code, close_p), long code AND Boolean close_p) +static +DEFINE_GC_HANDLER (handle_linkage_section) { - Boolean result; - fast SCHEME_OBJECT *Fixes; + cc_seen_p = true; + return (gc_handle_linkage_section (scan, object)); +} - Fixes = Fixup; - if (close_p) - OS_channel_close_noerror (dump_channel); +static +DEFINE_GC_HANDLER (handle_symbol) +{ + SCHEME_OBJECT * from = (OBJECT_ADDRESS (object)); + SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from)); + if (new_address == 0) + { + new_address = (GC_TRANSPORT_WORDS (from, 2, false)); + write_tospace ((new_address + SYMBOL_GLOBAL_VALUE), + (((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL) + ? BROKEN_HEART_ZERO + : UNBOUND_OBJECT)); + } + (*scan) = (OBJECT_NEW_ADDRESS (object, new_address)); + return (scan + 1); +} - result = true; - while (Fixes != NewMemTop) - { - fast SCHEME_OBJECT *Fix_Address; +static +DEFINE_GC_HANDLER (handle_broken_heart) +{ + return + (((OBJECT_DATUM (object)) == 0) + ? (scan + 1) + : (gc_handle_broken_heart (scan, object))); +} - Fix_Address = (OBJECT_ADDRESS (*Fixes++)); /* Where it goes. */ - *Fix_Address = *Fixes++; /* Put it there. */ - } - Fixup = Fixes; - if ((close_p) && ((!result) || (code != PRIM_DONE))) - OS_file_remove (dump_file_name); +static +DEFINE_GC_HANDLER (handle_variable) +{ + SCHEME_OBJECT * from = (OBJECT_ADDRESS (object)); + SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from)); + if (new_address == 0) + { + new_address = (GC_TRANSPORT_WORDS (from, 3, false)); + write_tospace ((new_address + 1), UNCOMPILED_VARIABLE); + write_tospace ((new_address + 2), SHARP_F); + } + (*scan) = (OBJECT_NEW_ADDRESS (object, new_address)); + return (scan + 1); +} - dump_file_name = ((char *) 0); - Fasdump_Exit_Hook (); - if (!result) - { - signal_error_from_primitive (ERR_IO_ERROR); - /*NOTREACHED*/ - return (0); - } - if (code == PRIM_DONE) - return (SHARP_T); - else if (code == PRIM_INTERRUPT) - return (SHARP_F); - else - { - signal_error_from_primitive (code); - /*NOTREACHED*/ - return (0); - } +static +DEFINE_GC_HANDLER (handle_environment) +{ + if (current_env_mode != FE_DUMP) + signal_error_from_primitive (ERR_FASDUMP_ENVIRONMENT); + (*scan) = (GC_HANDLE_VECTOR (object, false)); + return (scan + 1); } -/* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag) - - Dump an object into a file so that it can be loaded using - BINARY-FASLOAD. A spare heap is required for this operation. The - first argument is the object to be dumped. The second is the - filename or channel. The primitive returns #T or #F indicating - whether it successfully dumped the object (it can fail on an object - that is too large). It should signal an error rather than return - false, but ... some other time. - - The third argument, FLAG, specifies how to handle the dumping of - environment objects: - - SHARP_F means that it is an error to dump an object containing - environment objects. - - SHARP_T means that they should be dumped as if they were ordinary - objects. - - anything else means that the environment objects pointed at by - compiled code blocks should be eliminated on the dumped copy, - but other environments are not allowed. -*/ - -DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) +typedef struct { - Tchannel channel = NO_CHANNEL; - Boolean arg_string_p; - SCHEME_OBJECT Object, *New_Object, arg2, flag; - SCHEME_OBJECT * prim_table_start, * prim_table_end; - long Length, prim_table_length; - Boolean result; - PRIMITIVE_HEADER (3); + SCHEME_OBJECT * addr; + SCHEME_OBJECT object; +} fixup_t; - Object = (ARG_REF (1)); - arg2 = (ARG_REF (2)); - arg_string_p = (STRING_P (arg2)); - if (!arg_string_p) - channel = (arg_channel (2)); - flag = (ARG_REF (3)); +static fixup_t * fixups_start; +static fixup_t * fixups_next; +static fixup_t * fixups_end; + +static void +initialize_fixups (void) +{ + fixup_t * data = (OS_malloc (64 * (sizeof (fixup_t)))); + fixups_start = data; + fixups_next = data; + fixups_end = (data + 64); + transaction_record_action (tat_always, run_fixups, 0); +} - compiled_code_present_p = false; +static void +add_fixup (SCHEME_OBJECT * addr) +{ + if (fixups_next >= fixups_end) + { + unsigned long n = ((fixups_end - fixups_start) * 2); + unsigned long m = (fixups_next - fixups_start); + fixup_t * data = (OS_realloc (fixups_start, (n * (sizeof (fixup_t))))); + fixups_start = data; + fixups_next = (data + m); + fixups_end = (data + n); + } + (fixups_next -> addr) = addr; + (fixups_next -> object) = (*addr); + fixups_next += 1; +} - prim_table_end = &Free[(Space_Before_GC ())]; - prim_table_start = (initialize_primitive_table (Free, prim_table_end)); - if (prim_table_start >= prim_table_end) - Primitive_GC (prim_table_start - Free); +static void +run_fixups (void * p) +{ + fixup_t * scan = fixups_start; + while (scan < fixups_next) + { + (* (scan->addr)) = (scan->object); + scan += 1; + } + OS_free (fixups_start); +} + +DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, + "(PROCEDURE NAMESTRING)\n\ +Saves an image of the current world to the file NAMESTRING.\n\ +When the file is reloaded, PROCEDURE is called with an argument of #F.") +{ + SCHEME_OBJECT * to = Free; + SCHEME_OBJECT * prim_table_start; + SCHEME_OBJECT * c_code_table_start; + bool result; + PRIMITIVE_HEADER (2); - Fasdump_Free_Calc (NewFree, NewMemTop); - Fixup = NewMemTop; - ALIGN_FLOAT (NewFree); - New_Object = NewFree; - *NewFree++ = Object; + CHECK_ARG (1, INTERPRETER_APPLICABLE_P); + CHECK_ARG (2, STRING_P); - if (arg_string_p) + Primitive_GC_If_Needed (5); + initialize_fasl_header (true); + (FASLHDR_BAND_P (fh)) = true; { - /* This needs to be done before Fasdump_Exit is called. - DUMPLOOP may do that. - It should not be done if the primitive will not call - Fasdump_Exit on its way out (ie. Primitive_GC above). - */ - dump_file_name = ((CONST char *) (STRING_LOC (arg2, 0))); + SCHEME_OBJECT comb; + SCHEME_OBJECT root; + + comb = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, to)); + (to[COMB_1_FN]) = (ARG_REF (1)); + (to[COMB_1_ARG_1]) = SHARP_F; + to += 2; + + root = (MAKE_POINTER_OBJECT (TC_LIST, to)); + (*to++) = comb; + (*to++) = compiler_utilities; + + (FASLHDR_ROOT_POINTER (fh)) = to; + (*to++) = root; } - DUMPLOOP (New_Object, - ((flag == SHARP_F) ? 0 : ((flag == SHARP_T) ? 1 : 2))); - Length = (NewFree - New_Object); - prim_table_start = NewFree; - prim_table_end = (cons_primitive_table (NewFree, Fixup, &prim_table_length)); - if (prim_table_end >= Fixup) - FASDUMP_INTERRUPT (); + prim_table_start = to; + (FASLHDR_N_PRIMITIVES (fh)) = MAX_PRIMITIVE; + (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)) = (primitive_table_export_length ()); + to += (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)); -#ifdef NATIVE_CODE_IS_C + c_code_table_start = to; +#ifdef CC_IS_C + (FASLHDR_C_CODE_TABLE_SIZE (fh)) + = (c_code_table_export_length (& (FASLHDR_N_C_CODE_BLOCKS (fh)))); + to += (FASLHDR_C_CODE_TABLE_SIZE (fh)); +#endif + + if (to > heap_end) + result = false; + else + { + const char * filename = (STRING_POINTER (ARG_REF (2))); + SCHEME_OBJECT * faligned_heap = heap_start; + SCHEME_OBJECT * faligned_constant = constant_start; + fasl_file_handle_t handle; + + export_primitive_table (prim_table_start); +#ifdef CC_IS_C + export_c_code_table (c_code_table_start); +#endif - /* Cannot dump C compiled code. */ + while (!FLOATING_ALIGNED_P (faligned_heap)) + faligned_heap += 1; - if (compiled_code_present_p) - PRIMITIVE_RETURN (Fasdump_Exit (ERR_COMPILED_CODE_ERROR, false)); + while (!FLOATING_ALIGNED_P (faligned_constant)) + faligned_constant += 1; -#endif /* NATIVE_CODE_IS_C */ + (FASLHDR_HEAP_START (fh)) = faligned_heap; + (FASLHDR_HEAP_END (fh)) = prim_table_start; + (FASLHDR_CONSTANT_START (fh)) = faligned_constant; + (FASLHDR_CONSTANT_END (fh)) = constant_alloc_next; - if (arg_string_p) - { - channel = (OS_open_dump_file (dump_file_name)); - if (channel == NO_CHANNEL) - PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false)); - } + OS_file_remove_link (filename); + if (!open_fasl_output_file (filename, (&handle))) + error_bad_range_arg (2); + + result + = (write_fasl_file (prim_table_start, c_code_table_start, handle)); - dump_channel = channel; - result = (Write_File (New_Object, - Length, New_Object, - 0, Constant_Space, - prim_table_start, prim_table_length, - ((long) (prim_table_end - prim_table_start)), - prim_table_end, 0, 0, - compiled_code_present_p, false)); - - PRIMITIVE_RETURN (Fasdump_Exit ((result ? PRIM_DONE : PRIM_INTERRUPT), - arg_string_p)); + if (!close_fasl_output_file (handle)) + OS_file_remove (filename); + } + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result)); } -/* (DUMP-BAND PROCEDURE FILE-NAME) - Saves all of the heap and pure space on FILE-NAME. When the - file is loaded back using BAND_LOAD, PROCEDURE is called with an - argument of #F. -*/ - -DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) +static void +initialize_fasl_header (bool cc_p) { - SCHEME_OBJECT - Combination, * saved_free, - * prim_table_start, * prim_table_end, - * c_table_start, * c_table_end; - long - prim_table_length, - c_table_length; - Boolean result = false; - PRIMITIVE_HEADER (2); + fh = (&fasl_header); + (FASLHDR_VERSION (fh)) = OUTPUT_FASL_VERSION; + (FASLHDR_ARCH (fh)) = CURRENT_FASL_ARCH; + +#ifdef HEAP_IN_LOW_MEMORY + (FASLHDR_MEMORY_BASE (fh)) = 0; +#else + (FASLHDR_MEMORY_BASE (fh)) = memory_block_start; +#endif + (FASLHDR_HEAP_RESERVED (fh)) = heap_reserved; - Band_Dump_Permitted (); - CHECK_ARG (1, INTERPRETER_APPLICABLE_P); - CHECK_ARG (2, STRING_P); - if (Unused_Heap_Bottom < Heap_Bottom) - /* Cause the image to be in the low heap, to increase - the probability that no relocation is needed on reload. */ - Primitive_GC (0); - Primitive_GC_If_Needed (5); - saved_free = Free; - Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free)); - Free[COMB_1_FN] = (ARG_REF (1)); - Free[COMB_1_ARG_1] = SHARP_F; - Free += 2; - (* Free++) = Combination; - (* Free++) = compiler_utilities; - (* Free) = (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2))); - Free ++; /* Some compilers are TOO clever about this and increment Free - before calculating Free-2! */ - prim_table_start = Free; - prim_table_end = (cons_whole_primitive_table (prim_table_start, - Heap_Top, - &prim_table_length)); - if (prim_table_end >= Heap_Top) - goto done; - - c_table_start = prim_table_end; - c_table_end = (cons_c_code_table (c_table_start, Heap_Top, &c_table_length)); - if (c_table_end >= Heap_Top) - goto done; + (FASLHDR_STACK_START (fh)) = stack_start; + (FASLHDR_STACK_END (fh)) = stack_end; - { - SCHEME_OBJECT * faligned_heap, * faligned_constant; - CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0))); - - OS_file_remove_link (filename); - dump_channel = (OS_open_dump_file (filename)); - if (dump_channel == NO_CHANNEL) - error_bad_range_arg (2); - - for (faligned_heap = Heap_Bottom; - (! (FLOATING_ALIGNED_P (faligned_heap))); - faligned_heap += 1) - ; - - for (faligned_constant = Constant_Space; - (! (FLOATING_ALIGNED_P (faligned_constant))); - faligned_constant += 1) - ; - - result = (Write_File ((Free - 1), - ((long) (Free - faligned_heap)), - faligned_heap, - ((long) (Free_Constant - faligned_constant)), - faligned_constant, - prim_table_start, prim_table_length, - ((long) (prim_table_end - prim_table_start)), - c_table_start, c_table_length, - ((long) (c_table_end - c_table_start)), - (compiler_utilities != SHARP_F), true)); - OS_channel_close_noerror (dump_channel); - if (! result) - OS_file_remove (filename); - } + if (cc_p) + { + (FASLHDR_CC_VERSION (fh)) = compiler_interface_version; + (FASLHDR_CC_ARCH (fh)) = compiler_processor_type; + (FASLHDR_UTILITIES_VECTOR (fh)) = compiler_utilities; + } + else + { + (FASLHDR_CC_VERSION (fh)) = 0; + (FASLHDR_CC_ARCH (fh)) = COMPILER_NONE_TYPE; + (FASLHDR_UTILITIES_VECTOR (fh)) = SHARP_F; + } + (FASLHDR_N_C_CODE_BLOCKS (fh)) = 0; + (FASLHDR_C_CODE_TABLE_SIZE (fh)) = 0; +} -done: - Band_Dump_Exit_Hook (); - Free = saved_free; - PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result)); +static bool +write_fasl_file (SCHEME_OBJECT * prim_table_start, + SCHEME_OBJECT * c_code_table_start, + fasl_file_handle_t handle) +{ + return + ((write_fasl_header (fh, handle)) + && (write_to_fasl_file ((FASLHDR_HEAP_START (fh)), + (FASLHDR_HEAP_SIZE (fh)), + handle)) + && (write_to_fasl_file ((FASLHDR_CONSTANT_START (fh)), + (FASLHDR_CONSTANT_SIZE (fh)), + handle)) + && (write_to_fasl_file (prim_table_start, + (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)), + handle)) + && (write_to_fasl_file (c_code_table_start, + (FASLHDR_C_CODE_TABLE_SIZE (fh)), + handle))); } diff --git a/v7/src/microcode/fasl.c b/v7/src/microcode/fasl.c new file mode 100644 index 000000000..3b6528e8d --- /dev/null +++ b/v7/src/microcode/fasl.c @@ -0,0 +1,315 @@ +/* -*-C-*- + +$Id: fasl.c,v 11.1 2007/04/22 16:31:22 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* I/O for fasdump and fasload */ + +#include "config.h" +#include "fasl.h" + +static void encode_fasl_header (SCHEME_OBJECT *, fasl_header_t *); +static bool decode_fasl_header (SCHEME_OBJECT *, fasl_header_t *); +static SCHEME_OBJECT * faslobj_address (SCHEME_OBJECT, fasl_header_t *); + +bool +open_fasl_output_file (const char * filename, fasl_file_handle_t * handle_r) +{ + FILE * s = (fopen (filename, "wb")); + if (s == 0) + return (false); + (*handle_r) = s; + return (true); +} + +bool +close_fasl_output_file (fasl_file_handle_t handle) +{ + return ((fclose (handle)) == 0); +} + +bool +write_fasl_header (fasl_header_t * h, fasl_file_handle_t handle) +{ + SCHEME_OBJECT raw [FASL_HEADER_LENGTH]; + + encode_fasl_header (raw, h); + return (write_to_fasl_file (raw, FASL_HEADER_LENGTH, handle)); +} + +bool +write_to_fasl_file (const void * start, size_t n_words, + fasl_file_handle_t handle) +{ + return ((fwrite (start, SIZEOF_SCHEME_OBJECT, n_words, handle)) == n_words); +} + +bool +open_fasl_input_file (const char * filename, fasl_file_handle_t * handle_r) +{ + FILE * s = (fopen (filename, "rb")); + if (s == 0) + return (false); + (*handle_r) = s; + return (true); +} + +bool +close_fasl_input_file (fasl_file_handle_t handle) +{ + return ((fclose (handle)) == 0); +} + +bool +read_fasl_header (fasl_header_t * h, fasl_file_handle_t handle) +{ + SCHEME_OBJECT raw [FASL_HEADER_LENGTH]; + return + ((read_from_fasl_file (raw, FASL_HEADER_LENGTH, handle)) + && (decode_fasl_header (raw, h))); +} + +bool +read_from_fasl_file (void * start, size_t n_words, fasl_file_handle_t handle) +{ + return ((fread (start, SIZEOF_SCHEME_OBJECT, n_words, handle)) == n_words); +} + +fasl_read_status_t +check_fasl_version (fasl_header_t * fh) +{ + return + ((((FASLHDR_VERSION (fh)) >= OLDEST_INPUT_FASL_VERSION) + && ((FASLHDR_VERSION (fh)) <= NEWEST_INPUT_FASL_VERSION)) + ? ((((FASLHDR_ARCH (fh)) == CURRENT_FASL_ARCH) +#ifdef HEAP_IN_LOW_MEMORY + && ((FASLHDR_MEMORY_BASE (fh)) == 0) +#else + && ((FASLHDR_MEMORY_BASE (fh)) != 0) +#endif + ) + ? FASL_FILE_FINE + : FASL_FILE_BAD_MACHINE) + : FASL_FILE_BAD_VERSION); +} + +fasl_read_status_t +check_fasl_cc_version (fasl_header_t * fh, + unsigned long version, unsigned long type) +{ + return + ((((FASLHDR_CC_VERSION (fh)) == 0) + && ((FASLHDR_CC_ARCH (fh)) == COMPILER_NONE_TYPE)) + ? FASL_FILE_FINE + : ((FASLHDR_CC_VERSION (fh)) == version) + ? (((FASLHDR_CC_ARCH (fh)) == type) + ? FASL_FILE_FINE + : FASL_FILE_BAD_PROCESSOR) + : FASL_FILE_BAD_INTERFACE); +} + +static void +encode_fasl_header (SCHEME_OBJECT * raw, fasl_header_t * h) +{ + { + SCHEME_OBJECT * p = raw; + SCHEME_OBJECT * e = (raw + FASL_HEADER_LENGTH); + while (p < e) + (*p++) = SHARP_F; + } +#ifdef DEBUG +#ifdef HEAP_IN_LOW_MEMORY + fprintf (stderr, "\nmemory_base = %#lx\n", + ((unsigned long) (FASLHDR_MEMORY_BASE (h)))); +#endif + fprintf (stderr, "\nheap start %#lx\n", + ((unsigned long) (FASLHDR_HEAP_START (h)))); + fprintf (stderr, "\nroot object %#lx\n", + ((unsigned long) (FASLHDR_ROOT_POINTER (h)))); +#endif + + (raw[FASL_OFFSET_MARKER]) = FASL_FILE_MARKER; + + (raw[FASL_OFFSET_VERSION]) + = (MAKE_FASL_VERSION ((FASLHDR_VERSION (h)), (FASLHDR_ARCH (h)))); + (raw[FASL_OFFSET_CI_VERSION]) + = (MAKE_CI_VERSION ((FASLHDR_BAND_P (h)), + (FASLHDR_CC_VERSION (h)), + (FASLHDR_CC_ARCH (h)))); + + (raw[FASL_OFFSET_MEM_BASE]) + = ((SCHEME_OBJECT) (FASLHDR_MEMORY_BASE (h))); + + (raw[FASL_OFFSET_DUMPED_OBJ]) + = (MAKE_BROKEN_HEART (FASLHDR_ROOT_POINTER (h))); + + (raw[FASL_OFFSET_HEAP_BASE]) + = (MAKE_BROKEN_HEART (FASLHDR_HEAP_START (h))); + (raw[FASL_OFFSET_HEAP_SIZE]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_HEAP_SIZE (h)))); + + if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END) + (raw[FASL_OFFSET_HEAP_RSVD]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_HEAP_RESERVED (h)))); + + (raw[FASL_OFFSET_CONST_BASE]) + = (MAKE_BROKEN_HEART (FASLHDR_CONSTANT_START (h))); + (raw[FASL_OFFSET_CONST_SIZE]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_CONSTANT_SIZE (h)))); + + if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END) + { + (raw[FASL_OFFSET_STACK_START]) + = (MAKE_BROKEN_HEART (FASLHDR_STACK_START (h))); + (raw[FASL_OFFSET_STACK_SIZE]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_STACK_SIZE (h)))); + } + else + (raw[FASL_OFFSET_STACK_START]) + = (MAKE_BROKEN_HEART (FASLHDR_STACK_END (h))); + + (raw[FASL_OFFSET_PRIM_LENGTH]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_N_PRIMITIVES (h)))); + (raw[FASL_OFFSET_PRIM_SIZE]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_PRIMITIVE_TABLE_SIZE (h)))); + + (raw[FASL_OFFSET_C_LENGTH]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_N_C_CODE_BLOCKS (h)))); + (raw[FASL_OFFSET_C_SIZE]) + = (MAKE_OBJECT (TC_BROKEN_HEART, (FASLHDR_C_CODE_TABLE_SIZE (h)))); + + (raw[FASL_OFFSET_UT_BASE]) = (FASLHDR_UTILITIES_VECTOR (h)); +} + +static bool +decode_fasl_header (SCHEME_OBJECT * raw, fasl_header_t * h) +{ + if ((raw[FASL_OFFSET_MARKER]) != FASL_FILE_MARKER) + return (false); + { + SCHEME_OBJECT object = (raw[FASL_OFFSET_VERSION]); + (FASLHDR_VERSION (h)) = (FASL_VERSION (object)); + (FASLHDR_ARCH (h)) = (FASL_ARCH (object)); + } + { + SCHEME_OBJECT object = (raw[FASL_OFFSET_CI_VERSION]); + (FASLHDR_CC_VERSION (h)) = (CI_VERSION (object)); + (FASLHDR_CC_ARCH (h)) = (CI_PROCESSOR (object)); + (FASLHDR_BAND_P (h)) = (CI_BAND_P (object)); + } + { + SCHEME_OBJECT * fasl_memory_base + = ((SCHEME_OBJECT *) (raw[FASL_OFFSET_MEM_BASE])); + (FASLHDR_MEMORY_BASE (h)) = fasl_memory_base; + + (FASLHDR_ROOT_POINTER (h)) + = (faslobj_address ((raw[FASL_OFFSET_DUMPED_OBJ]), h)); + + (FASLHDR_HEAP_START (h)) + = (faslobj_address ((raw[FASL_OFFSET_HEAP_BASE]), h)); + (FASLHDR_HEAP_END (h)) + = ((FASLHDR_HEAP_START (h)) + + (OBJECT_DATUM (raw[FASL_OFFSET_HEAP_SIZE]))); + (FASLHDR_HEAP_RESERVED (h)) + = (((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END) + ? (OBJECT_DATUM (raw[FASL_OFFSET_HEAP_RSVD])) + : 4500); + + (FASLHDR_CONSTANT_START (h)) + = (faslobj_address ((raw[FASL_OFFSET_CONST_BASE]), h)); + (FASLHDR_CONSTANT_END (h)) + = ((FASLHDR_CONSTANT_START (h)) + + (OBJECT_DATUM (raw[FASL_OFFSET_CONST_SIZE]))); + + if ((FASLHDR_VERSION (h)) >= FASL_VERSION_STACK_END) + { + (FASLHDR_STACK_START (h)) + = (faslobj_address ((raw[FASL_OFFSET_STACK_START]), h)); + (FASLHDR_STACK_END (h)) + = ((FASLHDR_STACK_START (h)) + + (OBJECT_DATUM (raw[FASL_OFFSET_STACK_SIZE]))); + } + else + /* In older versions, the "stack start" field held "stack + bottom" instead. Since the stack grows downwards, this was + the maximum address. */ + { + (FASLHDR_STACK_END (h)) + = (faslobj_address ((raw[FASL_OFFSET_STACK_START]), h)); + /* If !HEAP_IN_LOW_MEMORY then fasl_memory_base is the right + value. Otherwise, fasl_memory_base is zero and that is at + least guaranteed to encompass the whole stack. */ + (FASLHDR_STACK_START (h)) = fasl_memory_base; + } + + (FASLHDR_N_PRIMITIVES (h)) + = (OBJECT_DATUM (raw[FASL_OFFSET_PRIM_LENGTH])); + (FASLHDR_PRIMITIVE_TABLE_SIZE (h)) + = (OBJECT_DATUM (raw[FASL_OFFSET_PRIM_SIZE])); + + (FASLHDR_N_C_CODE_BLOCKS (h)) + = (OBJECT_DATUM (raw[FASL_OFFSET_C_LENGTH])); + (FASLHDR_C_CODE_TABLE_SIZE (h)) + = (OBJECT_DATUM (raw[FASL_OFFSET_C_SIZE])); + + { + SCHEME_OBJECT ruv = (raw[FASL_OFFSET_UT_BASE]); + if (ruv == SHARP_F) + { + (FASLHDR_UTILITIES_VECTOR (h)) = SHARP_F; + (FASLHDR_UTILITIES_START (h)) = 0; + } + else + { + SCHEME_OBJECT fuv + = (OBJECT_NEW_ADDRESS (ruv, (faslobj_address (ruv, h)))); + (FASLHDR_UTILITIES_VECTOR (h)) = fuv; + (FASLHDR_UTILITIES_START (h)) = (OBJECT_ADDRESS (fuv)); + } + } + (__FASLHDR_UTILITIES_END (h)) = 0; + } + return (true); +} + +static SCHEME_OBJECT * +faslobj_address (SCHEME_OBJECT o, fasl_header_t * h) +{ + return + (((FASLHDR_MEMORY_BASE (h)) == 0) + ? (OBJECT_ADDRESS (o)) + : ((FASLHDR_MEMORY_BASE (h)) + (OBJECT_DATUM (o)))); +} + +SCHEME_OBJECT * +faslhdr_utilities_end (fasl_header_t * h) +{ + if (((__FASLHDR_UTILITIES_END (h)) == 0) + && (VECTOR_P (FASLHDR_UTILITIES_VECTOR (h)))) + (__FASLHDR_UTILITIES_END (h)) + = (VECTOR_LOC ((FASLHDR_UTILITIES_VECTOR (h)), + (VECTOR_LENGTH (FASLHDR_UTILITIES_VECTOR (h))))); + return (__FASLHDR_UTILITIES_END (h)); +} diff --git a/v7/src/microcode/fasl.h b/v7/src/microcode/fasl.h index f67e5cef0..3cdc03910 100644 --- a/v7/src/microcode/fasl.h +++ b/v7/src/microcode/fasl.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasl.h,v 9.43 2007/01/05 21:19:25 cph Exp $ +$Id: fasl.h,v 9.44 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -28,111 +28,180 @@ USA. /* Contains information relating to the format of FASL files. The machine/opsys information is contained in config.h The processor and compiled code version information is - contained in the appropriate cmp* file, or compiler.c */ - -/* FASL Version */ + contained in the appropriate cmp* file, or compiler.c. */ + +#ifndef SCM_FASL_H +#define SCM_FASL_H 1 + +#include "object.h" -#if (SIZEOF_UNSIGNED_LONG == 8) -#define FASL_FILE_MARKER 0xFAFAFAFAFAFAFAFAULL +#if (SIZEOF_UNSIGNED_LONG == 4) +# define FASL_FILE_MARKER 0xFAFAFAFAUL #else -#define FASL_FILE_MARKER 0xFAFAFAFAUL +# if (SIZEOF_UNSIGNED_LONG == 8) +# define FASL_FILE_MARKER 0xFAFAFAFAFAFAFAFAUL +# endif #endif /* The FASL file has a header which begins as follows: */ #define FASL_HEADER_LENGTH 50 /* Scheme objects in header */ -#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */ -#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */ -#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */ -#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */ -#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */ -#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */ -#define FASL_Offset_Version 6 /* FASL format version info. */ -#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */ -#define FASL_Offset_Prim_Length 8 /* Number of entries in primitive table */ -#define FASL_Offset_Prim_Size 9 /* Size of primitive table in SCHEME_OBJECTs */ -#define FASL_Offset_Ci_Version 10 /* Version number for compiled code interface */ -#define FASL_Offset_Ut_Base 11 /* Address of the utilities vector */ -#define FASL_Offset_Check_Sum 12 /* Header and data checksum. */ -#define FASL_Offset_C_Length 13 /* Number of entries in the C code table */ -#define FASL_Offset_C_Size 14 /* Size of C code table in SCHEME_OBJECTs */ -#define FASL_Offset_Mem_Base 15 /* Base address when not HEAP_IN_LOW_MEMORY */ - -#define FASL_Offset_First_Free 16 /* Used to clear header */ - -/* Aliases for backwards compatibility. */ - -/* Where ext. prims. vector is */ -#define FASL_Offset_Ext_Loc FASL_Offset_Prim_Length - -/* Version information encoding */ +#define FASL_OFFSET_MARKER 0 /* Marker to indicate FASL format */ +#define FASL_OFFSET_HEAP_SIZE 1 /* # of words in heap */ +#define FASL_OFFSET_HEAP_BASE 2 /* Address of heap when dumped */ +#define FASL_OFFSET_DUMPED_OBJ 3 /* Where dumped object was */ +#define FASL_OFFSET_CONST_SIZE 4 /* # of words in constant area */ +#define FASL_OFFSET_CONST_BASE 5 /* Address of const. area at dump */ +#define FASL_OFFSET_VERSION 6 /* FASL format version info. */ +#define FASL_OFFSET_STACK_START 7 /* value of stack_start when dumped */ +#define FASL_OFFSET_PRIM_LENGTH 8 /* # of entries in primitive table */ +#define FASL_OFFSET_PRIM_SIZE 9 /* # of words in primitive table */ +#define FASL_OFFSET_CI_VERSION 10 /* Version of comp. code interface */ +#define FASL_OFFSET_UT_BASE 11 /* Address of the utilities vector */ + +#if 0 +#define FASL_OFFSET_CHECK_SUM 12 /* Header and data checksum. */ +#endif -#define ONE ((SCHEME_OBJECT) 1) - -#define MACHINE_TYPE_LENGTH (OBJECT_LENGTH / 2) -#define MACHINE_TYPE_MASK ((ONE << MACHINE_TYPE_LENGTH) - 1) -#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK) -#define SUBVERSION_LENGTH (MACHINE_TYPE_LENGTH - TYPE_CODE_LENGTH) -#define SUBVERSION_MASK ((ONE << SUBVERSION_LENGTH) - 1) -#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUBVERSION_MASK) -#define The_Version(P) (OBJECT_TYPE (P)) - -#define Make_Version(V, S, M) \ - MAKE_OBJECT ((V), ((((unsigned long) (S)) << MACHINE_TYPE_LENGTH) \ - | (M))) \ - -#define CI_MASK ((ONE << (DATUM_LENGTH / 2)) - 1) -#define CI_VERSION(P) (((P) >> (DATUM_LENGTH / 2)) & CI_MASK) -#define CI_PROCESSOR(P) ((P) & CI_MASK) -#define CI_BAND_P(P) ((OBJECT_TYPE (P)) == TC_CONSTANT) - -#define MAKE_CI_VERSION(Band_p, Version, Processor_Type) \ - MAKE_OBJECT (((Band_p) ? TC_CONSTANT : TC_NULL), \ - ((((unsigned long) (Version)) << (DATUM_LENGTH / 2)) \ - | (Processor_Type))) +#define FASL_OFFSET_C_LENGTH 13 /* # of entries in the C code table */ +#define FASL_OFFSET_C_SIZE 14 /* # of words in the C code table */ +#define FASL_OFFSET_MEM_BASE 15 /* Saved value of memory_base */ +#define FASL_OFFSET_STACK_SIZE 16 /* # of words in stack area */ +#define FASL_OFFSET_HEAP_RSVD 17 /* value of heap_reserved */ -/* "Memorable" FASL versions -- ones where we modified something - and want to remain backwards compatible. -*/ - -/* Versions. */ - -#define FASL_FORMAT_ADDED_STACK 1 - -/* Subversions of highest numbered version. */ - -#define FASL_LONG_HEADER 3 -#define FASL_DENSE_TYPES 4 -#define FASL_PADDED_STRINGS 5 -#define FASL_REFERENCE_TRAP 6 -#define FASL_MERGED_PRIMITIVES 7 -#define FASL_INTERFACE_VERSION 8 -#define FASL_NEW_BIGNUMS 9 -#define FASL_C_CODE 10 - -/* Current parameters. Always used on output. */ - -#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK -#define FASL_SUBVERSION FASL_C_CODE - -/* - The definitions below correspond to the ones above. They usually - have the same values. They differ when the format is changing: A - system can be built which reads the old format, but dumps the new one. - */ - -#ifndef FASL_READ_VERSION -#define FASL_READ_VERSION FASL_FORMAT_ADDED_STACK -#endif +/* Version information encoding */ -#ifndef FASL_READ_SUBVERSION -#define FASL_READ_SUBVERSION FASL_NEW_BIGNUMS +#define FASL_ARCH_LENGTH (OBJECT_LENGTH / 2) +#define FASL_ARCH(P) ((P) & ((1UL << FASL_ARCH_LENGTH) - 1)) + +#define FASL_VERSION_LENGTH (FASL_ARCH_LENGTH - TYPE_CODE_LENGTH) +#define FASL_VERSION(P) \ + (((P) >> FASL_ARCH_LENGTH) & ((1UL << FASL_VERSION_LENGTH) - 1)) + +/* The '1' here is for upwards compatibility. */ +#define MAKE_FASL_VERSION(s, a) \ + (MAKE_OBJECT (1, ((((unsigned long) (s)) << FASL_ARCH_LENGTH) | (a)))) + +#define CI_VERSION(P) (((P) >> HALF_DATUM_LENGTH) & HALF_DATUM_MASK) +#define CI_PROCESSOR(P) ((cc_arch_t) ((P) & HALF_DATUM_MASK)) +#define CI_BAND_P(P) ((OBJECT_TYPE (P)) == TC_CONSTANT) + +#define MAKE_CI_VERSION(b, v, a) \ + (MAKE_OBJECT (((b) ? TC_CONSTANT : TC_NULL), \ + ((((unsigned long) (v)) << HALF_DATUM_LENGTH) \ + | ((unsigned long) (a))))) + +typedef enum +{ + FASL_VERSION_NONE, + FASL_VERSION_LONG_HEADER = 3, + FASL_VERSION_DENSE_TYPES, + FASL_VERSION_PADDED_STRINGS, + FASL_VERSION_REFERENCE_TRAP, + FASL_VERSION_MERGED_PRIMITIVES, + FASL_VERSION_INTERFACE_VERSION, + FASL_VERSION_NEW_BIGNUMS, + FASL_VERSION_C_CODE, + FASL_VERSION_STACK_END +} fasl_version_t; + +#define OLDEST_INPUT_FASL_VERSION FASL_VERSION_C_CODE +#define NEWEST_INPUT_FASL_VERSION FASL_VERSION_STACK_END + +#if 0 +/* Temporarily disabled for testing. */ +#define OUTPUT_FASL_VERSION FASL_VERSION_STACK_END +#else +#define OUTPUT_FASL_VERSION FASL_VERSION_C_CODE #endif - -/* These are for Bintopsb. - They are the values of the oldest supported formats. - */ - -#define FASL_OLDEST_VERSION FASL_FORMAT_ADDED_STACK -#define FASL_OLDEST_SUBVERSION FASL_PADDED_STRINGS + +typedef struct +{ + fasl_version_t version; + fasl_arch_t arch; + unsigned int cc_version; + cc_arch_t cc_arch; + bool band_p; + SCHEME_OBJECT * memory_base; + SCHEME_OBJECT * root_pointer; + SCHEME_OBJECT * heap_start; + SCHEME_OBJECT * heap_end; + unsigned long heap_reserved; + SCHEME_OBJECT * constant_start; + SCHEME_OBJECT * constant_end; + SCHEME_OBJECT * stack_start; + SCHEME_OBJECT * stack_end; + unsigned long n_primitives; + unsigned long primitive_table_size; + unsigned long n_c_code_blocks; + unsigned long c_code_table_size; + SCHEME_OBJECT utilities_vector; + SCHEME_OBJECT * utilities_start; + SCHEME_OBJECT * utilities_end; +} fasl_header_t; + +#define FASLHDR_VERSION(h) ((h)->version) +#define FASLHDR_ARCH(h) ((h)->arch) +#define FASLHDR_CC_VERSION(h) ((h)->cc_version) +#define FASLHDR_CC_ARCH(h) ((h)->cc_arch) +#define FASLHDR_BAND_P(h) ((h)->band_p) +#define FASLHDR_MEMORY_BASE(h) ((h)->memory_base) +#define FASLHDR_ROOT_POINTER(h) ((h)->root_pointer) +#define FASLHDR_HEAP_START(h) ((h)->heap_start) +#define FASLHDR_HEAP_END(h) ((h)->heap_end) +#define FASLHDR_HEAP_RESERVED(h) ((h)->heap_reserved) +#define FASLHDR_CONSTANT_START(h) ((h)->constant_start) +#define FASLHDR_CONSTANT_END(h) ((h)->constant_end) +#define FASLHDR_STACK_START(h) ((h)->stack_start) +#define FASLHDR_STACK_END(h) ((h)->stack_end) +#define FASLHDR_N_PRIMITIVES(h) ((h)->n_primitives) +#define FASLHDR_PRIMITIVE_TABLE_SIZE(h) ((h)->primitive_table_size) +#define FASLHDR_N_C_CODE_BLOCKS(h) ((h)->n_c_code_blocks) +#define FASLHDR_C_CODE_TABLE_SIZE(h) ((h)->c_code_table_size) +#define FASLHDR_UTILITIES_VECTOR(h) ((h)->utilities_vector) +#define FASLHDR_UTILITIES_START(h) ((h)->utilities_start) +#define __FASLHDR_UTILITIES_END(h) ((h)->utilities_end) + +#define FASLHDR_UTILITIES_END(h) (faslhdr_utilities_end (h)) + +#define FASLHDR_HEAP_SIZE(h) \ + ((unsigned long) \ + ((FASLHDR_HEAP_END (h)) - (FASLHDR_HEAP_START (h)))) + +#define FASLHDR_CONSTANT_SIZE(h) \ + ((unsigned long) \ + ((FASLHDR_CONSTANT_END (h)) - (FASLHDR_CONSTANT_START (h)))) + +#define FASLHDR_STACK_SIZE(h) \ + ((unsigned long) \ + ((FASLHDR_STACK_END (h)) - (FASLHDR_STACK_START (h)))) + +typedef enum +{ + FASL_FILE_FINE, + FASL_FILE_TOO_SHORT, + FASL_FILE_NOT_FASL, + FASL_FILE_BAD_MACHINE, + FASL_FILE_BAD_VERSION, + FASL_FILE_BAD_SUBVERSION, /* unused */ + FASL_FILE_BAD_PROCESSOR, + FASL_FILE_BAD_INTERFACE +} fasl_read_status_t; + +typedef FILE * fasl_file_handle_t; + +extern bool open_fasl_output_file (const char *, fasl_file_handle_t *); +extern bool close_fasl_output_file (fasl_file_handle_t); +extern bool write_fasl_header (fasl_header_t *, fasl_file_handle_t); +extern bool write_to_fasl_file (const void *, size_t, fasl_file_handle_t); +extern bool open_fasl_input_file (const char *, fasl_file_handle_t *); +extern bool close_fasl_input_file (fasl_file_handle_t); +extern bool read_fasl_header (fasl_header_t *, fasl_file_handle_t); +extern bool read_from_fasl_file (void *, size_t, fasl_file_handle_t); +extern SCHEME_OBJECT * faslhdr_utilities_end (fasl_header_t *); +extern fasl_read_status_t check_fasl_version (fasl_header_t *); +extern fasl_read_status_t check_fasl_cc_version + (fasl_header_t *, unsigned long, unsigned long); + +#endif /* not SCM_FASL_H */ diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 1d3bcfbaa..45242f7c7 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasload.c,v 9.100 2007/04/14 03:53:32 cph Exp $ +$Id: fasload.c,v 9.101 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,1176 +25,640 @@ USA. */ -/* The "fast loader" which reads in and relocates binary files and then - interns symbols. It is called with one argument: the (character - string) name of a file to load. It is called as a primitive, and - returns a single object read in. */ +/* The "fast loader" reads a FASL file, which contains a binary + representation of an object. The "band loader" reads a special + FASL file containing a world image. */ #include "scheme.h" #include "prims.h" +#include "history.h" #include "osscheme.h" #include "osfile.h" #include "osio.h" #include "gccode.h" #include "trap.h" #include "option.h" -#include "prmcon.h" - -static Tchannel load_channel; - -#define Load_Data(size, buffer) \ - ((long) \ - ((OS_channel_read_load_file \ - (load_channel, \ - ((char *) (buffer)), \ - ((size) * (sizeof (SCHEME_OBJECT))))) \ - / (sizeof (SCHEME_OBJECT)))) +#include "fasl.h" + +static fasl_header_t fasl_header; +static fasl_header_t * fh; +static SCHEME_OBJECT * new_heap_start; +static SCHEME_OBJECT * new_constant_start; +static SCHEME_OBJECT * new_stack_start; +static SCHEME_OBJECT * new_stack_end; +static SCHEME_OBJECT * new_utilities; +static SCHEME_OBJECT * new_prim_table; + +#define REQUIRED_HEAP(h) \ + ((FASLHDR_HEAP_SIZE (h)) \ + + (FASLHDR_N_PRIMITIVES (h)) \ + + (FASLHDR_PRIMITIVE_TABLE_SIZE (h))) + +struct load_band_termination_state +{ + const char * file_name; + bool no_return_p; +}; -#include "load.c" +typedef void (*cleanup_t) (void); -#ifdef STDC_HEADERS -# include -# include -#else - extern char * EXFUN (malloc, (int)); - extern int EXFUN (strlen, (const char *)); - extern char * EXFUN (strcpy, (char *, const char *)); +static const char * reload_band_name = 0; +static Tptrvec reload_cleanups = 0; +static unsigned long reload_heap_size = 0; +static unsigned long reload_constant_size = 0; + +static void init_fasl_file (const char *, bool, fasl_file_handle_t *); +static void close_fasl_file (void *); + +static SCHEME_OBJECT load_file (fasl_file_handle_t); +static void * read_from_file (void *, size_t, fasl_file_handle_t); +static bool primitive_numbers_unchanged_p (SCHEME_OBJECT *); + +static gc_table_t * relocate_block_table (void); +static gc_handler_t handle_primitive; +static gc_tuple_handler_t fasload_tuple; +static gc_vector_handler_t fasload_vector; +static gc_object_handler_t fasload_cc_entry; +#ifndef HEAP_IN_LOW_MEMORY +static gc_raw_address_to_object_t fasload_raw_address_to_object; +static gc_raw_address_to_cc_entry_t fasload_raw_address_to_cc_entry; #endif +static void * relocate_address (void *); -extern char * Error_Names []; -extern char * Abort_Names []; -extern SCHEME_OBJECT * load_renumber_table; -extern SCHEME_OBJECT compiler_utilities; - -extern SCHEME_OBJECT - EXFUN (intern_symbol, (SCHEME_OBJECT)); - -extern void - EXFUN (install_primitive_table, (SCHEME_OBJECT *, long)), - EXFUN (compiler_reset_error, (void)), - EXFUN (compiler_initialize, (long)), - EXFUN (compiler_reset, (SCHEME_OBJECT)); +static gc_table_t * intern_block_table (void); +static gc_handler_t intern_handle_symbol; +static gc_tuple_handler_t intern_tuple; +static gc_vector_handler_t intern_vector; +static gc_object_handler_t intern_cc_entry; -extern Boolean - EXFUN (install_c_code_table, (SCHEME_OBJECT *, long)); +static SCHEME_OBJECT read_band_file (SCHEME_OBJECT); +static void terminate_band_load (void *); -static long failed_heap_length = -1; - -#define MODE_BAND 0 -#define MODE_CHANNEL 1 -#define MODE_FNAME 2 - -static void -DEFUN (read_channel_continue, (header, mode, repeat_p), - SCHEME_OBJECT * header AND int mode AND Boolean repeat_p) +DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, "(NAMESTRING)\n\ +Load the contents of the file NAMESTRING into memory. The file was\n\ +presumably made by a call to PRIMITIVE-FASDUMP, and may contain data\n\ +for the heap and/or the pure area. The value returned is the object\n\ +that was dumped.") { - extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); - long value, heap_length; - - value = (initialize_variables_from_fasl_header (header)); - - if (value != FASL_FILE_FINE) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - switch (value) - { - /* These may want to be separated further. */ - case FASL_FILE_TOO_SHORT: - case FASL_FILE_NOT_FASL: - case FASL_FILE_BAD_MACHINE: - case FASL_FILE_BAD_VERSION: - case FASL_FILE_BAD_SUBVERSION: - signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); - /*NOTREACHED*/ - - case FASL_FILE_BAD_PROCESSOR: - case FASL_FILE_BAD_INTERFACE: - signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); - /*NOTREACHED*/ - } - } + fasl_file_handle_t handle; + static unsigned long failed_heap_length = 0; + unsigned long heap_length; + SCHEME_OBJECT result; + PRIMITIVE_HEADER (1); - if (Or2 (Reloc_Debug, File_Load_Debug)) - print_fasl_information(); + canonicalize_primitive_context (); + transaction_begin (); - if (((mode == MODE_BAND) - && (! (update_allocator_parameters (Free_Constant + Const_Count)))) - || ((mode != MODE_BAND) - && (! (TEST_CONSTANT_TOP (Free_Constant + Const_Count))))) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); + init_fasl_file ((STRING_ARG (1)), false, (&handle)); + if ((FASLHDR_CONSTANT_SIZE (fh)) > 0) signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); - /*NOTREACHED*/ - } - if (mode == MODE_BAND) - { - SET_CONSTANT_TOP (); - ALIGN_FLOAT (Free); - SET_MEMTOP (Heap_Top); - } - heap_length = (Heap_Count - + Primitive_Table_Size - + Primitive_Table_Length - + C_Code_Table_Size); - - if (GC_Check (heap_length)) - { - if (repeat_p - || (heap_length == failed_heap_length) - || (mode == MODE_BAND)) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); - /*NOTREACHED*/ - } - else if (mode == MODE_CHANNEL) - { - SCHEME_OBJECT reentry_record[1]; - - /* IMPORTANT: This KNOWS that it was called from BINARY-FASLOAD. - If this is ever called from elsewhere with MODE_CHANNEL, - it will have to be parameterized better. - - This reentry record must match the expectations of - continue_fasload below. - */ - - Request_GC (heap_length); - - /* This assumes that header == (Free + 1) */ - header = Free; - Free += (FASL_HEADER_LENGTH + 1); - *header = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, FASL_HEADER_LENGTH)); - - reentry_record[0] = (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, header)); - - suspend_primitive (CONT_FASLOAD, - ((sizeof (reentry_record)) - / (sizeof (SCHEME_OBJECT))), - &reentry_record[0]); - immediate_interrupt (); - /*NOTREACHED*/ - } - else + heap_length = (REQUIRED_HEAP (fh)); + if (GC_NEEDED_P (heap_length)) { + if (heap_length == failed_heap_length) + signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); failed_heap_length = heap_length; - OS_channel_close_noerror (load_channel); - Request_GC (heap_length); + REQUEST_GC (heap_length); signal_interrupt_from_primitive (); - /*NOTREACHED*/ } - } - failed_heap_length = -1; + failed_heap_length = 0; - if ((band_p) && (mode != MODE_BAND)) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_FASLOAD_BAND); - } - return; + result = (load_file (handle)); + transaction_commit (); + PRIMITIVE_RETURN (result); } - + static void -DEFUN (read_channel_start, (channel, mode), Tchannel channel AND int mode) +init_fasl_file (const char * file_name, bool band_p, + fasl_file_handle_t * handle) { - load_channel = channel; - - if (GC_Check (FASL_HEADER_LENGTH + 1)) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - Request_GC (FASL_HEADER_LENGTH + 1); - signal_interrupt_from_primitive (); - /* NOTREACHED */ - } + if (!open_fasl_input_file (file_name, handle)) + error_bad_range_arg (1); + transaction_record_action (tat_always, close_fasl_file, handle); - if ((Load_Data (FASL_HEADER_LENGTH, ((char *) (Stack_Bottom + 1)))) - != FASL_HEADER_LENGTH) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); + fh = (&fasl_header); + if (!read_fasl_header (fh, (*handle))) signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); - } - read_channel_continue ((Stack_Bottom + 1), mode, false); - return; -} +#ifndef INHIBIT_FASL_VERSION_CHECK + if ((check_fasl_version (fh)) != FASL_FILE_FINE) + { + outf_error ("\nBad version in FASL File: %s\n", file_name); + outf_error + ("File has: Version %4u Architecture %4u.\n", + (FASLHDR_VERSION (fh)), (FASLHDR_ARCH (fh))); + outf_error + ("Expected: Version between %4u and %4u Architecture %4u.\n", + OLDEST_INPUT_FASL_VERSION, + NEWEST_INPUT_FASL_VERSION, + CURRENT_FASL_ARCH); + signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); + } +#endif -static void -DEFUN (read_file_start, (file_name, from_band_load), - CONST char * file_name AND Boolean from_band_load) -{ - Tchannel channel; +#ifndef INHIBIT_COMPILED_VERSION_CHECK + if ((check_fasl_cc_version (fh, + compiler_interface_version, + compiler_processor_type)) + != FASL_FILE_FINE) + { + outf_error ("\nBad compiled-code version in FASL File: %s\n", file_name); + outf_error + ("File has: compiled-code interface %4u; architecture %4u.\n", + (FASLHDR_CC_VERSION (fh)), (FASLHDR_CC_ARCH (fh))); + outf_error + ("Expected: compiled code interface %4u; architecture %4u.\n", + compiler_interface_version, compiler_processor_type); + signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); + } +#endif - channel = (OS_open_load_file (file_name)); - - if (Per_File) - debug_edit_flags (); - if (channel == NO_CHANNEL) - error_bad_range_arg (1); - read_channel_start (channel, (from_band_load ? MODE_BAND : MODE_FNAME)); - return; + if ((FASLHDR_BAND_P (fh)) != band_p) + signal_error_from_primitive (ERR_FASLOAD_BAND); } - + static void -DEFUN (read_file_end, (mode, prim_table_ptr, c_code_table_ptr), - int mode - AND SCHEME_OBJECT ** prim_table_ptr - AND SCHEME_OBJECT ** c_code_table_ptr) +close_fasl_file (void * p) { - SCHEME_OBJECT * prim_table, * c_code_table; - extern unsigned long checksum_area (); - - if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_IO_ERROR); - } - computed_checksum = - (checksum_area (((unsigned long *) Free), - Heap_Count, - computed_checksum)); - NORMALIZE_REGION(((char *) Free), Heap_Count); - Free += Heap_Count; - - if ((Load_Data (Const_Count, ((char *) Free_Constant))) != Const_Count) - { - SET_CONSTANT_TOP (); - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_IO_ERROR); - } - computed_checksum = - (checksum_area (((unsigned long *) Free_Constant), - Const_Count, - computed_checksum)); - NORMALIZE_REGION (((char *) Free_Constant), Const_Count); - Free_Constant += Const_Count; - SET_CONSTANT_TOP (); - - prim_table = Free; - if ((Load_Data (Primitive_Table_Size, ((char *) prim_table))) - != Primitive_Table_Size) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_IO_ERROR); - } - computed_checksum = - (checksum_area (((unsigned long *) prim_table), - Primitive_Table_Size, - computed_checksum)); - NORMALIZE_REGION (((char *) prim_table), Primitive_Table_Size); - Free += Primitive_Table_Size; - - c_code_table = Free; - * c_code_table = FIXNUM_ZERO; - if ((C_Code_Table_Size != 0) - && ((Load_Data (C_Code_Table_Size, ((char *) c_code_table))) - != C_Code_Table_Size)) - { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_IO_ERROR); - } - computed_checksum = - (checksum_area (((unsigned long *) c_code_table), - C_Code_Table_Size, - computed_checksum)); - NORMALIZE_REGION (((char *) c_code_table), C_Code_Table_Size); - Free += C_Code_Table_Size; - - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - - if ((computed_checksum != ((unsigned long) 0)) - && (dumped_checksum != SHARP_F)) - signal_error_from_primitive (ERR_IO_ERROR); - - * prim_table_ptr = prim_table; - * c_code_table_ptr = c_code_table; - return; + (void) close_fasl_input_file (* ((fasl_file_handle_t *) p)); } -/* Statics used by Relocate, below */ - -relocation_type - heap_relocation, - const_relocation, - stack_relocation; +DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, "(NAMESTRING)\n\ +Restores the heap and constant space from the contents of the file\n\ +NAMESTRING, which is typically a file created by DUMP-BAND. The file\n\ +can, however, be any file which can be loaded with BINARY-FASLOAD.") +{ + SCHEME_OBJECT result; + PRIMITIVE_HEADER (1); -/* Relocate a pointer as read in from the file. If the pointer used - to point into the heap, relocate it into the heap. If it used to - be constant area, relocate it to constant area. Otherwise give an - error. -*/ + CHECK_ARG (1, STRING_P); + canonicalize_primitive_context (); + result = (read_band_file (ARG_REF (1))); -#ifdef ENABLE_DEBUGGING_TOOLS + /* Reset implementation state parameters. */ + INITIALIZE_INTERRUPTS (0); +#ifdef CC_SUPPORT_P + compiler_utilities = (PAIR_CDR (result)); + if (compiler_utilities != SHARP_F) + compiler_reset (compiler_utilities); + else + compiler_initialize (true); +#endif + fixed_objects = SHARP_F; + current_state_point = SHARP_F; -static Boolean Warned = false; + /* Setup initial program */ + SET_RC (RC_END_OF_COMPUTATION); + SET_EXP (SHARP_F); + SAVE_CONT (); + SET_EXP (PAIR_CAR (result)); + SET_ENV (THE_GLOBAL_ENV); + + /* Clear various interpreter state parameters. */ + trapping = false; + history_register = (make_dummy_history ()); + prev_restore_history_offset = 0; + CC_TRANSPORT_END (); + execute_reload_cleanups (); + EXIT_CRITICAL_SECTION ({}); -static SCHEME_OBJECT * -DEFUN (relocate, (P), long P) -{ - SCHEME_OBJECT * Result; - - if ((P >= Heap_Base) && (P < Dumped_Heap_Top)) - Result = ((SCHEME_OBJECT *) (P + heap_relocation)); - else if ((P >= Const_Base) && (P < Dumped_Constant_Top)) - Result = ((SCHEME_OBJECT *) (P + const_relocation)); - else if ((P >= Dumped_Constant_Top) && (P < Dumped_Stack_Top)) - Result = ((SCHEME_OBJECT *) (P + stack_relocation)); - else - { - outf_console ("Pointer out of range: 0x%lx\n", P); - if (!Warned) - { - outf_console ("Heap: %lx-%lx, Constant: %lx-%lx, Stack: ?-0x%lx\n", - ((long) Heap_Base), ((long) Dumped_Heap_Top), - ((long) Const_Base), ((long) Dumped_Constant_Top), - ((long) Dumped_Stack_Top)); - Warned = true; - } - Result = ((SCHEME_OBJECT *) 0); - } - if (Reloc_Debug) - outf_console ("0x%06lx -> 0x%06lx\n", P, ((long) Result)); - return (Result); + /* Return in a non-standard way. */ + PRIMITIVE_ABORT (PRIM_DO_EXPRESSION); + /*NOTREACHED*/ + PRIMITIVE_RETURN (UNSPECIFIC); } -#define RELOCATE relocate -#define RELOCATE_INTO(Loc, P) (Loc) = relocate(P) - -#else /* not ENABLE_DEBUGGING_TOOLS */ - -#define RELOCATE_INTO(Loc, P) do \ -{ \ - long _P = (P); \ - \ - if ((P >= Heap_Base) && (_P < Dumped_Heap_Top)) \ - (Loc) = ((SCHEME_OBJECT *) (_P + heap_relocation)); \ - else if ((P >= Const_Base) && (_P < Dumped_Constant_Top)) \ - (Loc) = ((SCHEME_OBJECT *) (_P + const_relocation)); \ - else \ - (Loc) = ((SCHEME_OBJECT *) (_P + stack_relocation)); \ -} while (0) - -#ifndef Conditional_Bug - -#define RELOCATE(P) \ -((((P) >= Heap_Base) && ((P) < Dumped_Heap_Top)) \ - ? ((SCHEME_OBJECT *) ((P) + heap_relocation)) \ - : ((((P) >= Const_Base) && ((P) < Dumped_Constant_Top)) \ - ? ((SCHEME_OBJECT *) ((P) + const_relocation)) \ - : ((SCHEME_OBJECT *) ((P) + stack_relocation)))) - -#else /* Conditional_Bug */ - -static SCHEME_OBJECT * relocate_temp; - -#define RELOCATE(P) \ - (RELOCATE_INTO (relocate_temp, P), relocate_temp) - -#endif /* Conditional_Bug */ -#endif /* ENABLE_DEBUGGING_TOOLS */ - -/* Next_Pointer starts by pointing to the beginning of the block of - memory to be handled. This loop relocates all pointers in the - block of memory. -*/ - -static long -DEFUN (primitive_dumped_number, (datum), unsigned long datum) +static SCHEME_OBJECT +read_band_file (SCHEME_OBJECT s) { - unsigned long high_bits = (datum >> HALF_DATUM_LENGTH); - return ((high_bits != 0) ? high_bits : datum); -} + const char * file_name; + struct load_band_termination_state * state; + fasl_file_handle_t handle; + SCHEME_OBJECT result; + void * old_name; + + transaction_begin (); + file_name = (OS_malloc ((STRING_LENGTH (s)) + 1)); + strcpy (((char *) file_name), (STRING_POINTER (s))); + state = (dstack_alloc (sizeof (struct load_band_termination_state))); + (state->file_name) = file_name; + (state->no_return_p) = false; + transaction_record_action (tat_abort, terminate_band_load, state); + + init_fasl_file (file_name, true, (&handle)); + if (!allocations_ok_p ((FASLHDR_CONSTANT_SIZE (fh)), + (REQUIRED_HEAP (fh)))) + signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); -#define PRIMITIVE_DUMPED_NUMBER(prim) \ - (primitive_dumped_number (OBJECT_DATUM (prim))) + /* Now read the file into memory. Past this point we can't abort + and return to the old image. */ + ENTER_CRITICAL_SECTION ("band load"); + (state->no_return_p) = true; -static void -DEFUN (Relocate_Block, (Scan, Stop_At), - fast SCHEME_OBJECT * Scan AND fast SCHEME_OBJECT * Stop_At) -{ - fast long address; - fast SCHEME_OBJECT Temp; + reset_allocator_parameters (FASLHDR_CONSTANT_SIZE (fh)); + result = (load_file (handle)); - if (Reloc_Debug) - { - outf_error - ("\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n", - ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At)); - } + /* Done -- we have the new image. */ + transaction_commit (); - while (Scan < Stop_At) - { - Temp = * Scan; - Switch_by_GC_Type (Temp) - { - case TC_BROKEN_HEART: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - case_Fasload_Non_Pointer: -#ifdef EMPTY_LIST_VALUE - if (Temp == EMPTY_LIST_VALUE) - * Scan = EMPTY_LIST; -#endif - Scan += 1; - break; - - case TC_PRIMITIVE: - *Scan++ = (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]); - break; - - case TC_PCOMB0: - *Scan++ = - OBJECT_NEW_TYPE - (TC_PCOMB0, - (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)])); - break; - - case TC_MANIFEST_NM_VECTOR: - Scan += ((OBJECT_DATUM (Temp)) + 1); - break; - - case TC_LINKAGE_SECTION: - { - switch (READ_LINKAGE_KIND (Temp)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - /* Assumes that all others are objects of type TC_HUNK3 - without their type codes. */ - - fast long count; - - Scan++; - for (count = (READ_CACHE_LINKAGE_COUNT (Temp)); - --count >= 0; - ) - { - address = (SCHEME_ADDR_TO_OLD_DATUM (* Scan)); - *Scan++ = (ADDR_TO_SCHEME_ADDR (RELOCATE (address))); - } - break; - } + /* Save the band name for possible later use. */ + old_name = ((void *) reload_band_name); + reload_band_name = file_name; + if (old_name != 0) + OS_free (old_name); - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: - { - fast long count; - fast char * word_ptr; - SCHEME_OBJECT * end_scan; - - START_OPERATOR_RELOCATION (Scan); - count = (READ_OPERATOR_LINKAGE_COUNT (Temp)); - word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan)); - end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count)); - - while(--count >= 0) - { - Scan = ((SCHEME_OBJECT *) (word_ptr)); - word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); - EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, Scan); - address = (SCHEME_ADDR_TO_OLD_DATUM (address)); - address = ((long) (RELOCATE (address))); - STORE_OPERATOR_LINKAGE_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), - Scan); - } - Scan = &end_scan[1]; - END_OPERATOR_RELOCATION (Scan - 1); - break; - } + return (result); +} - case CLOSURE_PATTERN_LINKAGE_KIND: - Scan += (1 + (READ_CACHE_LINKAGE_COUNT (Temp))); - break; +static void +terminate_band_load (void * ap) +{ + struct load_band_termination_state * state = ap; + int abort_value; - default: - { - gc_death (TERM_EXIT, - "Relocate_Block: Unknown compiler linkage kind.", - Scan, NULL); - /*NOTREACHED*/ - } - } - break; - } - - case TC_MANIFEST_CLOSURE: - { - /* See comment about relocation in TC_LINKAGE_SECTION above. */ - - fast long count; - fast char * word_ptr; - SCHEME_OBJECT * area_end; - - START_CLOSURE_RELOCATION (Scan); - Scan += 1; - count = (MANIFEST_CLOSURE_COUNT (Scan)); - word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan)); - area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1); - - while ((--count) >= 0) - { - Scan = ((SCHEME_OBJECT *) (word_ptr)); - word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); - EXTRACT_CLOSURE_ENTRY_ADDRESS (address, Scan); - address = (SCHEME_ADDR_TO_OLD_DATUM (address)); - address = ((long) (RELOCATE (address))); - STORE_CLOSURE_ENTRY_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan); - } - END_CLOSURE_RELOCATION (area_end); - Scan = (area_end + 1); - break; - } - -#ifdef BYTE_INVERSION - case TC_CHARACTER_STRING: - String_Inversion (RELOCATE (OBJECT_DATUM (Temp))); - goto normal_pointer; -#endif + if (! (state->no_return_p)) + { + OS_free ((void *) (state->file_name)); + return; + } - case TC_REFERENCE_TRAP: - if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) - { - Scan += 1; - break; - } - /* It is a pointer, fall through. */ + abort_value = (abort_to_interpreter_argument ()); - /* Compiled entry points and stack environments work automagically. */ - /* This should be more strict. */ + fputs ("\nload-band: ", stderr); + if (abort_value > 0) + { + const char * message + = ((abort_value <= MAX_ERROR) + ? (Error_Names[abort_value]) + : 0); + if (message == 0) + outf_fatal ("Unknown error %#lx", ((unsigned long) abort_value)); + else + outf_fatal ("Error %#lx (%s)", ((unsigned long) abort_value), message); + } + else + { + abort_value = ((-abort_value) - 1); + outf_fatal ("Abort %d (%s)", abort_value, (Abort_Names[abort_value])); + } + outf_fatal (" past the point of no return.\n"); + outf_fatal ("file name = \"%s\".\n", (state->file_name)); + OS_free ((void *) (state->file_name)); - default: -#ifdef BYTE_INVERSION - normal_pointer: -#endif - address = (OBJECT_DATUM (Temp)); - *Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)), - (RELOCATE (address)))); - break; - } - } - return; + execute_reload_cleanups (); + EXIT_CRITICAL_SECTION ({}); + Microcode_Termination (TERM_DISK_RESTORE); + /*NOTREACHED*/ } - -static Boolean -DEFUN (check_primitive_numbers, (table, length), - fast SCHEME_OBJECT * table AND fast long length) -{ - fast long count; - for (count = 0; count < length; count += 1) - if (table[count] != (MAKE_PRIMITIVE_OBJECT (count))) - return (false); - return (true); +DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0, "()\n\ +Return the filename from which the runtime system was last restored.\n\ +The result is a string, or #F if the system was not restored.") +{ + PRIMITIVE_HEADER (0); + PRIMITIVE_RETURN + ((reload_band_name != 0) + ? (char_pointer_to_string (reload_band_name)) + : (option_band_file != 0) + ? (char_pointer_to_string (option_band_file)) + : SHARP_F); } -extern void EXFUN (get_band_parameters, (long * heap_size, long * const_size)); - void -DEFUN (get_band_parameters, (heap_size, const_size), - long * heap_size AND long * const_size) +get_band_parameters (unsigned long * heap_size, unsigned long * const_size) { - /* This assumes we have just aborted out of a band load. */ - (*heap_size) = Heap_Count; - (*const_size) = Const_Count; + (*heap_size) = reload_heap_size; + (*const_size) = reload_constant_size; } - -static void -DEFUN (Intern_Block, (Next_Pointer, Stop_At), - fast SCHEME_OBJECT * Next_Pointer AND fast SCHEME_OBJECT * Stop_At) -{ - if (Reloc_Debug) - { - outf_console ("Interning a block.\n"); - } - while (Next_Pointer < Stop_At) - { - switch (OBJECT_TYPE (*Next_Pointer)) +void +add_reload_cleanup (cleanup_t cleanup_procedure) +{ + if (reload_cleanups == 0) { - case TC_MANIFEST_NM_VECTOR: - Next_Pointer += (1 + (OBJECT_DATUM (* Next_Pointer))); - break; - - case TC_INTERNED_SYMBOL: - if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE))) == - TC_BROKEN_HEART) - { - SCHEME_OBJECT old_symbol = (*Next_Pointer); - MEMORY_SET (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT); - { - SCHEME_OBJECT new_symbol = (intern_symbol (old_symbol)); - if (new_symbol != old_symbol) - { - (*Next_Pointer) = new_symbol; - MEMORY_SET - (old_symbol, - SYMBOL_NAME, - (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new_symbol))); - } - } - } - else if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME))) == - TC_BROKEN_HEART) - { - *Next_Pointer = - (MAKE_OBJECT_FROM_OBJECTS - ((*Next_Pointer), - (FAST_MEMORY_REF ((*Next_Pointer), SYMBOL_NAME)))); - } - Next_Pointer += 1; - break; - - default: - Next_Pointer += 1; - break; + reload_cleanups = (ptrvec_allocate (1)); + (* ((cleanup_t *) (PTRVEC_LOC (reload_cleanups, 0)))) + = cleanup_procedure; } - } - if (Reloc_Debug) - { - outf_console ("Done interning block.\n"); - } - return; + else + ptrvec_adjoin (reload_cleanups, cleanup_procedure); } - -/* This should be moved to config.h! */ - -#ifndef COMPUTE_RELOCATION -#define COMPUTE_RELOCATION(new, old) (((relocation_type) (new)) - (old)) -#endif +void +execute_reload_cleanups (void) +{ + void ** scan = (PTRVEC_START (reload_cleanups)); + void ** end = (PTRVEC_END (reload_cleanups)); + while (scan < end) + (* ((cleanup_t *) (scan++))) (); +} + static SCHEME_OBJECT -DEFUN (load_file, (mode), int mode) +load_file (fasl_file_handle_t handle) { - SCHEME_OBJECT - * Orig_Heap, - * Constant_End, * Orig_Constant, - * temp, * primitive_table, * c_code_table; - - /* Read File */ - -#ifdef ENABLE_DEBUGGING_TOOLS - Warned = false; -#endif - - load_renumber_table = Free; - Free += Primitive_Table_Length; - ALIGN_FLOAT (Free); - Orig_Heap = Free; - Orig_Constant = Free_Constant; - read_file_end (mode, &primitive_table, &c_code_table); - Constant_End = Free_Constant; - heap_relocation = (COMPUTE_RELOCATION (Orig_Heap, Heap_Base)); - - /* - Magic! - The relocation of compiled code entry points depends on the fact - that fasdump never dumps the compiler utilities vector (which - contains entry points used by compiled code to invoke microcode - provided utilities, like return_to_interpreter). - - If the file is not a band, any pointers into constant space are - pointers into the compiler utilities vector. const_relocation is - computed appropriately. - - Otherwise (the file is a band, and only bands can contain constant - space segments) the utilities vector stuff is relocated - automagically: the utilities vector is part of the band. - */ - - if ((! band_p) && (dumped_utilities != SHARP_F)) + new_heap_start = Free; + new_constant_start = constant_alloc_next; + new_stack_start = stack_start; + new_stack_end = stack_end; + new_utilities + = ((compiler_utilities == SHARP_F) + ? 0 + : (OBJECT_ADDRESS (compiler_utilities))); + + Free = (read_from_file (Free, (FASLHDR_HEAP_SIZE (fh)), handle)); + constant_alloc_next + = (read_from_file (constant_alloc_next, + (FASLHDR_CONSTANT_SIZE (fh)), + handle)); + + new_prim_table = Free; { - if (compiler_utilities == SHARP_F) - signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); - - const_relocation = - (COMPUTE_RELOCATION ((OBJECT_ADDRESS (compiler_utilities)), - (OBJECT_DATUM (dumped_utilities)))); - Dumped_Constant_Top = - (ADDRESS_TO_DATUM - (MEMORY_LOC (dumped_utilities, - (1 + (VECTOR_LENGTH (compiler_utilities)))))); + SCHEME_OBJECT * raw_prim_table = (Free + (FASLHDR_N_PRIMITIVES (fh))); + read_from_file (raw_prim_table, + (FASLHDR_PRIMITIVE_TABLE_SIZE (fh)), + handle); + import_primitive_table + (raw_prim_table, (FASLHDR_N_PRIMITIVES (fh)), new_prim_table); } - else - const_relocation = (COMPUTE_RELOCATION (Orig_Constant, Const_Base)); - stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top)); - -#ifdef BYTE_INVERSION - Setup_For_String_Inversion (); +#ifdef CC_IS_C + if ((FASLHDR_BAND_P (fh)) && ((FASLHDR_C_CODE_TABLE_SIZE (fh)) > 0)) + { + SCHEME_OBJECT * raw_table = (Free + (FASLHDR_N_PRIMITIVES (fh))); + read_from_file (raw_table, (FASLHDR_C_CODE_TABLE_SIZE (fh)), handle); + if (!import_c_code_table (raw_table, (FASLHDR_N_C_CODE_BLOCKS (fh)))) + signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); + } #endif - /* Setup the primitive and C code tables */ - - install_primitive_table (primitive_table, Primitive_Table_Length); - if ((mode == MODE_BAND) - && (! (install_c_code_table (c_code_table, C_Code_Table_Length)))) + if ((!FASLHDR_BAND_P (fh)) + && ((FASLHDR_UTILITIES_VECTOR (fh)) != SHARP_F) + && (compiler_utilities == SHARP_F)) + /* The file contains compiled code, but there's no compiled-code + support available. */ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); - if ((mode != MODE_BAND) - || (heap_relocation != ((relocation_type) 0)) - || (const_relocation != ((relocation_type) 0)) - || (stack_relocation != ((relocation_type) 0)) - || (! (check_primitive_numbers (load_renumber_table, - Primitive_Table_Length)))) - { - /* We need to relocate. Oh well. */ - if (Reloc_Debug) - outf_console - ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n", - ((long) heap_relocation), ((long) heap_relocation), - ((long) const_relocation), ((long) const_relocation)); - - /* - Relocate the new data. - - There are no pointers in the primitive table, thus - there is no need to relocate it. - */ - - Relocate_Block (Orig_Heap, primitive_table); - Relocate_Block (Orig_Constant, Constant_End); - } - -#ifdef BYTE_INVERSION - Finish_String_Inversion (); -#endif - - if (mode != MODE_BAND) - { - /* Again, there are no symbols in the primitive table. */ - - Intern_Block (Orig_Heap, primitive_table); - Intern_Block (Orig_Constant, Constant_End); - } + if (! ((FASLHDR_BAND_P (fh)) + && ((FASLHDR_HEAP_START (fh)) == new_heap_start) + && (((FASLHDR_CONSTANT_START (fh)) == new_constant_start) + || ((FASLHDR_CONSTANT_START (fh)) == (FASLHDR_CONSTANT_END (fh)))) + && (((FASLHDR_STACK_START (fh)) == 0) + || ((FASLHDR_STACK_START (fh)) == new_stack_start)) + && ((FASLHDR_STACK_END (fh)) == new_stack_end) + && ((FASLHDR_MEMORY_BASE (fh)) == memory_base) + && (primitive_numbers_unchanged_p (new_prim_table)))) + { + current_gc_table = (relocate_block_table ()); + gc_scan_oldspace (new_heap_start, Free); + gc_scan_oldspace (new_constant_start, constant_alloc_next); + } + if (!FASLHDR_BAND_P (fh)) + { + current_gc_table = (intern_block_table ()); + gc_scan_oldspace (new_heap_start, Free); + gc_scan_oldspace (new_constant_start, constant_alloc_next); + } #ifdef PUSH_D_CACHE_REGION - if (dumped_interface_version != 0) - { - if (primitive_table != Orig_Heap) - PUSH_D_CACHE_REGION (Orig_Heap, (primitive_table - Orig_Heap)); - if (Constant_End != Orig_Constant) - PUSH_D_CACHE_REGION (Orig_Constant, (Constant_End - Orig_Constant)); - } + if ((FASLHDR_CC_VERSION (fh)) != COMPILER_NONE_TYPE) + { + if ((FASLHDR_HEAP_SIZE (fh)) > 0) + PUSH_D_CACHE_REGION (new_heap_start, (FASLHDR_HEAP_SIZE (fh))); + if ((FASLHDR_CONSTANT_SIZE (fh)) > 0) + PUSH_D_CACHE_REGION (new_constant_start, (FASLHDR_CONSTANT_SIZE (fh))); + } #endif - FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, - Orig_Constant, Constant_End); - RELOCATE_INTO (temp, Dumped_Object); - return (* temp); + return + (* ((SCHEME_OBJECT *) + (relocate_address (FASLHDR_ROOT_POINTER (fh))))); } - -/* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL) - Load the contents of FILE-NAME-OR-CHANNEL into memory. The file - was presumably made by a call to PRIMITIVE-FASDUMP, and may contain - data for the heap and/or the pure area. The value returned is the - object which was dumped. Typically (but not always) this will be a - piece of SCode which is then evaluated to perform definitions in - some environment. - If a file name is given, the corresponding file is opened before - loading and closed after loading. A channel remains open. -*/ -DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0) +static void * +read_from_file (void * p, size_t n_words, fasl_file_handle_t handle) { - SCHEME_OBJECT arg, result; - PRIMITIVE_HEADER (1); - - PRIMITIVE_CANONICALIZE_CONTEXT(); - arg = (ARG_REF (1)); - if (STRING_P (arg)) - { - read_file_start ((STRING_ARG (1)), false); - result = (load_file (MODE_FNAME)); - } - else - { - read_channel_start ((arg_channel (1)), MODE_CHANNEL); - result = (load_file (MODE_CHANNEL)); - } -#ifdef AUTOCLOBBER_BUG - *Free = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, - ((PAGE_SIZE / (sizeof (SCHEME_OBJECT))) - - 1))); - Free += (PAGE_SIZE / (sizeof (SCHEME_OBJECT))); -#endif - PRIMITIVE_RETURN (result); + if (!read_from_fasl_file (p, n_words, handle)) + signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); + return (((char *) p) + (n_words * SIZEOF_SCHEME_OBJECT)); } -SCHEME_OBJECT -DEFUN (continue_fasload, (reentry_record), SCHEME_OBJECT * reentry_record) +static bool +primitive_numbers_unchanged_p (SCHEME_OBJECT * table) { - SCHEME_OBJECT header; - - /* The reentry record was prepared by read_channel_continue above. */ + unsigned long count; - load_channel = (arg_channel (1)); - header = (reentry_record[0]); - read_channel_continue ((VECTOR_LOC (header, 0)), MODE_CHANNEL, true); - PRIMITIVE_RETURN (load_file (MODE_CHANNEL)); + for (count = 0; (count < (FASLHDR_N_PRIMITIVES (fh))); count += 1) + if ((table[count]) != (MAKE_PRIMITIVE_OBJECT (count))) + return (false); + return (true); } -/* Band loading. */ - -static char *reload_band_name = 0; -static Tptrvec reload_cleanups = 0; - -DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0, - "Return the filename from which the runtime system was last restored.\n\ -The result is a string, or #F if the system was not restored.") +static gc_table_t * +relocate_block_table (void) { - PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN - ((reload_band_name != 0) - ? (char_pointer_to_string (reload_band_name)) - : (option_band_file != 0) - ? (char_pointer_to_string (option_band_file)) - : SHARP_F); -} - -typedef void EXFUN ((*Tcleanup), (void)); + static bool initialized_p = false; + static gc_table_t table; -void -DEFUN (add_reload_cleanup, (cleanup_procedure), Tcleanup cleanup_procedure) -{ - if (reload_cleanups == 0) + if (!initialized_p) { - reload_cleanups = (ptrvec_allocate (1)); - (* ((Tcleanup *) (PTRVEC_LOC (reload_cleanups, 0)))) = cleanup_procedure; + initialize_gc_table ((&table), false); + + (GCT_TUPLE (&table)) = fasload_tuple; + (GCT_VECTOR (&table)) = fasload_vector; + (GCT_CC_ENTRY (&table)) = fasload_cc_entry; +#ifndef HEAP_IN_LOW_MEMORY + (GCT_RAW_ADDRESS_TO_OBJECT (&table)) = fasload_raw_address_to_object; + (GCT_RAW_ADDRESS_TO_CC_ENTRY (&table)) = fasload_raw_address_to_cc_entry; +#endif + + (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair; + (GCT_ENTRY ((&table), TC_PRIMITIVE)) = handle_primitive; + (GCT_ENTRY ((&table), TC_PCOMB0)) = handle_primitive; + (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = gc_handle_non_pointer; + + initialized_p = true; } - else - ptrvec_adjoin (reload_cleanups, (PTR) cleanup_procedure); + return (&table); } -void -DEFUN_VOID (execute_reload_cleanups) +static +DEFINE_GC_HANDLER (handle_primitive) { - PTR * scan = (PTRVEC_START (reload_cleanups)); - PTR * end = (PTRVEC_END (reload_cleanups)); - while (scan < end) - (* ((Tcleanup *) (scan++))) (); + unsigned long datum = (OBJECT_DATUM (object)); + unsigned long high_bits = (datum >> HALF_DATUM_LENGTH); + (*scan) + = (MAKE_OBJECT_FROM_OBJECTS + (object, + (new_prim_table [((high_bits != 0) ? high_bits : datum)]))); + return (scan + 1); } -/* Utility for load band below. */ +#ifdef HEAP_IN_LOW_MEMORY -void -DEFUN_VOID (compiler_reset_error) -{ - outf_fatal ("\ncompiler_reset_error: The band being restored and\n"); - outf_fatal - ("the compiled code interface in this microcode are inconsistent.\n"); - Microcode_Termination (TERM_COMPILER_DEATH); -} - -#ifndef START_BAND_LOAD -#define START_BAND_LOAD() do \ -{ \ - ENTER_CRITICAL_SECTION ("band load"); \ -} while (0) -#endif +#define OLD_ADDRESS OBJECT_ADDRESS +#define OLD_CC_ADDRESS CC_ENTRY_ADDRESS -#ifndef END_BAND_LOAD -#define END_BAND_LOAD(success, dying) do \ -{ \ - if (success || dying) \ - execute_reload_cleanups (); \ - EXIT_CRITICAL_SECTION ({}); \ -} while (0) -#endif +#else -struct memmag_state -{ - SCHEME_OBJECT * heap_bottom; - SCHEME_OBJECT * heap_top; - SCHEME_OBJECT * unused_heap_bottom; - SCHEME_OBJECT * unused_heap_top; - SCHEME_OBJECT * free; - SCHEME_OBJECT * memtop; - SCHEME_OBJECT * constant_space; - SCHEME_OBJECT * constant_top; - SCHEME_OBJECT * free_constant; - SCHEME_OBJECT * stack_pointer; - SCHEME_OBJECT * stack_bottom; - SCHEME_OBJECT * stack_top; - SCHEME_OBJECT * stack_guard; -}; +#define OLD_ADDRESS(object) \ + ((FASLHDR_MEMORY_BASE (fh)) + (OBJECT_DATUM (object))) -static void -DEFUN (abort_band_load, (ap), PTR ap) +#define OLD_CC_ADDRESS(object) \ + (((insn_t *) (FASLHDR_MEMORY_BASE (fh))) + (OBJECT_DATUM (object))) + +static SCHEME_OBJECT +fasload_raw_address_to_object (unsigned int type, SCHEME_OBJECT * address) { - struct memmag_state * mp = ((struct memmag_state *) ap); - - Heap_Bottom = mp->heap_bottom; - Heap_Top = mp->heap_top; - Unused_Heap_Bottom = mp->unused_heap_bottom; - Unused_Heap_Top = mp->unused_heap_top; - Free = mp->free; - Free_Constant = mp->free_constant; - Constant_Space = mp->constant_space; - Constant_Top = mp->constant_top; - sp_register = mp->stack_pointer; - Stack_Bottom = mp->stack_bottom; - Stack_Top = mp->stack_top; - Stack_Guard = mp->stack_guard; - SET_MEMTOP (mp->memtop); - - END_BAND_LOAD (false, false); - return; + return (MAKE_OBJECT (type, (address - (FASLHDR_MEMORY_BASE (fh))))); } -static void -DEFUN (terminate_band_load, (ap), PTR ap) +SCHEME_OBJECT +fasload_raw_address_to_cc_entry (insn_t * address) { - fputs ("\nload-band: ", stderr); - { - int abort_value = (abort_to_interpreter_argument ()); - if (abort_value > 0) - outf_fatal ("Error %ld (%s)", - ((long) abort_value), - (Error_Names [abort_value])); - else - outf_fatal ("Abort %ld (%s)", - ((long) abort_value), - (Abort_Names [(-abort_value) - 1])); - } - outf_fatal (" past the point of no return.\n"); - { - char * band_name = (* ((char **) ap)); - if (band_name != 0) - { - outf_fatal ("band-name = \"%s\".\n", band_name); - free (band_name); - } - } - END_BAND_LOAD (false, true); - Microcode_Termination (TERM_DISK_RESTORE); - /*NOTREACHED*/ + return (MAKE_OBJECT (TC_COMPILED_ENTRY, + (address - ((insn_t *) (FASLHDR_MEMORY_BASE (fh)))))); } - -/* (LOAD-BAND FILE-NAME) - Restores the heap and pure space from the contents of FILE-NAME, - which is typically a file created by DUMP-BAND. The file can, - however, be any file which can be loaded with BINARY-FASLOAD. -*/ -DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) -{ - extern void EXFUN (reset_allocator_parameters, (void)); - SCHEME_OBJECT result; - PRIMITIVE_HEADER (1); - PRIMITIVE_CANONICALIZE_CONTEXT (); +#endif /* !HEAP_IN_LOW_MEMORY */ - { - CONST char * file_name = (STRING_ARG (1)); - transaction_begin (); - { - struct memmag_state * mp = (dstack_alloc (sizeof (struct memmag_state))); - - mp->heap_bottom = Heap_Bottom; - mp->heap_top = Heap_Top; - mp->unused_heap_bottom = Unused_Heap_Bottom; - mp->unused_heap_top = Unused_Heap_Top; - mp->free = Free; - mp->memtop = MemTop; - mp->free_constant = Free_Constant; - mp->constant_space = Constant_Space; - mp->constant_top = Constant_Top; - mp->stack_pointer = sp_register; - mp->stack_bottom = Stack_Bottom; - mp->stack_top = Stack_Top; - mp->stack_guard = Stack_Guard; - transaction_record_action (tat_abort, abort_band_load, mp); - } - - reset_allocator_parameters (); - SET_MEMTOP (Heap_Top); - START_BAND_LOAD (); - read_file_start (file_name, true); - transaction_commit (); - - /* Point of no return. */ - { - long length = ((strlen (file_name)) + 1); - char * band_name = (malloc (length)); - if (band_name != 0) - strcpy (band_name, file_name); - transaction_begin (); - { - char ** ap = (dstack_alloc (sizeof (char *))); - (*ap) = band_name; - transaction_record_action (tat_abort, terminate_band_load, ap); - } - result = (load_file (MODE_BAND)); - transaction_commit (); - if (reload_band_name != 0) - free (reload_band_name); - reload_band_name = band_name; - } - } - /* Reset implementation state paramenters */ - INITIALIZE_INTERRUPTS (); - INITIALIZE_STACK (); - SET_MEMTOP (Heap_Top - GC_Reserve); - { - SCHEME_OBJECT cutl = (MEMORY_REF (result, 1)); - if (cutl != SHARP_F) - { - compiler_utilities = cutl; - compiler_reset (cutl); - } - else - compiler_initialize (true); - } - /* Until the continuation is invoked. */ - SET_INTERRUPT_MASK (0); - Restore_Fixed_Obj (SHARP_F); - Fluid_Bindings = EMPTY_LIST; - Current_State_Point = SHARP_F; - /* Setup initial program */ - Store_Return (RC_END_OF_COMPUTATION); - exp_register = SHARP_F; - Save_Cont (); - exp_register = (MEMORY_REF (result, 0)); - env_register = THE_GLOBAL_ENV; - /* Clear various interpreter state parameters. */ - Trapping = false; - Return_Hook_Address = 0; - history_register = (Make_Dummy_History ()); - Prev_Restore_History_Stacklet = 0; - Prev_Restore_History_Offset = 0; - COMPILER_TRANSPORT_END (); - END_BAND_LOAD (true, false); - Band_Load_Hook (); - /* Return in a non-standard way. */ - PRIMITIVE_ABORT (PRIM_DO_EXPRESSION); - /*NOTREACHED*/ - PRIMITIVE_RETURN (UNSPECIFIC); -} - -#ifdef BYTE_INVERSION +#define RELOCATE_OBJECT(object) \ + (OBJECT_NEW_ADDRESS ((object), \ + ((SCHEME_OBJECT *) \ + (relocate_address (OLD_ADDRESS (object)))))) -#define MAGIC_OFFSET (TC_FIXNUM + 1) +static +DEFINE_GC_TUPLE_HANDLER (fasload_tuple) +{ + return (RELOCATE_OBJECT (tuple)); +} -SCHEME_OBJECT String_Chain, Last_String; +static +DEFINE_GC_VECTOR_HANDLER (fasload_vector) +{ + return (RELOCATE_OBJECT (vector)); +} -void -DEFUN_VOID (Setup_For_String_Inversion) +static +DEFINE_GC_OBJECT_HANDLER (fasload_cc_entry) { - String_Chain = SHARP_F; - Last_String = SHARP_F; - return; +#ifdef CC_SUPPORT_P + return + (CC_ENTRY_NEW_ADDRESS (object, + (relocate_address (OLD_CC_ADDRESS (object))))); +#else + return (object); +#endif } -void -DEFUN_VOID (Finish_String_Inversion) +/* Relocate an address as read in from the file. The address is + examined to see what region of memory it belongs in. */ + +static void * +relocate_address (void * vaddr) { - if (Byte_Invert_Fasl_Files) - while (String_Chain != SHARP_F) + byte_t * caddr = vaddr; + byte_t * result; + + if ((caddr >= ((byte_t *) (FASLHDR_HEAP_START (fh)))) + && (caddr < ((byte_t *) (FASLHDR_HEAP_END (fh))))) + result + = (((byte_t *) new_heap_start) + + (caddr - ((byte_t *) (FASLHDR_HEAP_START (fh))))); + else if ((caddr >= ((byte_t *) (FASLHDR_CONSTANT_START (fh)))) + && (caddr < ((byte_t *) (FASLHDR_CONSTANT_END (fh))))) + result + = (((byte_t *) new_constant_start) + + (caddr - ((byte_t *) (FASLHDR_CONSTANT_START (fh))))); + else if ((caddr >= ((byte_t *) (FASLHDR_UTILITIES_START (fh)))) + && (caddr < ((byte_t *) (FASLHDR_UTILITIES_END (fh))))) + result + = (((byte_t *) new_utilities) + + (caddr - ((byte_t *) (FASLHDR_UTILITIES_START (fh))))); + else if (ADDRESS_IN_STACK_REGION_P (caddr, + ((byte_t *) (FASLHDR_STACK_START (fh))), + ((byte_t *) (FASLHDR_STACK_END (fh))))) + result + = (N_PUSHED_TO_SP + ((SP_TO_N_PUSHED (caddr, + ((byte_t *) (FASLHDR_STACK_START (fh))), + ((byte_t *) (FASLHDR_STACK_END (fh))))), + ((byte_t *) new_stack_start), + ((byte_t *) new_stack_end))); + else { - long Count; - SCHEME_OBJECT Next; - - Count = OBJECT_DATUM (FAST_MEMORY_REF (String_Chain, STRING_HEADER)); - Count = 4 * (Count - 2) + (OBJECT_TYPE (String_Chain)) - MAGIC_OFFSET; - if (Reloc_Debug) - { - outf_console ("String at 0x%lx: restoring length of %ld.\n", - ((long) (OBJECT_ADDRESS (String_Chain))), - ((long) Count)); - } - Next = (STRING_LENGTH (String_Chain)); - SET_STRING_LENGTH (String_Chain, Count); - String_Chain = Next; + outf_fatal ("Pointer out of range: %#lx\n", ((unsigned long) caddr)); + outf_fatal ("Heap: %#lx-%#lx, Constant: %#lx-%#lx, Stack: %#lx-%#lx\n", + ((unsigned long) (FASLHDR_HEAP_START (fh))), + ((unsigned long) (FASLHDR_HEAP_END (fh))), + ((unsigned long) (FASLHDR_CONSTANT_START (fh))), + ((unsigned long) (FASLHDR_CONSTANT_END (fh))), + ((unsigned long) (FASLHDR_STACK_START (fh))), + ((unsigned long) (FASLHDR_STACK_END (fh)))); + termination_init_error (); } - return; + return (result); } -#define print_char(C) outf_console (((C < ' ') || (C > '|')) ? \ - "\\%03o" : "%c", (C && UCHAR_MAX)); - -void -DEFUN (String_Inversion, (Orig_Pointer), SCHEME_OBJECT * Orig_Pointer) +static gc_table_t * +intern_block_table (void) { - SCHEME_OBJECT *Pointer_Address; - char *To_Char; - long Code; + static bool initialized_p = false; + static gc_table_t table; - if (!Byte_Invert_Fasl_Files) - return; + if (!initialized_p) + { + initialize_gc_table ((&table), false); - Code = OBJECT_TYPE (Orig_Pointer[STRING_LENGTH_INDEX]); - if (Code == 0) /* Already reversed? */ - { - long Count, old_size, new_size, i; + (GCT_TUPLE (&table)) = intern_tuple; + (GCT_VECTOR (&table)) = intern_vector; + (GCT_CC_ENTRY (&table)) = intern_cc_entry; - old_size = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])); - new_size = - 2 + (((long) (Orig_Pointer[STRING_LENGTH_INDEX]))) / 4; + (GCT_ENTRY ((&table), TC_WEAK_CONS)) = gc_handle_pair; + (GCT_ENTRY ((&table), TC_INTERNED_SYMBOL)) = intern_handle_symbol; + (GCT_ENTRY ((&table), TC_BROKEN_HEART)) = gc_handle_non_pointer; - if (Reloc_Debug) - { - outf_console ("\nString at 0x%lx with %ld characters", - ((long) Orig_Pointer), - ((long) (Orig_Pointer[STRING_LENGTH_INDEX]))); + initialized_p = true; } - if (old_size != new_size) - { - outf_fatal ("\nWord count changed from %ld to %ld: ", - ((long) old_size), ((long) new_size)); - outf_fatal ("\nWhich, of course, is impossible!!\n"); - Microcode_Termination (TERM_EXIT); - } + return (&table); +} - Count = ((long) (Orig_Pointer[STRING_LENGTH_INDEX])) % 4; - if (Count == 0) - Count = 4; - if (Last_String == SHARP_F) - String_Chain = MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer); - else - FAST_MEMORY_SET - (Last_String, STRING_LENGTH_INDEX, - (MAKE_POINTER_OBJECT ((Count + MAGIC_OFFSET), Orig_Pointer))); - - Last_String = (MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer)); - Orig_Pointer[STRING_LENGTH_INDEX] = SHARP_F; - Count = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])) - 1; - if (Reloc_Debug) - outf_console ("\nCell count = %ld\n", ((long) Count)); - Pointer_Address = &(Orig_Pointer[STRING_CHARS]); - To_Char = (char *) Pointer_Address; - for (i = 0; i < Count; i++, Pointer_Address++) +static +DEFINE_GC_HANDLER (intern_handle_symbol) +{ + if (BROKEN_HEART_P (GET_SYMBOL_GLOBAL_VALUE (object))) { - int C1, C2, C3, C4; - - C4 = OBJECT_TYPE (*Pointer_Address) & 0xFF; - C3 = (((long) *Pointer_Address)>>16) & 0xFF; - C2 = (((long) *Pointer_Address)>>8) & 0xFF; - C1 = ((long) *Pointer_Address) & 0xFF; - if (Reloc_Debug || (old_size != new_size)) + SET_SYMBOL_GLOBAL_VALUE (object, UNBOUND_OBJECT); { - print_char(C1); - print_char(C2); - print_char(C3); - print_char(C4); + SCHEME_OBJECT new = (intern_symbol (object)); + if (new != object) + { + (*scan) = new; + SET_SYMBOL_NAME (object, (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new))); + } } - *To_Char++ = C1; - *To_Char++ = C2; - *To_Char++ = C3; - *To_Char++ = C4; } - } - if (Reloc_Debug) - outf_console ("\n"); - return; + else if (BROKEN_HEART_P (GET_SYMBOL_NAME (object))) + (*scan) + = (MAKE_OBJECT_FROM_OBJECTS (object, + (GET_SYMBOL_NAME (object)))); + return (scan + 1); +} + +static +DEFINE_GC_TUPLE_HANDLER (intern_tuple) +{ + return (tuple); +} + +static +DEFINE_GC_VECTOR_HANDLER (intern_vector) +{ + return (vector); +} + +static +DEFINE_GC_OBJECT_HANDLER (intern_cc_entry) +{ + return (object); } -#endif /* BYTE_INVERSION */ diff --git a/v7/src/microcode/fft.c b/v7/src/microcode/fft.c deleted file mode 100644 index 4d67164bf..000000000 --- a/v7/src/microcode/fft.c +++ /dev/null @@ -1,1736 +0,0 @@ -/* -*-C-*- - -$Id: fft.c,v 9.37 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Time-Frequency Transforms (pas) */ - -#include "scheme.h" -#include "prims.h" -#include "zones.h" -#include -#include "array.h" -#include "image.h" - -/* SUMMARY - - pas_cft (complex data, DIF, split-radix) - - pas_rft (real data, DIT, split-radix) output is conjugate-symmetric - - pas_csft (cs data, DIF, split-radix) output is real - - pas_cft - - pas_rft2d - - pas_csft2d - - - Stuff before 4-15-1989 - - C_Array_FFT (complex data, radix=2, NOT-in-place) - - CZT (chirp-z-transform) uses the old cft (hence slow). - - 2d DFT - */ - -/* The DFT is as defined in Siebert 6003 book, - i.e. - forward DFT = Negative exponent and division by N - backward DFT = Positive exponent - (note Seibert forward DFT is Oppenheim backward DFT) - */ - -/* mathematical constants */ -#ifdef PI -#undef PI -#endif -#define PI 3.141592653589793238462643 -#define TWOPI 6.283185307179586476925287 -#define SQRT_2 1.4142135623730950488 -#define ONE_OVER_SQRT_2 .7071067811865475244 -/* Abramowitz and Stegun */ - -DEFINE_PRIMITIVE ("PAS-CFT!", Prim_pas_cft, 5, 5, 0) -{ long i, length, power, flag; - REAL *f1,*f2, *wcos,*w3cos,*w3sin; - void pas_cft(); - PRIMITIVE_HEADER (5); - CHECK_ARG (2, ARRAY_P); /* real part */ - CHECK_ARG (3, ARRAY_P); /* imag part */ - CHECK_ARG (4, ARRAY_P); /* twiddle tables, total length = 3*(length/4) */ - CHECK_ARG (5, FIXNUM_P); /* (1)=tables precomputed, else recompute */ - - flag = (arg_integer (1)); - length = ARRAY_LENGTH(ARG_REF(2)); - if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2); - - for (power=0, i=length; i>1; power++) - { if ( (i % 2) == 1) error_bad_range_arg(2); - i=i/2; } - - f1 = ARRAY_CONTENTS(ARG_REF(2)); - f2 = ARRAY_CONTENTS(ARG_REF(3)); - if (f1==f2) error_wrong_type_arg(2); - - wcos = ARRAY_CONTENTS(ARG_REF(4)); /* twiddle tables */ - if (ARRAY_LENGTH(ARG_REF(4)) != (3*length/4)) error_bad_range_arg(4); - w3cos = wcos + length/4; - w3sin = w3cos + length/4; - if ((arg_nonnegative_integer(5)) == 1) - pas_cft(1, flag, f1,f2, length, power, wcos,w3cos,w3sin); - else - pas_cft(0, flag, f1,f2, length, power, wcos,w3cos,w3sin); - /* 1 means tables are already made - 0 means compute new tables */ - - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("PAS-CFT-MAKE-TWIDDLE-TABLES!", - Prim_pas_cft_make_twiddle_tables, 2, 2, 0) -{ long length, power, i; - REAL *wcos,*w3cos,*w3sin; - void pas_cft_make_twiddle_tables_once(); - PRIMITIVE_HEADER (2); - - length = arg_nonnegative_integer(1); /* length of cft that we intend to compute */ - CHECK_ARG (2, ARRAY_P); /* storage for twiddle tables */ - if (ARRAY_LENGTH(ARG_REF(2)) != (3*length/4)) error_bad_range_arg(2); - - power=0; - for (power=0, i=length; i>1; power++) - { if ( (i % 2) == 1) error_bad_range_arg(1); - i=i/2; } - - wcos = ARRAY_CONTENTS(ARG_REF(2)); /* twiddle tables */ - w3cos = wcos + length/4; - w3sin = w3cos + length/4; - pas_cft_make_twiddle_tables_once(length, power, wcos,w3cos,w3sin); - - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* - C COMPLEX FOURIER TRANSFORM (Split-Radix, Decimation-in-frequency) - C (adapted and optimized from Sorensen,et.al. ASSP-34 no.1 page 152, February 1986) - */ - -/* Twiddle Tables for PAS_CFT; - (tables for forward transform only) - Inverse transform === forward CFT (without 1/N scaling) followed by time-reversal. - / - The tables contain (2pi/N)*i for i=0,1,2,..,N/4 - (except i=0 is ignored, never used) - / - Table for wsin[i] is not needed because wsin[i]=wcos[n4-i]. - Table for w3sin[i] is needed however. The previous relationship does not work for w3sin. - */ - -/* There are two routines for making twiddle tables: - a fast one, and a slower one but more precise. - The differences in speed and accuracy are actually rather small, but anyway. - Use the slow one for making permanent tables. - */ - -void -pas_cft_make_twiddle_tables (n,m, wcos,w3cos,w3sin) /* efficient version */ - REAL *wcos, *w3cos, *w3sin; - long n,m; -{ long i, n4; - double tm; - REAL costm,sintm; - n4 = n/4; - for (i=1; i= 4 */ - REAL *x,*y, *wcos,*w3cos,*w3sin; - long n,m; -{ /* REAL a,a3,e; no need anymore, use tables */ - REAL r1,r2,s1,s2,s3, xt, cc1,cc3,ss1,ss3; - long n1,n2,n4, i,j,k, is,id, i0,i1,i2,i3; - long windex0, windex, windex_n4; /* indices for twiddle tables */ - /********** fortran indices start from 1,... **/ - x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */ - y = y-1; - /********** fortran indices start from 1,... **/ - /* c */ - /* c-----first M-1 stages of transform */ - /* c */ - windex_n4 = n/4; /* need for indexing sin via wcos twiddle table */ - n2 = 2*n; - for (k=1; k>1; /* n2 = n2/2; */ - n4 = n2>>2; /* n4 = n2/4; */ - /* e = 6.283185307179586476925287 / ((REAL) n2); no need anymore, use tables */ - /* a = 0.0; */ - { - /* j=1; */ - /* The first iteration in the loop "DO 20 J = 1, N4" - is done specially to save operations involving sin=0, cos=1 */ - /* a = j*e; no need anymore, use tables */ - is = 1; /* is = j; */ - id = 2*n2; - label40first: - for (i0=is; i0= j) goto label101; /* if (i .ge. j) goto 101 */ - xt = x[j]; - x[j] = x[i]; - x[i] = xt; - xt = y[j]; - y[j] = y[i]; - y[i] = xt; - label101: k = n>>1; /* k = n/2; */ - label102: if (k>=j) goto label103; - j = j - k; - k = k>>1; /* k = k/2; */ - goto label102; - label103: j = j + k; - } /* 104 CONTINUE */ - /* c-------------------------------------*/ - /* c */ -} /* RETURN ^M END */ - -DEFINE_PRIMITIVE ("PAS-RFT-CSFT!", Prim_pas_rft_csft, 5, 5, 0) -{ long i, length, power, flag, ft_type; - REAL *f1, *wcos,*w3cos,*w3sin; - void pas_rft(), pas_csft(); - PRIMITIVE_HEADER (5); - CHECK_ARG (2, ARRAY_P); /* Input data (real or cs) */ - CHECK_ARG (3, ARRAY_P); /* Twiddle tables, total length = 4*(length/8) */ - CHECK_ARG (4, FIXNUM_P); /* (1)=tables precomputed, else recompute */ - CHECK_ARG (5, FIXNUM_P); /* ft_type = 1 or 3 - 1 means compute rft, 3 means compute csft */ - flag = (arg_integer (1)); - f1 = ARRAY_CONTENTS(ARG_REF(2)); - length = ARRAY_LENGTH(ARG_REF(2)); - for (power=0, i=length; i>1; power++) - { if ( (i % 2) == 1) error_bad_range_arg(2); - i=i/2; } - - wcos = ARRAY_CONTENTS(ARG_REF(3)); /* twiddle tables */ - if (ARRAY_LENGTH(ARG_REF(3)) != (4*length/8)) error_bad_range_arg(3); - w3cos = wcos + (length/4); - w3sin = w3cos + (length/8); - - ft_type = (arg_nonnegative_integer(5)); /* rft or csft */ - if (ft_type == 1) { - if ((arg_nonnegative_integer(4)) == 1) - pas_rft (1, flag, f1, length, power, wcos,w3cos,w3sin); - else pas_rft (0, flag, f1, length, power, wcos,w3cos,w3sin); - } - else if (ft_type == 3) { - if ((arg_nonnegative_integer(4)) == 1) - pas_csft (1, flag, f1, length, power, wcos,w3cos,w3sin); - else pas_csft (0, flag, f1, length, power, wcos,w3cos,w3sin); - /* 1 means tables are already made - 0 means compute new tables */ - } - else error_bad_range_arg(5); - - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("PAS-REALDATA-MAKE-TWIDDLE-TABLES!", - Prim_pas_realdata_make_twiddle_tables, 2, 2, 0) -{ long length, power, i; - REAL *wcos,*w3cos,*w3sin; - void pas_realdata_make_twiddle_tables_once(); - PRIMITIVE_HEADER (2); - - length = arg_nonnegative_integer(1); /* length of rft that we intend to compute */ - CHECK_ARG (2, ARRAY_P); /* storage for twiddle tables */ - if (ARRAY_LENGTH(ARG_REF(2)) != (4*length/8)) error_bad_range_arg(2); - - power=0; - for (power=0, i=length; i>1; power++) - { if ( (i % 2) == 1) error_bad_range_arg(1); - i=i/2; } - - wcos = ARRAY_CONTENTS(ARG_REF(2)); /* twiddle tables */ - w3cos = wcos + length/4; - w3sin = w3cos + length/8; - pas_realdata_make_twiddle_tables_once(length, power, wcos,w3cos,w3sin); - - PRIMITIVE_RETURN (UNSPECIFIC); -} - -/* - C REAL FOURIER TRANSFORM (Split-Radix, Decimation-in-time) - C (adapted from Sorensen,et.al. ASSP-35 no.6 page 849, October 1986) - C - C the output is [Re(0),Re(1),...,Re(n/2), Im(n/2-1),...,Im(1)] - */ - -/* Twiddle Tables for PAS_RFT and PAS_CSFT - are identical. -> pas_realdata_make_twiddle_tables - (but they are indexed differently in each case) - / - The tables contain (2pi/N)*i where i=0,1,2,..,N/4 for wcos - and (2pi/N)*i where i=0,1,2,..,N/8 for w3cos w3sin - (except i=0 is ignored, never used) - / - Table for wsin[i] is not needed because wsin[i]=wcos[n4-i]. - Table for w3sin[i] is needed however. The previous relationship does not work for w3sin. - / - Instead of getting sin() from a wsin[i] table with i=1,..,N/8 - we get it from wcos[n4-i]. - This way we can use a CFT table which goes up to N/4 - for RFT CSFT also. We do so in image-processing (rft2d-csft2d). - */ - -/* There are two routines for making twiddle tables: - a fast one, and a slower one but more precise. - The differences in speed and accuracy are actually rather small, but anyway. - Use the slow one for making tables that stay around. - */ - -void pas_realdata_make_twiddle_tables(n,m, wcos,w3cos,w3sin) /* efficient version */ - REAL *wcos, *w3cos, *w3sin; - long n,m; -{ long i, n4, n8; - double tm; - REAL costm,sintm; - n4 = n/4; - n8 = n/8; - for (i=1; i= j) goto label101; /* if (i .ge. j) goto 101 */ - xt = x[j]; - x[j] = x[i]; - x[i] = xt; - label101: k = n>>1; /* k = n/2; */ - label102: if (k>=j) goto label103; - j = j - k; - k = k>>1; /* k = k/2; */ - goto label102; - label103: j = j + k; - } /* 104 CONTINUE */ - /* c-------------------------------------*/ - /* c */ - /* c ----length-two-butterflies----------- */ - is = 1; - id = 4; - label70: - for (i0=is; i0<=n; i0=i0+id) /* 70 DO 60 I0 = IS,N,ID */ - { i1 = i0 + 1; - r1 = x[i0]; - x[i0] = r1 + x[i1]; - x[i1] = r1 - x[i1]; - } /* 60 CONTINUE */ - is = 2*id - 1; - id = 4*id; - if (is < n) goto label70; /* IF (IS.LT.N) GOTO 70 */ - /* C - C -------L-shaped-butterflies-------- */ - n2 = 2; - for (k=2; k<=m; k++) /* DO 10 K = 2,M */ - { n2 = n2 * 2; - n4 = n2>>2; /* n4 = n2/4; */ - n8 = n2>>3; /* n8 = n2/8; */ - /* e = 6.283185307179586476925287 / ((REAL) n2); no need anymore, use tables */ - is = 0; - id = n2 * 2; - label40: - for (i=is; i>1; /* n2 = n2/2; */ - n4 = n2>>2; /* n4 = n2/4; */ - n8 = n4>>1; /* n8 = n4/2; */ - /* e = 6.283185307179586476925287 / ((REAL) n2); no need anymore, use tables */ - label17: - for (i=is; i= j) goto label101; /* if (i .ge. j) goto 101 */ - xt = x[j]; - x[j] = x[i]; - x[i] = xt; - label101: k = n>>1; /* k = n/2; */ - label102: if (k>=j) goto label103; - j = j - k; - k = k>>1; /* k = k/2; */ - goto label102; - label103: j = j + k; - } /* 104 CONTINUE */ - /* c */ -} /* RETURN ^M END */ - - - - -/* Image processing only for square images - (old stuff handles non-square but is slow) - For 2d FTs precomputed tables or not, make almost no difference in total time. - */ - -DEFINE_PRIMITIVE ("PAS-CFT2D!", Prim_pas_cft2d, 5,5, 0) -{ long i, length, power, flag, rows,rowpower; - REAL *f1,*f2, *wcos,*w3cos,*w3sin; - void pas_cft2d(); - PRIMITIVE_HEADER (5); - CHECK_ARG (2, ARRAY_P); /* real part */ - CHECK_ARG (3, ARRAY_P); /* imag part */ - CHECK_ARG (4, ARRAY_P); /* twiddle tables, length = 3*(rows/4) */ - - flag = (arg_integer (1)); - length = ARRAY_LENGTH(ARG_REF(2)); - if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2); - - for (power=0, i=length; i>1; power++) /* length must be power of 2 */ - { if ( (i % 2) == 1) error_bad_range_arg(2); - i=i/2; } - - if ((power % 2) == 1) error_bad_range_arg(2); - rowpower = (power/2); - rows = (1<1; power++) /* length must be power of 2 */ - { if ( (i % 2) == 1) error_bad_range_arg(2); - i=i/2; } - - if ((power % 2) == 1) error_bad_range_arg(2); - rowpower = (power/2); - rows = (1<>1, a; - long i, l, m; - REAL tm; - a = n; /* initially equal to length of data */ - - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - } -} - -void C_Array_FFT_With_Given_Tables(flag, power, n, f1, f2, g1,g2,w1,w2) - long flag, power, n; REAL f1[], f2[], g1[], g2[], w1[], w2[]; -{ long n2=n>>1, a; - long i, l, m; - REAL tm; - a = n; /* initially equal to length */ - - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - for (m=0; m do one more mult */ - mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ - } -} - - -/* CHIRP-Z-TRANSFORM (complex data) - */ - -/* C_Array_CZT Generalization of DFT - ;; - Frequency is scaled as an L/2-point DFT of the input data (zero padded to L/2). - ;; - phi = starting point (on unit circle) -- Range 0,1 (covers 0,2pi like DFT angle) - rho = resolution (angular frequency spacing) -- Range 0,1 (maps 0,2pi like DFT angle) - N = input data length - M = output data length - log2_L = smallest_power_of_2_ge(N+M-1) ---- - f1,f2 contain the input data (complex). - f1,f2,fo1,fo2,g1,g2 must be of length L - fft_w1,fft_w2 must be of length L/2 - czt_w1,czt_w2 must be of length max(M,N) ---- - ;; - RESULT is left on f1,f2 (M complex numbers). - */ -C_Array_CZT(phi,rho, N,M,log2_L, f1,f2,fo1,fo2, g1,g2, fft_w1,fft_w2,czt_w1,czt_w2) - double phi, rho; - REAL *f1,*f2,*fo1,*fo2, *g1,*g2, *fft_w1,*fft_w2,*czt_w1,*czt_w2; - long N,M,log2_L; -{ long i, maxMN, L, L2; - void Make_CZT_Tables(), CZT_Pre_Multiply(), Make_Chirp_Filter(); - void Make_FFT_Tables(), C_Array_FFT_With_Given_Tables(), C_Array_Complex_Multiply_Into_First_One(); - - maxMN = max(M,N); - L = 1<1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */ - if ( (i % 2) == 1) error_bad_range_arg (2); - i=i/2; } - for (nrows_power=0, i=nrows; i>1; nrows_power++) { - if ( (i % 2) == 1) error_bad_range_arg (1); - i=i/2; } - -#if (REAL_IS_DEFINED_DOUBLE != 0) - ALIGN_FLOAT (Free); - Free += 1; -#endif - Primitive_GC_If_Needed(Length*REAL_SIZE + ((max(nrows,ncols))*3*REAL_SIZE)); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + ncols; - w1 = Work_Here + (ncols<<1); - w2 = Work_Here + (ncols<<1) + (ncols>>1); - Make_FFT_Tables(w1,w2,ncols, flag); - for (i=0;i>1); - Make_FFT_Tables(w1,w2,nrows,flag); - for (i=0;i1; nrows_power++) { /* FIND/CHECK POWERS OF ROWS */ - if ( (i % 2) == 1) error_bad_range_arg (2); - i=i/2; } -#if (REAL_IS_DEFINED_DOUBLE != 0) - ALIGN_FLOAT (Free); - Free += 1; -#endif - Primitive_GC_If_Needed(nrows*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + nrows; - w1 = Work_Here + (nrows<<1); - w2 = Work_Here + (nrows<<1) + (nrows>>1); - Make_FFT_Tables(w1, w2, nrows, flag); /* MAKE TABLES */ - for (i=0;i1; ndeps_power++) { /* FIND/CHECK POWERS OF DEPS,ROWS,COLS */ - if ( (l % 2) == 1) error_bad_range_arg (2); - l=l/2; } - for (nrows_power=0, m=nrows; m>1; nrows_power++) { - if ( (m % 2) == 1) error_bad_range_arg (2); - m=m/2; } - for (ncols_power=0, n=ncols; n>1; ncols_power++) { - if ( (n % 2) == 1) error_bad_range_arg (2); - n=n/2; } - - printf("3D FFT implemented only for cubic-spaces.\n"); - printf("aborted\n."); - } -} - -Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array) - long flag, ndeps; REAL *Real_Array, *Imag_Array; -{ fast long l, m, n; - fast long ndeps_power, Surface_Length; - fast REAL *From_Real, *From_Imag; - fast REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here; - - for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWER OF NDEPS */ - if ( (l % 2) == 1) error_bad_range_arg (2); - l=l/2; } -#if (REAL_IS_DEFINED_DOUBLE != 0) - ALIGN_FLOAT (Free); - Free += 1; -#endif - Primitive_GC_If_Needed(ndeps*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + ndeps; - w1 = Work_Here + (ndeps<<1); - w2 = Work_Here + (ndeps<<1) + (ndeps>>1); - Make_FFT_Tables(w1, w2, ndeps, flag); /* MAKE TABLES */ - - Surface_Length=ndeps*ndeps; - From_Real = Real_Array; From_Imag = Imag_Array; - - for (l=0; l forward FFT, otherwise backward. - */ - -DEFINE_PRIMITIVE ("ARRAY-FFT!", Prim_array_fft, 3, 3, 0) -{ long length, power, flag, i; - SCHEME_OBJECT answer; - REAL *f1,*f2,*g1,*g2,*w1,*w2; - REAL *Work_Here; - - PRIMITIVE_HEADER (4); - flag = arg_integer(1); /* forward or backward */ - CHECK_ARG (2, ARRAY_P); /* input real */ - CHECK_ARG (3, ARRAY_P); /* input imag */ - - length = ARRAY_LENGTH(ARG_REF(2)); - if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2); - - for (power=0, i=length; i>1; power++) { - if ( (i % 2) == 1) error_bad_range_arg(2); - i=i/2; } - - f1 = ARRAY_CONTENTS(ARG_REF(2)); - f2 = ARRAY_CONTENTS(ARG_REF(3)); - if (f1==f2) error_wrong_type_arg(2); - -#if (REAL_IS_DEFINED_DOUBLE != 0) - ALIGN_FLOAT (Free); - Free += 1; -#endif - Primitive_GC_If_Needed(length*3*REAL_SIZE); - Work_Here = (REAL *) Free; - g1 = Work_Here; - g2 = Work_Here + length; - w1 = Work_Here + (length<<1); - w2 = Work_Here + (length<<1) + (length>>1); - - C_Array_FFT(flag, power, length, f1,f2,g1,g2,w1,w2); - - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("ARRAY-CZT!", Prim_array_czt, 6,6, 0) -{ double phi,rho; - long N,M,L, i; - long log2_L, maxMN; - long smallest_power_of_2_ge(); - int errcode; - REAL *a,*b,*c,*d; - REAL *f1,*f2,*fo1,*fo2, *g1,*g2, *fft_w1,*fft_w2,*czt_w1,*czt_w2, *Work_Here; - - PRIMITIVE_HEADER (6); - phi = (arg_real_number (1)); /* starting point [0,1]*/ - rho = (arg_real_number (2)); /* resolution [0,1] */ - CHECK_ARG (3, ARRAY_P); /* input real */ - CHECK_ARG (4, ARRAY_P); /* input imag */ - CHECK_ARG (5, ARRAY_P); /* output real */ - CHECK_ARG (6, ARRAY_P); /* output imag */ - - a = ARRAY_CONTENTS(ARG_REF(3)); - b = ARRAY_CONTENTS(ARG_REF(4)); - c = ARRAY_CONTENTS(ARG_REF(5)); - d = ARRAY_CONTENTS(ARG_REF(6)); - - N = ARRAY_LENGTH(ARG_REF(3)); /* N = input length */ - M = ARRAY_LENGTH(ARG_REF(5)); /* M = output length */ - if (N!=(ARRAY_LENGTH(ARG_REF(4)))) error_bad_range_arg(3); - if (M!=(ARRAY_LENGTH(ARG_REF(6)))) error_bad_range_arg(5); - - if ((M+N-1) < 4) error_bad_range_arg(5); - log2_L = smallest_power_of_2_ge(M+N-1); - L = 1< -#define ASSUME_ANSIDECL - -/* For macros toupper, isalpha, etc, - supposedly on the standard library. */ - -#include - -#ifdef STDC_HEADERS -# include -# include -#else - extern void EXFUN (exit, (int)); - extern PTR EXFUN (malloc, (int)); - extern PTR EXFUN (realloc, (PTR, int)); - extern void EXFUN (free, (PTR)); - extern int EXFUN (strcmp, (CONST char *, CONST char *)); - extern int EXFUN (strlen, (CONST char *)); -#endif - -typedef int boolean; - #ifdef vms /* VMS version 3 has no void. */ /* #define void */ @@ -100,10 +79,10 @@ typedef int boolean; #define pseudo_void int #define pseudo_return return (0) -PTR -DEFUN (xmalloc, (length), unsigned long length) +void * +xmalloc (unsigned long length) { - PTR result = (malloc (length)); + void * result = (malloc (length)); if (result == 0) { fprintf (stderr, "malloc: unable to allocate %ld bytes\n", length); @@ -112,10 +91,10 @@ DEFUN (xmalloc, (length), unsigned long length) return (result); } -PTR -DEFUN (xrealloc, (ptr, length), PTR ptr AND unsigned long length) +void * +xrealloc (void * ptr, unsigned long length) { - PTR result = (realloc (ptr, length)); + void * result = (realloc (ptr, length)); if (result == 0) { fprintf (stderr, "realloc: unable to allocate %ld bytes\n", length); @@ -140,7 +119,7 @@ DEFUN (xrealloc, (ptr, length), PTR ptr AND unsigned long length) /* Maximum number of primitives that can be handled. */ -boolean built_in_p; +bool built_in_p; char * token_array [4]; char default_token [] = "Define_Primitive"; @@ -148,7 +127,7 @@ char default_token_alternate [] = "DEFINE_PRIMITIVE"; char built_in_token [] = "Built_In_Primitive"; char external_token [] = "Define_Primitive"; -typedef pseudo_void EXFUN ((* TOKEN_PROCESSOR), (void)); +typedef pseudo_void (* TOKEN_PROCESSOR) (void); TOKEN_PROCESSOR token_processors [4]; char * the_kind; @@ -203,42 +182,40 @@ char inexistent_error_string [] = /* forward references */ -TOKEN_PROCESSOR EXFUN (scan, (void)); -boolean EXFUN (whitespace, (int c)); -int EXFUN (compare_descriptors, (struct descriptor * d1, struct descriptor * d2)); -int EXFUN (read_index, (char * arg, char * identification)); -int EXFUN (strcmp_ci, (char * s1, char * s2)); -pseudo_void EXFUN (create_alternate_entry, (void)); -pseudo_void EXFUN (create_builtin_entry, (void)); -pseudo_void EXFUN (create_normal_entry, (void)); -void EXFUN (dump, (boolean check)); -void EXFUN (grow_data_buffer, (void)); -void EXFUN (grow_token_buffer, (void)); -void EXFUN (initialize_builtin, (char * arg)); -void EXFUN (initialize_data_buffer, (void)); -void EXFUN (initialize_default, (void)); -void EXFUN (initialize_external, (void)); -void EXFUN (initialize_token_buffer, (void)); -static void EXFUN - (fp_mergesort, (int, int, struct descriptor **, struct descriptor **)); -void EXFUN (print_procedure, (FILE * output, +TOKEN_PROCESSOR scan (void); +bool whitespace (int c); +int compare_descriptors (struct descriptor * d1, struct descriptor * d2); +int read_index (char * arg, char * identification); +int strcmp_ci (char * s1, char * s2); +pseudo_void create_alternate_entry (void); +pseudo_void create_builtin_entry (void); +pseudo_void create_normal_entry (void); +void dump (bool check); +void grow_data_buffer (void); +void grow_token_buffer (void); +void initialize_builtin (char * arg); +void initialize_data_buffer (void); +void initialize_default (void); +void initialize_external (void); +void initialize_token_buffer (void); +static void fp_mergesort + (int, int, struct descriptor **, struct descriptor **); +void print_procedure (FILE * output, struct descriptor * primitive_descriptor, - char * error_string)); -void EXFUN (print_primitives, (FILE * output, int limit)); -void EXFUN (print_spaces, (FILE * output, int how_many)); -void EXFUN (print_entry, (FILE * output, int index, - struct descriptor * primitive_descriptor)); -void EXFUN (process, (void)); -void EXFUN (process_argument, (char * fn)); -void EXFUN (scan_to_token_start, (void)); -void EXFUN (skip_token, (void)); -void EXFUN (sort, (void)); -void EXFUN (update_from_entry, (struct descriptor * primitive_descriptor)); + char * error_string); +void print_primitives (FILE * output, int limit); +void print_spaces (FILE * output, int how_many); +void print_entry (FILE * output, int index, + struct descriptor * primitive_descriptor); +void process (void); +void process_argument (char * fn); +void scan_to_token_start (void); +void skip_token (void); +void sort (void); +void update_from_entry (struct descriptor * primitive_descriptor); int -DEFUN (main, (argc, argv), - int argc AND - char **argv) +main (int argc, char ** argv) { name = argv[0]; @@ -283,7 +260,7 @@ DEFUN (main, (argc, argv), /* Check whether there are any files left. */ if (argc == 1) { - dump (FALSE); + dump (0); goto done; } @@ -298,7 +275,7 @@ DEFUN (main, (argc, argv), if (file_list_file == NULL) { fprintf (stderr, "Error: %s can't open %s\n", name, argv[2]); - dump (TRUE); + dump (1); exit (1); } while ((fgets (fn, 1024, file_list_file)) != NULL) @@ -333,7 +310,7 @@ DEFUN (main, (argc, argv), sort (); } dprintf ("About to dump %s\n", ""); - dump (TRUE); + dump (1); done: if (output != stdout) @@ -343,8 +320,7 @@ DEFUN (main, (argc, argv), } void -DEFUN (process_argument, (fn), - char * fn) +process_argument (char * fn) { file_name = fn; if ((strcmp ("-", file_name)) == 0) @@ -357,7 +333,7 @@ DEFUN (process_argument, (fn), else if ((input = (fopen (file_name, "r"))) == NULL) { fprintf (stderr, "Error: %s can't open %s\n", name, file_name); - dump (TRUE); + dump (1); exit (1); } else @@ -372,11 +348,11 @@ DEFUN (process_argument, (fn), /* Search for tokens and when found, create primitive entries. */ void -DEFUN_VOID (process) +process (void) { TOKEN_PROCESSOR processor; - while (TRUE) + while (1) { processor = (scan ()); if (processor == NULL) break; @@ -393,9 +369,9 @@ DEFUN_VOID (process) */ TOKEN_PROCESSOR -DEFUN_VOID (scan) +scan (void) { - register int c; + int c; char compare_buffer [1024]; c = '\n'; @@ -407,7 +383,7 @@ DEFUN_VOID (scan) if ((c = (getc (input))) == '*') { c = (getc (input)); - while (TRUE) + while (1) { while (c != '*') { @@ -416,7 +392,7 @@ DEFUN_VOID (scan) fprintf (stderr, "Error: EOF in comment in file %s, or %s confused\n", file_name, name); - dump (TRUE); + dump (1); exit (1); } c = (getc (input)); @@ -430,10 +406,10 @@ DEFUN_VOID (scan) case '\n': { { - register char * scan_buffer; + char * scan_buffer; scan_buffer = (& (compare_buffer [0])); - while (TRUE) + while (1) { c = (getc (input)); if (c == EOF) @@ -449,7 +425,7 @@ DEFUN_VOID (scan) } } { - register char **scan_tokens; + char **scan_tokens; for (scan_tokens = (& (token_array [0])); ((* scan_tokens) != NULL); @@ -470,11 +446,10 @@ DEFUN_VOID (scan) /* Output Routines */ void -DEFUN (dump, (check), - boolean check) +dump (bool check) { - register int max_index; - register int count; + int max_index; + int count; FIND_INDEX_LENGTH (buffer_index, max_index_length); max_index = (buffer_index - 1); @@ -508,13 +483,8 @@ DEFUN (dump, (check), fprintf (output, "extern SCHEME_OBJECT\n"); for (count = 0; (count <= max_index); count += 1) { -#ifdef ASSUME_ANSIDECL - fprintf (output, " EXFUN (%s, (void))", - (((* data_buffer) [count]) . c_name)); -#else - fprintf (output, " %s ()", + fprintf (output, " %s (void)", (((* data_buffer) [count]) . c_name)); -#endif if (count == max_index) fprintf (output, ";\n\n"); else @@ -529,19 +499,13 @@ DEFUN (dump, (check), } void -DEFUN (print_procedure, (output, primitive_descriptor, error_string), - FILE * output AND - struct descriptor * primitive_descriptor AND - char * error_string) +print_procedure (FILE * output, + struct descriptor * primitive_descriptor, + char * error_string) { fprintf (output, "SCHEME_OBJECT\n"); -#ifdef ASSUME_ANSIDECL - fprintf (output, "DEFUN_VOID (%s)\n", - (primitive_descriptor -> c_name)); -#else - fprintf (output, "%s ()\n", + fprintf (output, "%s (void)\n", (primitive_descriptor -> c_name)); -#endif fprintf (output, "{\n"); fprintf (output, " PRIMITIVE_HEADER (%s);\n", (primitive_descriptor -> arity)); @@ -555,26 +519,19 @@ DEFUN (print_procedure, (output, primitive_descriptor, error_string), } void -DEFUN (print_primitives, (output, limit), - FILE * output AND - register int limit) +print_primitives (FILE * output, int limit) { - register int last; - register int count; - register char * table_entry; + int last; + int count; + char * table_entry; last = (limit - 1); /* Print the procedure table. */ -#ifdef ASSUME_ANSIDECL fprintf (output, - "\f\nSCHEME_OBJECT EXFUN ((* (%s_Procedure_Table [])), (void)) = {\n", + "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) (void) = {\n", the_kind); -#else - fprintf (output, "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) () = {\n", - the_kind); -#endif for (count = 0; (count < limit); count += 1) { print_entry (output, count, (result_buffer [count])); @@ -584,7 +541,7 @@ DEFUN (print_primitives, (output, limit), fprintf (output, "\n};\n"); /* Print the names table. */ - fprintf (output, "\f\nCONST char * %s_Name_Table [] = {\n", the_kind); + fprintf (output, "\f\nconst char * %s_Name_Table [] = {\n", the_kind); for (count = 0; (count < limit); count += 1) { fprintf (output, " \"%s\",\n", ((result_buffer [count]) -> scheme_name)); @@ -592,7 +549,7 @@ DEFUN (print_primitives, (output, limit), fprintf (output, " \"%s\"\n};\n", inexistent_entry.scheme_name); /* Print the documentation table. */ - fprintf (output, "\f\nCONST char * %s_Documentation_Table [] = {\n", the_kind); + fprintf (output, "\f\nconst char * %s_Documentation_Table [] = {\n", the_kind); for (count = 0; (count < limit); count += 1) { fprintf (output, " "); @@ -627,10 +584,9 @@ DEFUN (print_primitives, (output, limit), } void -DEFUN (print_entry, (output, index, primitive_descriptor), - FILE * output AND - int index AND - struct descriptor * primitive_descriptor) +print_entry (FILE * output, + int index, + struct descriptor * primitive_descriptor) { int index_length; @@ -657,9 +613,7 @@ DEFUN (print_entry, (output, index, primitive_descriptor), } void -DEFUN (print_spaces, (output, how_many), - FILE * output AND - register int how_many) +print_spaces (FILE * output, int how_many) { while ((--how_many) >= 0) putc (' ', output); @@ -672,7 +626,7 @@ char * token_buffer; int token_buffer_length; void -DEFUN_VOID (initialize_token_buffer) +initialize_token_buffer (void) { token_buffer_length = 80; token_buffer = (xmalloc (token_buffer_length)); @@ -680,7 +634,7 @@ DEFUN_VOID (initialize_token_buffer) } void -DEFUN_VOID (grow_token_buffer) +grow_token_buffer (void) { token_buffer_length *= 2; token_buffer = (xrealloc (token_buffer, token_buffer_length)); @@ -688,8 +642,8 @@ DEFUN_VOID (grow_token_buffer) } #define TOKEN_BUFFER_DECLS() \ - register char * TOKEN_BUFFER_scan; \ - register char * TOKEN_BUFFER_end + char * TOKEN_BUFFER_scan; \ + char * TOKEN_BUFFER_end #define TOKEN_BUFFER_START() \ { \ @@ -748,12 +702,9 @@ enum tokentype }; void -DEFUN (copy_token, (target, size, token_type), - char ** target AND - int * size AND - register enum tokentype token_type) +copy_token (char ** target, int * size, enum tokentype token_type) { - register int c; + int c; TOKEN_BUFFER_DECLS (); TOKEN_BUFFER_START (); @@ -802,9 +753,8 @@ DEFUN (copy_token, (target, size, token_type), return; } -boolean -DEFUN (whitespace, (c), - register int c) +bool +whitespace (int c) { switch (c) { @@ -814,15 +764,15 @@ DEFUN (whitespace, (c), case '\r': case '(': case ')': - case ',': return TRUE; - default: return FALSE; + case ',': return 1; + default: return 0; } } void -DEFUN_VOID (scan_to_token_start) +scan_to_token_start (void) { - register int c; + int c; while (whitespace (c = (getc (input)))) ; ungetc (c, input); @@ -830,9 +780,9 @@ DEFUN_VOID (scan_to_token_start) } void -DEFUN_VOID (skip_token) +skip_token (void) { - register int c; + int c; while (! (whitespace (c = (getc (input))))) ; ungetc (c, input); @@ -840,7 +790,7 @@ DEFUN_VOID (skip_token) } void -DEFUN_VOID (initialize_data_buffer) +initialize_data_buffer (void) { buffer_length = 0x200; buffer_index = 0; @@ -862,7 +812,7 @@ DEFUN_VOID (initialize_data_buffer) } void -DEFUN_VOID (grow_data_buffer) +grow_data_buffer (void) { char * old_data_buffer = ((char *) data_buffer); buffer_length *= 2; @@ -871,9 +821,9 @@ DEFUN_VOID (grow_data_buffer) (xrealloc (((char *) data_buffer), (buffer_length * (sizeof (struct descriptor)))))); { - register struct descriptor ** scan = result_buffer; - register struct descriptor ** end = (result_buffer + buffer_index); - register long offset = (((char *) data_buffer) - old_data_buffer); + struct descriptor ** scan = result_buffer; + struct descriptor ** end = (result_buffer + buffer_index); + long offset = (((char *) data_buffer) - old_data_buffer); while (scan < end) { (*scan) = ((struct descriptor *) (((char*) (*scan)) + offset)); @@ -941,9 +891,9 @@ DEFUN_VOID (grow_data_buffer) } void -DEFUN_VOID (initialize_default) +initialize_default (void) { - built_in_p = FALSE; + built_in_p = 0; (token_array [0]) = (& (default_token [0])); (token_array [1]) = (& (default_token_alternate [0])); (token_array [2]) = NULL; @@ -956,9 +906,9 @@ DEFUN_VOID (initialize_default) } void -DEFUN_VOID (initialize_external) +initialize_external (void) { - built_in_p = FALSE; + built_in_p = 0; (token_array [0]) = (& (external_token [0])); (token_array [1]) = NULL; (token_processors [0]) = create_normal_entry; @@ -969,13 +919,12 @@ DEFUN_VOID (initialize_external) } void -DEFUN (initialize_builtin, (arg), - char * arg) +initialize_builtin (char * arg) { - register int length; - register int index; + int length; + int index; - built_in_p = TRUE; + built_in_p = 1; length = (read_index (arg, "built_in_table_size")); while (buffer_length < length) grow_data_buffer (); @@ -992,10 +941,9 @@ DEFUN (initialize_builtin, (arg), } void -DEFUN (update_from_entry, (primitive_descriptor), - register struct descriptor * primitive_descriptor) +update_from_entry (struct descriptor * primitive_descriptor) { - register int temp; + int temp; temp = (strlen (primitive_descriptor -> scheme_name)); if (max_scheme_name_length < temp) @@ -1021,7 +969,7 @@ DEFUN (update_from_entry, (primitive_descriptor), } pseudo_void -DEFUN_VOID (create_normal_entry) +create_normal_entry (void) { MAYBE_GROW_BUFFER (); COPY_C_NAME ((* data_buffer) [buffer_index]); @@ -1035,7 +983,7 @@ DEFUN_VOID (create_normal_entry) } pseudo_void -DEFUN_VOID (create_alternate_entry) +create_alternate_entry (void) { MAYBE_GROW_BUFFER (); COPY_SCHEME_NAME ((* data_buffer) [buffer_index]); @@ -1051,10 +999,10 @@ DEFUN_VOID (create_alternate_entry) } pseudo_void -DEFUN_VOID (create_builtin_entry) +create_builtin_entry (void) { struct descriptor desc; - register int length; + int length; int index; char * index_buffer; @@ -1070,7 +1018,7 @@ DEFUN_VOID (create_builtin_entry) length = (index + 1); if (buffer_length < length) { - register int i; + int i; while (buffer_length < length) grow_data_buffer (); @@ -1097,9 +1045,7 @@ DEFUN_VOID (create_builtin_entry) } int -DEFUN (read_index, (arg, identification), - char * arg AND - char * identification) +read_index (char * arg, char * identification) { int result = 0; if (((arg [0]) == '0') && ((arg [1]) == 'x')) @@ -1117,10 +1063,10 @@ DEFUN (read_index, (arg, identification), /* Sorting */ void -DEFUN_VOID (sort) +sort (void) { - register struct descriptor ** temp_buffer; - register int count; + struct descriptor ** temp_buffer; + int count; if (buffer_index <= 0) return; @@ -1134,15 +1080,14 @@ DEFUN_VOID (sort) } static void -DEFUN (fp_mergesort, (low, high, array, temp_array), - int low AND - register int high AND - register struct descriptor ** array AND - register struct descriptor ** temp_array) +fp_mergesort (int low, + int high, + struct descriptor ** array, + struct descriptor ** temp_array) { - register int index; - register int low1; - register int low2; + int index; + int low1; + int low2; int high1; int high2; @@ -1225,9 +1170,7 @@ DEFUN (fp_mergesort, (low, high, array, temp_array), } int -DEFUN (compare_descriptors, (d1, d2), - struct descriptor * d1 AND - struct descriptor * d2) +compare_descriptors (struct descriptor * d1, struct descriptor * d2) { int value; @@ -1243,18 +1186,16 @@ DEFUN (compare_descriptors, (d1, d2), } int -DEFUN (strcmp_ci, (s1, s2), - register char * s1 AND - register char * s2) +strcmp_ci (char * s1, char * s2) { int length1 = (strlen (s1)); int length2 = (strlen (s2)); - register int length = ((length1 < length2) ? length1 : length2); + int length = ((length1 < length2) ? length1 : length2); while ((length--) > 0) { - register int c1 = (*s1++); - register int c2 = (*s2++); + int c1 = (*s1++); + int c2 = (*s2++); if (islower (c1)) c1 = (toupper (c1)); if (islower (c2)) c2 = (toupper (c2)); if (c1 < c2) return (-1); diff --git a/v7/src/microcode/fixnum.c b/v7/src/microcode/fixnum.c index aeca7f2c4..19b87bb34 100644 --- a/v7/src/microcode/fixnum.c +++ b/v7/src/microcode/fixnum.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fixnum.c,v 9.48 2007/01/05 21:19:25 cph Exp $ +$Id: fixnum.c,v 9.49 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -34,18 +34,18 @@ USA. #include "prims.h" static long -DEFUN (arg_fixnum, (n), int n) +arg_fixnum (int n) { - fast SCHEME_OBJECT argument = (ARG_REF (n)); + SCHEME_OBJECT argument = (ARG_REF (n)); if (! (FIXNUM_P (argument))) error_wrong_type_arg (n); return (FIXNUM_TO_LONG (argument)); } static long -DEFUN (arg_unsigned_fixnum, (n), int n) +arg_unsigned_fixnum (int n) { - fast SCHEME_OBJECT argument = (ARG_REF (n)); + SCHEME_OBJECT argument = (ARG_REF (n)); if (! (FIXNUM_P (argument))) error_wrong_type_arg (n); return (UNSIGNED_FIXNUM_TO_LONG (argument)); @@ -112,7 +112,7 @@ DEFINE_PRIMITIVE ("GREATER-THAN-FIXNUM?", Prim_greater_fixnum, 2, 2, 0) #define FIXNUM_RESULT(fixnum) \ { \ - fast long result = (fixnum); \ + long result = (fixnum); \ if (! (LONG_TO_FIXNUM_P (result))) \ error_bad_range_arg (1); \ PRIMITIVE_RETURN (LONG_TO_FIXNUM (result)); \ @@ -157,7 +157,7 @@ DEFINE_PRIMITIVE ("MULTIPLY-FIXNUM", Prim_multiply_fixnum, 2, 2, 0) CHECK_ARG (1, FIXNUM_P); CHECK_ARG (2, FIXNUM_P); { - fast long result = (Mul ((ARG_REF (1)), (ARG_REF (2)))); + long result = (Mul ((ARG_REF (1)), (ARG_REF (2)))); if (result == SHARP_F) error_bad_range_arg (1); PRIMITIVE_RETURN (result); @@ -166,10 +166,10 @@ DEFINE_PRIMITIVE ("MULTIPLY-FIXNUM", Prim_multiply_fixnum, 2, 2, 0) DEFINE_PRIMITIVE ("DIVIDE-FIXNUM", Prim_divide_fixnum, 2, 2, 0) { - fast long numerator; - fast long denominator; - fast long quotient; - fast long remainder; + long numerator; + long denominator; + long quotient; + long remainder; PRIMITIVE_HEADER (2); numerator = (arg_fixnum (1)); denominator = (arg_fixnum (2)); @@ -211,9 +211,9 @@ DEFINE_PRIMITIVE ("FIXNUM-QUOTIENT", Prim_fixnum_quotient, 2, 2, 0) { PRIMITIVE_HEADER (2); { - fast long numerator = (arg_fixnum (1)); - fast long denominator = (arg_fixnum (2)); - fast long quotient = + long numerator = (arg_fixnum (1)); + long denominator = (arg_fixnum (2)); + long quotient = ((denominator > 0) ? ((numerator < 0) ? (- ((- numerator) / denominator)) @@ -233,8 +233,8 @@ DEFINE_PRIMITIVE ("FIXNUM-REMAINDER", Prim_fixnum_remainder, 2, 2, 0) { PRIMITIVE_HEADER (2); { - fast long numerator = (arg_fixnum (1)); - fast long denominator = (arg_fixnum (2)); + long numerator = (arg_fixnum (1)); + long denominator = (arg_fixnum (2)); PRIMITIVE_RETURN (LONG_TO_FIXNUM ((denominator > 0) @@ -251,9 +251,9 @@ DEFINE_PRIMITIVE ("FIXNUM-REMAINDER", Prim_fixnum_remainder, 2, 2, 0) DEFINE_PRIMITIVE ("GCD-FIXNUM", Prim_gcd_fixnum, 2, 2, 0) { - fast long x; - fast long y; - fast long z; + long x; + long y; + long z; PRIMITIVE_HEADER (2); x = (arg_fixnum (1)); y = (arg_fixnum (2)); @@ -273,7 +273,7 @@ DEFINE_PRIMITIVE ("GCD-FIXNUM", Prim_gcd_fixnum, 2, 2, 0) #define FIXNUM_BOOLEAN_BODY(operation) \ do \ { \ - fast unsigned long x, y, z; \ + unsigned long x, y, z; \ \ PRIMITIVE_HEADER (2); \ \ @@ -311,7 +311,7 @@ DEFINE_PRIMITIVE ("FIXNUM-XOR", Prim_fixnum_xor, 2, 2, 0) DEFINE_PRIMITIVE ("FIXNUM-NOT", Prim_fixnum_not, 1, 1, 0) { - fast unsigned long x, z; + unsigned long x, z; PRIMITIVE_HEADER (1); @@ -323,8 +323,8 @@ DEFINE_PRIMITIVE ("FIXNUM-NOT", Prim_fixnum_not, 1, 1, 0) DEFINE_PRIMITIVE ("FIXNUM-LSH", Prim_fixnum_lsh, 2, 2, 0) { - fast unsigned long x, z; - fast long y; + unsigned long x, z; + long y; PRIMITIVE_HEADER (2); diff --git a/v7/src/microcode/fixobj.h b/v7/src/microcode/fixobj.h index 9c601c372..cbd93ca5b 100644 --- a/v7/src/microcode/fixobj.h +++ b/v7/src/microcode/fixobj.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fixobj.h,v 9.42 2007/01/05 21:19:25 cph Exp $ +$Id: fixobj.h,v 9.43 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -26,59 +26,52 @@ USA. */ /* Declarations of user offsets into the Fixed Objects Vector. - This should correspond to the file "utabmd.scm". */ + This should correspond to the file "utabmd.scm". */ -#define Non_Object 0x00 /* Used for unassigned variables. */ -#define System_Interrupt_Vector 0x01 /* Handlers for interrupts. */ -#define System_Error_Vector 0x02 /* Handlers for errors. */ -#define OBArray 0x03 /* Array for interning symbols. */ -#define Types_Vector 0x04 /* Type number -> Name map. */ -#define Returns_Vector 0x05 /* Return code -> Name map. */ +#define NON_OBJECT 0x00 /* Used for unassigned variables. */ +#define SYSTEM_INTERRUPT_VECTOR 0x01 /* Handlers for interrupts. */ +#define SYSTEM_ERROR_VECTOR 0x02 /* Handlers for errors. */ +#define OBARRAY 0x03 /* Array for interning symbols. */ +#define TYPES_VECTOR 0x04 /* Type number -> Name map. */ +#define RETURNS_VECTOR 0x05 /* Return code -> Name map. */ /* For each interrupt, an interrupt mask to be set when invoking the handler for that interrupt. */ #define FIXOBJ_INTERRUPT_MASK_VECTOR 0x06 -#define Errors_Vector 0x07 /* Error code -> Name map. */ -#define Identification_Vector 0x08 /* ID Vector index -> name map. */ +#define ERRORS_VECTOR 0x07 /* Error code -> Name map. */ +#define IDENTIFICATION_VECTOR 0x08 /* ID Vector index -> name map. */ #define FIXOBJ_SYSTEM_CALL_NAMES 0x09 /* System call index -> name */ #define FIXOBJ_SYSTEM_CALL_ERRORS 0x0A /* System call error -> name */ -#define GC_Daemon 0x0B /* Procedure to run after GC. */ -#define Trap_Handler 0x0C /* Abort after disaster. */ +#define GC_DAEMON 0x0B /* Procedure to run after GC. */ +#define TRAP_HANDLER 0x0C /* Abort after disaster. */ #define FIXOBJ_EDWIN_AUTO_SAVE 0x0D /* Files to save if fatal error. */ -#define Stepper_State 0x0E /* UNUSED in CScheme. */ -#define Fixed_Objects_Slots 0x0F /* Names of these slots. */ +#define STEPPER_STATE 0x0E +#define FIXED_OBJECTS_SLOTS 0x0F /* Names of these slots. */ #define FIXOBJ_FILES_TO_DELETE 0x10 /* Temporary files to delete. */ #define State_Space_Tag 0x11 /* Tag for state spaces. */ #define State_Point_Tag 0x12 /* Tag for state points. */ -#define Dummy_History 0x13 /* Empty history structure. */ +#define DUMMY_HISTORY 0x13 /* Empty history structure. */ #define Bignum_One 0x14 /* Cache for bignum one. */ -#define System_Scheduler 0x15 /* MultiScheme: - Scheduler for touched futures. */ +/* #define UNUSED 0x15 */ #define Termination_Vector 0x16 /* Names for terminations. */ #define Termination_Proc_Vector 0x17 /* Handlers for terminations. */ -#define Me_Myself 0x18 /* MultiScheme: - The shared fixed objects vector. */ -#define The_Work_Queue 0x19 /* MultiScheme: - Where work is stored. */ -#define Future_Logger 0x1A /* MultiScheme: When logging futures, - routine to log touched futures. */ -#define Touched_Futures 0x1B /* MultiScheme: When logging futures, - vector of touched futures. */ +/* #define UNUSED 0x18 */ +/* #define UNUSED 0x19 */ +/* #define UNUSED 0x1A */ +/* #define UNUSED 0x1B */ #define Precious_Objects 0x1C /* Objects that should not be lost! */ #define Error_Procedure 0x1D /* User invoked error handler. */ -#define Unsnapped_Link 0x1E /* UNUSED in CScheme. */ -#define Utilities_Vector 0x1F /* UNUSED in CScheme. */ -#define Compiler_Err_Procedure 0x20 /* User invoked error handler - from compiled code. */ +/* #define UNUSED 0x1E */ +/* #define UNUSED 0x1F */ +#define CC_ERROR_PROCEDURE 0x20 /* Error handler for compiled code. */ #define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */ #define State_Space_Root 0x22 /* Root of state space. */ #define Primitive_Profiling_Table 0x23 /* Table of profile counts for primitives. */ /* Trampolines for various generic arithmetic operations. - These facilitate upwards compatibility and simplify compilation. - */ + These facilitate upwards compatibility and simplify compilation. */ #define GENERIC_TRAMPOLINE_ZERO_P 0x24 #define GENERIC_TRAMPOLINE_POSITIVE_P 0x25 @@ -116,21 +109,18 @@ USA. #define PC_Sample_Prob_Comp_Table 0x3D /* Sure looked compiled ?! */ #define PC_Sample_UFO_Table 0x3E /* Invalid ENV at sample time */ -#define COMPILED_CODE_BKPT_HANDLER 0x3F /* Procedure to invoke when +#define CC_BKPT_PROCEDURE 0x3F /* Procedure to invoke when compiled code hits a - breakpoint. - */ - -#define GC_WABBIT_DESCRIPTOR 0x40 /* #F or a vector of 4 elements: - - A boolean flag - - A vector of objects to find - - A vector to fill with - references. - - A boolean flag = do you want - a vector of all obj heads - returned in this slot. If so, - slot 0 will be a boolean flag - indicating if there may be more. - */ - -#define NFixed_Objects 0x41 + breakpoint. */ +/* #F or a vector of 4 elements: + - A boolean flag + - A vector of objects to find + - A vector to fill with references + - A boolean flag = do you want a vector of all obj heads returned + in this slot. If so, slot 0 will be a boolean flag indicating if + there may be more. */ + +#define GC_WABBIT_DESCRIPTOR 0x40 + +/* 4 extra slots for expansion and debugging. */ +#define N_FIXED_OBJECTS 0x45 diff --git a/v7/src/microcode/flonum.c b/v7/src/microcode/flonum.c index 7bc45a6c7..d82ebe4ef 100644 --- a/v7/src/microcode/flonum.c +++ b/v7/src/microcode/flonum.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: flonum.c,v 9.47 2007/01/05 21:19:25 cph Exp $ +$Id: flonum.c,v 9.48 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -29,11 +29,10 @@ USA. #include "scheme.h" #include "prims.h" -#include "zones.h" #include double -DEFUN (arg_flonum, (arg_number), int arg_number) +arg_flonum (int arg_number) { SCHEME_OBJECT argument = (ARG_REF (arg_number)); if (! (FLONUM_P (argument))) @@ -45,7 +44,7 @@ DEFUN (arg_flonum, (arg_number), int arg_number) #define BOOLEAN_RESULT(x) PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (x)) SCHEME_OBJECT -DEFUN (double_to_flonum, (value), double value) +double_to_flonum (double value) { ALIGN_FLOAT (Free); Primitive_GC_If_Needed (FLONUM_SIZE + 1); @@ -61,7 +60,6 @@ DEFUN (double_to_flonum, (value), double value) #define FLONUM_BINARY_OPERATION(operator) \ { \ PRIMITIVE_HEADER (2); \ - Set_Time_Zone (Zone_Math); \ FLONUM_RESULT ((arg_flonum (1)) operator (arg_flonum (2))); \ } @@ -75,9 +73,8 @@ DEFINE_PRIMITIVE ("FLONUM-MULTIPLY", Prim_flonum_multiply, 2, 2, 0) DEFINE_PRIMITIVE ("FLONUM-DIVIDE", Prim_flonum_divide, 2, 2, 0) { PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); { - fast double denominator = (arg_flonum (2)); + double denominator = (arg_flonum (2)); if (denominator == 0) error_bad_range_arg (2); FLONUM_RESULT ((arg_flonum (1)) / denominator); @@ -87,16 +84,14 @@ DEFINE_PRIMITIVE ("FLONUM-DIVIDE", Prim_flonum_divide, 2, 2, 0) DEFINE_PRIMITIVE ("FLONUM-NEGATE", Prim_flonum_negate, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); FLONUM_RESULT (- (arg_flonum (1))); } DEFINE_PRIMITIVE ("FLONUM-ABS", Prim_flonum_abs, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); { - fast double x = (arg_flonum (1)); + double x = (arg_flonum (1)); FLONUM_RESULT ((x < 0) ? (-x) : x); } } @@ -104,7 +99,6 @@ DEFINE_PRIMITIVE ("FLONUM-ABS", Prim_flonum_abs, 1, 1, 0) #define FLONUM_BINARY_PREDICATE(operator) \ { \ PRIMITIVE_HEADER (2); \ - Set_Time_Zone (Zone_Math); \ BOOLEAN_RESULT ((arg_flonum (1)) operator (arg_flonum (2))); \ } @@ -118,7 +112,6 @@ DEFINE_PRIMITIVE ("FLONUM-GREATER?", Prim_flonum_greater_p, 2, 2, 0) #define FLONUM_UNARY_PREDICATE(operator) \ { \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ BOOLEAN_RESULT ((arg_flonum (1)) operator 0); \ } @@ -131,10 +124,8 @@ DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0) #define SIMPLE_TRANSCENDENTAL_FUNCTION(function) \ { \ - extern double EXFUN (function, (double)); \ double result; \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ errno = 0; \ result = (function (arg_flonum (1))); \ if (errno != 0) \ @@ -144,11 +135,9 @@ DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0) #define RESTRICTED_TRANSCENDENTAL_FUNCTION(function, restriction) \ { \ - extern double EXFUN (function, (double)); \ double x; \ double result; \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ x = (arg_flonum (1)); \ if (! (restriction)) \ error_bad_range_arg (1); \ @@ -178,11 +167,10 @@ DEFINE_PRIMITIVE ("FLONUM-ATAN", Prim_flonum_atan, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM-ATAN2", Prim_flonum_atan2, 2, 2, 0) { - extern double EXFUN (atan2, (double, double)); PRIMITIVE_HEADER (2); { - fast double y = (arg_flonum (1)); - fast double x = (arg_flonum (2)); + double y = (arg_flonum (1)); + double x = (arg_flonum (2)); if ((x == 0) && (y == 0)) error_bad_range_arg (2); FLONUM_RESULT (atan2 (y, x)); @@ -194,7 +182,6 @@ DEFINE_PRIMITIVE ("FLONUM-SQRT", Prim_flonum_sqrt, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM-EXPT", Prim_flonum_expt, 2, 2, 0) { - extern double EXFUN (pow, (double, double)); PRIMITIVE_HEADER (2); FLONUM_RESULT (pow ((arg_flonum (1)), (arg_flonum (2)))); } @@ -207,7 +194,6 @@ DEFINE_PRIMITIVE ("FLONUM?", Prim_flonum_p, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM-INTEGER?", Prim_flonum_integer_p, 1, 1, 0) { - extern Boolean EXFUN (flonum_integer_p, (SCHEME_OBJECT)); PRIMITIVE_HEADER (1); CHECK_ARG (1, FLONUM_P); PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (flonum_integer_p (ARG_REF (1)))); @@ -216,7 +202,6 @@ DEFINE_PRIMITIVE ("FLONUM-INTEGER?", Prim_flonum_integer_p, 1, 1, 0) #define FLONUM_CONVERSION(converter) \ { \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ CHECK_ARG (1, FLONUM_P); \ PRIMITIVE_RETURN (converter (ARG_REF (1))); \ } @@ -233,15 +218,13 @@ DEFINE_PRIMITIVE ("FLONUM-ROUND", Prim_flonum_round, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM-TRUNCATE->EXACT", Prim_flonum_truncate_to_exact, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, FLONUM_P); - PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1))); + PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1))); } #define FLONUM_EXACT_CONVERSION(converter) \ { \ PRIMITIVE_HEADER (1); \ - Set_Time_Zone (Zone_Math); \ CHECK_ARG (1, FLONUM_P); \ PRIMITIVE_RETURN (FLONUM_TO_INTEGER (converter (ARG_REF (1)))); \ } @@ -255,7 +238,6 @@ DEFINE_PRIMITIVE ("FLONUM-ROUND->EXACT", Prim_flonum_round_to_exact, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM-NORMALIZE", Prim_flonum_normalize, 1, 1, 0) { PRIMITIVE_HEADER (1); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, FLONUM_P); PRIMITIVE_RETURN (flonum_normalize (ARG_REF (1))); } @@ -263,7 +245,6 @@ DEFINE_PRIMITIVE ("FLONUM-NORMALIZE", Prim_flonum_normalize, 1, 1, 0) DEFINE_PRIMITIVE ("FLONUM-DENORMALIZE", Prim_flonum_denormalize, 2, 2, 0) { PRIMITIVE_HEADER (2); - Set_Time_Zone (Zone_Math); CHECK_ARG (1, FLONUM_P); CHECK_ARG (2, INTEGER_P); PRIMITIVE_RETURN (flonum_denormalize ((ARG_REF (1)), (ARG_REF (2)))); diff --git a/v7/src/microcode/foreign.c b/v7/src/microcode/foreign.c deleted file mode 100644 index f7b116aea..000000000 --- a/v7/src/microcode/foreign.c +++ /dev/null @@ -1,536 +0,0 @@ -/* -*-C-*- - -$Id: foreign.c,v 1.9 2007/01/12 03:45:55 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains the primitive support for the foreign function */ -/* interface. */ - -#include -#include -#include "scheme.h" -#include "prims.h" -#include "ux.h" -#include "osfs.h" -#include "foreign.h" - -static int initialization_done = 0; - -#define INITIALIZE_ONCE() \ -{ \ - if (!initialization_done) \ - initialize_once (); \ -} - -static void EXFUN (initialize_once, (void)); - -/* Allocation table stuff stolen from x11base.c */ - -PTR -DEFUN (foreign_malloc, (size), unsigned int size) -{ - PTR result = (UX_malloc (size)); - if (result == 0) - error_external_return (); - return (result); -} - -PTR -DEFUN (foreign_realloc, (ptr, size), PTR ptr AND unsigned int size) -{ - PTR result = (UX_realloc (ptr, size)); - if (result == 0) - error_external_return (); - return (result); -} - -struct allocation_table -{ - PTR * items; - int length; -}; - -static struct allocation_table foreign_object_table; -static struct allocation_table foreign_function_table; - -static void -DEFUN (allocation_table_initialize, (table), struct allocation_table * table) -{ - (table -> length) = 0; -} - -static unsigned int -DEFUN (allocate_table_index, (table, item), - struct allocation_table * table AND - PTR item) -{ - unsigned int length = (table -> length); - unsigned int new_length; - PTR * items = (table -> items); - PTR * new_items; - PTR * scan; - PTR * end; - if (length == 0) - { - new_length = 4; - new_items = (foreign_malloc ((sizeof (PTR)) * new_length)); - } - else - { - scan = items; - end = (scan + length); - while (scan < end) - if ((*scan++) == 0) - { - (*--scan) = item; - return (scan - items); - } - new_length = (length * 2); - new_items = (foreign_realloc (items, ((sizeof (PTR)) * new_length))); - } - scan = (new_items + length); - end = (new_items + new_length); - (*scan++) = item; - while (scan < end) - (*scan++) = 0; - (table -> items) = new_items; - (table -> length) = new_length; - return (length); -} - -static PTR -DEFUN (allocation_item_arg, (arg, table), - unsigned int arg AND - struct allocation_table * table) -{ - unsigned int index = (arg_index_integer (arg, (table -> length))); - PTR item = ((table -> items) [index]); - if (item == 0) - error_bad_range_arg (arg); - return (item); -} - -/* Helper functions */ -HANDLE -DEFUN (arg_handle, (arg_number), unsigned int arg_number) -{ - SCHEME_OBJECT arg; - - return (index_to_handle (arg_index_integer (arg_number, - foreign_object_table . length))); -} - -HANDLE -DEFUN (foreign_pointer_to_handle, (ptr), PTR ptr) -{ - unsigned int index; - HANDLE handle; - FOREIGN_OBJECT *ptr_object; - - INITIALIZE_ONCE (); - ptr_object = (FOREIGN_OBJECT *) foreign_malloc (sizeof (FOREIGN_OBJECT)); - ptr_object -> ptr = ptr; - ptr_object -> handle = handle; - index = allocate_table_index (&foreign_object_table, (PTR) ptr_object); - handle = index_to_handle (index); - ((FOREIGN_OBJECT *) ((foreign_object_table . items) [index])) -> handle = - handle; - return (handle_to_integer (handle)); -} - -PTR -DEFUN (handle_to_foreign_pointer, (handle), HANDLE handle) -{ - unsigned int index; - - index = handle_to_index (handle); - if (index >= foreign_object_table . length) { - error_external_return (); - } - return - (((FOREIGN_OBJECT *) ((foreign_object_table . items) [index])) -> ptr); -} - -int -DEFUN (find_foreign_function, (func_name), char *func_name) -{ - int i; - FOREIGN_FUNCTION *func_item; - - for (i=0; i < foreign_function_table . length; i++) { - func_item = (foreign_function_table . items) [i]; - if (func_item == 0) continue; - if (! strcmp (func_item -> name, func_name)) { - return (i); - } - } - return (-1); -} - -unsigned int -DEFUN (register_foreign_function, (name, applicable_function), - char * name AND - PTR applicable_function) -{ - FOREIGN_FUNCTION *func_item; - char * name_copy; - - INITIALIZE_ONCE (); - func_item = (FOREIGN_FUNCTION *) foreign_malloc (sizeof (FOREIGN_FUNCTION)); - name_copy = (char *) foreign_malloc (1 + strlen (name)); - strcpy (name_copy, name); - func_item -> name = name_copy; - func_item -> applicable_function = applicable_function; - return (allocate_table_index (&foreign_function_table, (PTR) func_item)); -} - -unsigned int -DEFUN (list_length, (list), SCHEME_OBJECT list) -{ - unsigned int i; - - i = 0; - TOUCH_IN_PRIMITIVE (list, list); - while (PAIR_P (list)) { - i += 1; - TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list); - } - return (i); -} - -PTR -DEFUN (apply_foreign_function, (func, arg_list), - PTR (*func)() AND - SCHEME_OBJECT arg_list) -{ - unsigned int arg_list_length; - PTR * arg_vec; - PTR result; - unsigned int i; - - arg_list_length = list_length (arg_list); - arg_vec = (PTR *) foreign_malloc (arg_list_length); - for (i = 0; i < arg_list_length; i++, arg_list = PAIR_CDR (arg_list)) { - arg_vec [i] = handle_to_foreign_pointer (PAIR_CAR (arg_list)); - } - result = (*func) (arg_vec); - free (arg_vec); - return (result); -} - -SCHEME_OBJECT -DEFUN (foreign_pointer_to_scheme_object, (ptr, type_translator), - PTR ptr AND - SCHEME_OBJECT (*type_translator) ()) -{ - return (type_translator (ptr)); -} - -/* old version of foreign_pointer_to_scheme_object */ -#if 0 -/* Note that foreign_pointer_to_scheme_object takes a pointer to pointer - (i.e. a call by reference to a pointer) so that it can increment the - pointer according to its type. This is used by the code which builds - the composite objects. */ - -SCHEME_OBJECT -DEFUN (foreign_pointer_to_scheme_object, (ptr_to_ptr, type), - PTR ptr_to_ptr AND - SCHEME_OBJECT type) -{ - long type_enum; - - if (foreign_primtive_type_p (type)) { - long long_val; - double double_val; - PTR temp_ptr; - type_enum = integer_to_long (type); - switch (type_enum) { - case FOREIGN_INT: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_INT); - *ptr_to_ptr = (((int *) temp_ptr) + 1); - long_val = (long) ((int) *temp_ptr); - case FOREIGN_SHORT: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_SHORT); - *ptr_to_ptr = (((short *) temp_ptr) + 1); - long_val = (long) ((short) *temp_ptr); - case FOREIGN_LONG: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_INT); - *ptr_to_ptr = (((long *) temp_ptr) + 1); - long_val = (long) *temp_ptr; - return (long_to_integer (long_val)); - case FOREIGN_CHAR: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_CHAR); - *ptr_to_ptr = (((char *) temp_ptr) + 1); - return (ASCII_TO_CHAR ((char) *temp_ptr)); - case FOREIGN_FLOAT: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_FLOAT); - *ptr_to_ptr = (((float *) temp_ptr) + 1); - double_val = (double) ((float) *temp_ptr); - case FOREIGN_DOUBLE: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_DOUBLE); - *ptr_to_ptr = (((double *) temp_ptr) + 1); - double_val = (double) *temp_ptr; - return (double_to_flonum (double_val)); - case FOREIGN_STRING: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_STRING); - *ptr_to_ptr = (((unsigned char *) temp_ptr) + 1); - return (char_pointer_to_string (temp_ptr)); - case FOREIGN_PTR: - temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_PTR); - *ptr_to_ptr = (((PTR) temp_ptr) + 1); - return (long_to_integer ((long) *temp_ptr)); - default: - error_external_return (); - } - } else if (foreign_composite_type_p (type)) { - /* We should probably tag the result vector. */ - type_enum = integer_to_long (which_composite_type (type)); - switch (type_enum) { - case FOREIGN_STRUCT: - case FOREIGN_UNION: - { - int num_fields; - SCHEME_OBJECT field_types; - SCHEME_OBJECT result_vector; - unsigned int i; - - field_types = composite_type_field_types (type); - num_fields = list_length (field_types); - result_vector = allocate_marked_vector (TC_VECTOR, num_fields, true); - for (i = 0; i < num_fields; ++i) { - if (!(PAIR_P (field_types))) { - error_external_return (); - } - FAST_VECTOR_SET (result_vector, - i, - foreign_pointer_to_scheme_object ( - ptr_to_ptr, PAIR_CAR (field_types))); - TOUCH_IN_PRIMITIVE ((PAIR_CDR (field_types)), field_types); - } - return (result_vector); - } - default: - error_external_return (); - } - } else { - error_external_return (); - } -} -#endif /* if 0 */ - -static void -DEFUN_VOID (initialize_once) -{ - allocation_table_initialize (&foreign_object_table); - allocation_table_initialize (&foreign_function_table); - - initialization_done = 1; -} - -/* Functions to go in osxx.c */ - -#include - -char * -DEFUN_VOID (OS_create_temporary_file_name) -{ - char * name_string; - - name_string = (char *) foreign_malloc (1 + TEMP_FILE_NAME_MAX_LEN); - (void) UX_tmpnam (name_string); - return (name_string); -} - -#ifdef HAVE_DYNAMIC_LOADING -#ifdef __HPUX__ -#include - -LOAD_INFO * -DEFUN (OS_load_object_file, (load_file_name), char * load_file_name) -{ - shl_t shl_handle; - int result; - struct shl_descriptor *shl_desc; - LOAD_INFO *info; - - shl_handle = shl_load (load_file_name, BIND_DEFERRED, 0L); - - if (shl_handle == NULL) { - error_external_return (); - } - - result = shl_gethandle (shl_handle, &shl_desc); - - if (result == -1) { - error_external_return (); - } - - info = foreign_malloc (sizeof (LOAD_INFO)); - info -> load_module_descriptor = shl_handle; - info -> program_start = shl_desc -> tstart; - info -> program_end = shl_desc -> tend; - info -> data_start = shl_desc -> dstart; - info -> data_end = shl_desc -> dend; - return (info); -} - -PTR -DEFUN (OS_find_function, (load_info, func_name), - LOAD_INFO * load_info AND - char * func_name) -{ - int return_code; - PTR (* test_proc)(); - LOAD_DESCRIPTOR desc; - - desc = (load_info -> load_module_descriptor); - return_code = shl_findsym (&desc , - func_name, - TYPE_PROCEDURE, - (long *) &test_proc); - - return ((return_code == 0) ? - test_proc : - NULL); -} - -#endif /* __HPUX__ */ -#endif /* HAVE_DYNAMIC_LOADING */ - -/* Definitions of primitives */ - -DEFINE_PRIMITIVE ("CALL-FOREIGN-FUNCTION", - Prim_call_foreign_function, 2, 2, -"Calls the foreign function referenced by HANDLE with the ARG-LIST \n\ -arguments. \n\ -Returns a handle to the return value; \n\ -The foreign function should have been created by \n\ -CREATE_PRIMITIVE_FOREIGN_FUNCTION. \n\ -The elements of the ARG-LIST must be handles to foreign objects. \n\ -Type and arity checking on the arguments should already have been done.") -{ - PRIMITIVE_HEADER (2); - { - SCHEME_OBJECT arg_list; - PTR result; - - CHECK_ARG (2, APPARENT_LIST_P); - arg_list = ARG_REF (2); - result = apply_foreign_function (handle_to_foreign_pointer - (arg_handle (1)), arg_list); - PRIMITIVE_RETURN (foreign_pointer_to_handle (result)); - } -} - -DEFINE_PRIMITIVE ("&CALL-FOREIGN-FUNCTION-RETURNING-SCHEME-OBJECT", - Prim_call_foreign_function_returning_scheme_object, 2, 2, -"Calls the foreign function referenced by HANDLE with the ARG-LIST \n\ -arguments. \n\ -Returns the result of the foreign function (which better be a scheme \n\ -object. \n\ -The foreign function should have been created by \n\ -CREATE_PRIMITIVE_FOREIGN_FUNCTION. \n\ -The elements of the ARG-LIST must be handles to foreign objects. \n\ -Type and arity checking on the arguments should already have been done.") -{ - PRIMITIVE_HEADER (2); - { - SCHEME_OBJECT arg_list; - PTR result; - - CHECK_ARG (2, APPARENT_LIST_P); - arg_list = ARG_REF (2); - result = apply_foreign_function (handle_to_foreign_pointer - (arg_handle (1)), arg_list); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("FOREIGN-HANDLE-TO-SCHEME-OBJECT", - Prim_foreign_handle_to_scheme_object, 2, 2, -"Returns the Scheme object corresponding to the foreign HANDLE \n\ -interpreted as the foreign type TYPE. \n\ -A type is either an integer which enumerates the various foreign types \n\ -(i.e. FOREIGN_INT, FOREIGN_CHAR, FOREIGN_SHORT, FOREIGN_LONG, \n\ -(FOREIGN_PTR, FOREIGN_DOUBLE, FOREIGN_STRING) or a list whose car is \n\ -an integer representing FOREIGN_STRUCT or FOREIGN_UNION and whose cdr \n\ -is a list of types.") -{ - PRIMITIVE_HEADER (2); - { - SCHEME_OBJECT arg2; - PTR arg1_ptr; - - arg1_ptr = handle_to_foreign_pointer (arg_handle (1)); - arg2 = ARG_REF (2); - if (! (INTEGER_P (arg2) || PAIR_P (arg2))) { - error_wrong_type_arg (2); - } - PRIMITIVE_RETURN (foreign_pointer_to_scheme_object (&arg1_ptr, arg2)); - } -} - -DEFINE_PRIMITIVE (LOAD-FOREIGN-FILE, Prim_load_foreign_file, 1, 1, -"Load the foreign object file FILENAME. \n\ -Returns a handle to a LOAD_INFO data structure.") -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (foreign_pointer_to_handle - (OS_load_object_file (STRING_ARG (1)))); -} - -DEFINE_PRIMITIVE (CREATE-TEMPORARY-FILE-NAME, Prim_get_temporary_file_name, - 0, 0, -"Return a temporary file name.") -{ - PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN (char_pointer_to_string (OS_create_temporary_file_name ())); -} - -DEFINE_PRIMITIVE (FIND-FOREIGN-FUNCTION, Prim_find_foreign_function, 2, 2, -"Returns a handle to a foreign function. \n\ -Takes the FUNCTION_NAME as a string and LOAD_INFO \n\ -which is a handle to a load_info structure returned by LOAD-FOREIGN-FILE. \n\ -If LOAD_INFO is not #F then we search for FUNCTION_NAME in the code which \n\ -was loaded to yield LOAD_INFO. \n\ -If LOAD_INFO is #F then we search over all the dynamically loaded files.") -{ - PRIMITIVE_HEADER (2); - { - PTR func_ptr; - LOAD_INFO * load_info; - - load_info = ((EMPTY_LIST_P (ARG_REF (2))) ? - ((LOAD_INFO *) NULL) : - ((LOAD_INFO *) handle_to_foreign_pointer (arg_handle (2)))); - - func_ptr = OS_find_function (load_info, STRING_ARG (1)); - - PRIMITIVE_RETURN ((func_ptr == NULL) ? - SHARP_F : - foreign_pointer_to_handle (func_ptr)); - } -} diff --git a/v7/src/microcode/foreign.h b/v7/src/microcode/foreign.h deleted file mode 100644 index a2ac3991e..000000000 --- a/v7/src/microcode/foreign.h +++ /dev/null @@ -1,213 +0,0 @@ -/* -*-C-*- - -$Id: foreign.h,v 1.7 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains the primitive support for the foreign function */ -/* interface. */ - -struct foreign_function { - char * name; - PTR applicable_function; -}; - -typedef unsigned int HANDLE; - -typedef struct foreign_function FOREIGN_FUNCTION; - -struct foreign_object { - PTR ptr; - HANDLE handle; -}; - -typedef struct foreign_object FOREIGN_OBJECT; - -#ifdef __HPUX__ -typedef shl_t LOAD_DESCRIPTOR; -typedef unsigned long LOAD_ADDRESS; -#endif - -struct load_info { - LOAD_DESCRIPTOR load_module_descriptor; - LOAD_ADDRESS program_start; - LOAD_ADDRESS program_end; - LOAD_ADDRESS data_start; - LOAD_ADDRESS data_end; -}; - -typedef struct load_info LOAD_INFO; - -#define index_to_handle(index) ((HANDLE) index) -#define handle_to_index(handle) ((unsigned int) handle) -#define handle_to_integer(handle) (long_to_integer ((unsigned long) handle)) -#define foreign_primtive_type_p(object) (FIXNUM_P (object)) -#define foreign_composite_type_p(object) (PAIR_P (object)) -#define which_composite_type(type) (PAIR_CAR (type)) -#define composite_type_field_types(type) (PAIR_CDR (type)) - -/* the following define should be in some other .h file */ -#define TEMP_FILE_NAME_MAX_LEN L_tmpnam /* in stdio.h */ - -/* The following should be ifdef'ed up the wazoo for different machines */ -#define DYNAMIC_COMPILE_SWITCHES "+z" - -/* These need to match the appropriate enumerations in foreign.scm */ -#define FOREIGN_FIRST_TYPE 0 -#define FOREIGN_INT 0 -#define FOREIGN_SHORT 1 -#define FOREIGN_LONG 2 -#define FOREIGN_CHAR 3 -#define FOREIGN_FLOAT 4 -#define FOREIGN_DOUBLE 5 -#define FOREIGN_STRING 6 -#define FOREIGN_PTR 7 -#define FOREIGN_STRUCT 8 -#define FOREIGN_UNION 9 -#define FOREIGN_LAST_TYPE 9 - -/* This is a bunch of stuff to figure out the alignment of fields in - structures */ - -/* This defines a union which is guaranteed to have the most restrictive - possible alignment constraint */ -union greatest_alignment { - int my_int; - short my_short; - long my_long; - char my_char; - float my_float; - double my_double; - char * my_string; - void * my_ptr; -} - -/* We hope that char's are the smallest sized objects */ -typedef char smallest_size; - -struct int_field { - union greatest_alignment foo; - smallest_size bar; - int int_item; -} -#define INT_ALIGNMENT_MASK \ - ((long) ((sizeof (int_field) - sizeof (int)) - 1)) - -struct short_field { - union greatest_alignment foo; - smallest_size bar; - short short_item; -} -#define SHORT_ALIGNMENT_MASK \ - ((long) ((sizeof (short_field) - sizeof (short)) - 1)) - -struct long_field { - union greatest_alignment foo; - smallest_size bar; - long long_item; -} -#define LONG_ALIGNMENT_MASK \ - ((long) ((sizeof (long_field) - sizeof (long)) - 1)) - -struct char_field { - union greatest_alignment foo; - smallest_size bar; - char char_item; -} -#define CHAR_ALIGNMENT_MASK \ - ((long) ((sizeof (char_field) - sizeof (char)) - 1)) - -struct float_field { - union greatest_alignment foo; - smallest_size bar; - float float_item; -} -#define FLOAT_ALIGNMENT_MASK \ - ((long) ((sizeof (float_field) - sizeof (float)) - 1)) - -struct double_field { - union greatest_alignment foo; - smallest_size bar; - double double_item; -} -#define DOUBLE_ALIGNMENT_MASK \ - ((long) ((sizeof (double_field) - sizeof (double)) - 1)) - -struct string_field { - union greatest_alignment foo; - smallest_size bar; - char * string_item; -} -#define STRING_ALIGNMENT_MASK \ - ((long) ((sizeof (string_field) - sizeof (char *)) - 1)) - -struct ptr_field { - union greatest_alignment foo; - smallest_size bar; - PTR ptr_item; -} -#define PTR_ALIGNMENT_MASK \ - ((long) ((sizeof (ptr_field) - sizeof (PTR)) - 1)) - -struct struct_field { - union greatest_alignment foo; - smallest_size bar; - struct greatest_alignment2 struct_item; -} - -#define ALIGN_FOREIGN_POINTER(ptr,type) \ -# if (type == FOREIGN_INT) \ - (((int *) (ptr & INT_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_SHORT) \ - (((short *) (ptr & SHORT_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_LONG) \ - (((long *) (ptr & LONG_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_CHAR) \ - (((char *) (ptr & CHAR_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_FLOAT) \ - (((float *) (ptr & FLOAT_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_DOUBLE) \ - (((double *) (ptr & DOUBLE_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_STRING) \ - (((unsigned char *) (ptr & STRING_ALIGNMENT_MASK)) + 1) \ -# else \ -# if (type == FOREIGN_PTR) \ - (((PTR) (ptr & PTR_ALIGNMENT_MASK)) + 1) \ -# endif \ -# endif \ -# endif \ -# endif \ -# endif \ -# endif \ -# endif \ -# endif - - -/* End of alignment junk */ diff --git a/v7/src/microcode/future.c b/v7/src/microcode/future.c deleted file mode 100644 index b144943d4..000000000 --- a/v7/src/microcode/future.c +++ /dev/null @@ -1,392 +0,0 @@ -/* -*-C-*- - -$Id: future.c,v 9.33 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Support code for futures */ - -#include "scheme.h" -#include "prims.h" -#include "locks.h" - -#ifndef COMPILE_FUTURES -#include "Error: future.c is useless without COMPILE_FUTURES" -#endif - -/* This is how we support future numbering for external metering */ -#ifndef New_Future_Number -#define New_Future_Number() SHARP_F -#else -SCHEME_OBJECT Get_New_Future_Number (); -#endif - -/* - -A future is a VECTOR starting with , and -, - -where is #!false if no value is known yet, - #!true if value is known and future can vanish at GC, - otherwise value is known, but keep the slot - -and where is #!true if someone wants slot kept for a time. - -*/ - -DEFINE_PRIMITIVE ("TOUCH", Prim_touch, 1, 1, 0) -{ - SCHEME_OBJECT result; - PRIMITIVE_HEADER (1); - TOUCH_IN_PRIMITIVE ((ARG_REF (1)), result); - PRIMITIVE_RETURN (result); -} - -DEFINE_PRIMITIVE ("FUTURE?", Prim_future_p, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FUTURE_P (ARG_REF (1)))); -} - -/* Utility setting routine for use by the various test and set if - equal operators. -*/ - -long -Set_If_Equal(Base, Offset, New, Wanted) - SCHEME_OBJECT Base, Wanted, New; - long Offset; -{ - Lock_Handle lock; - SCHEME_OBJECT Old_Value, Desired, Remember_Value; - long success; - - TOUCH_IN_PRIMITIVE(Wanted, Desired); -Try_Again: - Remember_Value = MEMORY_REF (Base, Offset); - TOUCH_IN_PRIMITIVE(Remember_Value, Old_Value); - lock = Lock_Cell(MEMORY_LOC (Base, Offset)); - if (Remember_Value != FAST_MEMORY_REF (Base, Offset)) - { - Unlock_Cell(lock); - goto Try_Again; - } - if (Old_Value == Desired) - { - Do_Store_No_Lock(MEMORY_LOC (Base, Offset), New); - success = true; - } - else - { - success = false; - } - Unlock_Cell(lock); - return success; -} - -DEFINE_PRIMITIVE ("SET-CAR-IF-EQ?!", Prim_set_car_if_eq, 3, 3, - "Replace the car of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\ -Return PAIR if so, otherwise return '().") -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (1, PAIR_P); - { - fast SCHEME_OBJECT pair = (ARG_REF (1)); - if (Set_If_Equal (pair, CONS_CAR, (ARG_REF (2)), (ARG_REF (3)))) - PRIMITIVE_RETURN (pair); - } - PRIMITIVE_RETURN (EMPTY_LIST); -} - -DEFINE_PRIMITIVE ("SET-CDR-IF-EQ?!", Prim_set_cdr_if_eq, 3, 3, - "Replace the cdr of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\ -Return PAIR if so, otherwise return '().") -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (1, PAIR_P); - { - fast SCHEME_OBJECT pair = (ARG_REF (1)); - if (Set_If_Equal (pair, CONS_CDR, (ARG_REF (2)), (ARG_REF (3)))) - PRIMITIVE_RETURN (pair); - } - PRIMITIVE_RETURN (EMPTY_LIST); -} - -/* (VECTOR-SET-IF-EQ?! ) - Replaces the th element of with if it used - to contain . The value returned is either (if - the modification takes place) or '() if it does not. -*/ -DEFINE_PRIMITIVE ("VECTOR-SET-IF-EQ?!", Prim_vector_set_if_eq, 4, 4, - "Replace VECTOR's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\ -Return VECTOR if so, otherwise return '().") -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (1, VECTOR_P); - { - fast SCHEME_OBJECT vector = (ARG_REF (1)); - if (Set_If_Equal - (vector, - ((arg_index_integer (2, (VECTOR_LENGTH (vector)))) + 1), - (ARG_REF (3)), - (ARG_REF (4)))) - PRIMITIVE_RETURN (vector); - } - PRIMITIVE_RETURN (EMPTY_LIST); -} - -DEFINE_PRIMITIVE ("SET-CXR-IF-EQ?!", Prim_set_cxr_if_eq, 4, 4, - "Replace HUNK3's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\ -Return HUNK3 if so, otherwise return '().") -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (1, HUNK3_P); - { - fast SCHEME_OBJECT hunk3 = (ARG_REF (1)); - if (Set_If_Equal - (hunk3, - ((arg_index_integer (2, 3)) + 1), - (ARG_REF (3)), - (ARG_REF (4)))) - PRIMITIVE_RETURN (hunk3); - } - PRIMITIVE_RETURN (EMPTY_LIST); -} - -DEFINE_PRIMITIVE ("FUTURE-SIZE", Prim_future_size, 1, 1, - "Return the number of elements in FUTURE.\n\ -This is similar to SYSTEM-VECTOR-SIZE,\n\ -but works only on futures and doesn't touch them.") -{ - PRIMITIVE_HEADER (1) - CHECK_ARG (1, FUTURE_P); - PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (VECTOR_LENGTH (ARG_REF (1)))); -} - -DEFINE_PRIMITIVE ("FUTURE-REF", Prim_future_ref, 2, 2, - "Return FUTURE's INDEX'th element.\n\ -This is similar to SYSTEM-VECTOR-REF,\n\ -but works only on futures and doesn't touch them.") -{ - PRIMITIVE_HEADER (2); - CHECK_ARG (1, FUTURE_P); - { - fast SCHEME_OBJECT future = (ARG_REF (1)); - PRIMITIVE_RETURN - (VECTOR_REF - (future, (arg_index_integer (2, (VECTOR_LENGTH (future)))))); - } -} - -DEFINE_PRIMITIVE ("FUTURE-SET!", Prim_future_set, 3, 3, - "Modify FUTURE's INDEX'th element to be VALUE.\n\ -This is similar to SYSTEM-VECTOR-SET!,\n\ -but works only on futures and doesn't touch them.") -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (1, FUTURE_P); - { - fast SCHEME_OBJECT future = (ARG_REF (1)); - fast long index = (arg_index_integer (2, (VECTOR_LENGTH (future)))); - fast SCHEME_OBJECT result = (VECTOR_REF (future, index)); - VECTOR_SET (future, index, (ARG_REF (3))); - PRIMITIVE_RETURN (result); - } -} - -DEFINE_PRIMITIVE ("LOCK-FUTURE!", Prim_lock_future, 1, 1, - "Set the lock flag on FUTURE.\n\ -This flag prevents FUTURE from being spliced out by the garbage collector.\n\ -If FUTURE is not a future, return #F immediately,\n\ -otherwise return #T after the lock has been set.\n\ -Will wait as long as necessary for the lock to be set.") -{ - PRIMITIVE_HEADER (1); - { - fast SCHEME_OBJECT future = (ARG_REF (1)); - if (! (FUTURE_P (future))) - PRIMITIVE_RETURN (SHARP_F); - while (1) - { - if (INTERRUPT_PENDING_P (INT_Mask)) - signal_interrupt_from_primitive (); - { - fast SCHEME_OBJECT lock; - SWAP_POINTERS ((MEMORY_LOC (future, FUTURE_LOCK)), SHARP_T, lock); - if (lock == SHARP_F) - PRIMITIVE_RETURN (SHARP_T); - } - Sleep (CONTENTION_DELAY); - } - } -} - -DEFINE_PRIMITIVE ("UNLOCK-FUTURE!", Prim_unlock_future, 1, 1, - "Clear the lock flag on FUTURE.\n\ -If FUTURE is not a future, return #F immediately,\n\ -otherwise return #T after the lock has been cleared.") -{ - PRIMITIVE_HEADER (1); - { - fast SCHEME_OBJECT future = (ARG_REF (1)); - if (! (FUTURE_P (future))) - PRIMITIVE_RETURN (SHARP_F); - if (! (Future_Is_Locked (future))) - error_wrong_type_arg (1); - MEMORY_SET (future, FUTURE_LOCK, SHARP_F); - PRIMITIVE_RETURN (SHARP_T); - } -} - -DEFINE_PRIMITIVE ("FUTURE->VECTOR", Prim_future_to_vector, 1, 1, - "Return a newly-allocated vector containing FUTURE's elements. -If FUTURE is not a future, return #F instead.") -{ - PRIMITIVE_HEADER (1); - { - SCHEME_OBJECT future = (ARG_REF (1)); - if (! (FUTURE_P (future))) - PRIMITIVE_RETURN (SHARP_F); - { - long length = (VECTOR_LENGTH (future)); - fast SCHEME_OBJECT * scan_source = (MEMORY_LOC (future, 1)); - fast SCHEME_OBJECT * end_source = (scan_source + length); - SCHEME_OBJECT result = - (allocate_marked_vector (TC_VECTOR, length, true)); - fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1)); - while (scan_source < end_source) - (*scan_result++) = (MEMORY_FETCH (*scan_source++)); - PRIMITIVE_RETURN (result); - } - } -} - -DEFINE_PRIMITIVE ("NON-TOUCHING-EQ?", Prim_future_eq, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == (ARG_REF (2)))); -} - -/* MAKE-INITIAL-PROCESS is called to create a small stacklet which - * will just call the specified thunk and then end the computation - */ - -DEFINE_PRIMITIVE ("MAKE-INITIAL-PROCESS", Prim_make_initial_process, 1, 1, 0) -{ - SCHEME_OBJECT Result; - long Useful_Length; - PRIMITIVE_HEADER (1); - - Result = MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Free); - Useful_Length = (3 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1; - -#ifdef USE_STACKLETS - - { - long Allocated_Length, Waste_Length; - - Allocated_Length = (Useful_Length + STACKLET_SLACK + STACKLET_HEADER_SIZE); - if (Allocated_Length < Default_Stacklet_Size) - { - Allocated_Length = Default_Stacklet_Size; - Waste_Length = ((Allocated_Length + 1) - - (Useful_Length + STACKLET_HEADER_SIZE)); - } - else - { - Waste_Length = (STACKLET_SLACK + 1); - } - Primitive_GC_If_Needed(Allocated_Length + 1); - Free[STACKLET_LENGTH] = - MAKE_POINTER_OBJECT (TC_MANIFEST_VECTOR, Allocated_Length); - Free[STACKLET_REUSE_FLAG] = SHARP_T; - Free[STACKLET_UNUSED_LENGTH] = - MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Waste_Length); - Free += (Allocated_Length + 1) - Useful_Length; - } - -#else /* not USE_STACKLETS */ - - Free[STACKLET_LENGTH] = - MAKE_OBJECT (TC_MANIFEST_VECTOR, Useful_Length + STACKLET_HEADER_SIZE - 1); - Free[STACKLET_REUSE_FLAG] = SHARP_F; - Free[STACKLET_UNUSED_LENGTH] = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0); - Free += STACKLET_HEADER_SIZE; - -#endif /* USE_STACKLETS */ - - Free[CONTINUATION_EXPRESSION] = LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()); - Free[CONTINUATION_RETURN_CODE] = - MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_INT_MASK); - Free += CONTINUATION_SIZE; - Free[CONTINUATION_EXPRESSION] = SHARP_F; - Free[CONTINUATION_RETURN_CODE] = - MAKE_OBJECT (TC_RETURN_CODE, RC_INTERNAL_APPLY); - Free += CONTINUATION_SIZE; - *Free++ = STACK_FRAME_HEADER; - *Free++ = (ARG_REF (1)); - Free[CONTINUATION_EXPRESSION] = (ARG_REF (1)); /* For testing & debugging */ - Free[CONTINUATION_RETURN_CODE] = - MAKE_OBJECT (TC_RETURN_CODE, RC_END_OF_COMPUTATION); - Free += CONTINUATION_SIZE; - PRIMITIVE_RETURN (Result); -} - -/* - Absolutely the cheapest future we can make. This includes - the I/O stuff and whatnot. Notice that the name is required. - - (make-cheap-future orig-code user-proc name) - -*/ - -DEFINE_PRIMITIVE ("MAKE-CHEAP-FUTURE", Prim_make_cheap_future, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - fast SCHEME_OBJECT future = (allocate_marked_vector (TC_FUTURE, 10, true)); - FAST_MEMORY_SET (future, FUTURE_IS_DETERMINED, SHARP_F); - FAST_MEMORY_SET (future, FUTURE_LOCK, SHARP_F); - FAST_MEMORY_SET (future, FUTURE_QUEUE, (cons (EMPTY_LIST, EMPTY_LIST))); - FAST_MEMORY_SET (future, FUTURE_PROCESS, (ARG_REF (1))); - FAST_MEMORY_SET (future, FUTURE_STATUS, SHARP_T); - FAST_MEMORY_SET (future, FUTURE_ORIG_CODE, (ARG_REF (2))); - /* Put the I/O system stuff here. */ - FAST_MEMORY_SET - (future, - FUTURE_PRIVATE, - (make_vector - (1, - (hunk3_cons - (SHARP_F, - (ARG_REF (3)), - (cons ((LONG_TO_UNSIGNED_FIXNUM (0)), - (char_pointer_to_string ("")))))), - true))); - FAST_MEMORY_SET (future, FUTURE_WAITING_ON, EMPTY_LIST); - FAST_MEMORY_SET (future, FUTURE_METERING, (New_Future_Number ())); - FAST_MEMORY_SET (future, FUTURE_USER, SHARP_F); - PRIMITIVE_RETURN (future); - } -} diff --git a/v7/src/microcode/futures.h b/v7/src/microcode/futures.h deleted file mode 100644 index a79040779..000000000 --- a/v7/src/microcode/futures.h +++ /dev/null @@ -1,219 +0,0 @@ -/* -*-C-*- - -$Id: futures.h,v 9.34 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains macros useful for dealing with futures */ - -/* NOTES ON FUTURES, derived from the rest of the interpreter code - - ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive - combinations unless the primitive itself is output in the code stream. - Therefore, we don't have to explicitly check here that the expression - register has a primitive in it. - - ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor - do the cached lexical address slots. - - ASSUMPTION: Environment structure, which is created only by the - interpreter, never contains FUTUREs on its spine. - - ASSUMPTION: History objects are never created using futures. - - ASSUMPTION: State points, which are created only by the interpreter, - never contain FUTUREs except possibly as the thunks (which are handled - by the apply code). - - OPTIMIZATIONS (?): - After a lot of discussion, we decided that variable reference will check - whether a value stored in the environment is a determined future which - is marked spliceable. If so, it will splice out the future from the - environment slot to speed up subsequent references. - - EQ? does a normal identity check and only if this fails does it touch the - arguments. The same thing does not speed up MEMQ or ASSQ in the normal - case, so it is omitted there. - - The following are NOT done, but might be useful later - (1) Splicing on SET! operations - (2) Splicing at apply and/or primitive apply - (3) Splicing all arguments when a primitive errors on any of them - (4) Splicing within the Arg_n_Type macro rather than after longjmping - to the error handler. - - KNOWN PROBLEMS: - (1) Garbage collector should be modified to splice out futures. DONE. - - (2) Purify should be looked at and we should decide what to do about - purifying an object with a reference to a future (it should probably - become constant but not pure). - - (3) Look at Impurify and Side-Effect-Impurify to see if futures - affect them in any way. */ - -/* Data structure definition */ - -/* The IS_DETERMINED slot has one of the following type of values: - #F if the value is not yet known; - #T if the value is known and the garbage collector is free - to remove the future object in favor of its value everywhere; - else the value is known, but the GC must leave the future object. */ - -#define FUTURE_VECTOR_HEADER 0 -#define FUTURE_IS_DETERMINED 1 -#define FUTURE_LOCK 2 -#define FUTURE_VALUE 3 /* if known, else */ -#define FUTURE_QUEUE 3 /* tasks waiting for value */ -#define FUTURE_PROCESS 4 -#define FUTURE_STATUS 5 -#define FUTURE_ORIG_CODE 6 -#define FUTURE_PRIVATE 7 -#define FUTURE_WAITING_ON 8 -#define FUTURE_METERING 9 -#define FUTURE_USER 10 - -#define Future_Is_Locked(P) \ - ((MEMORY_REF ((P), FUTURE_LOCK)) != SHARP_F) - -#define Future_Has_Value(P) \ - ((MEMORY_REF ((P), FUTURE_IS_DETERMINED)) != SHARP_F) - -#define Future_Value(P) \ - (MEMORY_REF ((P), FUTURE_VALUE)) - -#define Future_Spliceable(P) \ - (((MEMORY_REF ((P), FUTURE_IS_DETERMINED)) == SHARP_T) && \ - ((MEMORY_REF ((P), FUTURE_LOCK)) == SHARP_F)) - -#define Future_Is_Keep_Slot(P) \ - (! (BOOLEAN_P (MEMORY_REF ((P), FUTURE_IS_DETERMINED)))) - -#ifndef COMPILE_FUTURES - -#define TOUCH_IN_PRIMITIVE(P, To_Where) To_Where = (P) -#define TOUCH_SETUP(object) Microcode_Termination (TERM_TOUCH) -#define Log_Touch_Of_Future(F) {} -#define Call_Future_Logging() -#define Must_Report_References() (false) -#define FUTURE_VARIABLE_SPLICE(P, Offset, Value) - -#else /* COMPILE_FUTURES */ - -/* TOUCH_IN_PRIMITIVE is used by primitives which are not - strict in an argument but which touch it none the less. */ - -#define TOUCH_IN_PRIMITIVE(P, To_Where) \ -{ \ - SCHEME_OBJECT Value = (P); \ - while (FUTURE_P (Value)) \ - { \ - if (Future_Has_Value (Value)) \ - { \ - if (Future_Is_Keep_Slot (Value)) \ - { \ - Log_Touch_Of_Future (Value); \ - } \ - Value = (Future_Value (Value)); \ - } \ - else \ - { \ - val_register = Value; \ - PRIMITIVE_ABORT (PRIM_TOUCH); \ - } \ - } \ - (To_Where) = Value; \ -} - -#define TOUCH_SETUP(object) \ -{ \ - Save_Cont (); \ - Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \ - STACK_PUSH (object); \ - STACK_PUSH (Get_Fixed_Obj_Slot (System_Scheduler)); \ - STACK_PUSH (STACK_FRAME_HEADER + 1); \ - Pushed (); \ -} - -#define FUTURE_VARIABLE_SPLICE(P, Offset, Value) \ -{ \ - while ((FUTURE_P (Value)) && (Future_Spliceable (Value))) \ - { \ - Value = (Future_Value (Value)); \ - MEMORY_SET (P, Offset, Value); \ - } \ -} - -#ifdef FUTURE_LOGGING - -#define Touched_Futures_Vector() (Get_Fixed_Obj_Slot (Touched_Futures)) - -#define Logging_On() \ - ((Valid_Fixed_Obj_Vector ()) && (Touched_Futures_Vector ())) - -/* Log_Touch_Of_Future adds the future which was touched to the vector - of touched futures about which the scheme portion of the system has - not yet been informed. */ - -#define Log_Touch_Of_Future(F) \ -{ \ - if (Logging_On ()) \ - { \ - SCHEME_OBJECT TFV = (Touched_Futures_Vector ()); \ - long Count = \ - ((UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF (TFV, 0))) + 1); \ - (VECTOR_REF (TFV, 0)) = (LONG_TO_UNSIGNED_FIXNUM (Count)); \ - if (Count < (VECTOR_LENGTH (TFV))) \ - (VECTOR_REF (TFV, Count)) = (OBJECT_NEW_TYPE (TC_VECTOR, F)); \ - } \ -} - -/* Call_Future_Logging calls a user defined scheme routine if the vector - of touched futures has a nonzero length. */ - -#define Must_Report_References() \ - ((Logging_On ()) && \ - ((UNSIGNED_FIXNUM_TO_LONG \ - (VECTOR_REF ((Touched_Futures_Vector ()), 0))) \ - > 0)) - -#define Call_Future_Logging() \ -{ \ - Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \ - STACK_PUSH (Touched_Futures_Vector ()); \ - STACK_PUSH (Get_Fixed_Obj_Slot (Future_Logger)); \ - STACK_PUSH (STACK_FRAME_HEADER + 1); \ - Pushed (); \ - (Touched_Futures_Vector ()) = SHARP_F; \ - goto Apply_Non_Trapping; \ -} - -#else /* not FUTURE_LOGGING */ - -#define Log_Touch_Of_Future(F) {} -#define Call_Future_Logging() -#define Must_Report_References() (false) - -#endif /* FUTURE_LOGGING */ -#endif /* COMPILE_FUTURES */ diff --git a/v7/src/microcode/gc.h b/v7/src/microcode/gc.h index ba16b1a3a..ead796e6e 100644 --- a/v7/src/microcode/gc.h +++ b/v7/src/microcode/gc.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: gc.h,v 9.38 2007/01/05 21:19:25 cph Exp $ +$Id: gc.h,v 9.39 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,102 +25,50 @@ USA. */ -/* - * Garbage collection related macros of sufficient utility to be - * included in all compilations. - */ - -/* GC Types. */ - -#ifdef HAS_COMPILER_SUPPORT -#ifndef BAD_TYPES_LETHAL -#ifndef BAD_TYPES_INNOCUOUS -#define BAD_TYPES_INNOCUOUS -#endif /* BAD_TYPES_INNOCUOUS */ -#endif /* BAD_TYPES_LETHAL */ -#endif /* HAS_COMPILER_SUPPORT */ - -#ifdef BAD_TYPES_INNOCUOUS -#ifdef BAD_TYPES_LETHAL -#include "error: gc.h: BAD_TYPES both lethal and innocuous" -#endif /* BAD_TYPES_LETHAL */ -#else /* not BAD_TYPES_INNOCUOUS */ -#ifndef BAD_TYPES_LETHAL -#define BAD_TYPES_LETHAL -#endif /* BAD_TYPES_LETHAL */ -#endif /* BAD_TYPES_INNOCUOUS */ - -#define GC_Non_Pointer 0 -#define GC_Cell 1 -#define GC_Pair 2 -#define GC_Triple 3 -#define GC_Hunk3 3 -#define GC_Quadruple 4 -#define GC_Hunk4 4 -#define GC_Undefined -1 /* Undefined types */ -#define GC_Special -2 /* Internal GC types */ -#define GC_Vector -3 -#define GC_Compiled -4 - -#ifdef BAD_TYPES_INNOCUOUS -#define INVALID_TYPE_CODE(TC) GC_Undefined - -#else /* not BAD_TYPES_INNOCUOUS */ - -/* Some C compilers complain if the expression below does not yield - a value, and Microcode_Termination yields void. - */ - -#define INVALID_TYPE_CODE(TC) \ - (outf_fatal ("\nGC_Type_Code: Bad Type code = 0x%02x\n", TC), \ - Microcode_Termination(TERM_INVALID_TYPE_CODE), \ - GC_Undefined) - -#endif /* BAD_TYPES_INNOCUOUS */ - -#define GC_Type_Code(TC) \ - ((GC_Type_Map[TC] != GC_Undefined) ? \ - GC_Type_Map[TC] : \ - (INVALID_TYPE_CODE(TC))) - -#define GC_Type(Object) GC_Type_Code(OBJECT_TYPE (Object)) - -#define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer) -#define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell) -#define GC_Type_List(Object) (GC_Type(Object) == GC_Pair) -#define GC_Type_Triple(Object) (GC_Type(Object) == GC_Triple) -#define GC_Type_Quadruple(Object) (GC_Type(Object) == GC_Quadruple) -#define GC_Type_Undefined(Object) (GC_Type(Object) == GC_Undefined) -#define GC_Type_Special(Object) (GC_Type(Object) == GC_Special) -#define GC_Type_Vector(Object) (GC_Type(Object) == GC_Vector) -#define GC_Type_Compiled(Object) (GC_Type(Object) == GC_Compiled) - -/* Overflow detection, various cases */ - -#define GC_ENABLED_P() (INTERRUPT_ENABLED_P (INT_GC)) - -#define GC_Check(Amount) \ - (((Amount + Free) >= MemTop) && (GC_ENABLED_P ())) - -#define Space_Before_GC() \ - ((GC_ENABLED_P ()) \ - ? ((Free <= MemTop) ? (MemTop - Free) : 0) \ - : (Heap_Top - Free)) - -#define Request_GC(Amount) \ -{ \ - REQUEST_INTERRUPT (INT_GC); \ - GC_Space_Needed = Amount; \ -} - -#define SET_MEMTOP(addr) \ -{ \ - MemTop = (addr); \ - COMPILER_SETUP_INTERRUPT (); \ -} - -#define SET_STACK_GUARD(addr) \ -{ \ - Stack_Guard = (addr); \ - COMPILER_SETUP_INTERRUPT (); \ -} +/* GC definitions needed by all GC-like programs. */ + +#ifndef SCM_GC_H +#define SCM_GC_H 1 + +#include "object.h" + +typedef enum +{ + GC_COMPILED = -4, + GC_VECTOR, + GC_SPECIAL, /* Internal GC types */ + GC_UNDEFINED, + GC_NON_POINTER, + GC_CELL, + GC_PAIR, + GC_TRIPLE, + GC_QUADRUPLE +} gc_type_t; + +#define GC_TYPE_TO_INT(type) ((int) (type)) +#define GC_TYPE(object) (GC_TYPE_CODE (OBJECT_TYPE (object))) +#define GC_TYPE_CODE gc_type_code + +#define GC_TYPE_NON_POINTER(object) ((GC_TYPE (object)) == GC_NON_POINTER) +#define GC_TYPE_CELL(object) ((GC_TYPE (object)) == GC_CELL) +#define GC_TYPE_PAIR(object) ((GC_TYPE (object)) == GC_PAIR) +#define GC_TYPE_TRIPLE(object) ((GC_TYPE (object)) == GC_TRIPLE) +#define GC_TYPE_QUADRUPLE(object) ((GC_TYPE (object)) == GC_QUADRUPLE) +#define GC_TYPE_UNDEFINED(object) ((GC_TYPE (object)) == GC_UNDEFINED) +#define GC_TYPE_SPECIAL(object) ((GC_TYPE (object)) == GC_SPECIAL) +#define GC_TYPE_VECTOR(object) ((GC_TYPE (object)) == GC_VECTOR) +#define GC_TYPE_COMPILED(object) ((GC_TYPE (object)) == GC_COMPILED) + +typedef enum +{ + GC_POINTER_NORMAL, + GC_POINTER_COMPILED, + GC_POINTER_NOT +} gc_ptr_type_t; + +extern gc_type_t gc_type_map []; +extern gc_type_t gc_type_code (unsigned int); +extern gc_ptr_type_t gc_ptr_type (SCHEME_OBJECT); +extern SCHEME_OBJECT * get_object_address (SCHEME_OBJECT); + +#endif /* not SCM_GC_H */ diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index 280aff7c5..861bd8383 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: gccode.h,v 9.62 2007/01/05 21:19:25 cph Exp $ +$Id: gccode.h,v 9.63 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -29,549 +29,195 @@ USA. loops over memory. It is only included in a few files, unlike gc.h which contains general purpose macros and constants. */ +#ifndef SCM_GCCODE_H +#define SCM_GCCODE_H 1 + +#include "gc.h" +#include "cmpgc.h" +#include "fasl.h" + #ifdef ENABLE_DEBUGGING_TOOLS -#ifndef ENABLE_GC_DEBUGGING_TOOLS -#define ENABLE_GC_DEBUGGING_TOOLS -#endif +# ifndef ENABLE_GC_DEBUGGING_TOOLS +# define ENABLE_GC_DEBUGGING_TOOLS +# endif #endif -/* A SWITCH on GC types, duplicates information in GC_Type_Map[], but - exists for efficiency reasons. Macros must be used by convention: - first Switch_by_GC_Type, then each of the case_ macros (in any - order). The default: case MUST be included in the switch. */ - -#define Switch_by_GC_Type(P) \ - switch (OBJECT_TYPE (P)) - -#define case_simple_Non_Pointer \ - case TC_NULL: \ - case TC_CONSTANT: \ - case TC_RETURN_CODE: \ - case TC_THE_ENVIRONMENT - -#define case_Fasload_Non_Pointer \ - case_TC_FIXNUMs: \ - case TC_CHARACTER: \ - case_simple_Non_Pointer - -#define case_Non_Pointer \ - case TC_PRIMITIVE: \ - case TC_PCOMB0: \ - case TC_STACK_ENVIRONMENT: \ - case_Fasload_Non_Pointer - -/* Missing Non Pointer types (must always be treated specially): - TC_BROKEN_HEART - TC_MANIFEST_NM_VECTOR - TC_MANIFEST_SPECIAL_NM_VECTOR - TC_REFERENCE_TRAP - TC_MANIFEST_CLOSURE - TC_LINKAGE_SECTION - */ - -#define case_compiled_entry_point \ - case TC_COMPILED_ENTRY - -#define case_Cell \ - case TC_CELL - -/* No missing Cell types */ - -#define case_Fasdump_Pair \ - case TC_LIST: \ - case TC_SCODE_QUOTE: \ - case TC_COMBINATION_1: \ - case TC_EXTENDED_PROCEDURE: \ - case TC_PROCEDURE: \ - case TC_DELAY: \ - case TC_DELAYED: \ - case TC_COMMENT: \ - case TC_LAMBDA: \ - case TC_SEQUENCE_2: \ - case TC_PCOMB1: \ - case TC_ACCESS: \ - case TC_DEFINITION: \ - case TC_ASSIGNMENT: \ - case TC_IN_PACKAGE: \ - case TC_LEXPR: \ - case TC_DISJUNCTION: \ - case TC_COMPLEX: \ - case TC_ENTITY: \ - case TC_RATNUM - -#define case_Pair \ - case TC_INTERNED_SYMBOL: \ - case TC_UNINTERNED_SYMBOL: \ - case_Fasdump_Pair - -/* Missing pair types (must be treated specially): - TC_WEAK_CONS - */ - -#define case_Triple \ - case TC_COMBINATION_2: \ - case TC_EXTENDED_LAMBDA: \ - case TC_HUNK3_A: \ - case TC_HUNK3_B: \ - case TC_CONDITIONAL: \ - case TC_SEQUENCE_3: \ - case TC_PCOMB2 - -/* Missing triple types (must be treated specially): - TC_VARIABLE */ - -#define case_Quadruple \ - case TC_QUAD - -/* No missing quad types. */ - -#define case_simple_Vector \ - case TC_NON_MARKED_VECTOR: \ - case TC_VECTOR: \ - case TC_RECORD: \ - case TC_CONTROL_POINT: \ - case TC_COMBINATION: \ - case TC_PCOMB3: \ - case TC_VECTOR_1B: \ - case TC_VECTOR_16B - -#define case_Purify_Vector \ - case TC_BIG_FIXNUM: \ - case TC_CHARACTER_STRING: \ - case_simple_Vector - -#define case_Vector \ - case TC_ENVIRONMENT: \ - case_Purify_Vector - -#define case_Aligned_Vector \ - case TC_COMPILED_CODE_BLOCK: \ - case TC_BIG_FLONUM - -/* Missing vector types (must be treated specially): - TC_FUTURE - */ - -extern char gc_death_message_buffer []; - -extern void - EXFUN (gc_death, (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)); - -/* Assumption: A call to GC_BAD_TYPE is followed by the non-pointer code. */ - -#ifndef BAD_TYPES_INNOCUOUS - -#define GC_BAD_TYPE(name, object) do \ -{ \ - sprintf \ - (gc_death_message_buffer, \ - "%s: bad type code (0x%02lx)", \ - (name), \ - (OBJECT_TYPE (object))); \ - gc_death \ - (TERM_INVALID_TYPE_CODE, \ - gc_death_message_buffer, \ - Scan, \ - To); \ - /*NOTREACHED*/ \ -} while (0) - -#else /* BAD_TYPES_INNOCUOUS */ - -#define GC_BAD_TYPE(name, object) do \ -{ \ - outf_error ("\n%s: bad type code (0x%02lx) 0x%lx", \ - (name), \ - (OBJECT_TYPE (object)), \ - (object)); \ - outf_error (" -- Treating as non-pointer.\n"); \ - /* Fall through */ \ -} while (0) - -#endif /* BAD_TYPES_INNOCUOUS */ - -/* Macros for the garbage collector and related programs. */ - -/* Pointer setup for the GC Type handlers. */ - -#define GC_Consistency_Check(In_GC) \ -{ \ - if And2 (In_GC, Consistency_Check) \ - { \ - if ((Old >= Highest_Allocated_Address) \ - || (Old < Lowest_Allocated_Address)) \ - { \ - sprintf \ - (gc_death_message_buffer, \ - "setup_internal: out of range pointer (0x%lx)", \ - Temp); \ - gc_death (TERM_EXIT, gc_death_message_buffer, Scan, To); \ - /*NOTREACHED*/ \ - } \ - } \ -} - -/* Check whether it has been relocated. */ - -#define Normal_BH(In_GC, then_what) \ -{ \ - if (BROKEN_HEART_P (* Old)) \ - { \ - (* Scan) = (MAKE_OBJECT_FROM_OBJECTS (Temp, (* Old))); \ - then_what; \ - } \ -} - -#define RAW_BH(In_GC, then_what) \ -{ \ - if (BROKEN_HEART_P (* Old)) \ - { \ - (* Scan) = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (* Old))); \ - then_what; \ - } \ -} - -#define Setup_Internal(In_GC, Transport_Code, Already_Relocated_Code) \ -{ \ - GC_Consistency_Check (In_GC); \ - if (Old < low_heap) \ - continue; \ - Already_Relocated_Code; \ - New_Address = (MAKE_BROKEN_HEART (To)); \ - Transport_Code; \ -} - -#define Setup_Aligned(In_GC, Transport_Code, Already_Relocated_Code) \ -{ \ - GC_Consistency_Check (In_GC); \ - if (Old < low_heap) \ - continue; \ - Already_Relocated_Code; \ - ALIGN_FLOAT (To); \ - New_Address = (MAKE_BROKEN_HEART (To)); \ - Transport_Code; \ -} - -#define Setup_Pointer(In_GC, Transport_Code) \ -{ \ - Setup_Internal (In_GC, Transport_Code, Normal_BH (In_GC, continue)); \ -} - -#define Pointer_End() \ -{ \ - (* (OBJECT_ADDRESS (Temp))) = New_Address; \ - (* Scan) = (MAKE_OBJECT_FROM_OBJECTS (Temp, New_Address)); \ -} - -/* HP sucks the big donkey wong?! (still?) */ -/* HP92453-01 A.09.19 HP C Compiler on HP-UX 9.01 drops the - first line when "optimizing". - */ - -#if defined(hp9000s800) || defined(__hp9000s800) -SCHEME_OBJECT gccode_HPUX_lossage_bug_fix_fnord; /* ``I'm not dead yet!'' */ - -#define RAW_POINTER_END() \ -{ \ - gccode_HPUX_lossage_bug_fix_fnord = Temp; \ - (* (SCHEME_ADDR_TO_ADDR (gccode_HPUX_lossage_bug_fix_fnord))) \ - = New_Address; \ - (* Scan) = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (New_Address))); \ -} -#else /* not hp9000s800 */ -#define RAW_POINTER_END() \ -{ \ - (* (SCHEME_ADDR_TO_ADDR (Temp))) = New_Address; \ - (* Scan) = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (New_Address))); \ -} -#endif /* hp9000s800 */ - -/* GC Type handlers. These do the actual work. */ +typedef SCHEME_OBJECT * gc_handler_t + (SCHEME_OBJECT *, SCHEME_OBJECT); -#ifdef ENABLE_GC_DEBUGGING_TOOLS +#define DEFINE_GC_HANDLER(handler_name) \ +SCHEME_OBJECT * \ +handler_name (SCHEME_OBJECT * scan, SCHEME_OBJECT object) -extern SCHEME_OBJECT gc_object_referenced; -extern SCHEME_OBJECT gc_objects_referencing; -extern unsigned long gc_objects_referencing_count; -extern SCHEME_OBJECT * gc_objects_referencing_scan; -extern SCHEME_OBJECT * gc_objects_referencing_end; - -#define TRANSPORT_ONE_THING(transport_code) \ -{ \ - if ((gc_object_referenced == (*Old)) \ - && (gc_objects_referencing != SHARP_F)) \ - { \ - gc_objects_referencing_count += 1; \ - if (gc_objects_referencing_scan != gc_objects_referencing_end) \ - { \ - UPDATE_GC_OBJECTS_REFERENCING (); \ - (*gc_objects_referencing_scan++) = object_referencing; \ - } \ - } \ - transport_code; \ -} - -#define UPDATE_GC_OBJECTS_REFERENCING() \ -{ \ - if (BROKEN_HEART_P (MEMORY_REF (gc_objects_referencing, 0))) \ - { \ - SCHEME_OBJECT new = \ - (MAKE_OBJECT_FROM_OBJECTS \ - (gc_objects_referencing, \ - (MEMORY_REF (gc_objects_referencing, 0)))); \ - gc_objects_referencing_scan = \ - (VECTOR_LOC \ - (new, \ - (gc_objects_referencing_scan \ - - (VECTOR_LOC (gc_objects_referencing, 0))))); \ - gc_objects_referencing_end = \ - (VECTOR_LOC (new, (VECTOR_LENGTH (new)))); \ - gc_objects_referencing = new; \ - } \ -} - -#else - -#define TRANSPORT_ONE_THING(transport_code) transport_code +typedef SCHEME_OBJECT gc_tuple_handler_t + (SCHEME_OBJECT, unsigned int); -#endif - -#define Transport_Cell() \ -{ \ - TRANSPORT_ONE_THING ((*To++) = (*Old)); \ - Pointer_End (); \ -} - -#define Transport_Pair() \ -{ \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old)); \ - Pointer_End (); \ -} - -#define Transport_Triple() \ -{ \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old)); \ - Pointer_End (); \ -} - -#define TRANSPORT_RAW_TRIPLE() \ -{ \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old)); \ - RAW_POINTER_END (); \ -} - -#define Transport_Quadruple() \ -{ \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - TRANSPORT_ONE_THING ((*To++) = (*Old)); \ - Pointer_End (); \ -} - -#ifndef In_Fasdump +#define DEFINE_GC_TUPLE_HANDLER(handler_name) \ +SCHEME_OBJECT \ +handler_name (SCHEME_OBJECT tuple, unsigned int n_words) -/* The OBJECT_DATUM below gets the length of the vector. - (VECTOR_LENGTH (Temp)) cannot be used because Temp does - not necessarily point to the first word of the object. - Currently only compiled entry points point to the - "middle" of vectors. */ +typedef SCHEME_OBJECT gc_vector_handler_t + (SCHEME_OBJECT, bool); -#ifdef ENABLE_GC_DEBUGGING_TOOLS +#define DEFINE_GC_VECTOR_HANDLER(handler_name) \ +SCHEME_OBJECT \ +handler_name (SCHEME_OBJECT vector, bool align_p) -extern void EXFUN (check_transport_vector_lossage, - (SCHEME_OBJECT *, SCHEME_OBJECT *, SCHEME_OBJECT *)); - -#define CHECK_TRANSPORT_VECTOR_TERMINATION() \ -{ \ - if (! ((To <= Scan) \ - && (((Constant_Space <= To) && (To < Heap_Bottom)) \ - ? ((Constant_Space <= Scan) && (Scan < Heap_Bottom)) \ - : ((Heap_Bottom <= Scan) && (Scan < Heap_Top))))) \ - check_transport_vector_lossage (Scan, Saved_Scan, To); \ - if ((OBJECT_DATUM (*Old)) > 65536) \ - { \ - outf_error ("\nWarning: copying large vector: %ld\n", \ - (OBJECT_DATUM (*Old))); \ - outf_flush_error (); \ - } \ -} - -#else /* not ENABLE_GC_DEBUGGING_TOOLS */ - -#define CHECK_TRANSPORT_VECTOR_TERMINATION() - -#endif /* not ENABLE_GC_DEBUGGING_TOOLS */ - -#define Real_Transport_Vector() \ -{ \ - SCHEME_OBJECT * Saved_Scan; \ - \ - Saved_Scan = Scan; \ - Scan = (To + 1 + (OBJECT_DATUM (* Old))); \ - if ((Consistency_Check) \ - && (Scan > Heap_Top) \ - && (To < Heap_Top) \ - && (To >= Heap_Bottom)) \ - { \ - sprintf \ - (gc_death_message_buffer, \ - "real_transport_vector: vector length too large (%ld)", \ - (OBJECT_DATUM (*Old))); \ - gc_death (TERM_EXIT, gc_death_message_buffer, Saved_Scan, To); \ - } \ - CHECK_TRANSPORT_VECTOR_TERMINATION (); \ - while (To != Scan) \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - Scan = Saved_Scan; \ -} - -#else /* In_Fasdump */ - -#define Real_Transport_Vector() \ -{ \ - SCHEME_OBJECT * Saved_Scan; \ - \ - Saved_Scan = Scan; \ - Scan = (To + 1 + (OBJECT_DATUM (*Old))); \ - if (Scan >= Fixes) \ - { \ - Scan = Saved_Scan; \ - NewFree = To; \ - Fixup = Fixes; \ - return (PRIM_INTERRUPT); \ - } \ - while (To != Scan) \ - TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ - Scan = Saved_Scan; \ -} +typedef SCHEME_OBJECT gc_object_handler_t + (SCHEME_OBJECT); -#endif +#define DEFINE_GC_OBJECT_HANDLER(handler_name) \ +SCHEME_OBJECT \ +handler_name (SCHEME_OBJECT object) -#define Transport_Vector() \ -{ \ -Move_Vector: \ - Real_Transport_Vector (); \ - Pointer_End (); \ -} - -#define Transport_Future() \ -{ \ - if (! (Future_Spliceable (Temp))) \ - goto Move_Vector; \ - (*Scan) = (Future_Value (Temp)); \ - Scan -= 1; \ -} - -/* Weak Pointer code. The idea here is to support a post-GC pass which - removes any objects in the CAR of a WEAK_CONS cell which is no longer - referenced by other objects in the system. - - The idea is to maintain a (C based) list of weak conses in old - space. The head of this list is the variable Weak_Chain. During - the normal GC pass, weak cons cells are not copied in the normal - manner. Instead the following structure is built: - - Old Space | New Space - _______________________ | _______________________ - |Broken | New | | | NULL | Old CAR data | - |Heart | Location ======|==>| | | - |_______|_____________| | |______|______________| - |Old Car| Next in | | | Old CDR component | - | type | chain | | | | - |_____________________| | |_____________________| - - */ - -extern SCHEME_OBJECT Weak_Chain; - -#define EMPTY_WEAK_CHAIN (OBJECT_NEW_TYPE(TC_NULL, 0)) - -#define Transport_Weak_Cons() \ -{ \ - long Car_Type = (OBJECT_TYPE (*Old)); \ - (*To++) = (OBJECT_NEW_TYPE (TC_NULL, (*Old))); \ - Old += 1; \ - TRANSPORT_ONE_THING ((*To++) = (*Old)); \ - *Old = (OBJECT_NEW_TYPE (Car_Type, Weak_Chain)); \ - Weak_Chain = Temp; \ - Pointer_End (); \ -} - -/* Special versions of the above for DumpLoop in Fasdump. This code - only differs from the code above in that it must check whether - there is enough space to remember the fixup. */ - -#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \ -{ \ - BH_Code; \ - \ - /* It must be transported to New Space */ \ - \ - New_Address = (MAKE_BROKEN_HEART (To)); \ - if ((Fixes - To) < FASDUMP_FIX_BUFFER) \ - { \ - NewFree = To; \ - Fixup = Fixes; \ - return (PRIM_INTERRUPT); \ - } \ - (*--Fixes) = (* Old); \ - (*--Fixes) = (ADDRESS_TO_DATUM (Old)); \ - Extra_Code; \ -} - -#define Fasdump_Setup_Aligned(Extra_Code, BH_Code) \ -{ \ - BH_Code; \ - \ - /* It must be transported to New Space */ \ - \ - ALIGN_FLOAT (To); \ - New_Address = (MAKE_BROKEN_HEART (To)); \ - if ((Fixes - To) < FASDUMP_FIX_BUFFER) \ - { \ - NewFree = To; \ - Fixup = Fixes; \ - return (PRIM_INTERRUPT); \ - } \ - (*--Fixes) = (* Old); \ - (*--Fixes) = (ADDRESS_TO_DATUM (Old)); \ - Extra_Code; \ -} - -/* Undefine Symbols */ - -#define Fasdump_Symbol(global_value) \ -{ \ - (*To++) = (* Old); \ - (*To++) = global_value; \ - Pointer_End (); \ -} - -#define Fasdump_Variable() \ -{ \ - (*To++) = (* Old); \ - (*To++) = UNCOMPILED_VARIABLE; \ - (*To++) = SHARP_F; \ - Pointer_End (); \ -} - -/* Compiled Code Relocation Utilities */ +typedef SCHEME_OBJECT * gc_precheck_from_t (SCHEME_OBJECT *); -#include "cmpgc.h" +#define DEFINE_GC_PRECHECK_FROM(handler_name) \ +SCHEME_OBJECT * \ +handler_name (SCHEME_OBJECT * from) + +typedef SCHEME_OBJECT * gc_transport_words_t + (SCHEME_OBJECT *, unsigned long, bool); + +#define DEFINE_GC_TRANSPORT_WORDS(handler_name) \ +SCHEME_OBJECT * \ +handler_name (SCHEME_OBJECT * from, unsigned long n_words, bool align_p) + +typedef bool gc_ignore_object_p_t (SCHEME_OBJECT); + +#define DEFINE_GC_IGNORE_OBJECT_P(handler_name) \ +bool \ +handler_name (SCHEME_OBJECT object) + +typedef SCHEME_OBJECT gc_raw_address_to_object_t + (unsigned int, SCHEME_OBJECT *); +typedef SCHEME_OBJECT * gc_object_to_raw_address_t (SCHEME_OBJECT); +typedef SCHEME_OBJECT gc_raw_address_to_cc_entry_t (insn_t *); +typedef insn_t * gc_cc_entry_to_raw_address_t (SCHEME_OBJECT); -typedef struct gc_hook_list_s +typedef struct { - void EXFUN ((* hook), (void)); - struct gc_hook_list_s * next; -} * gc_hook_list; - -extern int EXFUN (add_pre_gc_hook, (void (*) (void))); -extern int EXFUN (add_post_gc_hook, (void (*) (void))); -extern void EXFUN (run_pre_gc_hooks, (void)); -extern void EXFUN (run_post_gc_hooks, (void)); + gc_handler_t * handlers [N_TYPE_CODES]; + gc_tuple_handler_t * tuple_handler; + gc_vector_handler_t * vector_handler; + gc_object_handler_t * cc_entry_handler; + gc_precheck_from_t * precheck_from; + gc_transport_words_t * transport_words; + gc_ignore_object_p_t * ignore_object_p; + gc_raw_address_to_object_t * raw_address_to_object; + gc_object_to_raw_address_t * object_to_raw_address; + gc_raw_address_to_cc_entry_t * raw_address_to_cc_entry; + gc_cc_entry_to_raw_address_t * cc_entry_to_raw_address; +} gc_table_t; + +#define GCT_ENTRY(table, type) (((table)->handlers) [(type)]) +#define GCT_TUPLE(table) ((table)->tuple_handler) +#define GCT_VECTOR(table) ((table)->vector_handler) +#define GCT_CC_ENTRY(table) ((table)->cc_entry_handler) +#define GCT_PRECHECK_FROM(table) ((table)->precheck_from) +#define GCT_TRANSPORT_WORDS(table) ((table)->transport_words) +#define GCT_IGNORE_OBJECT_P(table) ((table)->ignore_object_p) +#define GCT_RAW_ADDRESS_TO_OBJECT(table) ((table)->raw_address_to_object) +#define GCT_OBJECT_TO_RAW_ADDRESS(table) ((table)->object_to_raw_address) +#define GCT_RAW_ADDRESS_TO_CC_ENTRY(table) ((table)->raw_address_to_cc_entry) +#define GCT_CC_ENTRY_TO_RAW_ADDRESS(table) ((table)->cc_entry_to_raw_address) + +#define GC_HANDLE_TUPLE(object, n_words) \ + ((* (GCT_TUPLE (current_gc_table))) ((object), (n_words))) + +#define GC_HANDLE_VECTOR(object, align_p) \ + ((* (GCT_VECTOR (current_gc_table))) ((object), (align_p))) + +#define GC_HANDLE_CC_ENTRY(object) \ + ((* (GCT_CC_ENTRY (current_gc_table))) (object)) + +#define GC_PRECHECK_FROM(from) \ + ((* (GCT_PRECHECK_FROM (current_gc_table))) (from)) + +#define GC_TRANSPORT_WORDS(from, n_words, align_p) \ + ((* (GCT_TRANSPORT_WORDS (current_gc_table))) ((from), (n_words), (align_p))) + +#define GC_RAW_ADDRESS_TO_OBJECT(type, addr) \ + ((* (GCT_RAW_ADDRESS_TO_OBJECT (current_gc_table))) ((type), (addr))) + +#define GC_OBJECT_TO_RAW_ADDRESS(object) \ + ((* (GCT_OBJECT_TO_RAW_ADDRESS (current_gc_table))) (object)) + +#define GC_RAW_ADDRESS_TO_CC_ENTRY(addr) \ + ((* (GCT_RAW_ADDRESS_TO_CC_ENTRY (current_gc_table))) (addr)) + +#define GC_CC_ENTRY_TO_RAW_ADDRESS(object) \ + ((* (GCT_CC_ENTRY_TO_RAW_ADDRESS (current_gc_table))) (object)) + +extern gc_table_t * current_gc_table; + +extern gc_handler_t gc_handle_non_pointer; +extern gc_handler_t gc_handle_cell; +extern gc_handler_t gc_handle_pair; +extern gc_handler_t gc_handle_triple; +extern gc_handler_t gc_handle_quadruple; +extern gc_handler_t gc_handle_weak_pair; +extern gc_handler_t gc_handle_cc_entry; +extern gc_handler_t gc_handle_aligned_vector; +extern gc_handler_t gc_handle_unaligned_vector; +extern gc_handler_t gc_handle_broken_heart; +extern gc_handler_t gc_handle_nmv; +extern gc_handler_t gc_handle_reference_trap; +extern gc_handler_t gc_handle_linkage_section; +extern gc_handler_t gc_handle_manifest_closure; +extern gc_handler_t gc_handle_undefined; + +extern gc_tuple_handler_t gc_tuple; +extern gc_vector_handler_t gc_vector; +extern gc_object_handler_t gc_cc_entry; +extern gc_precheck_from_t gc_precheck_from; +extern gc_precheck_from_t gc_precheck_from_no_transport; +extern gc_transport_words_t gc_transport_words; +extern gc_transport_words_t gc_no_transport_words; +extern gc_raw_address_to_object_t gc_raw_address_to_object; +extern gc_object_to_raw_address_t gc_object_to_raw_address; +extern gc_raw_address_to_cc_entry_t gc_raw_address_to_cc_entry; +extern gc_cc_entry_to_raw_address_t gc_cc_entry_to_raw_address; + +extern void initialize_gc_table (gc_table_t *, bool); + +typedef void gc_tospace_allocator_t + (unsigned long, SCHEME_OBJECT **, SCHEME_OBJECT **); +typedef void gc_abort_handler_t (void); +typedef bool gc_walk_proc_t (SCHEME_OBJECT *, SCHEME_OBJECT *, void *); + +extern void initialize_gc + (unsigned long, SCHEME_OBJECT **, SCHEME_OBJECT **, + gc_tospace_allocator_t *, gc_abort_handler_t * NORETURN); + +extern void resize_tospace (unsigned long); +extern void open_tospace (SCHEME_OBJECT *); +extern bool tospace_available_p (unsigned long); +extern void add_to_tospace (SCHEME_OBJECT); +extern SCHEME_OBJECT read_tospace (SCHEME_OBJECT *); +extern void write_tospace (SCHEME_OBJECT *, SCHEME_OBJECT); +extern void increment_tospace_ptr (unsigned long); +extern SCHEME_OBJECT * get_newspace_ptr (void); +extern void * tospace_to_newspace (void *); +extern void * newspace_to_tospace (void *); +extern bool save_tospace (gc_walk_proc_t *, void *); + +extern void initialize_weak_chain (void); +extern void update_weak_pointers (void); + +extern gc_table_t * std_gc_table (void); +extern void gc_scan_oldspace (SCHEME_OBJECT *, SCHEME_OBJECT *); +extern void gc_scan_tospace (SCHEME_OBJECT *, SCHEME_OBJECT *); + +extern void std_gc_death (const char *, ...) + ATTRIBUTE ((__noreturn__, __format__ (__printf__, 1, 2))); +extern void gc_no_cc_support (void) NORETURN; +extern void gc_bad_type (SCHEME_OBJECT) NORETURN; + +#ifdef ENABLE_GC_DEBUGGING_TOOLS + extern void collect_gc_object_references (SCHEME_OBJECT, SCHEME_OBJECT); + extern void initialize_gc_object_references (void); + extern void finalize_gc_object_references (void); +#endif + +#endif /* not SCM_GCCODE_H */ diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c index e34764271..3cbd975f8 100644 --- a/v7/src/microcode/gcloop.c +++ b/v7/src/microcode/gcloop.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: gcloop.c,v 9.53 2007/01/05 21:19:25 cph Exp $ +$Id: gcloop.c,v 9.54 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,307 +25,1111 @@ USA. */ -/* - * - * This file contains the code for the most primitive part - * of garbage collection. - * - */ +/* Garbage collector core + + This is a one-space copying garbage collector. It's like a + two-space collector, except that the heap is copied to temporary + memory ("tospace"), then copied back at the end. This design is + more complex and slower than a two-space collector, but it has the + advantage that tospace can be allocated anywhere in the virtual + address space. This matters because our tagging scheme limits the + number of address bits we can use (26 on a 32-bit machine), and + with this design tospace can be located outside of the addressable + range, thus maximizing the usage of addressable memory. This + design is similar to that of the older "bchscheme" GC, except that + bchscheme allocated its tospace in a file. + + Some terminology: + + "Fromspace" is the allocated portion of the heap that we copy + objects from. + + "Tospace" is the temporary memory that we copy objects to. + + "Newspace" is the region of memory into which tospace will be + copied after the GC is complete. During the GC we copy objects + into tospace, but update pointers to refer to locations in + newspace. Since there's a simple relationship between pointers in + newspace and pointers in tospace, it's easy to convert between + them. -#include "scheme.h" + "Oldspace" is the addressable region of memory. This includes + fromspace, and also the stack and constant areas. It is + distinguished from fromspace because we can scan anywhere in + oldspace, but we copy only from fromspace. + +*/ + +#include "object.h" +#include "outf.h" #include "gccode.h" -/* Exports */ +static SCHEME_OBJECT ** p_fromspace_start; +static SCHEME_OBJECT ** p_fromspace_end; +static gc_tospace_allocator_t * gc_tospace_allocator; +static gc_abort_handler_t * gc_abort_handler NORETURN; + +static SCHEME_OBJECT * tospace_start; +static SCHEME_OBJECT * tospace_next; +static SCHEME_OBJECT * tospace_end; +static SCHEME_OBJECT * newspace_start; +static SCHEME_OBJECT * newspace_next; +static SCHEME_OBJECT * newspace_end; + +gc_table_t * current_gc_table; +static SCHEME_OBJECT * current_scan; +static SCHEME_OBJECT current_object; -extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); +#define ADDRESS_IN_FROMSPACE_P(addr) \ + ((((void *) (addr)) >= ((void *) (*p_fromspace_start))) \ + && (((void *) (addr)) < ((void *) (*p_fromspace_end)))) -#define GC_Pointer(Code) \ +#define TOSPACE_TO_NEWSPACE(p) (((p) - tospace_start) + newspace_start) +#define NEWSPACE_TO_TOSPACE(p) (((p) - newspace_start) + tospace_start) + +#define READ_TOSPACE(addr) (* (NEWSPACE_TO_TOSPACE (addr))) +#define WRITE_TOSPACE(addr, obj) ((* (NEWSPACE_TO_TOSPACE (addr))) = (obj)) + +#define CLOSE_TOSPACE() do \ { \ - Old = (OBJECT_ADDRESS (Temp)); \ - Code; \ -} + tospace_next = 0; \ + newspace_start = 0; \ + newspace_next = 0; \ + newspace_end = 0; \ +} while (false) -#define GC_RAW_POINTER(Code) \ +#define GUARANTEE_TOSPACE_OPEN() do \ { \ - Old = (SCHEME_ADDR_TO_ADDR (Temp)); \ - Code; \ -} + if (tospace_next == 0) \ + tospace_closed (); \ +} while (false) -#define Setup_Pointer_for_GC(Extra_Code) \ +#define GUARANTEE_TOSPACE_CLOSED() do \ { \ - GC_Pointer (Setup_Pointer (true, Extra_Code)); \ -} - -#ifdef ENABLE_GC_DEBUGGING_TOOLS + if (tospace_next != 0) \ + tospace_open (); \ +} while (false) -#ifndef GC_SCAN_HISTORY_SIZE -#define GC_SCAN_HISTORY_SIZE 1024 +#ifndef READ_REFERENCE_ADDRESS +# define READ_REFERENCE_ADDRESS(addr) \ + (* ((SCHEME_OBJECT **) (addr))) +# define WRITE_REFERENCE_ADDRESS(ref, addr) \ + ((* ((SCHEME_OBJECT **) (addr))) = (ref)) #endif -SCHEME_OBJECT - * gc_scan_trap = ((SCHEME_OBJECT *) 0), - * gc_free_trap = ((SCHEME_OBJECT *) 0), - gc_trap = (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE)), - * (gc_scan_history [GC_SCAN_HISTORY_SIZE]), - * (gc_to_history [GC_SCAN_HISTORY_SIZE]); +static SCHEME_OBJECT * weak_chain; -SCHEME_OBJECT gc_object_referenced = SHARP_F; -SCHEME_OBJECT gc_objects_referencing = SHARP_F; -unsigned long gc_objects_referencing_count; -SCHEME_OBJECT * gc_objects_referencing_scan; -SCHEME_OBJECT * gc_objects_referencing_end; +static void run_gc_loop (SCHEME_OBJECT * , SCHEME_OBJECT **); +static SCHEME_OBJECT gc_transport_weak_pair (SCHEME_OBJECT); +static void tospace_closed (void); +static void tospace_open (void); -static int gc_scan_history_index; +#ifdef ENABLE_GC_DEBUGGING_TOOLS +# ifndef GC_SCAN_HISTORY_SIZE +# define GC_SCAN_HISTORY_SIZE 1024 +# endif +# define INITIALIZE_GC_HISTORY initialize_gc_history +# define HANDLE_GC_TRAP handle_gc_trap +# define CHECK_NEWSPACE_SYNC check_newspace_sync +# define DEBUG_TRANSPORT_ONE_WORD debug_transport_one_word -#define INITIALIZE_GC_HISTORY() \ -{ \ - gc_scan_history_index = 0; \ - { \ - SCHEME_OBJECT ** scan = gc_scan_history; \ - SCHEME_OBJECT ** end = (scan + GC_SCAN_HISTORY_SIZE); \ - while (scan < end) \ - (*scan++) = ((SCHEME_OBJECT *) 0); \ - } \ - { \ - SCHEME_OBJECT ** scan = gc_to_history; \ - SCHEME_OBJECT ** end = (scan + GC_SCAN_HISTORY_SIZE); \ - while (scan < end) \ - (*scan++) = ((SCHEME_OBJECT *) 0); \ - } \ -} - -#define HANDLE_GC_TRAP() \ -{ \ - (gc_scan_history [gc_scan_history_index]) = Scan; \ - (gc_to_history [gc_scan_history_index]) = To; \ - if ((++gc_scan_history_index) == GC_SCAN_HISTORY_SIZE) \ - gc_scan_history_index = 0; \ - if ((Temp == gc_trap) \ - || ((gc_scan_trap != 0) && (Scan >= gc_scan_trap)) \ - || ((gc_free_trap != 0) && (To >= gc_free_trap))) \ - { \ - outf_error ("\nGCLoop: trap.\n"); \ - abort (); \ - } \ -} + static unsigned int gc_scan_history_index; + static SCHEME_OBJECT * gc_scan_history [GC_SCAN_HISTORY_SIZE]; + static SCHEME_OBJECT * gc_to_history [GC_SCAN_HISTORY_SIZE]; -#else + static SCHEME_OBJECT gc_trap + = (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE)); + static SCHEME_OBJECT * gc_scan_trap = 0; + static SCHEME_OBJECT * gc_to_trap = 0; -#define INITIALIZE_GC_HISTORY() -#define HANDLE_GC_TRAP() + static SCHEME_OBJECT gc_object_referenced = SHARP_F; + static SCHEME_OBJECT gc_object_references = SHARP_F; + static unsigned long gc_object_references_count; + static SCHEME_OBJECT * gc_object_references_scan; + static SCHEME_OBJECT * gc_object_references_end; + static unsigned long weak_chain_length; + + static void initialize_gc_history (void); + static void handle_gc_trap (SCHEME_OBJECT *, SCHEME_OBJECT); + static void check_newspace_sync (void); + static void debug_transport_one_word (SCHEME_OBJECT, SCHEME_OBJECT *); +#else +# define INITIALIZE_GC_HISTORY() do {} while (false) +# define HANDLE_GC_TRAP(scan, object) do {} while (false) +# define CHECK_NEWSPACE_SYNC() do {} while (false) +# define DEBUG_TRANSPORT_ONE_WORD(object, from) do {} while (false) #endif +void +initialize_gc (unsigned long n_words, + SCHEME_OBJECT ** pf_start, + SCHEME_OBJECT ** pf_end, + gc_tospace_allocator_t * allocator, + gc_abort_handler_t * abort_handler NORETURN) +{ + p_fromspace_start = pf_start; + p_fromspace_end = pf_end; + gc_tospace_allocator = allocator; + gc_abort_handler = abort_handler; + CLOSE_TOSPACE (); + tospace_start = 0; + tospace_end = 0; + (*gc_tospace_allocator) (n_words, (&tospace_start), (&tospace_end)); +} + +void +resize_tospace (unsigned long n_words) +{ + GUARANTEE_TOSPACE_CLOSED (); + (*gc_tospace_allocator) (n_words, (&tospace_start), (&tospace_end)); +} + +void +open_tospace (SCHEME_OBJECT * start) +{ + GUARANTEE_TOSPACE_CLOSED (); + tospace_next = tospace_start; + newspace_start = start; + newspace_next = start; + newspace_end = (start + (tospace_end - tospace_start)); +} + +bool +save_tospace (gc_walk_proc_t * proc, void * ctx) +{ + bool ok; + + GUARANTEE_TOSPACE_OPEN (); + CHECK_NEWSPACE_SYNC (); + ok = (proc (tospace_start, tospace_next, ctx)); + CLOSE_TOSPACE (); + return (ok); +} + +bool +tospace_available_p (unsigned long n_words) +{ + GUARANTEE_TOSPACE_OPEN (); + return ((tospace_end - tospace_next) >= n_words); +} + +void +add_to_tospace (SCHEME_OBJECT object) +{ + GUARANTEE_TOSPACE_OPEN (); + (*tospace_next++) = object; + newspace_next += 1; +} + +SCHEME_OBJECT +read_tospace (SCHEME_OBJECT * addr) +{ + GUARANTEE_TOSPACE_OPEN (); + return (READ_TOSPACE (addr)); +} + +void +write_tospace (SCHEME_OBJECT * addr, SCHEME_OBJECT object) +{ + GUARANTEE_TOSPACE_OPEN (); + WRITE_TOSPACE (addr, object); +} + +void +increment_tospace_ptr (unsigned long n_words) +{ + GUARANTEE_TOSPACE_OPEN (); + tospace_next += n_words; + newspace_next += n_words; +} + SCHEME_OBJECT * -DEFUN (GCLoop, - (Scan, To_Pointer), - fast SCHEME_OBJECT * Scan - AND SCHEME_OBJECT ** To_Pointer) -{ - fast SCHEME_OBJECT - * To, * Old, Temp, - * low_heap, New_Address; -#ifdef ENABLE_GC_DEBUGGING_TOOLS - SCHEME_OBJECT object_referencing; -#endif +get_newspace_ptr (void) +{ + return (newspace_next); +} - INITIALIZE_GC_HISTORY (); - To = * To_Pointer; - low_heap = Constant_Top; - for ( ; Scan != To; Scan++) - { - Temp = * Scan; -#ifdef ENABLE_GC_DEBUGGING_TOOLS - object_referencing = Temp; -#endif - HANDLE_GC_TRAP (); +void * +tospace_to_newspace (void * addr) +{ + return + (((addr >= ((void *) tospace_start)) + && (addr <= ((void *) tospace_end))) + ? ((((byte_t *) addr) - ((byte_t *) tospace_start)) + + ((byte_t *) newspace_start)) + : addr); +} - Switch_by_GC_Type (Temp) - { - case TC_BROKEN_HEART: - if (Scan == (OBJECT_ADDRESS (Temp))) - { - *To_Pointer = To; - return (Scan); - } - sprintf (gc_death_message_buffer, - "gcloop: broken heart (0x%lx) in scan", - Temp); - gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To); - /*NOTREACHED*/ - - case TC_MANIFEST_NM_VECTOR: - case TC_MANIFEST_SPECIAL_NM_VECTOR: - Scan += OBJECT_DATUM (Temp); - break; +void * +newspace_to_tospace (void * addr) +{ + return + (((addr >= ((void *) newspace_start)) + && (addr <= ((void *) newspace_end))) + ? ((((byte_t *) addr) - ((byte_t *) newspace_start)) + + ((byte_t *) tospace_start)) + : addr); +} - /* Compiled code relocation. */ +#define SIMPLE_HANDLER(name) \ + (GCT_ENTRY (table, i)) = name; \ + break - case TC_LINKAGE_SECTION: +void +initialize_gc_table (gc_table_t * table, bool transport_p) +{ + unsigned int i; + for (i = 0; (i < N_TYPE_CODES); i += 1) + switch (gc_type_map[i]) { - switch (READ_LINKAGE_KIND (Temp)) - { - case REFERENCE_LINKAGE_KIND: - case ASSIGNMENT_LINKAGE_KIND: - { - /* Assumes that all others are objects of type TC_QUAD without - their type codes. - */ - - fast long count; - - Scan++; - for (count = (READ_CACHE_LINKAGE_COUNT (Temp)); - --count >= 0; - Scan += 1) - { - Temp = (* Scan); - GC_RAW_POINTER (Setup_Internal (true, - TRANSPORT_RAW_TRIPLE (), - RAW_BH (true, continue))); - } - Scan -= 1; - break; - } + case GC_NON_POINTER: SIMPLE_HANDLER (gc_handle_non_pointer); + case GC_CELL: SIMPLE_HANDLER (gc_handle_cell); + case GC_PAIR: SIMPLE_HANDLER (gc_handle_pair); + case GC_TRIPLE: SIMPLE_HANDLER (gc_handle_triple); + case GC_QUADRUPLE: SIMPLE_HANDLER (gc_handle_quadruple); + case GC_VECTOR: SIMPLE_HANDLER (gc_handle_unaligned_vector); + case GC_COMPILED: SIMPLE_HANDLER (gc_handle_cc_entry); + case GC_UNDEFINED: SIMPLE_HANDLER (gc_handle_undefined); - case OPERATOR_LINKAGE_KIND: - case GLOBAL_OPERATOR_LINKAGE_KIND: + case GC_SPECIAL: + switch (i) { - fast long count; - fast char * word_ptr; - SCHEME_OBJECT * end_scan; - - START_OPERATOR_RELOCATION (Scan); - count = (READ_OPERATOR_LINKAGE_COUNT (Temp)); - word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan)); - end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count)); - - while (--count >= 0) - { - Scan = ((SCHEME_OBJECT *) word_ptr); - word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); - EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); - GC_RAW_POINTER (Setup_Aligned - (true, - TRANSPORT_RAW_COMPILED (), - RAW_COMPILED_BH (true, - goto next_operator))); - next_operator: - STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); - } - Scan = end_scan; - END_OPERATOR_RELOCATION (Scan); - break; - } + case TC_BROKEN_HEART: + SIMPLE_HANDLER (gc_handle_broken_heart); - case CLOSURE_PATTERN_LINKAGE_KIND: - Scan += (READ_CACHE_LINKAGE_COUNT (Temp)); - break; + case TC_REFERENCE_TRAP: + SIMPLE_HANDLER (gc_handle_reference_trap); + + case TC_LINKAGE_SECTION: + SIMPLE_HANDLER (gc_handle_linkage_section); + + case TC_MANIFEST_CLOSURE: + SIMPLE_HANDLER (gc_handle_manifest_closure); + + case TC_MANIFEST_NM_VECTOR: + SIMPLE_HANDLER (gc_handle_nmv); default: - { - gc_death (TERM_EXIT, - "GC: Unknown compiler linkage kind.", - Scan, Free); - /*NOTREACHED*/ + std_gc_death ("unknown GC special type: %#02x\n", i); + break; } - } break; } + (GCT_ENTRY (table, TC_WEAK_CONS)) = gc_handle_weak_pair; + (GCT_ENTRY (table, TC_BIG_FLONUM)) = gc_handle_aligned_vector; + (GCT_ENTRY (table, TC_COMPILED_CODE_BLOCK)) = gc_handle_aligned_vector; + /* The next is for backwards compatibility with older bands. + This type used to be TC_MANIFEST_SPECIAL_NM_VECTOR. */ + (GCT_ENTRY (table, 0x2B)) = gc_handle_non_pointer; + (GCT_TUPLE (table)) = gc_tuple; + (GCT_VECTOR (table)) = gc_vector; + (GCT_CC_ENTRY (table)) = gc_cc_entry; + if (transport_p) + { + (GCT_PRECHECK_FROM (table)) = gc_precheck_from; + (GCT_TRANSPORT_WORDS (table)) = gc_transport_words; + } + else + { + (GCT_PRECHECK_FROM (table)) = gc_precheck_from_no_transport; + (GCT_TRANSPORT_WORDS (table)) = gc_no_transport_words; + } + (GCT_IGNORE_OBJECT_P (table)) = 0; + (GCT_RAW_ADDRESS_TO_OBJECT (table)) = gc_raw_address_to_object; + (GCT_OBJECT_TO_RAW_ADDRESS (table)) = gc_object_to_raw_address; + (GCT_RAW_ADDRESS_TO_CC_ENTRY (table)) = gc_raw_address_to_cc_entry; + (GCT_CC_ENTRY_TO_RAW_ADDRESS (table)) = gc_cc_entry_to_raw_address; +} + +gc_table_t * +std_gc_table (void) +{ + static bool initialized_p = false; + static gc_table_t table; + if (!initialized_p) + { + initialize_gc_table ((&table), true); + initialized_p = true; + } + return (&table); +} + +void +gc_scan_oldspace (SCHEME_OBJECT * scan, SCHEME_OBJECT * end) +{ + run_gc_loop (scan, (&end)); +} + +void +gc_scan_tospace (SCHEME_OBJECT * scan, SCHEME_OBJECT * end) +{ + if (end == 0) + run_gc_loop ((NEWSPACE_TO_TOSPACE (scan)), (&tospace_next)); + else + { + SCHEME_OBJECT * tend = (NEWSPACE_TO_TOSPACE (end)); + run_gc_loop ((NEWSPACE_TO_TOSPACE (scan)), (&tend)); + } +} + +static void +run_gc_loop (SCHEME_OBJECT * scan, SCHEME_OBJECT ** pend) +{ + gc_ignore_object_p_t * ignore_object_p + = (GCT_IGNORE_OBJECT_P (current_gc_table)); + INITIALIZE_GC_HISTORY (); + while (scan < (*pend)) + { + SCHEME_OBJECT object = (*scan); + HANDLE_GC_TRAP (scan, object); + if ((ignore_object_p != 0) && ((*ignore_object_p) (object))) + scan += 1; + else + { + current_scan = scan; + current_object = object; + scan + = ((* (GCT_ENTRY (current_gc_table, (OBJECT_TYPE (object))))) + (scan, object)); + } + } +} - case TC_MANIFEST_CLOSURE: +DEFINE_GC_TUPLE_HANDLER (gc_tuple) +{ + SCHEME_OBJECT * from = (OBJECT_ADDRESS (tuple)); + SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from)); + return + (OBJECT_NEW_ADDRESS (tuple, + ((new_address != 0) + ? new_address + : (GC_TRANSPORT_WORDS (from, n_words, false))))); +} + +DEFINE_GC_VECTOR_HANDLER (gc_vector) +{ + SCHEME_OBJECT * from = (OBJECT_ADDRESS (vector)); + SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (from)); + return + (OBJECT_NEW_ADDRESS (vector, + ((new_address != 0) + ? new_address + : (GC_TRANSPORT_WORDS (from, + (1 + (OBJECT_DATUM (*from))), + align_p))))); +} + +DEFINE_GC_OBJECT_HANDLER (gc_cc_entry) +{ +#ifdef CC_SUPPORT_P + SCHEME_OBJECT old_block = (cc_entry_to_block (object)); + SCHEME_OBJECT new_block = (GC_HANDLE_VECTOR (old_block, true)); + return (CC_ENTRY_NEW_BLOCK (object, + (OBJECT_ADDRESS (new_block)), + (OBJECT_ADDRESS (old_block)))); +#else + gc_no_cc_support (); + return (object); +#endif +} + +DEFINE_GC_PRECHECK_FROM (gc_precheck_from) +{ +#if 0 +#ifdef ENABLE_GC_DEBUGGING_TOOLS + if (!ADDRESS_IN_MEMORY_BLOCK_P (from)) + std_gc_death ("out of range pointer: %#lx", ((unsigned long) from)); +#endif +#endif + return + ((ADDRESS_IN_FROMSPACE_P (from)) + ? ((BROKEN_HEART_P (*from)) + ? (OBJECT_ADDRESS (*from)) + : 0) + : from); +} + +DEFINE_GC_PRECHECK_FROM (gc_precheck_from_no_transport) +{ +#if 0 +#ifdef ENABLE_GC_DEBUGGING_TOOLS + if (!ADDRESS_IN_MEMORY_BLOCK_P (from)) + std_gc_death ("out of range pointer: %#lx", ((unsigned long) from)); +#endif +#endif + return (from); +} + +DEFINE_GC_TRANSPORT_WORDS (gc_transport_words) +{ + SCHEME_OBJECT * from_start = from; + SCHEME_OBJECT * from_end = (from_start + n_words); + SCHEME_OBJECT * new_address; + + GUARANTEE_TOSPACE_OPEN (); + if (align_p) + while (!FLOATING_ALIGNED_P (newspace_next)) { - fast long count; - fast char * word_ptr; - SCHEME_OBJECT * area_end; + (*tospace_next++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); + newspace_next += 1; + } +#ifdef ENABLE_GC_DEBUGGING_TOOLS + if (tospace_next >= tospace_end) + std_gc_death ("tospace completely filled"); + { + SCHEME_OBJECT * end = (tospace_next + n_words); + if (end > tospace_end) + std_gc_death ("block overflows tospace: %#lx", + ((unsigned long) end)); + } + if (n_words == 0) + std_gc_death ("gc_transport_words: attempt to transfer zero words."); + if (n_words > 0x10000) + { + outf_error ("\nWarning: copying large block: %lu\n", n_words); + outf_flush_error (); + } +#endif + new_address = newspace_next; + while (from < from_end) + { + DEBUG_TRANSPORT_ONE_WORD (current_object, from); + (*tospace_next++) = (*from++); + newspace_next += 1; + } + (*from_start) = (MAKE_BROKEN_HEART (new_address)); + return (new_address); +} + +DEFINE_GC_TRANSPORT_WORDS (gc_no_transport_words) +{ + tospace_closed (); + return (from); +} + +DEFINE_GC_HANDLER (gc_handle_non_pointer) +{ + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_cell) +{ + (*scan) = (GC_HANDLE_TUPLE (object, 1)); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_pair) +{ + (*scan) = (GC_HANDLE_TUPLE (object, 2)); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_triple) +{ + (*scan) = (GC_HANDLE_TUPLE (object, 3)); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_quadruple) +{ + (*scan) = (GC_HANDLE_TUPLE (object, 4)); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_weak_pair) +{ + SCHEME_OBJECT * new_address = (GC_PRECHECK_FROM (OBJECT_ADDRESS (object))); + (*scan) + = ((new_address != 0) + ? (OBJECT_NEW_ADDRESS (object, new_address)) + : (gc_transport_weak_pair (object))); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_cc_entry) +{ + (*scan) = (GC_HANDLE_CC_ENTRY (object)); + return (scan + 1); +} - START_CLOSURE_RELOCATION (Scan); - Scan += 1; - count = (MANIFEST_CLOSURE_COUNT (Scan)); - word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan)); - area_end = ((MANIFEST_CLOSURE_END (Scan, count)) - 1); +DEFINE_GC_HANDLER (gc_handle_aligned_vector) +{ + (*scan) = (GC_HANDLE_VECTOR (object, true)); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_unaligned_vector) +{ + (*scan) = (GC_HANDLE_VECTOR (object, false)); + return (scan + 1); +} + +DEFINE_GC_HANDLER (gc_handle_broken_heart) +{ + std_gc_death ("broken heart in scan: %#lx", object); + return (scan); +} + +DEFINE_GC_HANDLER (gc_handle_nmv) +{ + return (scan + 1 + (OBJECT_DATUM (object))); +} - while ((--count) >= 0) +DEFINE_GC_HANDLER (gc_handle_reference_trap) +{ + (*scan) = (((OBJECT_DATUM (object)) <= TRAP_MAX_IMMEDIATE) + ? object + : (GC_HANDLE_TUPLE (object, 2))); + return (scan + 1); +} + +SCHEME_OBJECT +gc_raw_address_to_object (unsigned int type, SCHEME_OBJECT * address) +{ + return (MAKE_POINTER_OBJECT (type, address)); +} + +SCHEME_OBJECT * +gc_object_to_raw_address (SCHEME_OBJECT object) +{ + return (OBJECT_ADDRESS (object)); +} + +SCHEME_OBJECT +gc_raw_address_to_cc_entry (insn_t * address) +{ + return (MAKE_CC_ENTRY (address)); +} + +insn_t * +gc_cc_entry_to_raw_address (SCHEME_OBJECT entry) +{ + return (CC_ENTRY_ADDRESS (entry)); +} + +DEFINE_GC_HANDLER (gc_handle_linkage_section) +{ +#ifdef CC_SUPPORT_P + unsigned long count = (linkage_section_count (object)); + scan += 1; + switch (linkage_section_type (object)) + { + case LINKAGE_SECTION_TYPE_REFERENCE: + case LINKAGE_SECTION_TYPE_ASSIGNMENT: + while (count > 0) { - Scan = ((SCHEME_OBJECT *) (word_ptr)); - word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); - EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan); - GC_RAW_POINTER (Setup_Aligned - (true, - TRANSPORT_RAW_COMPILED (), - RAW_COMPILED_BH (true, - goto next_closure))); - next_closure: - STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan); + WRITE_REFERENCE_ADDRESS + ((GC_OBJECT_TO_RAW_ADDRESS + (GC_HANDLE_TUPLE + ((GC_RAW_ADDRESS_TO_OBJECT + (TC_HUNK3, + (READ_REFERENCE_ADDRESS (scan)))), + 3))), + scan); + scan += 1; + count -= 1; } + break; - Scan = area_end; - END_CLOSURE_RELOCATION (Scan); - break; + case LINKAGE_SECTION_TYPE_OPERATOR: + case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR: + { + DECLARE_RELOCATION_REFERENCE (ref); + START_OPERATOR_RELOCATION (scan, ref); + while (count > 0) + { + write_uuo_target + ((GC_CC_ENTRY_TO_RAW_ADDRESS + (GC_HANDLE_CC_ENTRY + (GC_RAW_ADDRESS_TO_CC_ENTRY + (READ_UUO_TARGET (scan, ref))))), + scan); + scan += UUO_LINK_SIZE; + count -= 1; + } } + break; - case_compiled_entry_point: - GC_Pointer (Setup_Aligned (true, - Transport_Compiled (), - Compiled_BH (true, goto after_entry))); - after_entry: - *Scan = Temp; - break; + default: + std_gc_death ("Unknown linkage-section type."); + break; + } + return (scan); +#else + gc_no_cc_support (); + return (scan); +#endif +} - case_Cell: - Setup_Pointer_for_GC(Transport_Cell()); - break; +DEFINE_GC_HANDLER (gc_handle_manifest_closure) +{ +#ifdef CC_SUPPORT_P +#ifdef EMBEDDED_CLOSURE_ADDRS_P + DECLARE_RELOCATION_REFERENCE (ref); + START_CLOSURE_RELOCATION (scan, ref); + scan += 1; + { + insn_t * start = (compiled_closure_start (scan)); + unsigned long count = (compiled_closure_count (scan)); + while (count > 0) + { + write_compiled_closure_target + ((GC_CC_ENTRY_TO_RAW_ADDRESS + (GC_HANDLE_CC_ENTRY + (GC_RAW_ADDRESS_TO_CC_ENTRY + (READ_COMPILED_CLOSURE_TARGET (start, ref))))), + start); + start = (compiled_closure_next (start)); + count -= 1; + } + scan = (skip_compiled_closure_padding (start)); + } + return (scan); +#else + return (compiled_closure_objects (scan + 1)); +#endif +#else + gc_no_cc_support (); + return (scan); +#endif +} + +DEFINE_GC_HANDLER (gc_handle_undefined) +{ + gc_bad_type (object); + return (scan + 1); +} + +/* Weak pairs are supported by adding an extra pass to the GC. During + the normal pass, a weak pair is transported to new space, but the + car of the pair is marked as a non-pointer so it won't be traced. + Then the original weak pair in old space is chained into a list. + This work is performed by 'gc_transport_weak_pair'. + + At the end of this pass, we have a list of all of the old weak + pairs. Since each weak pair in old space has a broken-heart + pointer to the corresponding weak pair in new space, we also have a + list of all of the new weak pairs. + + The extra pass then traverses this list, restoring the original + type of the object in the car of each pair. Then, if the car is a + pointer that hasn't been copied to new space, it is replaced by #F. + This work is performed by 'update_weak_pointers'. + + Here is a diagram showing the layout of a weak pair immediately + after it is transported to new space. After the normal pass is + complete, the only thing that will have changed is that the "old + CDR object" will have been updated to point to new space, if it is + a pointer object. + + + weak_chain old space | new space + | _______________________ | _______________________ + | |broken | new | | | | | + +=====>|heart | location ======|==>| NULL | old CAR data | + |_______|_____________| | |______|______________| + |old car| next in | | | | + | type | chain | | | old CDR object | + |_______|_____________| | |_____________________| + + */ + +static SCHEME_OBJECT +gc_transport_weak_pair (SCHEME_OBJECT pair) +{ + SCHEME_OBJECT * old_addr = (OBJECT_ADDRESS (pair)); + SCHEME_OBJECT * new_addr = (GC_TRANSPORT_WORDS (old_addr, 2, false)); + SCHEME_OBJECT old_car = (READ_TOSPACE (new_addr)); + SCHEME_OBJECT * caddr; + + /* Don't add pair to chain unless old_car is a pointer into old + space. */ + + switch (gc_ptr_type (old_car)) + { + case GC_POINTER_NORMAL: + caddr = (OBJECT_ADDRESS (old_car)); + break; + + case GC_POINTER_COMPILED: +#ifdef CC_SUPPORT_P + caddr = (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (old_car))); +#else + gc_no_cc_support (); +#endif + break; + + default: + caddr = 0; + break; + } + if ((caddr != 0) && (ADDRESS_IN_FROMSPACE_P (caddr))) + { + WRITE_TOSPACE (new_addr, (OBJECT_NEW_TYPE (TC_NULL, old_car))); + (old_addr[1]) + = ((weak_chain == 0) + ? (MAKE_OBJECT ((OBJECT_TYPE (old_car)), 0)) + : (MAKE_POINTER_OBJECT ((OBJECT_TYPE (old_car)), weak_chain))); + weak_chain = old_addr; +#ifdef ENABLE_GC_DEBUGGING_TOOLS + weak_chain_length += 1; +#endif + } + return (OBJECT_NEW_ADDRESS (pair, new_addr)); +} + +void +initialize_weak_chain (void) +{ + weak_chain = 0; +#ifdef ENABLE_GC_DEBUGGING_TOOLS + weak_chain_length = 0; +#endif +} + +void +update_weak_pointers (void) +{ +#if 0 +#ifdef ENABLE_GC_DEBUGGING_TOOLS + outf_console ("; **** Weak chain length = %lu\n", weak_chain_length); + outf_flush_console (); +#endif +#endif + while (weak_chain != 0) + { + SCHEME_OBJECT * new_addr = (OBJECT_ADDRESS (weak_chain[0])); + SCHEME_OBJECT obj = (weak_chain[1]); + SCHEME_OBJECT old_car + = (OBJECT_NEW_TYPE ((OBJECT_TYPE (obj)), + (READ_TOSPACE (new_addr)))); + SCHEME_OBJECT * addr; - case TC_REFERENCE_TRAP: - if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) + switch (gc_ptr_type (old_car)) { - /* It is a non pointer. */ + case GC_POINTER_NORMAL: + addr = (OBJECT_ADDRESS (old_car)); + WRITE_TOSPACE (new_addr, + ((BROKEN_HEART_P (*addr)) + ? (MAKE_OBJECT_FROM_OBJECTS (old_car, (*addr))) + : SHARP_F)); + break; + + case GC_POINTER_COMPILED: +#ifdef CC_SUPPORT_P + addr = (cc_entry_address_to_block_address + (CC_ENTRY_ADDRESS (old_car))); + WRITE_TOSPACE (new_addr, + ((BROKEN_HEART_P (*addr)) + ? (CC_ENTRY_NEW_BLOCK (old_car, + (OBJECT_ADDRESS (*addr)), + addr)) + : SHARP_F)); +#else + std_gc_death (0, "update_weak_pointers: unsupported compiled code"); +#endif + break; + + case GC_POINTER_NOT: + std_gc_death ("update_weak_pointers: non-pointer found"); break; } - /* Fall Through. */ + weak_chain = (((OBJECT_DATUM (obj)) == 0) ? 0 : (OBJECT_ADDRESS (obj))); + } +} + +void +std_gc_death (const char * format, ...) +{ + va_list ap; - case_Pair: - Setup_Pointer_for_GC (Transport_Pair ()); - break; + va_start (ap, format); + outf_fatal ("\n"); + voutf_fatal (format, ap); + outf_fatal ("\n"); + if (current_scan != 0) + { + outf_fatal ("scan = 0x%lx", ((unsigned long) current_scan)); + if (tospace_next != 0) + outf_fatal ("; to = 0x%lx", ((unsigned long) tospace_next)); + outf_fatal ("\n"); + } + va_end (ap); + if (gc_abort_handler != 0) + (*gc_abort_handler) (); + exit (1); +} + +static void +tospace_closed (void) +{ + std_gc_death ("GC transport not allowed here"); +} + +static void +tospace_open (void) +{ + if (tospace_next != 0) + std_gc_death ("tospace is open, should be closed"); +} + +void +gc_no_cc_support (void) +{ + std_gc_death ("No compiled-code support."); +} + +void +gc_bad_type (SCHEME_OBJECT object) +{ + std_gc_death ("bad type code: %#02lx %#lx", + (OBJECT_TYPE (object)), + object); +} - case TC_VARIABLE: - case_Triple: - Setup_Pointer_for_GC (Transport_Triple ()); - break; +#ifdef ENABLE_GC_DEBUGGING_TOOLS - case_Quadruple: - Setup_Pointer_for_GC (Transport_Quadruple ()); - break; +static void +initialize_gc_history (void) +{ + gc_scan_history_index = 0; + memset (gc_scan_history, 0, (sizeof (gc_scan_history))); + memset (gc_to_history, 0, (sizeof (gc_to_history))); +} - case_Aligned_Vector: - GC_Pointer (Setup_Aligned (true, - goto Move_Vector, - Normal_BH (true, continue))); - break; +static void +handle_gc_trap (SCHEME_OBJECT * scan, SCHEME_OBJECT object) +{ + (gc_scan_history[gc_scan_history_index]) = scan; + (gc_to_history[gc_scan_history_index]) = newspace_next; + gc_scan_history_index += 1; + if (gc_scan_history_index == GC_SCAN_HISTORY_SIZE) + gc_scan_history_index = 0; + if ((object == gc_trap) + || ((gc_scan_trap != 0) + && (scan >= gc_scan_trap)) + || ((gc_to_trap != 0) + && (newspace_next != 0) + && (newspace_next >= gc_to_trap))) + { + outf_error ("\nhandle_gc_trap: trap.\n"); + abort (); + } +} - case_Vector: - Setup_Pointer_for_GC (Transport_Vector ()); - break; +static void +check_newspace_sync (void) +{ + if ((newspace_next - newspace_start) + != (tospace_next - tospace_start)) + std_gc_death ("mismatch between newspace and tospace ptrs: %d/%d", + (newspace_next - newspace_start), + (tospace_next - tospace_start)); +} - case TC_FUTURE: - Setup_Pointer_for_GC (Transport_Future ()); - break; +void +collect_gc_object_references (SCHEME_OBJECT object, SCHEME_OBJECT collector) +{ + gc_object_referenced = object; + gc_object_references = collector; +} - case TC_WEAK_CONS: - Setup_Pointer_for_GC (Transport_Weak_Cons ()); - break; +static void +debug_transport_one_word (SCHEME_OBJECT object, SCHEME_OBJECT * from) +{ + if ((gc_object_references != SHARP_F) + && (gc_object_referenced == (*from))) + { + gc_object_references_count += 1; + if (gc_object_references_scan < gc_object_references_end) + (*gc_object_references_scan++) = object; + } +} + +void +initialize_gc_object_references (void) +{ + if (gc_object_references != SHARP_F) + { + /* Temporarily change to non-marked vector. */ + MEMORY_SET + (gc_object_references, 0, + (MAKE_OBJECT + (TC_MANIFEST_NM_VECTOR, + (OBJECT_DATUM (MEMORY_REF (gc_object_references, 0)))))); + gc_object_references_count = 0; + gc_object_references_scan = (VECTOR_LOC (gc_object_references, 1)); + gc_object_references_end + = (VECTOR_LOC (gc_object_references, + (VECTOR_LENGTH (gc_object_references)))); + /* Wipe the table. */ + VECTOR_SET (gc_object_references, 0, FIXNUM_ZERO); + { + SCHEME_OBJECT * scan = gc_object_references_scan; + while (scan < gc_object_references_end) + (*scan++) = SHARP_F; + } + (*tospace_next++) = gc_object_references; + newspace_next += 1; + } +} - default: - GC_BAD_TYPE ("gcloop", Temp); - /* Fall Through */ +void +finalize_gc_object_references (void) +{ + if (gc_object_references != SHARP_F) + { + SCHEME_OBJECT header = (MEMORY_REF (gc_object_references, 0)); + if (BROKEN_HEART_P (header)) + { + SCHEME_OBJECT * to_addr + = (NEWSPACE_TO_TOSPACE (OBJECT_ADDRESS (header))); + SCHEME_OBJECT * scan_to = to_addr; + SCHEME_OBJECT * scan_from = (VECTOR_LOC (gc_object_references, 0)); - case_Non_Pointer: - break; + /* Change back to marked vector. */ + (*scan_to++) + = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (OBJECT_DATUM (*to_addr)))); + + /* Store the count in the table. */ + VECTOR_SET (gc_object_references, 0, + (ULONG_TO_FIXNUM (gc_object_references_count))); + + /* Make sure tospace copy is up to date. */ + while (scan_from < gc_object_references_scan) + (*scan_to++) = (*scan_from++); + + /* No need to scan the vector's contents, since anything + here has already been transported. */ + } + gc_object_references = SHARP_F; + gc_object_referenced = SHARP_F; + } +} - } /* Switch_by_GC_Type */ - } /* For loop */ +#endif /* ENABLE_GC_DEBUGGING_TOOLS */ + +gc_type_t gc_type_map [N_TYPE_CODES] = +{ + GC_NON_POINTER, /* TC_NULL,etc */ + GC_PAIR, /* TC_LIST */ + GC_NON_POINTER, /* TC_CHARACTER */ + GC_PAIR, /* TC_SCODE_QUOTE */ + GC_TRIPLE, /* TC_PCOMB2 */ + GC_PAIR, /* TC_UNINTERNED_SYMBOL */ + GC_VECTOR, /* TC_BIG_FLONUM */ + GC_PAIR, /* TC_COMBINATION_1 */ + GC_NON_POINTER, /* TC_CONSTANT */ + GC_PAIR, /* TC_EXTENDED_PROCEDURE */ + GC_VECTOR, /* TC_VECTOR */ + GC_NON_POINTER, /* TC_RETURN_CODE */ + GC_TRIPLE, /* TC_COMBINATION_2 */ + GC_SPECIAL, /* TC_MANIFEST_CLOSURE */ + GC_VECTOR, /* TC_BIG_FIXNUM */ + GC_PAIR, /* TC_PROCEDURE */ + GC_PAIR, /* TC_ENTITY */ + GC_PAIR, /* TC_DELAY */ + GC_VECTOR, /* TC_ENVIRONMENT */ + GC_PAIR, /* TC_DELAYED */ + GC_TRIPLE, /* TC_EXTENDED_LAMBDA */ + GC_PAIR, /* TC_COMMENT */ + GC_VECTOR, /* TC_NON_MARKED_VECTOR */ + GC_PAIR, /* TC_LAMBDA */ + GC_NON_POINTER, /* TC_PRIMITIVE */ + GC_PAIR, /* TC_SEQUENCE_2 */ + GC_NON_POINTER, /* TC_FIXNUM */ + GC_PAIR, /* TC_PCOMB1 */ + GC_VECTOR, /* TC_CONTROL_POINT */ + GC_PAIR, /* TC_INTERNED_SYMBOL */ + GC_VECTOR, /* TC_CHARACTER_STRING,TC_VECTOR_8B */ + GC_PAIR, /* TC_ACCESS */ + GC_TRIPLE, /* TC_HUNK3_A */ + GC_PAIR, /* TC_DEFINITION */ + GC_SPECIAL, /* TC_BROKEN_HEART */ + GC_PAIR, /* TC_ASSIGNMENT */ + GC_TRIPLE, /* TC_HUNK3_B */ + GC_PAIR, /* TC_IN_PACKAGE */ + GC_VECTOR, /* TC_COMBINATION */ + GC_SPECIAL, /* TC_MANIFEST_NM_VECTOR */ + GC_COMPILED, /* TC_COMPILED_ENTRY */ + GC_PAIR, /* TC_LEXPR */ + GC_VECTOR, /* TC_PCOMB3 */ + GC_UNDEFINED, /* 0x2B */ + GC_TRIPLE, /* TC_VARIABLE */ + GC_NON_POINTER, /* TC_THE_ENVIRONMENT */ + GC_UNDEFINED, /* 0x2E */ + GC_VECTOR, /* TC_VECTOR_1B,TC_BIT_STRING */ + GC_NON_POINTER, /* TC_PCOMB0 */ + GC_VECTOR, /* TC_VECTOR_16B */ + GC_SPECIAL, /* TC_REFERENCE_TRAP */ + GC_TRIPLE, /* TC_SEQUENCE_3 */ + GC_TRIPLE, /* TC_CONDITIONAL */ + GC_PAIR, /* TC_DISJUNCTION */ + GC_CELL, /* TC_CELL */ + GC_PAIR, /* TC_WEAK_CONS */ + GC_QUADRUPLE, /* TC_QUAD */ + GC_SPECIAL, /* TC_LINKAGE_SECTION */ + GC_PAIR, /* TC_RATNUM */ + GC_NON_POINTER, /* TC_STACK_ENVIRONMENT */ + GC_PAIR, /* TC_COMPLEX */ + GC_VECTOR, /* TC_COMPILED_CODE_BLOCK */ + GC_VECTOR, /* TC_RECORD */ + GC_UNDEFINED /* 0x3F */ +}; + +#if (N_TYPE_CODES != 0x40) +# include "gcloop.c and object.h inconsistent -- gc_type_map" +#endif + +gc_type_t +gc_type_code (unsigned int type_code) +{ + return (gc_type_map[type_code]); +} + +gc_ptr_type_t +gc_ptr_type (SCHEME_OBJECT object) +{ + switch (GC_TYPE (object)) + { + case GC_SPECIAL: + return + (((REFERENCE_TRAP_P (object)) + && ((OBJECT_DATUM (object)) >= TRAP_MAX_IMMEDIATE)) + ? GC_POINTER_NORMAL + : GC_POINTER_NOT); - *To_Pointer = To; - return (To); + case GC_CELL: + case GC_PAIR: + case GC_TRIPLE: + case GC_QUADRUPLE: + case GC_VECTOR: + return (GC_POINTER_NORMAL); -} /* GCLoop */ + case GC_COMPILED: + return (GC_POINTER_COMPILED); + break; + + default: + return (GC_POINTER_NOT); + } +} + +SCHEME_OBJECT * +get_object_address (SCHEME_OBJECT object) +{ + switch (gc_ptr_type (object)) + { + case GC_POINTER_NORMAL: + return (OBJECT_ADDRESS (object)); + + case GC_POINTER_COMPILED: +#ifdef CC_SUPPORT_P + return (cc_entry_to_block_address (object)); +#endif + + default: + return (0); + } +} diff --git a/v7/src/microcode/gctype.c b/v7/src/microcode/gctype.c deleted file mode 100644 index 542cfa2a5..000000000 --- a/v7/src/microcode/gctype.c +++ /dev/null @@ -1,329 +0,0 @@ -/* -*-C-*- - -$Id: gctype.c,v 9.38 2007/01/05 21:19:25 cph Exp $ - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* This file contains the table which maps between Types and GC Types. */ - -#include "config.h" /* for definition of TYPE_CODE_LENGTH */ - - /*********************************/ - /* Mapping GC_Type to Type_Codes */ - /*********************************/ - -int GC_Type_Map[MAX_TYPE_CODE + 1] = { - GC_Non_Pointer, /* TC_NULL,etc */ - GC_Pair, /* TC_LIST */ - GC_Non_Pointer, /* TC_CHARACTER */ - GC_Pair, /* TC_SCODE_QUOTE */ - GC_Triple, /* TC_PCOMB2 */ - GC_Pair, /* TC_UNINTERNED_SYMBOL */ - GC_Vector, /* TC_BIG_FLONUM */ - GC_Pair, /* TC_COMBINATION_1 */ - GC_Non_Pointer, /* TC_CONSTANT */ - GC_Pair, /* TC_EXTENDED_PROCEDURE */ - GC_Vector, /* TC_VECTOR */ - GC_Non_Pointer, /* TC_RETURN_CODE */ - GC_Triple, /* TC_COMBINATION_2 */ - GC_Special, /* TC_MANIFEST_CLOSURE */ - GC_Vector, /* TC_BIG_FIXNUM */ - GC_Pair, /* TC_PROCEDURE */ - GC_Pair, /* TC_ENTITY */ - GC_Pair, /* TC_DELAY */ - GC_Vector, /* TC_ENVIRONMENT */ - GC_Pair, /* TC_DELAYED */ - GC_Triple, /* TC_EXTENDED_LAMBDA */ - GC_Pair, /* TC_COMMENT */ - GC_Vector, /* TC_NON_MARKED_VECTOR */ - GC_Pair, /* TC_LAMBDA */ - GC_Non_Pointer, /* TC_PRIMITIVE */ - GC_Pair, /* TC_SEQUENCE_2 */ - GC_Non_Pointer, /* TC_FIXNUM */ - GC_Pair, /* TC_PCOMB1 */ - GC_Vector, /* TC_CONTROL_POINT */ - GC_Pair, /* TC_INTERNED_SYMBOL */ - GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */ - GC_Pair, /* TC_ACCESS */ - GC_Triple, /* TC_HUNK3_A */ - GC_Pair, /* TC_DEFINITION */ - GC_Special, /* TC_BROKEN_HEART */ - GC_Pair, /* TC_ASSIGNMENT */ - GC_Triple, /* TC_HUNK3_B */ - GC_Pair, /* TC_IN_PACKAGE */ - -/* GC_Type_Map continues on next page */ - -/* GC_Type_Map continued */ - - GC_Vector, /* TC_COMBINATION */ - GC_Special, /* TC_MANIFEST_NM_VECTOR */ - GC_Compiled, /* TC_COMPILED_ENTRY */ - GC_Pair, /* TC_LEXPR */ - GC_Vector, /* TC_PCOMB3 */ - GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */ - GC_Triple, /* TC_VARIABLE */ - GC_Non_Pointer, /* TC_THE_ENVIRONMENT */ - GC_Vector, /* TC_FUTURE */ - GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */ - GC_Non_Pointer, /* TC_PCOMB0 */ - GC_Vector, /* TC_VECTOR_16B */ - GC_Special, /* TC_REFERENCE_TRAP */ - GC_Triple, /* TC_SEQUENCE_3 */ - GC_Triple, /* TC_CONDITIONAL */ - GC_Pair, /* TC_DISJUNCTION */ - GC_Cell, /* TC_CELL */ - GC_Pair, /* TC_WEAK_CONS */ - GC_Quadruple, /* TC_QUAD */ - GC_Special, /* TC_LINKAGE_SECTION */ - GC_Pair, /* TC_RATNUM */ - GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */ - GC_Pair, /* TC_COMPLEX */ - GC_Vector, /* TC_COMPILED_CODE_BLOCK */ - GC_Vector, /* TC_RECORD */ - -#if (TYPE_CODE_LENGTH == 6) - - GC_Undefined /* 0x3F */ - -#else /* (TYPE_CODE_LENGTH != 6) */ - - GC_Undefined, /* 0x3F */ - GC_Undefined, /* 0x40 */ - GC_Undefined, /* 0x41 */ - GC_Undefined, /* 0x42 */ - GC_Undefined, /* 0x43 */ - GC_Undefined, /* 0x44 */ - GC_Undefined, /* 0x45 */ - GC_Undefined, /* 0x46 */ - GC_Undefined, /* 0x47 */ - GC_Undefined, /* 0x48 */ - GC_Undefined, /* 0x49 */ - GC_Undefined, /* 0x4A */ - GC_Undefined, /* 0x4B */ - GC_Undefined, /* 0x4C */ - GC_Undefined, /* 0x4D */ - GC_Undefined, /* 0x4E */ - GC_Undefined, /* 0x4F */ - GC_Undefined, /* 0x50 */ - GC_Undefined, /* 0x51 */ - GC_Undefined, /* 0x52 */ - GC_Undefined, /* 0x53 */ - GC_Undefined, /* 0x54 */ - -/* GC_Type_Map continues on next page */ - -/* GC_Type_Map continued */ - - GC_Undefined, /* 0x55 */ - GC_Undefined, /* 0x56 */ - GC_Undefined, /* 0x57 */ - GC_Undefined, /* 0x58 */ - GC_Undefined, /* 0x59 */ - GC_Undefined, /* 0x5A */ - GC_Undefined, /* 0x5B */ - GC_Undefined, /* 0x5C */ - GC_Undefined, /* 0x5D */ - GC_Undefined, /* 0x5E */ - GC_Undefined, /* 0x5F */ - GC_Undefined, /* 0x60 */ - GC_Undefined, /* 0x61 */ - GC_Undefined, /* 0x62 */ - GC_Undefined, /* 0x63 */ - GC_Undefined, /* 0x64 */ - GC_Undefined, /* 0x65 */ - GC_Undefined, /* 0x66 */ - GC_Undefined, /* 0x67 */ - GC_Undefined, /* 0x68 */ - GC_Undefined, /* 0x69 */ - GC_Undefined, /* 0x6A */ - GC_Undefined, /* 0x6B */ - GC_Undefined, /* 0x6C */ - GC_Undefined, /* 0x6D */ - GC_Undefined, /* 0x6E */ - GC_Undefined, /* 0x6F */ - GC_Undefined, /* 0x70 */ - GC_Undefined, /* 0x71 */ - GC_Undefined, /* 0x72 */ - GC_Undefined, /* 0x73 */ - GC_Undefined, /* 0x74 */ - GC_Undefined, /* 0x75 */ - GC_Undefined, /* 0x76 */ - GC_Undefined, /* 0x77 */ - GC_Undefined, /* 0x78 */ - GC_Undefined, /* 0x79 */ - GC_Undefined, /* 0x7A */ - GC_Undefined, /* 0x7B */ - GC_Undefined, /* 0x7C */ - GC_Undefined, /* 0x7D */ - GC_Undefined, /* 0x7E */ - GC_Undefined, /* 0x7F */ - - GC_Undefined, /* 0x80 */ - GC_Undefined, /* 0x81 */ - GC_Undefined, /* 0x82 */ - GC_Undefined, /* 0x83 */ - GC_Undefined, /* 0x84 */ - GC_Undefined, /* 0x85 */ - GC_Undefined, /* 0x86 */ - GC_Undefined, /* 0x87 */ - GC_Undefined, /* 0x88 */ - GC_Undefined, /* 0x89 */ - GC_Undefined, /* 0x8A */ - GC_Undefined, /* 0x8B */ - GC_Undefined, /* 0x8C */ - GC_Undefined, /* 0x8D */ - GC_Undefined, /* 0x8E */ - GC_Undefined, /* 0x8F */ - GC_Undefined, /* 0x90 */ - GC_Undefined, /* 0x91 */ - GC_Undefined, /* 0x92 */ - GC_Undefined, /* 0x93 */ - GC_Undefined, /* 0x94 */ - GC_Undefined, /* 0x95 */ - GC_Undefined, /* 0x96 */ - GC_Undefined, /* 0x97 */ - GC_Undefined, /* 0x98 */ - GC_Undefined, /* 0x99 */ - GC_Undefined, /* 0x9A */ - GC_Undefined, /* 0x9B */ - GC_Undefined, /* 0x9C */ - GC_Undefined, /* 0x9D */ - GC_Undefined, /* 0x9E */ - GC_Undefined, /* 0x9F */ - GC_Undefined, /* 0xA0 */ - GC_Undefined, /* 0xA1 */ - GC_Undefined, /* 0xA2 */ - GC_Undefined, /* 0xA3 */ - GC_Undefined, /* 0xA4 */ - GC_Undefined, /* 0xA5 */ - GC_Undefined, /* 0xA6 */ - GC_Undefined, /* 0xA7 */ - GC_Undefined, /* 0xA8 */ - GC_Undefined, /* 0xA9 */ - GC_Undefined, /* 0xAA */ - GC_Undefined, /* 0xAB */ - GC_Undefined, /* 0xAC */ - GC_Undefined, /* 0xAD */ - GC_Undefined, /* 0xAE */ - GC_Undefined, /* 0xAF */ - - GC_Undefined, /* 0xB0 */ - GC_Undefined, /* 0xB1 */ - GC_Undefined, /* 0xB2 */ - GC_Undefined, /* 0xB3 */ - GC_Undefined, /* 0xB4 */ - GC_Undefined, /* 0xB5 */ - GC_Undefined, /* 0xB6 */ - GC_Undefined, /* 0xB7 */ - GC_Undefined, /* 0xB8 */ - GC_Undefined, /* 0xB9 */ - GC_Undefined, /* 0xBA */ - GC_Undefined, /* 0xBB */ - GC_Undefined, /* 0xBC */ - GC_Undefined, /* 0xBD */ - GC_Undefined, /* 0xBE */ - GC_Undefined, /* 0xBF */ - GC_Undefined, /* 0xC0 */ - GC_Undefined, /* 0xC1 */ - GC_Undefined, /* 0xC2 */ - GC_Undefined, /* 0xC3 */ - GC_Undefined, /* 0xC4 */ - GC_Undefined, /* 0xC5 */ - GC_Undefined, /* 0xC6 */ - GC_Undefined, /* 0xC7 */ - GC_Undefined, /* 0xC8 */ - GC_Undefined, /* 0xC9 */ - GC_Undefined, /* 0xCA */ - GC_Undefined, /* 0xCB */ - GC_Undefined, /* 0xCC */ - GC_Undefined, /* 0xCD */ - GC_Undefined, /* 0xCE */ - GC_Undefined, /* 0xCF */ - GC_Undefined, /* 0xD0 */ - GC_Undefined, /* 0xD1 */ - GC_Undefined, /* 0xD2 */ - GC_Undefined, /* 0xD3 */ - GC_Undefined, /* 0xD4 */ - GC_Undefined, /* 0xD5 */ - GC_Undefined, /* 0xD6 */ - GC_Undefined, /* 0xD7 */ - GC_Undefined, /* 0xD8 */ - GC_Undefined, /* 0xD9 */ - GC_Undefined, /* 0xDA */ - GC_Undefined, /* 0xDB */ - GC_Undefined, /* 0xDC */ - GC_Undefined, /* 0xDD */ - GC_Undefined, /* 0xDE */ - GC_Undefined, /* 0xDF */ - - GC_Undefined, /* 0xE0 */ - GC_Undefined, /* 0xE1 */ - GC_Undefined, /* 0xE2 */ - GC_Undefined, /* 0xE3 */ - GC_Undefined, /* 0xE4 */ - GC_Undefined, /* 0xE5 */ - GC_Undefined, /* 0xE6 */ - GC_Undefined, /* 0xE7 */ - GC_Undefined, /* 0xE8 */ - GC_Undefined, /* 0xE9 */ - GC_Undefined, /* 0xEA */ - GC_Undefined, /* 0xEB */ - GC_Undefined, /* 0xEC */ - GC_Undefined, /* 0xED */ - GC_Undefined, /* 0xEE */ - GC_Undefined, /* 0xEF */ - GC_Undefined, /* 0xF0 */ - GC_Undefined, /* 0xF1 */ - GC_Undefined, /* 0xF2 */ - GC_Undefined, /* 0xF3 */ - GC_Undefined, /* 0xF4 */ - GC_Undefined, /* 0xF5 */ - GC_Undefined, /* 0xF6 */ - GC_Undefined, /* 0xF7 */ - GC_Undefined, /* 0xF8 */ - GC_Undefined, /* 0xF9 */ - GC_Undefined, /* 0xFA */ - GC_Undefined, /* 0xFB */ - GC_Undefined, /* 0xFC */ - GC_Undefined, /* 0xFD */ - GC_Undefined, /* 0xFE */ - GC_Undefined /* last */ -#endif /* (TYPE_CODE_LENGTH != 6) */ - - }; - -#if (TYPE_CODE_LENGTH == 6) - -#if (MAX_TYPE_CODE != 0x3F) -#include "gctype.c and object.h inconsistent -- GC_Type_Map" -#endif - -#else /* (TYPE_CODE_LENGTH != 6) */ - -#if (MAX_TYPE_CODE != 0xFF) -#include "gctype.c and object.h inconsistent -- GC_Type_Map" -#endif - -#endif /* (TYPE_CODE_LENGTH == 6) */ diff --git a/v7/src/microcode/generic.c b/v7/src/microcode/generic.c index 2865729db..495ad64f3 100644 --- a/v7/src/microcode/generic.c +++ b/v7/src/microcode/generic.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: generic.c,v 9.43 2007/01/05 21:19:25 cph Exp $ +$Id: generic.c,v 9.44 2007/04/22 16:31:22 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,10 +30,10 @@ USA. #define INDIRECT(slot, arity) \ { \ - PRIMITIVE_CANONICALIZE_CONTEXT (); \ + canonicalize_primitive_context (); \ Will_Push (STACK_ENV_EXTRA_SLOTS + 1); \ - STACK_PUSH (Get_Fixed_Obj_Slot (slot)); \ - STACK_PUSH (STACK_FRAME_HEADER + arity); \ + STACK_PUSH (VECTOR_REF (fixed_objects, slot)); \ + PUSH_APPLY_FRAME_HEADER (arity); \ Pushed (); \ PRIMITIVE_ABORT (PRIM_APPLY); \ /*NOTREACHED*/ \ @@ -44,7 +44,7 @@ USA. { \ PRIMITIVE_HEADER (1); \ { \ - fast SCHEME_OBJECT x = (ARG_REF (1)); \ + SCHEME_OBJECT x = (ARG_REF (1)); \ if (FIXNUM_P (x)) \ return (BOOLEAN_TO_OBJECT (test (x))); \ } \ @@ -62,7 +62,7 @@ DEFINE_PRIMITIVE ("NEGATIVE?", Prim_negative, 1, 1, 0) { \ PRIMITIVE_HEADER (1); \ { \ - fast SCHEME_OBJECT x = (ARG_REF (1)); \ + SCHEME_OBJECT x = (ARG_REF (1)); \ if (FIXNUM_P (x)) \ return (long_to_integer ((FIXNUM_TO_LONG (x)) op 1)); \ } \ @@ -78,8 +78,8 @@ DEFINE_PRIMITIVE ("-1+", Prim_subtract_one, 1, 1, 0) { \ PRIMITIVE_HEADER (2); \ { \ - fast SCHEME_OBJECT x = (ARG_REF (1)); \ - fast SCHEME_OBJECT y = (ARG_REF (2)); \ + SCHEME_OBJECT x = (ARG_REF (1)); \ + SCHEME_OBJECT y = (ARG_REF (2)); \ if ((FIXNUM_P (x)) && (FIXNUM_P (y))) \ return (BOOLEAN_TO_OBJECT (test (x, y))); \ } \ @@ -99,8 +99,8 @@ DEFINE_PRIMITIVE ("&>", Prim_greater, 2, 2, 0) { \ PRIMITIVE_HEADER (2); \ { \ - fast SCHEME_OBJECT x = (ARG_REF (1)); \ - fast SCHEME_OBJECT y = (ARG_REF (2)); \ + SCHEME_OBJECT x = (ARG_REF (1)); \ + SCHEME_OBJECT y = (ARG_REF (2)); \ if ((FIXNUM_P (x)) && (FIXNUM_P (y))) \ return (long_to_integer ((FIXNUM_TO_LONG (x)) op \ (FIXNUM_TO_LONG (y)))); \ diff --git a/v7/src/microcode/getpgsz.h b/v7/src/microcode/getpgsz.h deleted file mode 100644 index 32adae61e..000000000 --- a/v7/src/microcode/getpgsz.h +++ /dev/null @@ -1,25 +0,0 @@ -#ifdef BSD -#ifndef BSD4_1 -#define HAVE_GETPAGESIZE -#endif -#endif - -#ifndef HAVE_GETPAGESIZE - -#include - -#ifdef EXEC_PAGESIZE -#define getpagesize() EXEC_PAGESIZE -#else -#ifdef NBPG -#define getpagesize() NBPG * CLSIZE -#ifndef CLSIZE -#define CLSIZE 1 -#endif /* no CLSIZE */ -#else /* no NBPG */ -#define getpagesize() NBPC -#endif /* no NBPG */ -#endif /* no EXEC_PAGESIZE */ - -#endif /* not HAVE_GETPAGESIZE */ - diff --git a/v7/src/microcode/gpio.c b/v7/src/microcode/gpio.c deleted file mode 100644 index 91ff5bef1..000000000 --- a/v7/src/microcode/gpio.c +++ /dev/null @@ -1,176 +0,0 @@ -/* -*-C-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* $Id: gpio.c,v 1.15 2007/01/05 21:19:25 cph Exp $ */ - -/* Scheme primitives for GPIO */ - -#include "scheme.h" -#include "prims.h" -#include "ux.h" -#include "uxio.h" - -#include -#include -#include - -DEFINE_PRIMITIVE ("GPIO-OPEN", Prim_gpio_open, 1, 1, 0) -{ - int gpio_channel; - - PRIMITIVE_HEADER (1); - - gpio_channel = (open (STRING_ARG (1), (O_RDWR | O_NDELAY))); - if (gpio_channel == -1) - { - error_external_return(); - } - if (!(LONG_TO_FIXNUM_P( gpio_channel))) - { - /* This is a crock, but guarantees that we can assume fixnum - in all the other primitives. - */ - close (gpio_channel); - error_external_return(); - } - - /* Reset interface */ - - io_reset (gpio_channel); - - /* Timeout in 5 sec. */ - io_timeout_ctl (gpio_channel, 5000000); - - /* Guarantee exclusive access. */ - io_lock (gpio_channel); - -#if 1 - /* Map into address space. */ - io_burst (gpio_channel, 1); -#endif - - /* Set data width to 16 bits. */ - io_width_ctl (gpio_channel, 16); - - PRIMITIVE_RETURN( LONG_TO_FIXNUM (gpio_channel)); -} - - -DEFINE_PRIMITIVE ("GPIO-CLOSE", Prim_gpio_close, 1, 1, 0) -{ - int gpio_channel; - - PRIMITIVE_HEADER (1); - - gpio_channel = (UNSIGNED_FIXNUM_ARG (1)); - -#if 1 - io_burst (gpio_channel, 0); -#endif - - io_unlock (gpio_channel); - close (gpio_channel); - - PRIMITIVE_RETURN( long_to_integer( gpio_channel )); -} - - -DEFINE_PRIMITIVE ("GPIO-READ-STATUS", Prim_gpio_read_status, 1, 1, 0) -{ - int gpio_channel; - - PRIMITIVE_HEADER (1); - - gpio_channel = (UNSIGNED_FIXNUM_ARG (1)); - - PRIMITIVE_RETURN( LONG_TO_FIXNUM( gpio_get_status( gpio_channel))); -} - - -DEFINE_PRIMITIVE ("GPIO-WRITE-CONTROL", Prim_gpio_write_control, 2, 2, 0) -{ - int gpio_channel, control_value; - - PRIMITIVE_HEADER (2); - - gpio_channel = (UNSIGNED_FIXNUM_ARG (1)); - control_value = (UNSIGNED_FIXNUM_ARG (2)); - - PRIMITIVE_RETURN( LONG_TO_FIXNUM( gpio_set_ctl( gpio_channel, control_value))); -} - -/* Both of the following return the number of bytes transferred. */ - - -DEFINE_PRIMITIVE ("GPIO-READ-STRING!", Prim_gpio_read_string, 4, 4, 0) -{ - int gpio_channel, count; - char *data; - - PRIMITIVE_HEADER (4); - - gpio_channel = (UNSIGNED_FIXNUM_ARG (1)); - data = ((char *) (STRING_LOC ((ARG_REF (2)), (UNSIGNED_FIXNUM_ARG (3))))); - count = (UNSIGNED_FIXNUM_ARG (4)); - - while (1) - { - long scr = (read (gpio_channel, data, count)); - if (scr < 0) - { - UX_prim_check_errno (syscall_read); - continue; - } - if (scr > count) - error_external_return (); - PRIMITIVE_RETURN( LONG_TO_FIXNUM (scr)); - } -} - - -DEFINE_PRIMITIVE ("GPIO-WRITE-STRING", Prim_gpio_write_string, 4, 4, 0) -{ - int gpio_channel, count; - char *data; - - PRIMITIVE_HEADER (4); - - gpio_channel = (UNSIGNED_FIXNUM_ARG (1)); - data = ((char *) (STRING_LOC ((ARG_REF (2)), (UNSIGNED_FIXNUM_ARG (3))))); - count = (UNSIGNED_FIXNUM_ARG (4)); - - while (1) - { - long scr = (write (gpio_channel, data, count)); - if (scr < 0) - { - UX_prim_check_errno (syscall_write); - continue; - } - if (scr > count) - error_external_return (); - PRIMITIVE_RETURN( LONG_TO_FIXNUM (scr)); - } -} diff --git a/v7/src/microcode/hard-par.c b/v7/src/microcode/hard-par.c deleted file mode 100644 index 848a77b1a..000000000 --- a/v7/src/microcode/hard-par.c +++ /dev/null @@ -1,1757 +0,0 @@ -/* Everything you wanted to know about your machine and C compiler, - but didn't know who to ask. - Author: Steven Pemberton, CWI, Amsterdam; steven@cwi.nl - Bugfixes and upgrades gratefully received. - - Name changed to `hard-params' by Richard Stallman, April 89. - xmalloc function defined, Richard Stallman, June 89. - Some changes to make it compile and generate "safer" output - for compilers that predefine some of these constants by - Matt Birkholz and the MIT Scheme Team. - - Copyright (c) 1988, 1989 Steven Pemberton, CWI, Amsterdam. - All rights reserved. - - COMPILING - With luck and a following wind, just the following will work: - cc hard-params.c -o hard-params - - If your compiler doesn't support: add flag: - signed char (eg pcc) -DNO_SC - unsigned char -DNO_UC - unsigned short and long -DNO_UI - signal(), or setjmp/longjmp() -DNO_SIG - - Try it first with no flags, and see if you get any errors - you might be - surprised. (Most non-ANSI compilers need -DNO_SC, though.) - Some compilers need a -f flag for floating point. - - Don't use any optimisation flags: the program may not work if you do. - Though "while (a+1.0-a-1.0 == 0.0)" may look like "while(1)" to an - optimiser, to a floating-point unit there's a world of difference. - - Some compilers offer various flags for different floating point - modes; it's worth trying all possible combinations of these. - - Add -DID=\"name\" if you want the machine/flags identified in the output. - - SYSTEM DEPENDENCIES - You may possibly need to add some calls to signal() for other sorts of - exception on your machine than SIGFPE, and SIGOVER. See lines beginning - #ifdef SIGxxx in main() (and communicate the differences to me!). - - If your C preprocessor doesn't have the predefined __FILE__ macro, and - you want to call this file anything other than hard-params.c, change the - #define command for __FILE__ accordingly. If it doesn't accept macro - names at all in #include lines, order a new C compiler. While you're - waiting for it to arrive, change the last #include in this file (the - last but one line) accordingly. - - OUTPUT - Run without argument to get the information as English text. If run - with argument -l (e.g. hard-params -l), output is a series of #define's for - the ANSI standard limits.h include file, excluding MB_MAX_CHAR. If run - with argument -f, output is a series of #define's for the ANSI standard - float.h include file. Flag -v gives verbose output: output includes the - English text above as C comments. The program exit(0)'s if everything - went ok, otherwise it exits with a positive number, telling how many - problems there were. - - VERIFYING THE COMPILER - If, having produced the float.h and limits.h header files, you want to - verify that the compiler reads them back correctly (there are a lot of - boundary cases, of course, like minimum and maximum numbers), you can - recompile hard-params.c with -DVERIFY set (plus the other flags that you used - when compiling the version that produced the header files). This then - recompiles the program so that it #includes "limits.h" and "float.h", - and checks that the constants it finds there are the same as the - constants it produces. Run the resulting program with hard-params -fl. As of - this writing, of 21 compiler/flags combinations only 1 compiler has - passed without error! (The honour goes to 'pcc' on an IBM RT.) - - You can also use this option if your compiler already has both files, - and you want to confirm that this program produces the right results. - - TROUBLE SHOOTING. - This program is now quite trustworthy, and suspicious and wrong output - may well be caused by bugs in the compiler, not in the program (however - of course, this is not guaranteed, and no responsibility can be - accepted, etc.) - - The program only works if overflows are ignored by the C system or - are catchable with signal(). - - If the program fails to run to completion (often with the error message - "Unexpected signal at point x"), this often turns out to be a bug in the - C compiler's run-time system. Check what was about to be printed, and - try to narrow the problem down. - - Another possible problem is that you have compiled the program to produce - loss-of-precision arithmetic traps. The program cannot cope with these, - and you should re-compile without them. (They should never be the default). - - Make sure you compiled with optimisation turned off. - - Output preceded by *** WARNING: identifies behaviour of the C system - deemed incorrect by the program. Likely problems are that printf or - scanf don't cope properly with certain boundary numbers. For each float - and double that is printed, the printed value is checked that it is - correct by using sscanf to read it back. Care is taken that numbers are - printed with enough digits to uniquely identify them, and therefore that - they can be read back identically. If the number read back is different, - the program prints a warning message. If the two numbers in the warning - look identical, then printf is more than likely rounding the last - digit(s) incorrectly. To put you at ease that the two really are - different, the bit patterns of the two numbers are also printed. The - difference is very likely in the last bit. Many scanf's read the - minimum double back as 0.0, and similarly cause overflow when reading - the maximum double. The program quite ruthlessly declares all these - behaviours faulty. - - The warning that "a cast didn't work" refers to cases like this: - - float f; - #define C 1.234567890123456789 - f= C; - if (f != (float) C) printf ("Wrong!"); - - A faulty compiler will widen f to double and ignore the cast to float, - and because there is more accuracy in a double than a float, fail to - recognise that they are the same. In the actual case in point, f and C - are passed as parameters to a function that discovers they are not equal, - so it's just possible that the error was in the parameter passing, - not in the cast (see function Validate()). - For ANSI C, which has float constants, the error message is "constant has - wrong precision". - - REPORTING PROBLEMS - If the program doesn't work for you for any reason that can't be - narrowed down to a problem in the C compiler, or it has to be changed in - order to get it to compile, or it produces suspicious output (like a very - low maximum float, for instance), please mail the problem and an example - of the incorrect output to steven@cwi.nl or mcvax!steven.uucp, so that - improvements can be worked into future versions; mcvax/cwi.nl is the - European backbone, and is connected to uunet and other fine hosts. - - This version of the program is the first to try to catch and diagnose - bugs in the compiler/run-time system. I would be especially pleased to - have reports of failures so that I can improve this service. - - I apologise unreservedly for the contorted use of the preprocessor... - - THE SMALL PRINT - You may copy and distribute verbatim copies of this source file. - - You may modify this source file, and copy and distribute such - modified versions, provided that you leave the copyright notice - at the top of the file and also cause the modified file to carry - prominent notices stating that you changed the files and the date - of any change; and cause the whole of any work that you distribute - or publish, that in whole or in part contains or is a derivative of - this program or any part thereof, to be licensed at no charge to - all third parties on terms identical to those here. - - If you do have a fix to any problem, please send it to me, so that - other people can have the benefits. - - While every effort has been taken to make this program as reliable as - possible, no responsibility can be taken for the correctness of the - output, or suitability for any particular use. - - ACKNOWLEDGEMENTS - Many people have given time and ideas to making this program what it is. - To all of them thanks, and apologies for not mentioning them by name. -*/ - -#ifndef __FILE__ -#define __FILE__ "hard-params.c" -#endif - -#ifndef PASS -#define PASS 1 -#define PASS1 1 -#define VERSION "4.1" - -/* Procedure just marks the functions that don't return a result */ -#ifdef Procedure -#undef Procedure -#endif -#define Procedure - -#define Vprintf if (V) printf - -/* stdc is used in tests like if (stdc) */ -#ifdef __STDC__ -#define stdc 1 -#else -#define stdc 0 -#endif - -/* volatile is used to reduce the chance of optimisation, - and to prevent variables being put in registers (when setjmp/longjmp - wouldn't work as we want) */ -#ifndef __STDC__ -#define volatile -#endif - -#include - -#ifdef VERIFY -#include "limits.h" -#include "float.h" -#endif - -#ifdef NO_SIG /* There's no signal(), or setjmp/longjmp() */ - - /* Dummy routines instead */ - int lab=1; - int setjmp(lab) int lab; { return(0); } - signal(i, p) int i, (*p)(); {} - -#else - -#include -#include - - jmp_buf lab; - overflow(sig) int sig; { /* what to do on overflow/underflow */ - signal(sig, overflow); - longjmp(lab, 1); - } - -#endif /*NO_SIG*/ - -#define Unexpected(place) if (setjmp(lab)!=0) croak(place) - -int V= 0, /* verbose */ - L= 0, /* produce limits.h */ - F= 0, /* produce float.h */ - bugs=0; /* The number of (possible) bugs in the output */ - -char co[4], oc[4]; /* Comment starter and ender symbols */ - -int bits_per_byte; /* the number of bits per unit returned by sizeof() */ - -#ifdef TEST -/* Set the fp modes on a SUN with 68881 chip, to check that different - rounding modes etc. get properly detected. - Compile with additional flag -DTEST, and run with additional parameter - +hex-number, to set the 68881 mode register to hex-number -*/ - -/* Bits 0x30 = rounding mode: */ -#define ROUND_BITS 0x30 -#define TO_NEAREST 0x00 -#define TO_ZERO 0x10 -#define TO_MINUS_INF 0x20 -#define TO_PLUS_INF 0x30 /* The SUN FP user's guide seems to be wrong here */ - -/* Bits 0xc0 = extended rounding: */ -#define EXT_BITS 0xc0 -#define ROUND_EXTENDED 0x00 -#define ROUND_SINGLE 0x40 -#define ROUND_DOUBLE 0x80 - -/* Enabled traps: */ -#define EXE_INEX1 0x100 -#define EXE_INEX2 0x200 -#define EXE_DZ 0x400 -#define EXE_UNFL 0x800 -#define EXE_OVFL 0x1000 -#define EXE_OPERR 0x2000 -#define EXE_SNAN 0x4000 -#define EXE_BSUN 0x8000 - -printmode(new) unsigned new; { - fpmode_(&new); - printf("New fp mode:\n"); - printf(" Round toward "); - switch (new & ROUND_BITS) { - case TO_NEAREST: printf("nearest"); break; - case TO_ZERO: printf("zero"); break; - case TO_MINUS_INF: printf("minus infinity"); break; - case TO_PLUS_INF: printf("plus infinity"); break; - default: printf("???"); break; - } - - printf("\n Extended rounding precision: "); - - switch (new & EXT_BITS) { - case ROUND_EXTENDED: printf("extended"); break; - case ROUND_SINGLE: printf("single"); break; - case ROUND_DOUBLE: printf("double"); break; - default: printf("???"); break; - } - - printf("\n Enabled exceptions:"); - if (new & (unsigned) EXE_INEX1) printf(" inex1"); - if (new & (unsigned) EXE_INEX2) printf(" inex2"); - if (new & (unsigned) EXE_DZ) printf(" dz"); - if (new & (unsigned) EXE_UNFL) printf(" unfl"); - if (new & (unsigned) EXE_OVFL) printf(" ovfl"); - if (new & (unsigned) EXE_OPERR) printf(" operr"); - if (new & (unsigned) EXE_SNAN) printf(" snan"); - if (new & (unsigned) EXE_BSUN) printf(" bsun"); - printf("\n"); -} - -int setmode(s) char *s; { - unsigned mode=0, dig; - char c; - - while (*s) { - c= *s++; - if (c>='0' && c<='9') dig= c-'0'; - else if (c>='a' && c<='f') dig= c-'a'+10; - else if (c>='A' && c<='F') dig= c-'A'+10; - else return 1; - mode= mode<<4 | dig; - } - printmode(mode); - return 0; -} -#else -int setmode(s) char *s; { - fprintf(stderr, "Can't set mode: not compiled with TEST\n"); - return(1); -} -#endif - -croak(place) int place; { - printf("*** Unexpected signal at point %d\n", place); - exit(bugs+1); /* An exit isn't essential here, but avoids loops */ -} - -/* This is here in case alloca.c is used. That wants to call this. */ - -char * -xmalloc(size) unsigned size; { - char *malloc(); - char *value = malloc(size); - if (value == 0) { - fprintf(stderr, "Virtual memory exceeded\n"); - exit(bugs+1); - } - return value; -} - -main(argc, argv) int argc; char *argv[]; { - int dprec, fprec, lprec, basic(), fprop(), dprop(), efprop(), edprop(); - char *malloc(); - unsigned int size; - long total; - int i; char *s; int bad; - -#ifdef SIGFPE - signal(SIGFPE, overflow); -#endif -#ifdef SIGOVER - signal(SIGOVER, overflow); -#endif -/* Add more calls as necessary */ - - Unexpected(1); - - bad=0; - for (i=1; i < argc; i++) { - s= argv[i]; - if (*s == '-') { - s++; - while (*s) { - switch (*(s++)) { - case 'v': V=1; break; - case 'l': L=1; break; - case 'f': F=1; break; - default: bad=1; break; - } - } - } else if (*s == '+') { - s++; - bad= setmode(s); - } else bad= 1; - } - if (bad) { - fprintf(stderr, - "Usage: %s [-vlf]\n v=Verbose l=Limits.h f=Float.h\n", - argv[0]); - exit(1); - } - if (L || F) { - co[0]= '/'; oc[0]= ' '; - co[1]= '*'; oc[1]= '*'; - co[2]= ' '; oc[2]= '/'; - co[3]= '\0'; oc[3]= '\0'; - } else { - co[0]= '\0'; oc[0]= '\0'; - V=1; - } - - if (L) printf("%slimits.h%s\n", co, oc); - if (F) printf("%sfloat.h%s\n", co, oc); -#ifdef ID - printf("%sProduced on %s by hard-params version %s, CWI, Amsterdam%s\n", - co, ID, VERSION, oc); -#else - printf("%sProduced by hard-params version %s, CWI, Amsterdam%s\n", - co, VERSION, oc); -#endif - if (F) printf ("\n#ifndef _FLOAT_H_\n"); - -#ifdef VERIFY - printf("%sVerification phase%s\n", co, oc); -#endif - -#ifdef NO_SIG - Vprintf("%sCompiled without signal(): %s%s\n", - co, - "there's nothing that can be done if overflow occurs", - oc); -#endif -#ifdef NO_SC - Vprintf("%sCompiled without signed char%s\n", co, oc); -#endif -#ifdef NO_UC - Vprintf("%Compiled without unsigned char%s\n", co, oc); -#endif -#ifdef NO_UI - Vprintf("%Compiled without unsigned short or long%s\n", co, oc); -#endif -#ifdef __STDC__ - Vprintf("%sCompiler claims to be ANSI C level %d%s\n", - co, __STDC__, oc); -#else - Vprintf("%sCompiler does not claim to be ANSI C%s\n", co, oc); -#endif - printf("\n"); - bits_per_byte= basic(); - Vprintf("\n"); - if (F||V) { - fprec= fprop(bits_per_byte); - dprec= dprop(bits_per_byte); - lprec= ldprop(bits_per_byte); - efprop(fprec, dprec, lprec); - edprop(fprec, dprec, lprec); - eldprop(fprec, dprec, lprec); - } - if (V) { - /* An extra goody: the approximate amount of data-space */ - /* Allocate store until no more available */ - size=1<<((bits_per_byte*sizeof(int))-2); - total=0; - while (size!=0) { - while (malloc(size)!=(char *)NULL) total+=(size/2); - size/=2; - } - - Vprintf("%sMemory mallocatable ~= %ld Kbytes%s\n", - co, (total+511)/512, oc); - } - - if (F) printf ("\n#endif %snot _FLOAT_H_%s\n", co, oc); - - exit(bugs); -} - -Procedure eek_a_bug(problem) char *problem; { - printf("\n%s*** WARNING: %s%s\n", co, problem, oc); - bugs++; -} - -Procedure i_define(sort, name, val, req) char *sort, *name; long val, req; -{ - printf ("\n#ifndef %s%s\n", sort, name); - if (val >= 0) - { - printf("#define %s%s %ld\n", sort, name, val); - } else - { - printf("#define %s%s (%ld)\n", sort, name, val); - } - if (val != req) - { - printf("%s*** Verify failed for above #define!\n", co); - printf(" Compiler has %ld for value%s\n\n", req, oc); - bugs++; - } - printf ("#endif %s%s%s%s\n", co, sort, name, oc); - Vprintf("\n"); -} - -#ifndef NO_UI - -#ifdef __STDC__ -#define U "U" -#else -#define U "" -#endif - -Procedure u_define(sort, name, val, req) - char *sort, *name; unsigned long val, req; -{ - printf ("\n#ifndef %s%s\n", sort, name); - printf("#define %s%s %lu%s\n", sort, name, val, U); - if (val != req) { - printf("%s*** Verify failed for above #define!\n", co); - printf(" Compiler has %lu for value%s\n\n", req, oc); - bugs++; - } - printf ("#endif %s%s%s%s\n", co, sort, name, oc); - Vprintf("\n"); -} -#endif - -/* Long_double is the longest floating point type available: */ -#ifdef __STDC__ -#define Long_double long double -#else -#define Long_double double -#endif - -char *f_rep(); - -Procedure f_define(sort, name, precision, val, mark) - char *sort, *name; int precision; Long_double val; char *mark; -{ - printf ("\n#ifndef %s%s\n", sort, name); - if (stdc) - { - printf("#define %s%s %s%s\n", - sort, name, f_rep(precision, val), mark); - } else if (*mark == 'F') - { - /* non-ANSI C has no float constants, so cast the constant */ - printf("#define %s%s ((float)%s)\n", - sort, name, f_rep(precision, val)); - } else - { - printf("#define %s%s %s\n", sort, name, f_rep(precision, val)); - } - printf ("#endif %s%s%s%s\n", co, sort, name, oc); - Vprintf("\n"); -} - -int floor_log(base, x) int base; Long_double x; { /* return floor(log base(x)) */ - int r=0; - while (x>=base) { r++; x/=base; } - return r; -} - -int ceil_log(base, x) int base; Long_double x; { - int r=0; - while (x>1.0) { r++; x/=base; } - return r; -} - -int exponent(x, fract, exp) Long_double x; double *fract; int *exp; { - /* Split x into a fraction and a power of ten; - returns 0 if x is unusable, 1 otherwise. - Only used for error messages about faulty output. - */ - int r=0, neg=0; - Long_double old; - *fract=0.0; *exp=0; - if (x<0.0) { - x= -x; - neg= 1; - } - if (x==0.0) return 1; - if (x>=10.0) { - while (x>=10.0) { - old=x; r++; x/=10.0; - if (old==x) return 0; - } - } else { - while (x<1.0) { - old=x; r--; x*=10.0; - if (old==x) return 0; - } - } - if (neg) *fract= -x; - else *fract=x; - *exp=r; - return 1; -} - -#define fabs(x) (((x)<0.0)?(-x):(x)) - -char *f_rep(precision, val) int precision; Long_double val; { - static char buf[1024]; - char *f1; - if (sizeof(double) == sizeof(Long_double)) { - /* Assume they're the same, and use non-stdc format */ - /* This is for stdc compilers using non-stdc libraries */ - f1= "%.*e"; - } else { - /* It had better support Le then */ - f1= "%.*Le"; - } - sprintf(buf, f1, precision, val); - return buf; -} - -Procedure bitpattern(p, size) char *p; int size; { - char c; - int i, j; - - for (i=1; i<=size; i++) { - c= *p; - p++; - for (j=bits_per_byte-1; j>=0; j--) - printf("%c", (c>>j)&1 ? '1' : '0'); - if (i!=size) printf(" "); - } -} - -#define Order(x, px, mode)\ - printf("%s %s ", co, mode); for (i=0; i>(bits_per_byte*(sizeof(x)-i)))&mask)); }\ - printf("%s\n", oc); - -Procedure endian(bits_per_byte) int bits_per_byte; { - /*unsigned*/ short s=0; - /*unsigned*/ int j=0; - /*unsigned*/ long l=0; - - char *ps= (char *) &s, - *pj= (char *) &j, - *pl= (char *) &l, - *c= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; - unsigned int mask, i; - - mask=0; - for (i=1; i<=bits_per_byte; i++) mask= (mask<<1)|1; - - if (V) { - printf("%sCharacter order:%s\n", co, oc); - Order(s, ps, "short:"); - Order(j, pj, "int: "); - Order(l, pl, "long: "); - } -} - -#ifdef VERIFY -#ifndef SCHAR_MAX -#define SCHAR_MAX char_max -#define SCHAR_MIN char_min -#endif -#ifndef UCHAR_MAX -#define UCHAR_MAX char_max -#endif -#else -#ifdef CHAR_BIT -#undef CHAR_BIT -#endif -#define CHAR_BIT char_bit -#ifdef CHAR_MAX -#undef CHAR_MAX -#endif -#define CHAR_MAX char_max -#ifdef CHAR_MIN -#undef CHAR_MIN -#endif -#define CHAR_MIN char_min -#ifdef SCHAR_MAX -#undef SCHAR_MAX -#endif -#define SCHAR_MAX char_max -#ifdef SCHAR_MIN -#undef SCHAR_MIN -#endif -#define SCHAR_MIN char_min -#ifdef UCHAR_MAX -#undef UCHAR_MAX -#endif -#define UCHAR_MAX char_max -#endif /* not VERIFY */ - -int cprop() { /* Properties of character */ - volatile char c, char_max, char_min; - volatile int bits_per_byte, is_signed; - long char_bit; - - Unexpected(2); - - /* Calculate number of bits per character *************************/ - c=1; bits_per_byte=0; - do { c=c<<1; bits_per_byte++; } while(c!=0); - c= (char)(-1); - if (((int)c)<0) is_signed=1; - else is_signed=0; - Vprintf("%sChar = %d bits, %ssigned%s\n", - co, (int)sizeof(c)*bits_per_byte, (is_signed?"":"un"), oc); - char_bit=(long)(sizeof(c)*bits_per_byte); - if (L) i_define("CHAR", "_BIT", char_bit, (long) CHAR_BIT); - - c=0; char_max=0; - c++; - if (setjmp(lab)==0) { /* Yields char_max */ - while (c>char_max) { - char_max=c; - c++; - } - } else { - Vprintf("%sCharacter overflow generates a trap!%s\n", co, oc); - } - c=0; char_min=0; - c--; - if (setjmp(lab)==0) { /* Yields char_min */ - while (cchar_max) { - char_max=c; - c++; - } - } - Unexpected(4); - i_define("UCHAR", "_MAX", (long) char_max, - (long) UCHAR_MAX); -#endif - } else { -#ifndef NO_SC /* Define NO_SC if the next line gives a syntax error */ - volatile signed char c, char_max, char_min; - c=0; char_max=0; - c++; - if (setjmp(lab)==0) { /* Yields char_max */ - while (c>char_max) { - char_max=c; - c++; - } - } - c=0; char_min=0; - c--; - if (setjmp(lab)==0) { /* Yields char_min */ - while (csizeof(int)?" BEWARE! larger than int!":"", - oc); - Vprintf("%sInt pointers = %d bits%s%s\n", - co, (int)sizeof(int *)*bits_per_byte, - sizeof(int *)>sizeof(int)?" BEWARE! larger than int!":"", - oc); - sprop(); - iprop(); - lprop(); - usprop(); - uiprop(); - ulprop(); - - Unexpected(6); - - /* Alignment constants ********************************************/ - Vprintf("%sAlignments used for char=%d short=%d int=%d long=%d%s\n", - co, - (int)sizeof(struct{char i1; char c1;})-(int)sizeof(char), - (int)sizeof(struct{short i2; char c2;})-(int)sizeof(short), - (int)sizeof(struct{int i3; char c3;})-(int)sizeof(int), - (int)sizeof(struct{long i4; char c4;})-(int)sizeof(long), - oc); - - /* Ten little endians *********************************************/ - - endian(bits_per_byte); - - /* Pointers *******************************************************/ - if (V) { - if ("abcd"=="abcd") - printf("%sStrings are shared%s\n", co, oc); - else printf("%sStrings are not shared%s\n", co, oc); - } - - return bits_per_byte; -} - -#endif /* ifndef PASS */ - -/* As I said, I apologise for the contortions below. The functions are - expanded by the preprocessor twice or three times (for float and double, - and maybe for long double, and for short, int and long). That way, - I never make a change to one that I forget to make to the other. - You can look on it as C's fault for not supporting multi-line macro's. - This whole file is read 3 times by the preprocessor, with PASSn set for - n=1, 2 or 3, to decide which parts to reprocess. -*/ - -/* #undef on an already undefined thing is (wrongly) flagged as an error - by some compilers, therefore the #ifdef that follows: -*/ -#ifdef Number -#undef Number -#undef THING -#undef Thing -#undef thing -#undef FPROP -#undef Fname -#undef Store -#undef Sum -#undef Diff -#undef Mul -#undef Div -#undef Self -#undef F_check -#undef Validate -#undef EPROP -#undef MARK - -#undef F_RADIX -#undef F_MANT_DIG -#undef F_DIG -#undef F_ROUNDS -#undef F_EPSILON -#undef F_MIN_EXP -#undef F_MIN -#undef F_MIN_10_EXP -#undef F_MAX_EXP -#undef F_MAX -#undef F_MAX_10_EXP -#endif - -#ifdef Integer -#undef Integer -#undef INT -#undef IPROP -#undef Iname -#undef UPROP -#undef Uname -#undef OK_UI - -#undef I_MAX -#undef I_MIN -#undef U_MAX -#endif - -#ifdef PASS1 - -#define Number float -#define THING "FLOAT" -#define Thing "Float" -#define thing "float" -#define Fname "FLT" -#define FPROP fprop -#define Store fStore -#define Sum fSum -#define Diff fDiff -#define Mul fMul -#define Div fDiv -#define Self fSelf -#define F_check fCheck -#define Validate fValidate -#define MARK "F" - -#define EPROP efprop - -#define Integer short -#define INT "short" -#define IPROP sprop -#define Iname "SHRT" -#ifndef NO_UI -#define OK_UI 1 -#endif - -#define UPROP usprop -#define Uname "USHRT" - -#ifdef VERIFY -#define I_MAX SHRT_MAX -#define I_MIN SHRT_MIN -#define U_MAX USHRT_MAX - -#define F_RADIX FLT_RADIX -#define F_MANT_DIG FLT_MANT_DIG -#define F_DIG FLT_DIG -#define F_ROUNDS FLT_ROUNDS -#define F_EPSILON FLT_EPSILON -#define F_MIN_EXP FLT_MIN_EXP -#define F_MIN FLT_MIN -#define F_MIN_10_EXP FLT_MIN_10_EXP -#define F_MAX_EXP FLT_MAX_EXP -#define F_MAX FLT_MAX -#define F_MAX_10_EXP FLT_MAX_10_EXP -#endif /* VERIFY */ - -#endif /* PASS1 */ - -#ifdef PASS2 - -#define Number double -#define THING "DOUBLE" -#define Thing "Double" -#define thing "double" -#define Fname "DBL" -#define FPROP dprop -#define Store dStore -#define Sum dSum -#define Diff dDiff -#define Mul dMul -#define Div dDiv -#define Self dSelf -#define F_check dCheck -#define Validate dValidate -#define MARK "" - -#define EPROP edprop - -#define Integer int -#define INT "int" -#define IPROP iprop -#define Iname "INT" -#define OK_UI 1 /* Unsigned int is always possible */ - -#define UPROP uiprop -#define Uname "UINT" - -#ifdef VERIFY -#define I_MAX INT_MAX -#define I_MIN INT_MIN -#define U_MAX UINT_MAX - -#define F_MANT_DIG DBL_MANT_DIG -#define F_DIG DBL_DIG -#define F_EPSILON DBL_EPSILON -#define F_MIN_EXP DBL_MIN_EXP -#define F_MIN DBL_MIN -#define F_MIN_10_EXP DBL_MIN_10_EXP -#define F_MAX_EXP DBL_MAX_EXP -#define F_MAX DBL_MAX -#define F_MAX_10_EXP DBL_MAX_10_EXP -#endif /* VERIFY */ - -#endif /* PASS2 */ - -#ifdef PASS3 - -#ifdef __STDC__ -#define Number long double -#endif - -#define THING "LONG DOUBLE" -#define Thing "Long double" -#define thing "long double" -#define Fname "LDBL" -#define FPROP ldprop -#define Store ldStore -#define Sum ldSum -#define Diff ldDiff -#define Mul ldMul -#define Div ldDiv -#define Self ldSelf -#define F_check ldCheck -#define Validate ldValidate -#define MARK "L" - -#define EPROP eldprop - -#define Integer long -#define INT "long" -#define IPROP lprop -#define Iname "LONG" -#ifndef NO_UI -#define OK_UI 1 -#endif - -#define UPROP ulprop -#define Uname "ULONG" - -#ifdef VERIFY -#define I_MAX LONG_MAX -#define I_MIN LONG_MIN -#define U_MAX ULONG_MAX - -#define F_MANT_DIG LDBL_MANT_DIG -#define F_DIG LDBL_DIG -#define F_EPSILON LDBL_EPSILON -#define F_MIN_EXP LDBL_MIN_EXP -#define F_MIN LDBL_MIN -#define F_MIN_10_EXP LDBL_MIN_10_EXP -#define F_MAX_EXP LDBL_MAX_EXP -#define F_MAX LDBL_MAX -#define F_MAX_10_EXP LDBL_MAX_10_EXP -#endif /* VERIFY */ - -#endif /* PASS3 */ - -#ifndef VERIFY -#define I_MAX int_max -#define I_MIN int_min -#define U_MAX int_max - -#define F_RADIX f_radix -#define F_MANT_DIG f_mant_dig -#define F_DIG f_dig -#define F_ROUNDS f_rounds -#define F_EPSILON f_epsilon -#define F_MIN_EXP f_min_exp -#define F_MIN f_min -#define F_MIN_10_EXP f_min_10_exp -#define F_MAX_EXP f_max_exp -#define F_MAX f_max -#define F_MAX_10_EXP f_max_10_exp -#endif - -Procedure IPROP() { /* for short, int, and long */ - volatile Integer newi, int_max, maxeri, int_min, minneri; - volatile int ibits, ipower, two=2; - - /* Calculate max short/int/long ***********************************/ - /* Calculate 2**n-1 until overflow - then use the previous value */ - - newi=1; int_max=0; - - if (setjmp(lab)==0) { /* Yields int_max */ - for(ipower=0; newi>int_max; ipower++) { - int_max=newi; - newi=newi*two+1; - } - Vprintf("%sOverflow of a%s %s does not generate a trap%s\n", - co, INT[0]=='i'?"n":"", INT, oc); - } else { - Vprintf("%sOverflow of a%s %s generates a trap%s\n", - co, INT[0]=='i'?"n":"", INT, oc); - } - Unexpected(7); - - /* Minimum value: assume either two's or one's complement *********/ - int_min= -int_max; - if (setjmp(lab)==0) { /* Yields int_min */ - if (int_min-1 < int_min) int_min--; - } - Unexpected(8); - - /* Now for those daft Cybers: */ - - maxeri=0; newi=int_max; - - if (setjmp(lab)==0) { /* Yields maxeri */ - for(ibits=ipower; newi>maxeri; ibits++) { - maxeri=newi; - newi=newi+newi+1; - } - } - Unexpected(9); - - minneri= -maxeri; - if (setjmp(lab)==0) { /* Yields minneri */ - if (minneri-1 < minneri) minneri--; - } - Unexpected(10); - - Vprintf("%sMaximum %s = %ld (= 2**%d-1)%s\n", - co, INT, (long)int_max, ipower, oc); - Vprintf("%sMinimum %s = %ld%s\n", co, INT, (long)int_min, oc); - - if (L) i_define(Iname, "_MAX", (long) int_max, (long) I_MAX); - if (L) i_define(Iname, "_MIN", (long) int_min, (long) I_MIN); - - if (maxeri>int_max) { - Vprintf("%sThere is a larger %s, %ld (= 2**%d-1), %s %s%s\n", - co, INT, (long)maxeri, ibits, - "but only for addition, not multiplication", - "(I smell a Cyber!)", - oc); - } - - if (minneriint_max) { - int_max=newi; - newi=newi*two+1; - } - } - Unexpected(11); - Vprintf("%sMaximum unsigned %s = %lu%s\n", - co, INT, (unsigned long) int_max, oc); - if (L) u_define(Uname, "_MAX", (unsigned long) int_max, - (unsigned long) U_MAX); -#endif -} - - -#ifdef Number - -/* These routines are intended to defeat any attempt at optimisation - or use of extended precision, and to defeat faulty narrowing casts: -*/ -Procedure Store(a, b) Number a, *b; { *b=a; } -Number Sum(a, b) Number a, b; { Number r; Store(a+b, &r); return (r); } -Number Diff(a, b) Number a, b; { Number r; Store(a-b, &r); return (r); } -Number Mul(a, b) Number a, b; { Number r; Store(a*b, &r); return (r); } -Number Div(a, b) Number a, b; { Number r; Store(a/b, &r); return (r); } -Number Self(a) Number a; { Number r; Store(a, &r); return (r); } - -Procedure F_check(precision, val1) int precision; Long_double val1; { - /* You don't think I'm going to go to all the trouble of writing - a program that works out what all sorts of values are, only to - have printf go and print the wrong values out, do you? - No, you're right, so this function tries to see if printf - has written the right value, by reading it back again. - This introduces a new problem of course: suppose printf writes - the correct value, and scanf reads it back wrong... oh well. - But I'm adamant about this: the precision given is enough - to uniquely identify the printed number, therefore I insist - that sscanf read the number back identically. Harsh yes, but - sometimes you've got to be cruel to be kind. - */ - Long_double new1; - Number val, new, diff; - double rem; - int e; - char *rep; - char *f2; - - if (sizeof(double) == sizeof(Long_double)) { - /* Assume they're the same, and use non-stdc format */ - /* This is for stdc compilers using non-stdc libraries */ - f2= "%le"; /* Input */ - } else { - /* It had better support Le then */ - f2= "%Le"; - } - val= val1; - rep= f_rep(precision, (Long_double) val); - if (setjmp(lab)==0) { - sscanf(rep, f2, &new1); - } else { - eek_a_bug("sscanf caused a trap"); - printf("%s scanning: %s format: %s%s\n\n", co, rep, f2, oc); - Unexpected(12); - return; - } - - if (setjmp(lab)==0) { /* See if new is usable */ - new= new1; - if (new != 0.0) { - diff= val/new - 1.0; - if (diff < 0.1) diff= 1.0; - /* That should be enough to generate a trap */ - } - } else { - eek_a_bug("sscanf returned an unusable number"); - printf("%s scanning: %s with format: %s%s\n\n", - co, rep, f2, oc); - Unexpected(13); - return; - } - - Unexpected(14); - if (new != val) { - eek_a_bug("Possibly bad output from printf above"); - if (!exponent(val, &rem, &e)) { - printf("%s but value was an unusable number%s\n\n", - co, oc); - return; - } - printf("%s expected value around %.*fe%d, bit pattern:\n ", - co, precision, rem, e); - bitpattern((char *) &val, sizeof(val)); - printf ("%s\n", oc); - printf("%s sscanf gave %s, bit pattern:\n ", - co, f_rep(precision, (Long_double) new)); - bitpattern((char *) &new, sizeof(new)); - printf ("%s\n", oc); - printf("%s difference= %s%s\n\n", - co, f_rep(precision, (Long_double) (val-new)), oc); - } -} - -Procedure Validate(prec, val, req, same) int prec, same; Long_double val, req; { - Unexpected(15); - if (!same) { - printf("%s*** Verify failed for above #define!\n", co); - if (setjmp(lab) == 0) { /* for the case that req == nan */ - printf(" Compiler has %s for value%s\n", - f_rep(prec, req), oc); - } else { - printf(" Compiler has %s for value%s\n", - "an unusable number", oc); - } - if (setjmp(lab) == 0) { - F_check(prec, (Long_double) req); - } /*else forget it*/ - if (setjmp(lab) == 0) { - if (req > 0.0 && val > 0.0) { - printf("%s difference= %s%s\n", - co, f_rep(prec, val-req), oc); - } - } /*else forget it*/ - Unexpected(16); - printf("\n"); - bugs++; - } else if (val != req) { - if (stdc) { - printf("%s*** Verify failed for above #define!\n", co); - printf(" Constant has the wrong precision%s\n", - oc); - bugs++; - } else eek_a_bug("the cast didn't work"); - printf("\n"); - } -} - -int FPROP(bits_per_byte) int bits_per_byte; { - /* Properties of floating types, using algorithms by Cody and Waite - from MA Malcolm, as modified by WM Gentleman and SB Marovich. - Further extended by S Pemberton. - - Returns the number of digits in the fraction. - */ - - volatile int i, f_radix, iexp, irnd, mrnd, f_rounds, f_mant_dig, - iz, k, inf, machep, f_max_exp, f_min_exp, mx, negeps, - mantbits, digs, f_dig, trap, - hidden, normal, f_min_10_exp, f_max_10_exp; - volatile Number a, b, base, basein, basem1, f_epsilon, epsneg, - f_max, newxmax, f_min, xminner, y, y1, z, z1, z2; - - Unexpected(17); - - Vprintf("%sPROPERTIES OF %s:%s\n", co, THING, oc); - - /* Base and size of mantissa **************************************/ - /* First repeatedly double until adding 1 has no effect. */ - /* For instance, if base is 10, with 3 significant digits */ - /* it will try 1, 2, 4, 8, ... 512, 1024, and stop there, */ - /* since 1024 is only representable as 1020. */ - a=1.0; - if (setjmp(lab)==0) { /* inexact trap? */ - do { a=Sum(a, a); } - while (Diff(Diff(Sum(a, 1.0), a), 1.0) == 0.0); - } else { - fprintf(stderr, "*** Program got loss-of-precision trap!\n"); - /* And supporting those is just TOO much trouble! */ - exit(bugs+1); - } - Unexpected(18); - /* Now double until you find a number that can be added to the */ - /* above number. For 1020 this is 8 or 16, depending whether the */ - /* result is rounded or truncated. */ - /* In either case the result is 1030. 1030-1020= the base, 10. */ - b=1.0; - do { b=Sum(b, b); } while ((base=Diff(Sum(a, b), a)) == 0.0); - f_radix=base; - Vprintf("%sBase = %d%s\n", co, f_radix, oc); - - /* Sanity check; if base<2, I can't guarantee the rest will work */ - if (f_radix < 2) { - eek_a_bug("Function return or parameter passing faulty? (This is a guess.)"); - printf("\n"); - return(0); - } - -#ifdef PASS1 /* only for FLT */ - if (F) i_define("FLT", "_RADIX", (long) f_radix, (long) F_RADIX); -#endif - - /* Now the number of digits precision: */ - f_mant_dig=0; b=1.0; - do { f_mant_dig++; b=Mul(b, base); } - while (Diff(Diff(Sum(b,1.0),b),1.0) == 0.0); - f_dig=floor_log(10, (Long_double)(b/base)) + (base==10?1:0); - Vprintf("%sSignificant base digits = %d %s %d %s%s\n", - co, f_mant_dig, "(= at least", f_dig, "decimal digits)", oc); - if (F) i_define(Fname, "_MANT_DIG", (long) f_mant_dig, - (long) F_MANT_DIG); - if (F) i_define(Fname, "_DIG", (long) f_dig, (long) F_DIG); - digs= ceil_log(10, (Long_double)b); /* the number of digits to printf */ - - /* Rounding *******************************************************/ - basem1=Diff(base, 0.5); - if (Diff(Sum(a, basem1), a) != 0.0) { - if (f_radix == 2) basem1=0.375; - else basem1=1.0; - if (Diff(Sum(a, basem1), a) != 0.0) irnd=2; /* away from 0 */ - else irnd=1; /* to nearest */ - } else irnd=0; /* towards 0 */ - - basem1=Diff(base, 0.5); - - if (Diff(Diff(-a, basem1), -a) != 0.0) { - if (f_radix == 2) basem1=0.375; - else basem1=1.0; - if (Diff(Diff(-a, basem1), -a) != 0.0) mrnd=2; /* away from 0*/ - else mrnd=1; /* to nearest */ - } else mrnd=0; /* towards 0 */ - - f_rounds=4; /* Unknown rounding */ - if (irnd==0 && mrnd==0) f_rounds=0; /* zero = chops */ - if (irnd==1 && mrnd==1) f_rounds=1; /* nearest */ - if (irnd==2 && mrnd==0) f_rounds=2; /* +inf */ - if (irnd==0 && mrnd==2) f_rounds=3; /* -inf */ - - if (f_rounds != 4) { - Vprintf("%sArithmetic rounds towards ", co); - switch (f_rounds) { - case 0: Vprintf("zero (i.e. it chops)"); break; - case 1: Vprintf("nearest"); break; - case 2: Vprintf("+infinity"); break; - case 3: Vprintf("-infinity"); break; - default: Vprintf("???"); break; - } - Vprintf("%s\n", oc); - } else { /* Hmm, try to give some help here: */ - Vprintf("%sArithmetic rounds oddly: %s\n", co, oc); - Vprintf("%s Negative numbers %s%s\n", - co, mrnd==0 ? "towards zero" : - mrnd==1 ? "to nearest" : - "away from zero", - oc); - Vprintf("%s Positive numbers %s%s\n", - co, irnd==0 ? "towards zero" : - irnd==1 ? "to nearest" : - "away from zero", - oc); - } - /* An extra goody */ - if (f_radix == 2 && f_rounds == 1) { - if (Diff(Sum(a, 1.0), a) != 0.0) { - Vprintf("%s Tie breaking rounds up%s\n", co, oc); - } else if (Diff(Sum(a, 3.0), a) == 4.0) { - Vprintf("%s Tie breaking rounds to even%s\n", co, oc); - } else { - Vprintf("%s Tie breaking rounds down%s\n", co, oc); - } - } -#ifdef PASS1 /* only for FLT */ - if (F) i_define("FLT", "_ROUNDS", (long) f_rounds, (long) F_ROUNDS); -#endif - - /* Various flavours of epsilon ************************************/ - negeps=f_mant_dig+f_mant_dig; - basein=1.0/base; - a=1.0; - for(i=1; i<=negeps; i++) a*=basein; - - b=a; - while (Diff(Diff(1.0, a), 1.0) == 0.0) { - a*=base; - negeps--; - } - negeps= -negeps; - Vprintf("%sSmallest x such that 1.0-base**x != 1.0 = %d%s\n", - co, negeps, oc); - - epsneg=a; - if ((f_radix!=2) && irnd) { - /* a=(a*(1.0+a))/(1.0+1.0); => */ - a=Div(Mul(a, Sum(1.0, a)), Sum(1.0, 1.0)); - /* if ((1.0-a)-1.0 != 0.0) epsneg=a; => */ - if (Diff(Diff(1.0, a), 1.0) != 0.0) epsneg=a; - } - Vprintf("%sSmall x such that 1.0-x != 1.0 = %s%s\n", - co, f_rep(digs, (Long_double) epsneg), oc); - /* it may not be the smallest */ - if (V) F_check(digs, (Long_double) epsneg); - Unexpected(19); - - machep= -f_mant_dig-f_mant_dig; - a=b; - while (Diff(Sum(1.0, a), 1.0) == 0.0) { a*=base; machep++; } - Vprintf("%sSmallest x such that 1.0+base**x != 1.0 = %d%s\n", - co, machep, oc); - - f_epsilon=a; - if ((f_radix!=2) && irnd) { - /* a=(a*(1.0+a))/(1.0+1.0); => */ - a=Div(Mul(a, Sum(1.0, a)), Sum(1.0, 1.0)); - /* if ((1.0+a)-1.0 != 0.0) f_epsilon=a; => */ - if (Diff(Sum(1.0, a), 1.0) != 0.0) f_epsilon=a; - } - Vprintf("%sSmallest x such that 1.0+x != 1.0 = %s%s\n", - co, f_rep(digs, (Long_double) f_epsilon), oc); - /* Possible loss of precision warnings here from non-stdc compilers: */ - if (F) f_define(Fname, "_EPSILON", digs, (Long_double) f_epsilon, MARK); - if (V || F) F_check(digs, (Long_double) f_epsilon); - Unexpected(20); - if (F) Validate(digs, (Long_double) f_epsilon, (Long_double) F_EPSILON, - f_epsilon == Self(F_EPSILON)); - Unexpected(21); - - /* Extra chop info *************************************************/ - if (f_rounds == 0) { - if (Diff(Mul(Sum(1.0,f_epsilon),1.0),1.0) != 0.0) { - Vprintf("%sAlthough arithmetic chops, it uses guard digits%s\n", co, oc); - } - } - - /* Size of and minimum normalised exponent ************************/ - y=0; i=0; k=1; z=basein; z1=(1.0+f_epsilon)/base; - - /* Coarse search for the largest power of two */ - if (setjmp(lab)==0) { /* for underflow trap */ /* Yields i, k, y, y1 */ - do { - y=z; y1=z1; - z=Mul(y,y); z1=Mul(z1, y); - a=Mul(z,1.0); - z2=Div(z1,y); - if (z2 != y1) break; - if ((Sum(a,a) == 0.0) || (fabs(z) >= y)) break; - i++; - k+=k; - } while(1); - } else { - Vprintf("%s%s underflow generates a trap%s\n", co, Thing, oc); - } - Unexpected(22); - - if (f_radix != 10) { - iexp=i+1; /* for the sign */ - mx=k+k; - } else { - iexp=2; - iz=f_radix; - while (k >= iz) { iz*=f_radix; iexp++; } - mx=iz+iz-1; - } - - /* Fine tune starting with y and y1 */ - if (setjmp(lab)==0) { /* for underflow trap */ /* Yields k, f_min */ - do { - f_min=y; z1=y1; - y=Div(y,base); y1=Div(y1,base); - a=Mul(y,1.0); - z2=Mul(y1,base); - if (z2 != z1) break; - if ((Sum(a,a) == 0.0) || (fabs(y) >= f_min)) break; - k++; - } while (1); - } - Unexpected(23); - - f_min_exp=(-k)+1; - - if ((mx <= k+k-3) && (f_radix != 10)) { mx+=mx; iexp+=1; } - Vprintf("%sNumber of bits used for exponent = %d%s\n", co, iexp, oc); - Vprintf("%sMinimum normalised exponent = %d%s\n", co, f_min_exp, oc); - if (F) i_define(Fname, "_MIN_EXP", (long) f_min_exp, (long) F_MIN_EXP); - - if (setjmp(lab)==0) { - Vprintf("%sMinimum normalised positive number = %s%s\n", - co, f_rep(digs, (Long_double) f_min), oc); - } else { - eek_a_bug("printf can't print the smallest normalised number"); - printf("\n"); - } - Unexpected(24); - /* Possible loss of precision warnings here from non-stdc compilers: */ - if (setjmp(lab) == 0) { - if (F) f_define(Fname, "_MIN", digs, (Long_double) f_min, MARK); - if (V || F) F_check(digs, (Long_double) f_min); - } else { - eek_a_bug("xxx_MIN caused a trap"); - printf("\n"); - } - - if (setjmp(lab) == 0) { - if (F) Validate(digs, (Long_double) f_min, (Long_double) F_MIN, - f_min == Self(F_MIN)); - } else { - printf("%s*** Verify failed for above #define!\n %s %s\n\n", - co, "Compiler has an unusable number for value", oc); - bugs++; - } - Unexpected(25); - - a=1.0; f_min_10_exp=0; - while (a > f_min*10.0) { a/=10.0; f_min_10_exp--; } - if (F) i_define(Fname, "_MIN_10_EXP", (long) f_min_10_exp, - (long) F_MIN_10_EXP); - - /* Minimum exponent ************************************************/ - if (setjmp(lab)==0) { /* for underflow trap */ /* Yields xminner */ - do { - xminner=y; - y=Div(y,base); - a=Mul(y,1.0); - if ((Sum(a,a) == 0.0) || (fabs(y) >= xminner)) break; - } while (1); - } - Unexpected(26); - - if (xminner != 0.0 && xminner != f_min) { - normal= 0; - Vprintf("%sThe smallest numbers are not kept normalised%s\n", - co, oc); - if (setjmp(lab)==0) { - Vprintf("%sSmallest unnormalised positive number = %s%s\n", - co, f_rep(digs, (Long_double) xminner), oc); - if (V) F_check(digs, (Long_double) xminner); - } else { - eek_a_bug("printf can't print the smallest unnormalised number."); - printf("\n"); - } - Unexpected(27); - } else { - normal= 1; - Vprintf("%sThe smallest numbers are normalised%s\n", co, oc); - } - - /* Maximum exponent ************************************************/ - f_max_exp=2; f_max=1.0; newxmax=base+1.0; - inf=0; trap=0; - while (f_max