diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/get_archive_args v15.6301-amd64/pop/com/get_archive_args --- v15.63/pop/com/get_archive_args 1998-11-03 13:48:50.000000000 -0500 +++ v15.6301-amd64/pop/com/get_archive_args 2010-01-03 04:06:09.000000000 -0500 @@ -118,7 +118,7 @@ ;; elf_linux*) LIBEXTN=.so - AR='gcc -shared -o $LIBNAME' + AR='gcc -g -shared -o $LIBNAME' RANLIB= ;; osf1*) @@ -137,7 +137,10 @@ # Output commands to set variables in caller shell -- this must be # eval'ed by the caller. AR and RANLIB must then be eval'ed after # setting LIBNAME. -if [ $Shell = "csh" ]; then + +if [ "$Shell" == "csh" ]; then + echo "set CC='$CC'; set IDIRS='$IDIRS'; set CFLAGS='$CFLAGS'; set LIBEXTN='$LIBEXTN'; set AR='$AR'; set LDLIBS='$LDLIBS'; set RANLIB='$RANLIB'" +elif [ "$Shell" == "tcsh" ]; then echo "set CC='$CC'; set IDIRS='$IDIRS'; set CFLAGS='$CFLAGS'; set LIBEXTN='$LIBEXTN'; set AR='$AR'; set LDLIBS='$LDLIBS'; set RANLIB='$RANLIB'" else echo "CC='$CC'; IDIRS='$IDIRS'; CFLAGS='$CFLAGS'; LIBEXTN='$LIBEXTN'; AR='$AR'; LDLIBS='$LDLIBS'; RANLIB='$RANLIB'" diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/mkXpw v15.6301-amd64/pop/com/mkXpw --- v15.63/pop/com/mkXpw 1998-11-03 13:17:28.000000000 -0500 +++ v15.6301-amd64/pop/com/mkXpw 2005-03-11 05:30:38.000000000 -0500 @@ -18,7 +18,7 @@ cd $usepop/pop/x/Xpw -$CC -c $CFLAGS $IDIRS *.c && \ +$CC -g -c $CFLAGS $IDIRS *.c && \ eval $AR *.o $LDLIBS && \ eval $RANLIB && \ rm *.o && \ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/mkstartup v15.6301-amd64/pop/com/mkstartup --- v15.63/pop/com/mkstartup 2005-01-18 13:33:21.000000000 -0500 +++ v15.6301-amd64/pop/com/mkstartup 2005-03-13 17:09:38.000000000 -0500 @@ -16,7 +16,7 @@ $popsys/basepop11 %nort %noinit \ $popliblib/mkimage.p \ - -nodebug -nonwriteable -install $usepop/pop/lib/psv/startup.psv \ + -nodebug -install $usepop/pop/lib/psv/startup.psv \ popuseslist \ poppackagelist \ popxlib \ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/mkstartup.bham v15.6301-amd64/pop/com/mkstartup.bham --- v15.63/pop/com/mkstartup.bham 2005-01-18 13:33:21.000000000 -0500 +++ v15.6301-amd64/pop/com/mkstartup.bham 2005-03-13 17:09:38.000000000 -0500 @@ -16,7 +16,7 @@ $popsys/basepop11 %nort %noinit \ $popliblib/mkimage.p \ - -nodebug -nonwriteable -install $usepop/pop/lib/psv/startup.psv \ + -nodebug -install $usepop/pop/lib/psv/startup.psv \ popuseslist \ poppackagelist \ popxlib \ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/mkxved v15.6301-amd64/pop/com/mkxved --- v15.63/pop/com/mkxved 1995-08-22 10:45:38.000000000 -0400 +++ v15.6301-amd64/pop/com/mkxved 2005-03-13 17:20:43.000000000 -0500 @@ -1,4 +1,5 @@ -# --- Copyright University of Sussex 1995. All rights reserved. ---------- +#!/bin/sh +# --- Copyright University of Sussex 2005. All rights reserved. ---------- # File: C.unix/com/mkxved # Purpose: Make an XVed saved image # Author: Robert John Duncan, Aug 20 1991 (see revisions) @@ -6,13 +7,15 @@ $popsys/pop11 %nort %noinit \ $popliblib/mkimage.p \ - -nodebug -nonwriteable -install -entry xved_standalone_setup \ + -nodebug -install -entry xved_standalone_setup \ $popsavelib/xved.psv \ mkxved rm -f $popsavelib/xved.psv- # --- Revision History --------------------------------------------------- +# --- Aaron Sloman, Mar 13 2005 +# removed -nonwriteable # --- John Gibson, Aug 22 1995 Added %noinit # --- John Gibson, Jun 3 1993 Added -nodebug -nonwriteable # --- John Gibson, Jan 21 1993 Changed to use -entry diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/mkxvedpro v15.6301-amd64/pop/com/mkxvedpro --- v15.63/pop/com/mkxvedpro 2005-01-17 07:24:58.000000000 -0500 +++ v15.6301-amd64/pop/com/mkxvedpro 2005-03-13 17:21:33.000000000 -0500 @@ -1,4 +1,7 @@ #!/bin/sh +# --- Copyright University of Birmingham 2005. All rights reserved. ------ +# Author: Aaron Sloman, Mar 13 2005 + # --- Copyright University of Sussex 1991. All rights reserved. ---------- ### --- Copyright University of Birmingham 2005. ### $usepop/pop/com/mkxvedpro @@ -19,3 +22,8 @@ ## ved_help replaced by ved_ploghelp + + +# --- Revision History --------------------------------------------------- +# --- Aaron Sloman, Mar 13 2005 +# removed -nonwriteable diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/popenv v15.6301-amd64/pop/com/popenv --- v15.63/pop/com/popenv 2007-09-10 18:00:20.000000000 -0400 +++ v15.6301-amd64/pop/com/popenv 2005-03-11 05:56:54.000000000 -0500 @@ -37,8 +37,7 @@ if (! $?popcontrib) setenv popcontrib $usepop/pop/packages/contrib # For system startup -# Removed AS 10 Sep 2007 -# if (! $?poplib) setenv poplib ~ +if (! $?poplib) setenv poplib ~ setenv popsavelib $usepop/pop/lib/psv setenv popcomppath ':$poplib:$poplocalauto:$popautolib:$popliblib' setenv popsavepath ':$poplib:$poplocalbin:$popsavelib' @@ -204,7 +203,12 @@ case Linux: set XLINK = XT - if ( -d /usr/X11R6/lib ) then + if ( -d /usr/X11R6/lib64 ) then + set XT_DIRS = -L/usr/X11R6/lib64 + set XM_DIRS = -L/usr/X11R6/lib64 + # libXm sometimes depends on libXext + set XM_FILES = "-lXm -lXt -lXext -lX11" + else if ( -d /usr/X11R6/lib ) then set XT_DIRS = -L/usr/X11R6/lib set XM_DIRS = -L/usr/X11R6/lib # libXm sometimes depends on libXext @@ -268,8 +272,6 @@ # --- Revision History --------------------------------------------------- -# --- Aaron Sloman, 10 Sep 2007 -# removed default setting of $poplib # --- Aaron Sloman, Jan 16 2005 # Changed for V15.6, including introduction of packages dir # New values for poplocal and poplocalbin diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/com/popenv.sh v15.6301-amd64/pop/com/popenv.sh --- v15.63/pop/com/popenv.sh 2007-09-10 18:01:12.000000000 -0400 +++ v15.6301-amd64/pop/com/popenv.sh 2005-03-11 06:00:02.000000000 -0500 @@ -35,12 +35,11 @@ export poplocal poplocalauto poplocalbin # Contrib directory -popcontrib=${popcontrib=$usepop/pop/contrib} +popcontrib=${popcontrib=$usepop/pop/packages/contrib} export popcontrib # For system startup -# Removed AS 10 Sep 2007 -#poplib=${poplib=$HOME} +poplib=${poplib=$HOME} popsavelib=$usepop/pop/lib/psv popcomppath=':$poplib:$poplocalauto:$popautolib:$popliblib' popsavepath=':$poplib:$poplocalbin:$popsavelib' @@ -201,9 +200,9 @@ Linux) XLINK=XT - if [ -d /usr/X11R6/lib ]; then - XT_DIRS=-L/usr/X11R6/lib - XM_DIRS=-L/usr/X11R6/lib + if [ -d /usr/X11R6/lib64 ]; then + XT_DIRS=-L/usr/X11R6/lib64 + XM_DIRS=-L/usr/X11R6/lib64 # libXm sometimes depends on libXext XM_FILES="-lXm -lXt -lXext -lX11" elif [ -d /usr/X386/lib ]; then @@ -267,8 +266,6 @@ # --- Revision History --------------------------------------------------- -# --- Aaron Sloman, 10 Sep 2007 -# removed default setting of $poplib # --- Aaron Sloman, Jan 16 2005 # Changed for V15.6, including introduction of packages dir # New values for poplocal and poplocalbin diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/extern/lib/XtPoplog.c v15.6301-amd64/pop/extern/lib/XtPoplog.c --- v15.63/pop/extern/lib/XtPoplog.c 2007-01-06 18:35:48.000000000 -0500 +++ v15.6301-amd64/pop/extern/lib/XtPoplog.c 1999-01-26 22:14:20.000000000 -0500 @@ -1,20 +1,9 @@ -/* --- Copyright University of Sussex 2007. All rights reserved. ---------- +/* --- Copyright University of Sussex 1998. All rights reserved. ---------- * File: C.all/extern/lib/XtPoplog.c * Purpose: Poplog additions to the X toolkit library * Author: Roger Evans, Dec 15 1989 (see revisions) * Documentation: * Related Files: - - * NOTE: this file was modified 6 Jan 2007 to deal with the problem - * spurious warnings generated by Lesstif when windows are closed. - * This version of the file XtPoplog.c, unlike XtPoplog.c.ok, passes such messages - * to pop11 for printing. It seems to work. The version in - * XtPoplog.c could be made the default. This one does pass the - * strings to pop11 and the error print routine in - * $usepop/pop/x/src/xt_error.p has been modified to prevent - * printing of the spurious warnings, by default. However there - * is an option there to turn the printing on again. - * See http://www.cs.bham.ac.uk/research/projects/poplog/bugfixes/ */ #include "c_core.h" @@ -23,7 +12,7 @@ #ifndef VMS #include -extern int errno; /* for systems which don't have this in */ +extern int errno; /* for systems which don't have this in */ #endif @@ -62,12 +51,8 @@ /* Stop printing of error messages via sysprmessage until things are * sorted out - - 6 Jan 2007 A.S. Reverted to printing through sysprmessage - Partly to make it easier to deal with spurious warning messages - in Lesstif */ -static Boolean do_pop_print = True; +static Boolean do_pop_print = False; #ifdef __STDC__ #include @@ -75,8 +60,8 @@ static void X_printf(String fmt, ...) { - va_list args; - va_start(args, fmt); + va_list args; + va_start(args, fmt); #else #include @@ -85,52 +70,46 @@ X_printf(va_alist) va_dcl { - String fmt; - va_list args; - va_start(args); - fmt = va_arg(args, String); + String fmt; + va_list args; + va_start(args); + fmt = va_arg(args, String); #endif - { - POPOBJ prmessage; - if (do_pop_print) - prmessage = pop_get_ident("Xpt_sys_pr_message"); - - if (fmt) - { /* get a temporary buffer to print into */ - char string[ERRSTRINGSIZE], c; - register int i, j, slength; - /* call the C print formatter */ - vsprintf(string, fmt, args); - /* test and remove any newline chars from string */ - slength = strlen(string); - for (i = 0, j = 0; i < slength; i++) - if ((c = string[i]) != '\n') string[j++] = c; - /* null terminate string */ - string[j] = 0; - /* print it */ - if (do_pop_print) - pop_call(prmessage, string); - else - printf(";;; %s\n", string); - } - else - { - /* don't print through poplog. Can cause problems if - exiting output.p in XVed. - - if (do_pop_print) - pop_call(prmessage, NULL); - else - */ - - /* print a newline */ - printf("\n"); - } - } + { + POPOBJ prmessage; + if (do_pop_print) + prmessage = pop_get_ident("Xpt_sys_pr_message"); + + if (fmt) + { /* get a temporary buffer to print into */ + char string[ERRSTRINGSIZE], c; + register int i, j, slength; + /* call the C print formatter */ + vsprintf(string, fmt, args); + /* test and remove any newline chars from string */ + slength = strlen(string); + for (i = 0, j = 0; i < slength; i++) + if ((c = string[i]) != '\n') string[j++] = c; + /* null terminate string */ + string[j] = 0; + /* print it */ + if (do_pop_print) + pop_call(prmessage, string); + else + printf(";;; %s\n", string); + } + else + { /* print a newline */ + if (do_pop_print) + pop_call(prmessage, NULL); + else + printf("\n"); + } + } - va_end(args); + va_end(args); } @@ -140,7 +119,7 @@ void PopXtError(message) String message; { (void) sprintf(err_buff, "xte: X TOOLKIT ERROR (%s)", message); - pop_mishap(err_buff); + pop_mishap(err_buff); } @@ -149,21 +128,21 @@ void PopXtWarning(message) String message; { - (void) X_printf("WARNING - xtw: X TOOLKIT WARNING (%s)", message); - (void) X_printf(NULL); + (void) X_printf("WARNING - xtw: X TOOLKIT WARNING (%s)", message); + (void) X_printf(NULL); } #ifndef VMS #if defined(sun) && !(defined(SVR4) || defined(linux)) static char *_SysErrorMsg (n) - int n; + int n; { - globalref char *sys_errlist[]; - globalref int sys_nerr; - char *s = ((n >= 0 && n < sys_nerr) ? sys_errlist[n] : "unknown error"); + globalref char *sys_errlist[]; + globalref int sys_nerr; + char *s = ((n >= 0 && n < sys_nerr) ? sys_errlist[n] : "unknown error"); - return (s ? s : "no such error"); + return (s ? s : "no such error"); } #else #define _SysErrorMsg strerror @@ -172,55 +151,55 @@ /* Higher level X Toolkit error/warnings handlers - (same as default error handlers except they also show error name/type) + (same as default error handlers except they also show error name/type) */ #define XTFORMATSTR "%s: %s -- %s" static Err_msg(name,type,class,defaultp,params,num_params, err_p) - String name,type,class,defaultp; - String* params; - Cardinal* num_params; - void (*err_p)(); + String name,type,class,defaultp; + String* params; + Cardinal* num_params; + void (*err_p)(); { - char buffer[1000], message[1000]; - XtGetErrorDatabaseText(name, type, class, defaultp, buffer, 1000); - if (params == NULL || num_params == NULL || *num_params == 0) - { - sprintf(message, XTFORMATSTR, type, name, buffer); - err_p(message); - } - else - { - String par[10]; - int i, npar = *num_params < 10 ? *num_params : 10; - for (i = 0; i < npar; i++) - par[i] = params[i]; - for (i = npar; i < 10; i++) - par[i] = NULL; - (void) sprintf(message, buffer, par[0], par[1], par[2], par[3], - par[4], par[5], par[6], par[7], par[8], par[9]); - (void) sprintf(buffer, XTFORMATSTR, type, name, message); - err_p(buffer); - if (npar != *num_params) - XtWarning("some arguments in previous message were lost"); - } + char buffer[1000], message[1000]; + XtGetErrorDatabaseText(name, type, class, defaultp, buffer, 1000); + if (params == NULL || num_params == NULL || *num_params == 0) + { + sprintf(message, XTFORMATSTR, type, name, buffer); + err_p(message); + } + else + { + String par[10]; + int i, npar = *num_params < 10 ? *num_params : 10; + for (i = 0; i < npar; i++) + par[i] = params[i]; + for (i = npar; i < 10; i++) + par[i] = NULL; + (void) sprintf(message, buffer, par[0], par[1], par[2], par[3], + par[4], par[5], par[6], par[7], par[8], par[9]); + (void) sprintf(buffer, XTFORMATSTR, type, name, message); + err_p(buffer); + if (npar != *num_params) + XtWarning("some arguments in previous message were lost"); + } } void PopXtWarningMsg(name,type,class,defaultp,params,num_params) - String name,type,class,defaultp; - String* params; - Cardinal* num_params; + String name,type,class,defaultp; + String* params; + Cardinal* num_params; { - Err_msg(name, type, class, defaultp, params, num_params, XtWarning); + Err_msg(name, type, class, defaultp, params, num_params, XtWarning); } void PopXtErrorMsg(name,type,class,defaultp,params,num_params) - String name,type,class,defaultp; - String* params; - Cardinal* num_params; + String name,type,class,defaultp; + String* params; + Cardinal* num_params; { - Err_msg(name, type, class, defaultp, params, num_params, XtError); + Err_msg(name, type, class, defaultp, params, num_params, XtError); } @@ -229,23 +208,23 @@ /* Xlib 'fatal' error: mishap with a helpful message and close the display */ void PopXIOError(dpy) - Display *dpy; + Display *dpy; { - POPOBJ xio_error_handler; + POPOBJ xio_error_handler; - (void) X_printf(NULL); + (void) X_printf(NULL); - (void) X_printf("--- XLIB IO ERROR (client killed with KillClient?)"); - (void) X_printf("--- X server: '%s'", XDisplayString (dpy)); + (void) X_printf("--- XLIB IO ERROR (client killed with KillClient?)"); + (void) X_printf("--- X server: '%s'", XDisplayString (dpy)); #ifndef VMS - (void) X_printf ("--- Error Code: %d (%s)", errno, _SysErrorMsg (errno)); + (void) X_printf ("--- Error Code: %d (%s)", errno, _SysErrorMsg (errno)); #endif - xio_error_handler = pop_get_ident("XIO_sys_error_handler"); - pop_call(xio_error_handler, dpy); - /* must go straight back since external code may well try and - use the display handle... */ - _pop_external_flags &= (PEF_DOING_ABEXIT | PEF_ASYNC_CALLBACK); - pop_mishap(XIOESTRING); + xio_error_handler = pop_get_ident("XIO_sys_error_handler"); + pop_call(xio_error_handler, dpy); + /* must go straight back since external code may well try and + use the display handle... */ + _pop_external_flags &= (PEF_DOING_ABEXIT | PEF_ASYNC_CALLBACK); + pop_mishap(XIOESTRING); } @@ -254,74 +233,74 @@ #define XPESTRING "WARNING - xpe: X PROTOCOL ERROR -- %s" #define FORMAT2STR "--- %s (%s)" #define GET_TEXT(key, default_str) \ - XGetErrorDatabaseText(dpy, mtype, key, default_str, mesg, BUFSIZ); + XGetErrorDatabaseText(dpy, mtype, key, default_str, mesg, BUFSIZ); #define PRINT_TEXT(arg) \ - sprintf(buffer, "--- %s", mesg); (void) X_printf(buffer, arg); + sprintf(buffer, "--- %s", mesg); (void) X_printf(buffer, arg); /* Xlib recoverable error - copied from default handler */ int PopXError(dpy, event) - Display *dpy; - XErrorEvent *event; + Display *dpy; + XErrorEvent *event; { - char buffer[BUFSIZ], buffer2[BUFSIZ]; - char mesg[BUFSIZ]; - char number[32]; - char *mtype = "XlibMessage"; + char buffer[BUFSIZ], buffer2[BUFSIZ]; + char mesg[BUFSIZ]; + char number[32]; + char *mtype = "XlibMessage"; - (void) X_printf(NULL); + (void) X_printf(NULL); - /* Print out Error Type */ - XGetErrorText(dpy, event->error_code, mesg, BUFSIZ); - (void) X_printf(XPESTRING, mesg); + /* Print out Error Type */ + XGetErrorText(dpy, event->error_code, mesg, BUFSIZ); + (void) X_printf(XPESTRING, mesg); - /* Print out Request Number+type */ + /* Print out Request Number+type */ - GET_TEXT("MajorCode", "Request Major code %d"); - sprintf(buffer, mesg, event->request_code); + GET_TEXT("MajorCode", "Request Major code %d"); + sprintf(buffer, mesg, event->request_code); - sprintf(number, "%d", event->request_code); - XGetErrorDatabaseText(dpy, "XRequest", number, "", mesg, BUFSIZ); + sprintf(number, "%d", event->request_code); + XGetErrorDatabaseText(dpy, "XRequest", number, "", mesg, BUFSIZ); - (void) X_printf(FORMAT2STR, buffer, mesg); + (void) X_printf(FORMAT2STR, buffer, mesg); - /* Minor Request Code */ - GET_TEXT("MinorCode", "Request Minor code %d"); - PRINT_TEXT(event->minor_code); + /* Minor Request Code */ + GET_TEXT("MinorCode", "Request Minor code %d"); + PRINT_TEXT(event->minor_code); - /* The Resource involved */ - GET_TEXT("ResourceID", "RequestID 0x%x"); - PRINT_TEXT(event->resourceid); + /* The Resource involved */ + GET_TEXT("ResourceID", "RequestID 0x%x"); + PRINT_TEXT(event->resourceid); - /* Serial Number of Error */ - GET_TEXT("ErrorSerial", "Error Serial #%d"); - PRINT_TEXT(event->serial); + /* Serial Number of Error */ + GET_TEXT("ErrorSerial", "Error Serial #%d"); + PRINT_TEXT(event->serial); - /* Last processed Serial Number */ - GET_TEXT("CurrentSerial", "Current Serial #%d"); - PRINT_TEXT(NextRequest(dpy)-1); + /* Last processed Serial Number */ + GET_TEXT("CurrentSerial", "Current Serial #%d"); + PRINT_TEXT(NextRequest(dpy)-1); - return(0); + return(0); } /* Copied from default language proc */ String PopXtDefaultLanguageProc(dpy, xnl, closure) - Display *dpy; /* unused */ - String xnl; - XtPointer closure; /* unused */ + Display *dpy; /* unused */ + String xnl; + XtPointer closure; /* unused */ { - /* We assume the locale is already set - if (! setlocale(LC_ALL, xnl)) - XtWarning("locale not supported by C library, locale unchanged"); - */ - - if (! XSupportsLocale()) - { XtWarning("locale not supported by Xlib, locale set to C"); - setlocale(LC_ALL, "C"); - } - if (! XSetLocaleModifiers("")) - XtWarning("X locale modifiers not supported, using default"); + /* We assume the locale is already set + if (! setlocale(LC_ALL, xnl)) + XtWarning("locale not supported by C library, locale unchanged"); + */ + + if (! XSupportsLocale()) + { XtWarning("locale not supported by Xlib, locale set to C"); + setlocale(LC_ALL, "C"); + } + if (! XSetLocaleModifiers("")) + XtWarning("X locale modifiers not supported, using default"); - return setlocale(LC_ALL, NULL); /* re-query in case overwritten */ + return setlocale(LC_ALL, NULL); /* re-query in case overwritten */ } @@ -345,12 +324,12 @@ typedef unsigned long OlBitMask; /* OPEN LOOK bitmask #defines */ typedef struct _OlListItem { /* OPEN LOOK list item */ - OlDefine label_type; - Opaque label; - XImage * glyph; - OlBitMask attr; - Opaque tag; - unsigned char mnemonic; + OlDefine label_type; + Opaque label; + XImage * glyph; + OlBitMask attr; + Opaque tag; + unsigned char mnemonic; } OlListItem; typedef struct _OlListToken *OlListToken; /* opaque item token */ @@ -362,13 +341,13 @@ OlListToken parent, reference; OlListItem *item; { - OlListToken (*Addfn)(); + OlListToken (*Addfn)(); - /* Get the add procedure */ - XtVaGetValues(widget, XtNapplAddItem, (XtArgVal)&Addfn, NULL); + /* Get the add procedure */ + XtVaGetValues(widget, XtNapplAddItem, (XtArgVal)&Addfn, NULL); - /* Call the add procedure, returning the new item */ - return((OlListToken)(*Addfn)(widget, parent, reference, *item)); + /* Call the add procedure, returning the new item */ + return((OlListToken)(*Addfn)(widget, parent, reference, *item)); } #undef XtNapplAddItem @@ -385,73 +364,73 @@ XEvent *event; Boolean *continue_to_dispatch; { - Atom protocols; - Display *dpy; - String protocol_name; - - /* ignore all but the quit message */ - if (event->type == ClientMessage) { - dpy = XtDisplay(w); - protocols = XInternAtom(dpy, "WM_PROTOCOLS", FALSE); - if (event->xclient.message_type == protocols) { - - /* Call action proc to handle message*/ - protocol_name = XGetAtomName(dpy,event->xclient.data.l[0]); - XtCallActionProc(w,PROTOCOL_ACTION,event, - &protocol_name,1); - XFree(protocol_name); - - *continue_to_dispatch = False; - } - } + Atom protocols; + Display *dpy; + String protocol_name; + + /* ignore all but the quit message */ + if (event->type == ClientMessage) { + dpy = XtDisplay(w); + protocols = XInternAtom(dpy, "WM_PROTOCOLS", FALSE); + if (event->xclient.message_type == protocols) { + + /* Call action proc to handle message*/ + protocol_name = XGetAtomName(dpy,event->xclient.data.l[0]); + XtCallActionProc(w,PROTOCOL_ACTION,event, + &protocol_name,1); + XFree(protocol_name); + + *continue_to_dispatch = False; + } + } } /* max number of protocols that can be set - (currently there are only 3 protocols anyway!) */ + (currently there are only 3 protocols anyway!) */ #define MAX_WM_PROTOCOLS 32 /* add protocol handler as event filter for specified widget - (run on all shell widgets created by Poplog) + (run on all shell widgets created by Poplog) */ void XptAddProtoHandler(w,pcols,pcols_len) Widget w; char **pcols; int pcols_len; { - Atom pcol_atoms[MAX_WM_PROTOCOLS]; - Display *dpy = XtDisplay(w); - Boolean sv = w->core.mapped_when_managed; - int i; - - /* truncate overlong protocols list */ - if (pcols_len > MAX_WM_PROTOCOLS) pcols_len = MAX_WM_PROTOCOLS; - - /* convert protocls to atoms in buffer */ - for (i=0; i < pcols_len; i++) { - pcol_atoms[i] = XInternAtom(dpy, *(pcols++), FALSE); - } - - w->core.mapped_when_managed = FALSE; /* block mapping by realize */ - XtRealizeWidget(w); - XSetWMProtocols(dpy, XtWindow(w), pcol_atoms, pcols_len); - if (sv) { - /* restore mapped_when_managed */ - w->core.mapped_when_managed = sv; - /* map real shells explicitly */ - if (XtParent(w) == (Widget)NULL) XtMapWidget(w); - } + Atom pcol_atoms[MAX_WM_PROTOCOLS]; + Display *dpy = XtDisplay(w); + Boolean sv = w->core.mapped_when_managed; + int i; + + /* truncate overlong protocols list */ + if (pcols_len > MAX_WM_PROTOCOLS) pcols_len = MAX_WM_PROTOCOLS; + + /* convert protocls to atoms in buffer */ + for (i=0; i < pcols_len; i++) { + pcol_atoms[i] = XInternAtom(dpy, *(pcols++), FALSE); + } + + w->core.mapped_when_managed = FALSE; /* block mapping by realize */ + XtRealizeWidget(w); + XSetWMProtocols(dpy, XtWindow(w), pcol_atoms, pcols_len); + if (sv) { + /* restore mapped_when_managed */ + w->core.mapped_when_managed = sv; + /* map real shells explicitly */ + if (XtParent(w) == (Widget)NULL) XtMapWidget(w); + } - XtInsertEventHandler(w, (EventMask)NoEventMask, True, ProtoHandler, - NULL, XtListTail); + XtInsertEventHandler(w, (EventMask)NoEventMask, True, ProtoHandler, + NULL, XtListTail); } /* == Actions =================================================== */ /* default action proc for protocols - respond to WM_DELETE_WINDOW - by using XtPopdown on widgets that are Popup shells, and - XtDestroyWidget on widgets that are application shells. - Ignore everything else. + by using XtPopdown on widgets that are Popup shells, and + XtDestroyWidget on widgets that are application shells. + Ignore everything else. */ static void XptWMProtocol(w,event,params,num_params) Widget w; @@ -459,14 +438,14 @@ String *params; Cardinal *num_params; { - if (*num_params == 1 && strcmp(*params,"WM_DELETE_WINDOW") == 0) - if (XtParent(w)) XtPopdown(w); - else XtDestroyWidget(w); + if (*num_params == 1 && strcmp(*params,"WM_DELETE_WINDOW") == 0) + if (XtParent(w)) XtPopdown(w); + else XtDestroyWidget(w); } /* default action for garbage feedback - num-params non-zero means we're starting, and arg is what kind of - gc + num-params non-zero means we're starting, and arg is what kind of + gc */ XtInputMask XptAppTryEvents(); @@ -476,30 +455,30 @@ String *params; Cardinal *num_params; { - if (*num_params == 1) - XtSetSensitive(w,False); - else - XtSetSensitive(w,True); - - /* try and make sure server updates display */ - XSync(XtDisplay(w),False); - XptAppTryEvents(XtWidgetToApplicationContext(w)); + if (*num_params == 1) + XtSetSensitive(w,False); + else + XtSetSensitive(w,True); + + /* try and make sure server updates display */ + XSync(XtDisplay(w),False); + XptAppTryEvents(XtWidgetToApplicationContext(w)); } /* add standard poplog actions to an appcontext - called on every - appcontext created by poplog + appcontext created by poplog */ static XtActionsRec XptDefaultActions[] = { - {PROTOCOL_ACTION, XptWMProtocol}, - {"XptGarbageFeedback", XptGarbageFeedback} + {PROTOCOL_ACTION, XptWMProtocol}, + {"XptGarbageFeedback", XptGarbageFeedback} }; #define NumXptDefaultActions 2 void XptAddAppconActions(appcon) XtAppContext appcon; { - XtAppAddActions(appcon,XptDefaultActions,NumXptDefaultActions); + XtAppAddActions(appcon,XptDefaultActions,NumXptDefaultActions); } @@ -509,12 +488,12 @@ typedef struct { XtAppContext appcon; - POPOBJ clos; + POPOBJ clos; } AppEntry; globaldef AppEntry - appcon_tab[INT_NBITS], - *appcon_tab_end = appcon_tab; + appcon_tab[INT_NBITS], + *appcon_tab_end = appcon_tab; #define APPCON_TAB_LIM (&appcon_tab[INT_NBITS]) #define BITOF(entp) (1<<(entp-appcon_tab)) @@ -527,66 +506,66 @@ static int poll_appcons() { register AppEntry *entp = appcon_tab; - register unsigned int mask = appcons_enabled, newmask = mask; - POPWORD save_external_flags = _pop_external_flags; - globalref int (*_pop_Xt_poll_deferred)(); - - if (mask == 0) return(0); - if (_pop_in_X_call) - { _pop_stop_polling(XT_POLL_NUM); - /* setting this nonzero causes the external apply mechanism - * to call _pop_retry_Xt_poll when _pop_in_X_call reverts to zero - */ - _pop_Xt_poll_deferred = poll_appcons; - return(1); - } - - /* ensure malloc won't take mem from the popsys area */ - _pop_external_flags |= PEF_DO_USER_MALLOC; - - for (; mask != 0; mask >>= 1, entp++) - if ((mask&1) && XtAppPending(entp->appcon)) - { _pop_add_ast(AST_APP_PENDING, entp->clos); - newmask &= ~BITOF(entp); /* disable it */ - }; - - _pop_external_flags = save_external_flags; - - mask = appcons_enabled; - if (!(appcons_enabled = newmask)) _pop_stop_polling(XT_POLL_NUM); - if (newmask != mask) - { _pop_do_interrupt(); - return(2); - } - else - return(0); + register unsigned int mask = appcons_enabled, newmask = mask; + POPWORD save_external_flags = _pop_external_flags; + globalref int (*_pop_Xt_poll_deferred)(); + + if (mask == 0) return(0); + if (_pop_in_X_call) + { _pop_stop_polling(XT_POLL_NUM); + /* setting this nonzero causes the external apply mechanism + * to call _pop_retry_Xt_poll when _pop_in_X_call reverts to zero + */ + _pop_Xt_poll_deferred = poll_appcons; + return(1); + } + + /* ensure malloc won't take mem from the popsys area */ + _pop_external_flags |= PEF_DO_USER_MALLOC; + + for (; mask != 0; mask >>= 1, entp++) + if ((mask&1) && XtAppPending(entp->appcon)) + { _pop_add_ast(AST_APP_PENDING, entp->clos); + newmask &= ~BITOF(entp); /* disable it */ + }; + + _pop_external_flags = save_external_flags; + + mask = appcons_enabled; + if (!(appcons_enabled = newmask)) _pop_stop_polling(XT_POLL_NUM); + if (newmask != mask) + { _pop_do_interrupt(); + return(2); + } + else + return(0); } static AppEntry *set_async_appcon(on, appcon) Boolean on; XtAppContext appcon; { register AppEntry *entp = appcon_tab, *tabend = appcon_tab_end; - register unsigned int mask; + register unsigned int mask; - for (mask = 1; entp < tabend; mask <<= 1) - if ((entp++)->appcon == appcon) - { register unsigned int enabled = appcons_enabled; - if (enabled & mask) - /* currently enabled */ - { if (!on && !(enabled &= ~mask)) - _pop_set_poll_state(XT_POLL_NUM, NULL); - } - else - /* currently disabled */ - { if (on && ((enabled |= mask) == mask)) - _pop_set_poll_state(XT_POLL_NUM, poll_appcons); - } - - appcons_enabled = enabled; - return(--entp); /* entry addr in table for deleting */ - } + for (mask = 1; entp < tabend; mask <<= 1) + if ((entp++)->appcon == appcon) + { register unsigned int enabled = appcons_enabled; + if (enabled & mask) + /* currently enabled */ + { if (!on && !(enabled &= ~mask)) + _pop_set_poll_state(XT_POLL_NUM, NULL); + } + else + /* currently disabled */ + { if (on && ((enabled |= mask) == mask)) + _pop_set_poll_state(XT_POLL_NUM, poll_appcons); + } + + appcons_enabled = enabled; + return(--entp); /* entry addr in table for deleting */ + } - return(NULL); /* not in table */ + return(NULL); /* not in table */ } int _pop_set_async_appcon(appcon, clos, normaction) @@ -594,47 +573,47 @@ POPOBJ clos; Boolean normaction; { register AppEntry *curr; - sigsave_t savesig; - unsigned int m; + sigsave_t savesig; + unsigned int m; - BLOCK_SIG_ALL(savesig); - curr = set_async_appcon((Boolean) clos, appcon); + BLOCK_SIG_ALL(savesig); + curr = set_async_appcon((Boolean) clos, appcon); - if (clos != (POPOBJ)NULL) - { /* setting */ - if (curr == NULL) - if (appcon_tab_end < APPCON_TAB_LIM) - { /* space for more */ - (appcon_tab_end++)->appcon = appcon; - curr = set_async_appcon(TRUE, appcon); - } - else - { RESTORE_SIG(savesig); - return(-1); /* no space left */ - } - curr->clos = clos; - m = BITOF(curr); - if (normaction) __pop_appcons_normal |= m; - else __pop_appcons_normal &= ~m; - } - - else - /* clearing */ - if (curr != NULL) - { register AppEntry *p; + if (clos != (POPOBJ)NULL) + { /* setting */ + if (curr == NULL) + if (appcon_tab_end < APPCON_TAB_LIM) + { /* space for more */ + (appcon_tab_end++)->appcon = appcon; + curr = set_async_appcon(TRUE, appcon); + } + else + { RESTORE_SIG(savesig); + return(-1); /* no space left */ + } + curr->clos = clos; + m = BITOF(curr); + if (normaction) __pop_appcons_normal |= m; + else __pop_appcons_normal &= ~m; + } + + else + /* clearing */ + if (curr != NULL) + { register AppEntry *p; #define REMOVE_BIT(v) v = ((v>>1) &~ m) | (v & m) - m = BITOF(curr)-1; /* bits below this one */ - REMOVE_BIT(appcons_enabled); - REMOVE_BIT(__pop_appcons_normal); - - /* remove existing entry by shifting down */ - appcon_tab_end--; - for (p = curr+1; curr < appcon_tab_end; curr++, p++) - { curr->appcon = p->appcon; curr->clos = p->clos; }; - } + m = BITOF(curr)-1; /* bits below this one */ + REMOVE_BIT(appcons_enabled); + REMOVE_BIT(__pop_appcons_normal); + + /* remove existing entry by shifting down */ + appcon_tab_end--; + for (p = curr+1; curr < appcon_tab_end; curr++, p++) + { curr->appcon = p->appcon; curr->clos = p->clos; }; + } - RESTORE_SIG(savesig); - return(0); + RESTORE_SIG(savesig); + return(0); } POPOBJ _pop_async_appcon_clos() @@ -661,30 +640,30 @@ #define POLL_MAX 400 /* 2/5 sec */ static int - IOWaitStatus, - poll_time = POLL_INIT; + IOWaitStatus, + poll_time = POLL_INIT; /* remembers appcon on which last event occurred */ static XtAppContext last_event_appcon; /* Private interface to XtAppPending. This version prioritises X - events over others (to stop XtAppProcessEvent, which prioritises - timers, sometimes exhibiting to X lockout due to repeated rapidly - firing timers) + events over others (to stop XtAppProcessEvent, which prioritises + timers, sometimes exhibiting to X lockout due to repeated rapidly + firing timers) */ static XtInputMask XptAppPending(appcon) register XtAppContext appcon; { register XtInputMask m = XtAppPending(appcon); - if (m & XtIMXEvent) m = XtIMXEvent; - return(m); + if (m & XtIMXEvent) m = XtIMXEvent; + return(m); } /* input callback for input on xt wakeup device etc - flag interrupt */ void _XptDummyInput() { _pop_set_xt_wakeup(FALSE); - if (IOWaitStatus < INTERRUPTED) IOWaitStatus = INTERRUPTED; + if (IOWaitStatus < INTERRUPTED) IOWaitStatus = INTERRUPTED; } static void timeout_callback() @@ -692,99 +671,99 @@ } /* - * Wait-state polling for async appcontexts + * Wait-state polling for async appcontexts */ static XtAppContext try_appcons(pollingp) Boolean *pollingp; { register AppEntry *entp = appcon_tab, *tabend = appcon_tab_end; - register XtAppContext appcon, lastevent_app = NULL, normapp; - register unsigned int mask = 0, bit; - Boolean last_ok = FALSE; - - _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; - - for (; entp < tabend; entp++) - { bit = BITOF(entp); - appcon = entp->appcon; - if (__pop_appcons_normal & bit) /* must be at least one such */ - { XtInputMask m; - normapp = appcon; - if (last_event_appcon == appcon) last_ok = TRUE; - while (!POP_ABEXIT && IOWaitStatus == CONTINUE - && (m = XptAppPending(appcon))) - { XtAppProcessEvent(appcon, m); - /* only set lastevent_app for real events */ - if (IOWaitStatus == CONTINUE) lastevent_app = appcon; - } - } - else if (XtAppPending(appcon)) - { _pop_add_ast(AST_APP_PENDING, entp->clos); - continue; - } - - if (mask) *pollingp = TRUE; /* this is the 2nd, so more than 1 */ - mask |= bit; - } - - appcons_enabled = mask; - if (lastevent_app != NULL) - { if (lastevent_app != last_event_appcon) poll_time = POLL_INIT; - last_event_appcon = lastevent_app; - } - else if (!last_ok) - last_event_appcon = normapp; + register XtAppContext appcon, lastevent_app = NULL, normapp; + register unsigned int mask = 0, bit; + Boolean last_ok = FALSE; + + _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; + + for (; entp < tabend; entp++) + { bit = BITOF(entp); + appcon = entp->appcon; + if (__pop_appcons_normal & bit) /* must be at least one such */ + { XtInputMask m; + normapp = appcon; + if (last_event_appcon == appcon) last_ok = TRUE; + while (!POP_ABEXIT && IOWaitStatus == CONTINUE + && (m = XptAppPending(appcon))) + { XtAppProcessEvent(appcon, m); + /* only set lastevent_app for real events */ + if (IOWaitStatus == CONTINUE) lastevent_app = appcon; + } + } + else if (XtAppPending(appcon)) + { _pop_add_ast(AST_APP_PENDING, entp->clos); + continue; + } + + if (mask) *pollingp = TRUE; /* this is the 2nd, so more than 1 */ + mask |= bit; + } + + appcons_enabled = mask; + if (lastevent_app != NULL) + { if (lastevent_app != last_event_appcon) poll_time = POLL_INIT; + last_event_appcon = lastevent_app; + } + else if (!last_ok) + last_event_appcon = normapp; - return(lastevent_app); + return(lastevent_app); } void XptPause() { XtInputMask m; - XtIntervalId id; - XtAppContext waitapp; - caddr_t (*poll_other)() = _pop_set_Xt_poll(NULL); - Boolean polling = poll_other != NULL; + XtIntervalId id; + XtAppContext waitapp; + caddr_t (*poll_other)() = _pop_set_Xt_poll(NULL); + Boolean polling = poll_other != NULL; #ifdef __NUTC__ - /* no asynchronous wakeup, so must always poll */ - polling = TRUE; + /* no asynchronous wakeup, so must always poll */ + polling = TRUE; #endif - __pop_xt_wakeup_struct.XWK_FLAG_ENABLED = TRUE; + __pop_xt_wakeup_struct.XWK_FLAG_ENABLED = TRUE; - for (;;) - { IOWaitStatus = CONTINUE; + for (;;) + { IOWaitStatus = CONTINUE; - if (poll_other) poll_other = (caddr_t (*)()) (*poll_other)(); - if (POP_CONDITION) break; + if (poll_other) poll_other = (caddr_t (*)()) (*poll_other)(); + if (POP_CONDITION) break; - if (try_appcons(&polling) || POP_CONDITION || IOWaitStatus != CONTINUE - || __pop_xt_wakeup_struct.XWK_ON) - break; - - /* go into (possible) wait */ - waitapp = last_event_appcon; - if (polling) id = XtAppAddTimeOut(waitapp, poll_time, - (XtTimerCallbackProc) timeout_callback, NULL); - - XtAppProcessEvent(waitapp, (m=XptAppPending(waitapp)) ? m : XtIMAll); - - if (polling) - { if (IOWaitStatus == POLL_TIMEOUT) - { if (poll_time < POLL_MAX) poll_time += POLL_STEP; - continue; - } - XtRemoveTimeOut(id); - } - - /* finish off any remaining events */ - while (!POP_CONDITION && IOWaitStatus == CONTINUE - && (m = XptAppPending(waitapp))) - XtAppProcessEvent(waitapp, m); + if (try_appcons(&polling) || POP_CONDITION || IOWaitStatus != CONTINUE + || __pop_xt_wakeup_struct.XWK_ON) + break; + + /* go into (possible) wait */ + waitapp = last_event_appcon; + if (polling) id = XtAppAddTimeOut(waitapp, poll_time, + (XtTimerCallbackProc) timeout_callback, NULL); + + XtAppProcessEvent(waitapp, (m=XptAppPending(waitapp)) ? m : XtIMAll); + + if (polling) + { if (IOWaitStatus == POLL_TIMEOUT) + { if (poll_time < POLL_MAX) poll_time += POLL_STEP; + continue; + } + XtRemoveTimeOut(id); + } + + /* finish off any remaining events */ + while (!POP_CONDITION && IOWaitStatus == CONTINUE + && (m = XptAppPending(waitapp))) + XtAppProcessEvent(waitapp, m); - break; - } + break; + } - _pop_set_xt_wakeup(FALSE); - _pop_set_Xt_poll(poll_appcons); + _pop_set_xt_wakeup(FALSE); + _pop_set_Xt_poll(poll_appcons); } @@ -794,57 +773,57 @@ { IOWaitStatus = 1; } int XptReadWait(efnum) -int efnum; /* event flag number */ +int efnum; /* event flag number */ { XtInputMask m; - XtIntervalId timid; - XtInputId inid = NULL; - XtAppContext waitapp, inidapp; - caddr_t (*poll_other)() = _pop_set_Xt_poll(NULL); - Boolean polling = poll_other != NULL; - - __pop_xt_wakeup_struct.XWK_FLAG_ENABLED = TRUE; - - for (;;) - { IOWaitStatus = CONTINUE; - - if (poll_other) poll_other = (caddr_t (*)()) (*poll_other)(); - if (POP_CONDITION) break; - - try_appcons(&polling); - if (POP_CONDITION || IOWaitStatus != CONTINUE - || __pop_xt_wakeup_struct.XWK_ON) - break; - - /* go into (possible) wait */ - waitapp = last_event_appcon; - if (polling) timid = XtAppAddTimeOut(waitapp, poll_time, - (XtTimerCallbackProc) timeout_callback, NULL); - - if (inid && waitapp != inidapp) - { XtRemoveInput(inid); inid = NULL; } - if (!inid) inid = XtAppAddInput(inidapp = waitapp, efnum, - NULL, (XtInputCallbackProc) input_callback, NULL); - - while (!POP_ABEXIT && IOWaitStatus == CONTINUE) - XtAppProcessEvent(waitapp, (m=XptAppPending(waitapp)) ? m : XtIMAll); - - if (polling) - { if (IOWaitStatus == POLL_TIMEOUT) - { if (poll_time < POLL_MAX) poll_time += POLL_STEP; - continue; - } - XtRemoveTimeOut(timid); - } - - break; - } - - if (inid) XtRemoveInput(inid); - _pop_set_xt_wakeup(FALSE); - _pop_set_Xt_poll(poll_appcons); + XtIntervalId timid; + XtInputId inid = NULL; + XtAppContext waitapp, inidapp; + caddr_t (*poll_other)() = _pop_set_Xt_poll(NULL); + Boolean polling = poll_other != NULL; + + __pop_xt_wakeup_struct.XWK_FLAG_ENABLED = TRUE; + + for (;;) + { IOWaitStatus = CONTINUE; + + if (poll_other) poll_other = (caddr_t (*)()) (*poll_other)(); + if (POP_CONDITION) break; + + try_appcons(&polling); + if (POP_CONDITION || IOWaitStatus != CONTINUE + || __pop_xt_wakeup_struct.XWK_ON) + break; + + /* go into (possible) wait */ + waitapp = last_event_appcon; + if (polling) timid = XtAppAddTimeOut(waitapp, poll_time, + (XtTimerCallbackProc) timeout_callback, NULL); + + if (inid && waitapp != inidapp) + { XtRemoveInput(inid); inid = NULL; } + if (!inid) inid = XtAppAddInput(inidapp = waitapp, efnum, + NULL, (XtInputCallbackProc) input_callback, NULL); + + while (!POP_ABEXIT && IOWaitStatus == CONTINUE) + XtAppProcessEvent(waitapp, (m=XptAppPending(waitapp)) ? m : XtIMAll); + + if (polling) + { if (IOWaitStatus == POLL_TIMEOUT) + { if (poll_time < POLL_MAX) poll_time += POLL_STEP; + continue; + } + XtRemoveTimeOut(timid); + } + + break; + } + + if (inid) XtRemoveInput(inid); + _pop_set_xt_wakeup(FALSE); + _pop_set_Xt_poll(poll_appcons); - /* return number of devices ready (i.e. 1) or -1 if interrupted */ - return(IOWaitStatus > 0 ? IOWaitStatus : -1); + /* return number of devices ready (i.e. 1) or -1 if interrupted */ + return(IOWaitStatus > 0 ? IOWaitStatus : -1); } #endif /* VMS */ @@ -855,9 +834,9 @@ #include typedef struct - { short nfds, /* max fd in set + 1 (zero if empty) */ - minfd; /* min fd in set */ - fd_set fdset; + { short nfds, /* max fd in set + 1 (zero if empty) */ + minfd; /* min fd in set */ + fd_set fdset; } fdesc_set; static fdesc_set *curr_fdsets; @@ -866,128 +845,128 @@ static void input_callback(client, fdp) int client, *fdp; { int set; - if (IOWaitStatus < 0) - { for (set = 0; set <= 2; set++) - if (curr_fdsets[set].nfds > 0) FD_ZERO(&curr_fdsets[set].fdset); - IOWaitStatus = 0; - } - IOWaitStatus++; - FD_SET(*fdp, &curr_fdsets[client&3].fdset); - client >>= 2; - XtRemoveInput(curr_inid_array[client]); - curr_inid_array[client] = (XtInputId) 0; + if (IOWaitStatus < 0) + { for (set = 0; set <= 2; set++) + if (curr_fdsets[set].nfds > 0) FD_ZERO(&curr_fdsets[set].fdset); + IOWaitStatus = 0; + } + IOWaitStatus++; + FD_SET(*fdp, &curr_fdsets[client&3].fdset); + client >>= 2; + XtRemoveInput(curr_inid_array[client]); + curr_inid_array[client] = (XtInputId) 0; } int XptIOWait(fdsets) fdesc_set *fdsets; { XtInputMask m; - XtIntervalId timid; - XtInputId inid_array[FD_SETSIZE], *inidp = NULL; - XtAppContext waitapp, inidapp; - caddr_t (*poll_other)() = _pop_set_Xt_poll(NULL); - Boolean polling = poll_other != NULL; - - __pop_xt_wakeup_struct.XWK_FLAG_ENABLED = TRUE; - curr_fdsets = fdsets; - curr_inid_array = inid_array; - - for (;;) - { IOWaitStatus = CONTINUE; - - if (poll_other) poll_other = (caddr_t (*)()) (*poll_other)(); - if (POP_CONDITION) break; - - try_appcons(&polling); - if (POP_CONDITION || IOWaitStatus != CONTINUE - || __pop_xt_wakeup_struct.XWK_ON) - break; - - /* go into (possible) wait */ - waitapp = last_event_appcon; - if (polling) timid = XtAppAddTimeOut(waitapp, poll_time, - (XtTimerCallbackProc) timeout_callback, NULL); - - if (inidp && waitapp != inidapp) - { XtInputId *ip = inid_array, id; - while (ip < inidp) if (id = *ip++) XtRemoveInput(id); - inidp = NULL; - } - if (!inidp) - { int set; - inidapp = waitapp; - inidp = inid_array; - for (set = 0; set <= 2; set++) - { static char masks[] = {XtInputReadMask, XtInputWriteMask, - XtInputExceptMask}; - fdesc_set *fdes = &fdsets[set]; - int fd, nfds = fdes->nfds; - long cond = masks[set]; - fd_set *fdsp = &fdes->fdset; - if (nfds == 0) continue; - - for (fd = fdes->minfd; fd < nfds; fd++) - if FD_ISSET(fd, fdsp) - { long client = ((inidp-inid_array)<< 2) | set; - *inidp++ = XtAppAddInput(inidapp, fd, (XtPointer) cond, - (XtInputCallbackProc) input_callback, - (XtPointer) client); - } - } - } - - while (!POP_ABEXIT && IOWaitStatus == CONTINUE) - XtAppProcessEvent(waitapp, (m=XptAppPending(waitapp)) ? m : XtIMAll); - - if (polling) - { if (IOWaitStatus == POLL_TIMEOUT) - { if (poll_time < POLL_MAX) poll_time += POLL_STEP; - continue; - } - XtRemoveTimeOut(timid); - } - - if (IOWaitStatus > 0) - /* finish off any other I/O events */ - while (!POP_ABEXIT && (XtAppPending(waitapp) & XtIMAlternateInput)) - XtAppProcessEvent(waitapp, XtIMAlternateInput); - - break; - } - - if (inidp) - { XtInputId *ip = inid_array, id; - while (ip < inidp) if (id = *ip++) XtRemoveInput(id); - } - _pop_set_xt_wakeup(FALSE); - _pop_set_Xt_poll(poll_appcons); + XtIntervalId timid; + XtInputId inid_array[FD_SETSIZE], *inidp = NULL; + XtAppContext waitapp, inidapp; + caddr_t (*poll_other)() = _pop_set_Xt_poll(NULL); + Boolean polling = poll_other != NULL; + + __pop_xt_wakeup_struct.XWK_FLAG_ENABLED = TRUE; + curr_fdsets = fdsets; + curr_inid_array = inid_array; + + for (;;) + { IOWaitStatus = CONTINUE; + + if (poll_other) poll_other = (caddr_t (*)()) (*poll_other)(); + if (POP_CONDITION) break; + + try_appcons(&polling); + if (POP_CONDITION || IOWaitStatus != CONTINUE + || __pop_xt_wakeup_struct.XWK_ON) + break; + + /* go into (possible) wait */ + waitapp = last_event_appcon; + if (polling) timid = XtAppAddTimeOut(waitapp, poll_time, + (XtTimerCallbackProc) timeout_callback, NULL); + + if (inidp && waitapp != inidapp) + { XtInputId *ip = inid_array, id; + while (ip < inidp) if (id = *ip++) XtRemoveInput(id); + inidp = NULL; + } + if (!inidp) + { int set; + inidapp = waitapp; + inidp = inid_array; + for (set = 0; set <= 2; set++) + { static char masks[] = {XtInputReadMask, XtInputWriteMask, + XtInputExceptMask}; + fdesc_set *fdes = &fdsets[set]; + int fd, nfds = fdes->nfds; + long cond = masks[set]; + fd_set *fdsp = &fdes->fdset; + if (nfds == 0) continue; + + for (fd = fdes->minfd; fd < nfds; fd++) + if FD_ISSET(fd, fdsp) + { long client = ((inidp-inid_array)<< 2) | set; + *inidp++ = XtAppAddInput(inidapp, fd, (XtPointer) cond, + (XtInputCallbackProc) input_callback, + (XtPointer) client); + } + } + } + + while (!POP_ABEXIT && IOWaitStatus == CONTINUE) + XtAppProcessEvent(waitapp, (m=XptAppPending(waitapp)) ? m : XtIMAll); + + if (polling) + { if (IOWaitStatus == POLL_TIMEOUT) + { if (poll_time < POLL_MAX) poll_time += POLL_STEP; + continue; + } + XtRemoveTimeOut(timid); + } + + if (IOWaitStatus > 0) + /* finish off any other I/O events */ + while (!POP_ABEXIT && (XtAppPending(waitapp) & XtIMAlternateInput)) + XtAppProcessEvent(waitapp, XtIMAlternateInput); + + break; + } + + if (inidp) + { XtInputId *ip = inid_array, id; + while (ip < inidp) if (id = *ip++) XtRemoveInput(id); + } + _pop_set_xt_wakeup(FALSE); + _pop_set_Xt_poll(poll_appcons); - /* return number of devices ready or -1 if interrupted */ - return(IOWaitStatus > 0 ? IOWaitStatus : -1); + /* return number of devices ready or -1 if interrupted */ + return(IOWaitStatus > 0 ? IOWaitStatus : -1); } -#endif /* UNIX */ +#endif /* UNIX */ XtInputMask XptAppTryEvents(appcon) XtAppContext appcon; { XtInputMask m; - _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; + _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; - /* must do at least one event if available */ - while (m = XptAppPending(appcon)) - { XtAppProcessEvent(appcon, m); - if (last_event_appcon != appcon) - { last_event_appcon = appcon; - poll_time = POLL_INIT; - } - if (POP_CONDITION) break; - } + /* must do at least one event if available */ + while (m = XptAppPending(appcon)) + { XtAppProcessEvent(appcon, m); + if (last_event_appcon != appcon) + { last_event_appcon = appcon; + poll_time = POLL_INIT; + } + if (POP_CONDITION) break; + } - /* re-enable if set for async */ - set_async_appcon(TRUE, appcon); + /* re-enable if set for async */ + set_async_appcon(TRUE, appcon); - return(m); + return(m); } @@ -999,31 +978,31 @@ XtAppContext appcon; XtInputMask mask; { _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; - XtAppProcessEvent(appcon, mask); - set_async_appcon(TRUE, appcon); /* re-enable if set for async */ + XtAppProcessEvent(appcon, mask); + set_async_appcon(TRUE, appcon); /* re-enable if set for async */ } void XptAppNextEvent(appcon, event_return) XtAppContext appcon; XEvent *event_return; { XtAppNextEvent(appcon, event_return); - set_async_appcon(TRUE, appcon); /* re-enable if set for async */ + set_async_appcon(TRUE, appcon); /* re-enable if set for async */ } Boolean XptDispatchEvent(event) XEvent *event; { - _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; - return(XtDispatchEvent(event)); + _pop_external_flags |= PEF_RETURN_ABEXIT_ANY; + return(XtDispatchEvent(event)); } - /* All async appcons are disabled in pop before this is called */ + /* All async appcons are disabled in pop before this is called */ void XptAppMainLoop(appcon) XtAppContext appcon; { /* since there's no way of returning out of MainLoop that doesn't - screw the toolkit, might as well catch abnormal exits completely */ - _pop_external_flags |= PEF_CATCH_ABEXIT_ANY; - XtAppMainLoop(appcon); + screw the toolkit, might as well catch abnormal exits completely */ + _pop_external_flags |= PEF_CATCH_ABEXIT_ANY; + XtAppMainLoop(appcon); } @@ -1032,10 +1011,10 @@ #ifdef VMS /* - * This damn procedure name is 32 chars long, 1 over the limit for VMS - symbols, and the VMS version is called XtDisplayStringConvWarning anyway - (instead of just being truncated to 31 chars). - This defines the truncated name. + * This damn procedure name is 32 chars long, 1 over the limit for VMS + symbols, and the VMS version is called XtDisplayStringConvWarning anyway + (instead of just being truncated to 31 chars). + This defines the truncated name. */ void XtDisplayStringConversionWarnin(dpy, from_value, to_type) Display *dpy; @@ -1057,22 +1036,22 @@ typedef struct _XptInputId { struct _XptInputId *previd, - *nextid; - int chan; - unsigned short devclass, - ef_num; - XtInputId xt_id; - XtAppContext appcon; - XtInputCallbackProc proc; - Opaque clntdata; + *nextid; + int chan; + unsigned short devclass, + ef_num; + XtInputId xt_id; + XtAppContext appcon; + XtInputCallbackProc proc; + Opaque clntdata; } *XptInputId; #define NUM_ID_ENTRIES 8 static struct _XptInputId - id_entries[NUM_ID_ENTRIES], - id_dummy, - *free_ids; + id_entries[NUM_ID_ENTRIES], + id_dummy, + *free_ids; #define curr_id_list id_dummy.nextid @@ -1082,34 +1061,34 @@ static Boolean poll_input() { register XptInputId id; - register unsigned count; - Boolean result = FALSE; + register unsigned count; + Boolean result = FALSE; - for (id = curr_id_list; id != NULL; id = id->nextid) - { if (id->devclass == DC$_MAILBOX) - { /* mailbox */ - sys$getchn(id->chan, 0, &dib1desc, 0, 0); - /* number of messages in mailbox */ - count = *((unsigned short*) - &((struct dibdef*) dib1)->dib$l_devdepend); - } - else - { /* terminal */ - sys$qiow(0, id->chan, IO$_SENSEMODE|IO$M_TYPEAHDCNT, 0, 0, 0, - dib1, 8, 0, 0, 0, 0); - /* number of chars in typeahead buffer */ - count = *((unsigned short*) dib1); - }; - - if (count != 0) - { sys$setef(id->ef_num); - result = TRUE; - } - else - sys$clref(id->ef_num); - } + for (id = curr_id_list; id != NULL; id = id->nextid) + { if (id->devclass == DC$_MAILBOX) + { /* mailbox */ + sys$getchn(id->chan, 0, &dib1desc, 0, 0); + /* number of messages in mailbox */ + count = *((unsigned short*) + &((struct dibdef*) dib1)->dib$l_devdepend); + } + else + { /* terminal */ + sys$qiow(0, id->chan, IO$_SENSEMODE|IO$M_TYPEAHDCNT, 0, 0, 0, + dib1, 8, 0, 0, 0, 0); + /* number of chars in typeahead buffer */ + count = *((unsigned short*) dib1); + }; + + if (count != 0) + { sys$setef(id->ef_num); + result = TRUE; + } + else + sys$clref(id->ef_num); + } - return(result); + return(result); } static void inpt_callback(id, efp, xtidp) @@ -1117,10 +1096,10 @@ char *efp; XtInputId *xtidp; { XptInputId memid; - /* call handler */ - memid = id; - (*id->proc)(id->clntdata, &id->chan, (XtInputId*) &memid); - sys$clref(id->ef_num); + /* call handler */ + memid = id; + (*id->proc)(id->clntdata, &id->chan, (XtInputId*) &memid); + sys$clref(id->ef_num); } XptInputId XptAppAddInput(appcon, chan, condition, proc, clntdata) @@ -1129,203 +1108,196 @@ XtInputCallbackProc proc; Opaque clntdata; { register XptInputId id, lim; - unsigned dclass; - int ef_num, save; - static int setup_done; - - if (!setup_done) - { /* set up freelist */ - free_ids = id = id_entries; - for (lim = id+NUM_ID_ENTRIES-1; id < lim; id++) id->nextid = id+1; - id->nextid = NULL; - setup_done = TRUE; - }; - - /* check device */ - if (!(sys$getchn(chan, 0, &dib2desc, 0, 0)&1)) - /* invalid channel */ - return((XptInputId) NULL); - dclass = ((struct dibdef*) dib2)->dib$b_devclass; - if (dclass != DC$_MAILBOX && dclass != DC$_TERM) - /* currently only mailboxes & terminals supported */ - return((XptInputId) NULL); - - /* add entry */ - if ((id = free_ids) == NULL) return((XptInputId) NULL); /* no space left */ - ef_num = pop$get_clust0_ef(); - if (ef_num == -1) return((XptInputId) NULL); /* no event flag */ - - if (curr_id_list != NULL) save = sys$setast(0); - - sys$clref(ef_num); - free_ids = id->nextid; - id->previd = &id_dummy; - id->nextid = curr_id_list; /* current list becomes tail */ - id->chan = chan; - id->devclass = dclass; - id->ef_num = ef_num; - id->appcon = appcon; - id->proc = proc; - id->clntdata = clntdata; - id->xt_id = XtAppAddInput(appcon, ef_num, NULL, inpt_callback, id); - curr_id_list = id; /* make head of list */ - - if (id->nextid == NULL) - /* start checking */ - _pop_set_poll_state(IO_POLL_NUM, poll_input); - else if (save == SS$_WASSET) - sys$setast(1); + unsigned dclass; + int ef_num, save; + static int setup_done; + + if (!setup_done) + { /* set up freelist */ + free_ids = id = id_entries; + for (lim = id+NUM_ID_ENTRIES-1; id < lim; id++) id->nextid = id+1; + id->nextid = NULL; + setup_done = TRUE; + }; + + /* check device */ + if (!(sys$getchn(chan, 0, &dib2desc, 0, 0)&1)) + /* invalid channel */ + return((XptInputId) NULL); + dclass = ((struct dibdef*) dib2)->dib$b_devclass; + if (dclass != DC$_MAILBOX && dclass != DC$_TERM) + /* currently only mailboxes & terminals supported */ + return((XptInputId) NULL); + + /* add entry */ + if ((id = free_ids) == NULL) return((XptInputId) NULL); /* no space left */ + ef_num = pop$get_clust0_ef(); + if (ef_num == -1) return((XptInputId) NULL); /* no event flag */ + + if (curr_id_list != NULL) save = sys$setast(0); + + sys$clref(ef_num); + free_ids = id->nextid; + id->previd = &id_dummy; + id->nextid = curr_id_list; /* current list becomes tail */ + id->chan = chan; + id->devclass = dclass; + id->ef_num = ef_num; + id->appcon = appcon; + id->proc = proc; + id->clntdata = clntdata; + id->xt_id = XtAppAddInput(appcon, ef_num, NULL, inpt_callback, id); + curr_id_list = id; /* make head of list */ + + if (id->nextid == NULL) + /* start checking */ + _pop_set_poll_state(IO_POLL_NUM, poll_input); + else if (save == SS$_WASSET) + sys$setast(1); - return(id); + return(id); } void XptRemoveInput(id) register XptInputId id; { int save = sys$setast(0); - XtRemoveInput(id->xt_id); - pop$free_clust0_ef(id->ef_num); + XtRemoveInput(id->xt_id); + pop$free_clust0_ef(id->ef_num); - /* unlink from list and add to freelist */ - id->previd->nextid = id->nextid; - id->nextid = free_ids; - free_ids = id; - if (curr_id_list == NULL) - /* turn off checking */ - _pop_set_poll_state(IO_POLL_NUM, NULL); + /* unlink from list and add to freelist */ + id->previd->nextid = id->nextid; + id->nextid = free_ids; + free_ids = id; + if (curr_id_list == NULL) + /* turn off checking */ + _pop_set_poll_state(IO_POLL_NUM, NULL); - if (save == SS$_WASSET) sys$setast(1); + if (save == SS$_WASSET) sys$setast(1); } -#endif /* VMS */ +#endif /* VMS */ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, Jan 6 2007 - Set: do_pop_print = True; to make it easier to control - printing of X window warning messages (needed for Lesstif). - See - $usepop/pop/x/src/xt_error.p - Xpt_sys_pr_message - --- Robert Duncan, Aug 11 1998 - Changes for NuTCRACKER 4.0 + Changes for NuTCRACKER 4.0 --- John Gibson, Mar 26 1998 - Added missing include for + Added missing include for --- John Gibson, Apr 2 1997 - Added PopXtDefaultLanguageProc + Added PopXtDefaultLanguageProc --- Robert Duncan, Oct 28 1996 - Fixed XptPause for NuTCRACKER + Fixed XptPause for NuTCRACKER --- John Gibson, Sep 10 1996 - Changed poll_appcons to work better when _pop_in_X_call is true. + Changed poll_appcons to work better when _pop_in_X_call is true. --- Robert Duncan, May 29 1996 - Added cases for NuTCRACKER + Added cases for NuTCRACKER --- John Gibson, Aug 8 1995 - Added (XtPointer) casts on ____cond and ______client args to call of - XtAppAddInput in XptIOWait. + Added (XtPointer) casts on ____cond and ______client args to call of + XtAppAddInput in XptIOWait. --- John Gibson, Aug 4 1995 - Added cast for NULL in _pop_async_appcon_clos + Added cast for NULL in _pop_async_appcon_clos --- John Gibson, Mar 7 1995 - Made some things type "int" rather than "long" + Made some things type "int" rather than "long" --- Poplog System, Jan 18 1995 (Julian Clinton) - Added extra Linux include. + Added extra Linux include. --- John Gibson, Oct 24 1994 - _pop_signals_pending and _pop_external_flags are now the actual - pop variables rather than pointers to them + _pop_signals_pending and _pop_external_flags are now the actual + pop variables rather than pointers to them --- John Gibson, Jun 10 1994 - Replaced XptReadWait with XptIOWait for Unix + Replaced XptReadWait with XptIOWait for Unix --- John Gibson, May 23 1994 - Made polling time decrease to 2/5 sec over a longer period + Made polling time decrease to 2/5 sec over a longer period --- John Gibson, Dec 3 1993 - Added XtDisplayStringConversionWarnin for VMS + Added XtDisplayStringConversionWarnin for VMS --- Adrian Howard, Jul 5 1993 - Removed previous change and altered display structure access to - use legal NextRequest macro. + Removed previous change and altered display structure access to + use legal NextRequest macro. --- Robert Duncan, May 12 1993 - Minor change to disable access to the display structure when - compiling under HP-UX and without XLIB_ILLEGAL_ACCESS defined - (HP have made the display structure opaque under X11R5) + Minor change to disable access to the display structure when + compiling under HP-UX and without XLIB_ILLEGAL_ACCESS defined + (HP have made the display structure opaque under X11R5) --- John Gibson, May 6 1993 - Moved this file to $popexternlib + Moved this file to $popexternlib --- John Gibson, Dec 5 1992 - o Changed XptReadWait for VMS to work exactly the same as for Unix. - o Moved VMS pop$get_clust0_ef to c_core.c + o Changed XptReadWait for VMS to work exactly the same as for Unix. + o Moved VMS pop$get_clust0_ef to c_core.c --- Simon Nichols, Nov 3 1992 - Removed definition of CC$VAXCSHR, which in VMS V5.5 leads to three - undefined symbols (VAXC$GA_STD{ERR,IN,OUT}). + Removed definition of CC$VAXCSHR, which in VMS V5.5 leads to three + undefined symbols (VAXC$GA_STD{ERR,IN,OUT}). --- Robert John Duncan, Jun 9 1992 - Changed X_printf to use ANSI varargs macros from + Changed X_printf to use ANSI varargs macros from --- Robert John Duncan, Jun 8 1992 - Removed references to b*copy and b*zero (not defined on all systems) + Removed references to b*copy and b*zero (not defined on all systems) --- John Gibson, Dec 4 1991 - More mods to fix XptPause & XptReadWait + More mods to fix XptPause & XptReadWait --- John Gibson, Dec 2 1991 - VMS mod to XptReadWait + VMS mod to XptReadWait --- Robert John Duncan, Nov 28 1991 - Added declaration for -errno- + Added declaration for -errno- --- John Gibson, Nov 21 1991 - Changed X_printf so it just uses printf to print messages. - Made VMS fixes. + Changed X_printf so it just uses printf to print messages. + Made VMS fixes. --- Robert John Duncan, Nov 7 1991 - Reinstated definition of _SysErrorMsg for Unix + Reinstated definition of _SysErrorMsg for Unix --- John Gibson, Oct 31 1991 - Removed dummy VMS definitions for R4 X stuff, etc. + Removed dummy VMS definitions for R4 X stuff, etc. --- Jonathan Meyer, Sep 11 1991 - Changed to use mishap codes for error messages + Changed to use mishap codes for error messages --- Jonathan Meyer, Sep 6 1991 - Added X_printf - for printing errors nicely. - Added erorr handlers using the X tooliit higher level interface as - well. + Added X_printf - for printing errors nicely. + Added erorr handlers using the X tooliit higher level interface as + well. --- Jonathan Meyer, Jul 31 1991 - renamed XptWm -> XptWM + renamed XptWm -> XptWM --- Robert John Duncan, Jul 2 1991 - Removed unnecessary XtIsShell check in XptWMProtocol - (wouldn't compile under OpenWindows) + Removed unnecessary XtIsShell check in XptWMProtocol + (wouldn't compile under OpenWindows) --- Roger Evans, Jun 28 1991 removed callback code --- Jonathan Meyer, Jun 21 1991 - Added hard reference to _vendorShellWidgetClass so that poplog - can easily be linked with Motif and OLIT2.5. + Added hard reference to _vendorShellWidgetClass so that poplog + can easily be linked with Motif and OLIT2.5. --- Jonathan Meyer, Jun 5 1991 - Changed XptAddProtoHandler to add the handler to the - tail of the list so that it will not override any handlers - that have been added by the widget itself. - Changed the response of XptWMProtocol to call XtPopdown on - shell widgets created using XtAppCreatePopupShell, and - XtDestroyWidget on other shell widgets. + Changed XptAddProtoHandler to add the handler to the + tail of the list so that it will not override any handlers + that have been added by the widget itself. + Changed the response of XptWMProtocol to call XtPopdown on + shell widgets created using XtAppCreatePopupShell, and + XtDestroyWidget on other shell widgets. --- Jonathan Meyer, May 29 1991 - added XpolAddListItem - to fix sun3 scrolling list procedure - as in bugreport isl-fr.4319 + added XpolAddListItem - to fix sun3 scrolling list procedure + as in bugreport isl-fr.4319 --- Roger Evans, May 29 1991 - added better protocol handling to XptAddProtoHandler + added better protocol handling to XptAddProtoHandler --- Roger Evans, May 26 1991 - changed PopXIOError to call XIO_sys_error_handler and - clear abexit flags + changed PopXIOError to call XIO_sys_error_handler and + clear abexit flags --- John Gibson, Mar 14 1991 - Added async appcontext processing and lots of other changes. + Added async appcontext processing and lots of other changes. --- John Gibson, Feb 11 1991 - Added VMS stuff, reorganised XptReadWait and split off XptPause, etc. + Added VMS stuff, reorganised XptReadWait and split off XptPause, etc. --- Roger Evans, Feb 3 1991 added closdisplay to XIO error handler --- Roger Evans, Jan 29 1991 - Added protocol message handler and action initialisation - Added garbage action handler + Added protocol message handler and action initialisation + Added garbage action handler --- Roger Evans, Jan 28 1991 - Added XptAppPending code to fix X lockout problems (bug report - jonm.3) + Added XptAppPending code to fix X lockout problems (bug report + jonm.3) --- John Gibson, Jan 19 1991 - Added call of _pop_set_xt_wakeup(0) in _XptDummyInput + Added call of _pop_set_xt_wakeup(0) in _XptDummyInput --- Roger Evans, Nov 21 1990 fixed oneshot processing! --- Roger Evans, Nov 21 1990 added oneshot processing to XptReadWait --- Roger Evans, Nov 20 1990 added XptDummyInput --- Roger Evans, Nov 20 1990 added more abnormal exit code --- Roger Evans, Nov 19 1990 added abnormal exit code --- John Gibson, Nov 19 1990 - Replaced pop_interrupt_pending() with *_pop_signals_pending + Replaced pop_interrupt_pending() with *_pop_signals_pending --- Roger Evans, Nov 9 1990 added XptReadWait --- Roger Evans, Nov 8 1990 - added XptActionHook and revised CB_TYPE orderings + added XptActionHook and revised CB_TYPE orderings --- Roger Evans, Oct 11 1990 Much revised - changed to use real callback - threw away action stuff + changed to use real callback + threw away action stuff --- Roger Evans, Jun 26 1990 added new definition for -select- --- Roger Evans, Mar 9 1990 corrected E_PTR value in PopXtDestroyCallback - for new data representation + for new data representation */ Only in v15.63/pop/extern/lib: XtPoplog.c.OK Only in v15.63/pop/extern/lib: XtPoplog.c.orig Only in v15.6301-amd64/pop/extern/lib: c_core.c.bb Only in v15.63/pop/extern/lib: c_core.c.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/extern/lib/c_core.h v15.6301-amd64/pop/extern/lib/c_core.h --- v15.63/pop/extern/lib/c_core.h 1999-01-19 21:36:23.000000000 -0500 +++ v15.6301-amd64/pop/extern/lib/c_core.h 2005-03-11 05:30:38.000000000 -0500 @@ -217,7 +217,7 @@ #define TF_ABS 4 #define TF_REPEAT 8 -extern int pop_timer(); +extern long pop_timer(); /* * Common definitions Only in v15.63/pop/extern/lib: encoding_euc_jp.so Only in v15.63/pop/extern/lib: encoding_iso8859_1.so Only in v15.63/pop/extern/lib: encoding_iso8859_8.so Only in v15.63/pop/extern/lib: encoding_shift_jis.so Only in v15.63/pop/extern/lib: encoding_ucs_2.so Only in v15.63/pop/extern/lib: encoding_utf_8.so Only in v15.63/pop/extern/lib: libXpw.so Only in v15.63/pop/extern/lib: libpop.a diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/extern/lib/mklibpop v15.6301-amd64/pop/extern/lib/mklibpop --- v15.63/pop/extern/lib/mklibpop 1999-01-19 21:36:03.000000000 -0500 +++ v15.6301-amd64/pop/extern/lib/mklibpop 2009-12-24 15:25:18.000000000 -0500 @@ -80,7 +80,8 @@ rm -f $LIB # compile files and create library -$CC -c -O $CC_FLAGS -I$POP_X_INCLUDE *.c && \ +echo $CC -c -g -O $CC_FLAGS -I$POP_X_INCLUDE *.c +$CC -c -g -O $CC_FLAGS -I$POP_X_INCLUDE *.c && \ $AR $LIB *.o && \ $RANLIB diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/extern/lib/pop_timer.c v15.6301-amd64/pop/extern/lib/pop_timer.c --- v15.63/pop/extern/lib/pop_timer.c 1996-10-23 09:18:00.000000000 -0400 +++ v15.6301-amd64/pop/extern/lib/pop_timer.c 2005-03-11 05:30:39.000000000 -0500 @@ -532,7 +532,7 @@ RESTORE_ERRNO; } -int pop_timer(flags, ident, handler, tvp) +long pop_timer(flags, ident, handler, tvp) unsigned flags; POPWORD ident; void (*handler)(); Only in v15.6301-amd64/pop/lib/auto: popuseslist.p- Only in v15.63/pop/lib/auto: speak_espeak.p Only in v15.63/pop/lib/auto: speak_flite.p diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/arrays.p v15.6301-amd64/pop/lisp/src/arrays.p --- v15.63/pop/lisp/src/arrays.p 1996-04-17 07:01:51.000000000 -0400 +++ v15.6301-amd64/pop/lisp/src/arrays.p 2009-12-30 17:03:00.000000000 -0500 @@ -545,8 +545,6 @@ ;;; defaults if len fi_< 16 then 16 - elseif len fi_> 64 then - 64 else len endif @@ -758,10 +756,10 @@ lq1 fi_+ 1 -> lq1; lq2 fi_+ 1 -> lq2; lq3 fi_+ 1 -> lq3; - fast_apply( + fi_&&(fast_apply( sub_s(lq1, v1), sub_s(lq2, v2), - bit_op) -> sub_s(lq3, v3) + bit_op), 255) -> sub_s(lq3, v3) endwhile; returnif (hr1 == 0); /* No bits left over */ lq1 fi_<< 3 fi_+ 1 -> lo1; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/chars.p v15.6301-amd64/pop/lisp/src/chars.p --- v15.63/pop/lisp/src/chars.p 1995-08-07 11:59:05.000000000 -0400 +++ v15.6301-amd64/pop/lisp/src/chars.p 2009-12-27 00:32:50.000000000 -0500 @@ -106,7 +106,9 @@ /* Character conversions */ define character(item); - if isintegral(item) then + if ischaracter(item) then + item + elseif isintegral(item) then conscharacter(item) else get_simple_string(item) -> item; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/equals.p v15.6301-amd64/pop/lisp/src/equals.p --- v15.63/pop/lisp/src/equals.p 1995-08-08 06:50:25.000000000 -0400 +++ v15.6301-amd64/pop/lisp/src/equals.p 2009-12-27 00:32:39.000000000 -0500 @@ -194,13 +194,13 @@ returnunless ((hi1 fi_- lo1) == (hi2 fi_- lo2)) (false); unless b1 do - lo1 -> fast_front(Temp_b1); - hi1 -> fast_front(Temp_b1_back); + 0 -> fast_front(Temp_b1); + hi1 fi_- lo1 -> fast_front(Temp_b1_back); Temp_b1 -> b1 endunless; unless b2 do - lo2 -> fast_front(Temp_b2); - hi2 -> fast_front(Temp_b2_back); + 0 -> fast_front(Temp_b2); + hi2 fi_- lo2 -> fast_front(Temp_b2_back); Temp_b2 -> b2 endunless; returnunless (sys_=(b1, b2)) (false); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/exporti.p v15.6301-amd64/pop/lisp/src/exporti.p --- v15.63/pop/lisp/src/exporti.p 1996-01-17 11:21:53.000000000 -0500 +++ v15.6301-amd64/pop/lisp/src/exporti.p 2009-12-30 18:38:17.000000000 -0500 @@ -95,7 +95,7 @@ Exporti(@SECOND, inline_cadr, false); Exporti(@SEVENTH, inline_nth(% 7, pair_key %), false); Exporti(@SIXTH, inline_nth(% 6, pair_key %), false); -Exporti(@SVREF, inline_svref, false); +;;; Exporti(@SVREF, inline_svref, false); Exporti(@TENTH, inline_nth(% 10, pair_key %), false); Exporti(@THIRD, inline_nth(% 3, pair_key %), false); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/exports v15.6301-amd64/pop/lisp/src/exports --- v15.63/pop/lisp/src/exports 1999-08-27 09:01:57.000000000 -0400 +++ v15.6301-amd64/pop/lisp/src/exports 2009-12-30 00:04:57.000000000 -0500 @@ -297,7 +297,7 @@ @GET-DECODED-TIME, get_decoded_time, [0 0 9] @GET-DISPATCH-MACRO-CHARACTER, get_dmac_char, [2 3 1] @GET-INTERNAL-REAL-TIME, get_internal_real_time, [0 0 1] -@GET-INTERNAL-RUN-TIME, systime, [0 0 1] +@GET-INTERNAL-RUN-TIME, get_internal_run_time, [0 0 1] @GET-MACRO-CHARACTER, get_macro_char, [1 2 2] @GET-OUTPUT-STREAM-STRING, get_stringout_string, [] @GET-PROPERTIES, get_properties, [] diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/hash.p v15.6301-amd64/pop/lisp/src/hash.p --- v15.63/pop/lisp/src/hash.p 1995-11-29 10:19:25.000000000 -0500 +++ v15.6301-amd64/pop/lisp/src/hash.p 2009-12-30 16:15:01.000000000 -0500 @@ -19,7 +19,8 @@ dlocal pop_hash_lim; #_< syshash(pair_key) >_#; ;;; Running total kept on stack - while ispair(l) do + if pop_hash_lim /== 0 then + while ispair(l) do pop_hash_lim fi_- 1 -> pop_hash_lim; fast_apply(fast_destpair(l) -> l, hash_p); unless isinteger(dup()) do @@ -27,9 +28,10 @@ endunless; nonop fi_+ (); returnif(pop_hash_lim == 0); - endwhile; - if l /== [] then + endwhile; + if l /== [] then fi_+ fast_apply(l, hash_p) + endif endif enddefine; @@ -176,7 +178,7 @@ /* Convert rehash size to power of two */ if rehash_size == nil then - false + 1 elseif (isinteger(rehash_size) and rehash_size fi_> 0) then 1 elseif (isdecimal(rehash_size) and rehash_size > 1) then @@ -194,7 +196,7 @@ /* Convert rehash threshold (occupancy ratio) into number of entries */ if rehash_threshold == nil then - false + round(size * 0.7) else unless isreal(rehash_threshold) and rehash_threshold >= 0 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/inlines.p v15.6301-amd64/pop/lisp/src/inlines.p --- v15.63/pop/lisp/src/inlines.p 1996-01-17 11:20:50.000000000 -0500 +++ v15.6301-amd64/pop/lisp/src/inlines.p 2009-12-30 18:35:25.000000000 -0500 @@ -356,7 +356,7 @@ inline_rplaca = Inline_any(% fast_rplaca, 2 %), inline_rplacd = Inline_any(% fast_rplacd, 2 %), inline_schar = Inline_any(% fast_schar, 2 %), - inline_svref = Inline_any(% fast_subscrv0, 2 %), /* see note below */ +;;; inline_svref = Inline_any(% fast_subscrv0, 2 %), /* see note below */ inline_char_code= Inline_any(% fast_char_code, 1 %), inline_code_char= Inline_any(% fast_code_char, 1 %), inline_char_int = Inline_any(% fast_char_code, 1 %), diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/itemise.p v15.6301-amd64/pop/lisp/src/itemise.p --- v15.63/pop/lisp/src/itemise.p 1995-08-25 10:56:52.000000000 -0400 +++ v15.6301-amd64/pop/lisp/src/itemise.p 2009-12-27 00:31:54.000000000 -0500 @@ -124,17 +124,6 @@ enddefine; -define skipform(); - ;;; used when *READ-SUPPRESS* is true - if is_char_mac(lextype) then - lextype() - else - until (lexget(), AT_TOKEN_END) do enduntil, lexput(); - nil - endif -enddefine; - - define digit(); lvars n; lexchar; @@ -263,12 +252,32 @@ true -> lex_eof_error; ;;; force an error eof() endif; - lexchar + if read_suppress == nil then + lexchar + endif enduntil; false ->> lex_redo -> lexnum enddefine; +define skipform(); + ;;; used when *READ-SUPPRESS* is true + if is_char_mac(lextype) then + lextype() + else + repeat + if lextype == multiple_escape then + multiple_escape() + elseif lextype == single_escape then + lexget() + endif; + lexget(); + quitif(AT_TOKEN_END); + endrepeat, lexput(); + nil + endif +enddefine; + define colon(); lvars pkg; if lexpkg then diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/print.p v15.6301-amd64/pop/lisp/src/print.p --- v15.63/pop/lisp/src/print.p 1995-11-29 10:21:19.000000000 -0500 +++ v15.6301-amd64/pop/lisp/src/print.p 2009-12-26 19:31:24.000000000 -0500 @@ -355,7 +355,13 @@ define lconstant Escape_pr(s); cucharout(`|`); - appdata(s, cucharout); + appdata(s, + procedure(c); + if c = `\\` or c = `|` then + cucharout(`\\`); + endif; + cucharout(c); + endprocedure); cucharout(`|`); enddefine; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/specs.p v15.6301-amd64/pop/lisp/src/specs.p --- v15.63/pop/lisp/src/specs.p 1995-08-07 10:15:53.000000000 -0400 +++ v15.6301-amd64/pop/lisp/src/specs.p 2009-12-30 21:34:48.000000000 -0500 @@ -8,15 +8,20 @@ lisp_compile_mode; +#include sysdefs.ph + section $-lisp; /* Field spec <-> element type conversions */ lconstant Word_spec_to_int - = newproperty([[uint 32] + = newproperty([ + [ulong 64] + [long -64] + [uint 32] [int -32] - [ulong 32] - [long -32] + [uint 32] + ;;; [long -32] [pint -30] [ushort 16] [short -16] @@ -25,8 +30,11 @@ lconstant Int_spec_to_word - = newproperty([[-32 long] - [32 ulong] + = newproperty([ + [64 ulong] + [-64 long] + [-32 int] + [32 uint] [-30 pint] [-16 short] [16 ushort] @@ -133,17 +141,32 @@ /* Key <-> spec/element-type conversions */ lconstant Spec_to_key - = newproperty([[1 ^bitvector_key] - [character ^string_key] - [short ^shortvec_key] - [int ^intvec_key] - [long ^intvec_key] - [full ^vector_key]], 31, false, true); + = newproperty([[1 ^bitvector_key] + [character ^string_key] + [byte ^bytevec_key] + [sbyte ^sbytevec_key] + [ushort ^ushortvec_key] + [short ^shortvec_key] + [uint ^untvec_key] + [int ^intvec_key] + [ulong ^ulongvec_key] + [long ^longvec_key] + [full ^vector_key]], 31, false, true); define spec_->_key(spec) -> key; - if isintegral(spec) and abs(spec) > 32 then - "full" -> spec + if isintegral(spec) then + if abs(spec) > 64 then + "full" + elseif abs(spec) > 32 then + if spec > 0 then "ulong" else "long" endif; + elseif abs(spec) > 16 then + if spec > 0 then "uint" else "int" endif; + elseif abs(spec) > 8 then + if spec > 0 then "ushort" else "short" endif; + elseif abs(spec) > 1 then + if spec > 0 then "byte" else "sbyte" endif; + else spec endif -> spec; elseif spec == "decimal" then "sfloat" -> spec elseif spec == "ddecimal" then diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/lisp/src/time.p v15.6301-amd64/pop/lisp/src/time.p --- v15.63/pop/lisp/src/time.p 1995-11-29 10:21:51.000000000 -0500 +++ v15.6301-amd64/pop/lisp/src/time.p 2009-12-30 08:24:25.000000000 -0500 @@ -11,7 +11,7 @@ section $-lisp; -constant internal_time_units_per_sec = 100; +constant internal_time_units_per_sec = 1000000; constant _1900_1970 = 70 * 365 * 86400 /* 17 leap years */ + (17 * 86400); @@ -20,9 +20,12 @@ sys_real_time() + _1900_1970 enddefine; +define get_internal_run_time(); + systime()*10000 ;;; internal_time_units_per_sec/100 +enddefine; define get_internal_real_time(); - sys_real_time() * internal_time_units_per_sec + sys_microtime() enddefine; Only in v15.6301-amd64/pop/obj: old Only in v15.63/pop/obj: src.olb Only in v15.63/pop/obj: src.wlb Only in v15.63/pop/obj: vedsrc.olb Only in v15.63/pop/obj: vedsrc.wlb Only in v15.63/pop/obj: xsrc.olb Only in v15.63/pop/obj: xsrc.wlb Only in v15.63/pop/packages/com: mkrhino Only in v15.63/pop/packages/com: popbin Only in v15.63/pop/packages/com: poplogout.sh-dud Only in v15.6301-amd64/pop/packages/contrib: AATARBUILD2004-10-10 Only in v15.6301-amd64/pop/packages/contrib: AATARFILE.LATEST Only in v15.6301-amd64/pop/packages/contrib: CONTENTS Only in v15.6301-amd64/pop/packages/contrib: COPYRIGHT Only in v15.6301-amd64/pop/packages/contrib: ai_through_search Only in v15.6301-amd64/pop/packages/contrib: contrib.news Only in v15.6301-amd64/pop/packages/contrib: lisp Only in v15.6301-amd64/pop/packages/contrib: nlp_book Only in v15.6301-amd64/pop/packages/contrib: pml Only in v15.6301-amd64/pop/packages/contrib: pop11 Only in v15.6301-amd64/pop/packages/contrib: prolog Only in v15.6301-amd64/pop/packages/contrib: pwm Only in v15.6301-amd64/pop/packages/contrib: ved Only in v15.6301-amd64/pop/packages/contrib: x Only in v15.63/pop/packages/master: README Only in v15.6301-amd64/pop/packages/neural/bin: alpha Only in v15.6301-amd64/pop/packages/neural/bin: axposf Only in v15.6301-amd64/pop/packages/neural/bin: sun Only in v15.6301-amd64/pop/packages/neural/bin: sun4r5 Only in v15.6301-amd64/pop/packages/neural/bin: sun4r5.old Only in v15.63/pop/packages/newc_dec: auto Only in v15.63/pop/packages/newkit: AREADME.txt Only in v15.63/pop/packages/newkit/prb: AREADME.txt Only in v15.6301-amd64/pop/packages/newkit/prb: README Only in v15.63/pop/packages/newkit/sim: AREADME.txt Only in v15.6301-amd64/pop/packages/popvision: AATARBUILD-2005-01-07 Only in v15.6301-amd64/pop/packages/popvision: AATARBUILD-2006-03-29 Only in v15.6301-amd64/pop/packages/popvision: AATARFILE.LATEST Only in v15.63/pop/packages/popvision: AATARFILE.LATEST-090220 Only in v15.63/pop/packages/prb: AREADME.txt Only in v15.6301-amd64/pop/packages/prb: README Only in v15.63/pop/packages/rclib: AREADME.txt Only in v15.6301-amd64/pop/packages/rclib: COPYRIGHT Only in v15.6301-amd64/pop/packages/rclib: README Only in v15.63/pop/packages/rcmenu: hyper.pdf Only in v15.6301-amd64/pop/packages/rcmenu: hyper.ps.gz Only in v15.63/pop/packages/sim: AREADME.txt Only in v15.63/pop/packages/teaching: AREADME.txt Only in v15.63/pop/packages/teaching/auto: haiku_speak.p Only in v15.63/pop/packages/teaching/lib: eliza_speak.p Only in v15.6301-amd64/pop/packages/teaching/lib: elizaprog.p- Only in v15.63/pop/packages/teaching/lib: rhino.p Only in v15.6301-amd64/pop/packages/vedlatex/auto: findcite.p.orig Only in v15.63/pop/packages/vedutils: AREADME.txt Only in v15.6301-amd64/pop/pop: .nfs00000000001c45f000000001 Only in v15.63/pop/pop: AS-build-on-CentOS-5.2-2009-07-04 Only in v15.63/pop/pop: AS-re-packaged-2009-07-04 Only in v15.63/pop/pop: basepop11 Only in v15.63/pop/pop: basepop11.stb Only in v15.63/pop/pop: clisp Only in v15.63/pop/pop: copybasepop11 Binary files v15.63/pop/pop/corepop and v15.6301-amd64/pop/pop/corepop differ Only in v15.63/pop/pop: corepop11 Only in v15.6301-amd64/pop/pop: cpu.dat Only in v15.63/pop/pop: doc Only in v15.63/pop/pop: im Only in v15.63/pop/pop: newpop.psv diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/pop/pgcomp v15.6301-amd64/pop/pop/pgcomp --- v15.63/pop/pop/pgcomp 2007-12-25 17:23:46.000000000 -0500 +++ v15.6301-amd64/pop/pop/pgcomp 1994-12-16 11:33:14.000000000 -0500 @@ -1,5 +1,4 @@ -#!/bin/bash -##Altered 25 Dec 2007, to use 'bash' instead of 'sh' +#!/bin/sh # --- Copyright University of Sussex 1994. All rights reserved. ---------- # File: C.unix/pop/pgcomp # Purpose: Compile POPLOG source files (.p or .s) diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/pop/pglibr v15.6301-amd64/pop/pop/pglibr --- v15.63/pop/pop/pglibr 2007-12-25 17:24:12.000000000 -0500 +++ v15.6301-amd64/pop/pop/pglibr 1993-07-09 23:34:47.000000000 -0400 @@ -1,5 +1,4 @@ -#!/bin/bash -##Altered 25 Dec 2007, to use 'bash' instead of 'sh' +#!/bin/sh # --- Copyright University of Sussex 1993. All rights reserved. ---------- # File: C.unix/pop/pglibr # Purpose: Update POPLOG module library diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/pop/pglink v15.6301-amd64/pop/pop/pglink --- v15.63/pop/pop/pglink 2007-12-25 17:24:34.000000000 -0500 +++ v15.6301-amd64/pop/pop/pglink 2005-01-04 09:04:19.000000000 -0500 @@ -1,5 +1,4 @@ -#!/bin/bash -##Altered 25 Dec 2007, to use 'bash' instead of 'sh' +#!/bin/sh # --- Copyright University of Sussex 2005. All rights reserved. ---------- # File: C.unix/pop/pglink # Purpose: Link the full Poplog system Only in v15.63/pop/pop: pml Only in v15.63/pop/pop: pop11 Binary files v15.63/pop/pop/popc and v15.6301-amd64/pop/pop/popc differ Only in v15.63/pop/pop: popc.psv Binary files v15.63/pop/pop/poplibr and v15.6301-amd64/pop/pop/poplibr differ Only in v15.63/pop/pop: poplibr.psv Binary files v15.63/pop/pop/poplink and v15.6301-amd64/pop/pop/poplink differ Only in v15.63/pop/pop: poplink.psv Only in v15.63/pop/pop: poplink_1.o Only in v15.63/pop/pop: poplink_2.o Only in v15.63/pop/pop: poplink_3.o Only in v15.63/pop/pop: poplink_4.o Only in v15.63/pop/pop: poplink_cmnd Only in v15.63/pop/pop: poplink_cmnd.motif Only in v15.63/pop/pop: poplink_cmnd.motif.sh Only in v15.63/pop/pop: poplink_cmnd.nomotif Only in v15.63/pop/pop: poplink_cmnd.nomotif.sh Only in v15.63/pop/pop: poplink_dat.o Only in v15.63/pop/pop: popsetarch Only in v15.63/pop/pop: prolog Only in v15.63/pop/pop: ved Only in v15.63/pop/pop: xved diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/aarith.s v15.6301-amd64/pop/src/aarith.s --- v15.63/pop/src/aarith.s 2003-01-07 13:46:55.000000000 -0500 +++ v15.6301-amd64/pop/src/aarith.s 2005-03-11 06:16:00.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2002. All rights reserved. ---------- +/* --- Copyright University of Sussex 1996. All rights reserved. ---------- * File: S.pcunix/src/aarith.s * Purpose: Arithmetic routines for Intel 80x86 (Unix assembler) * Author: Robert Duncan, Oct 31 1988 (see revisions) @@ -15,8 +15,8 @@ lconstant macro ( - USP = "ebx", - PB = "ebp", + USP = "rbx", + PB = "rbp", _PD_EXECUTE = @@PD_EXECUTE, _PD_ARRAY_TABLE = @@PD_ARRAY_TABLE, @@ -56,40 +56,40 @@ DEF_C_LAB 4 (_biset) - movl (%USP), %eax - addl $4, %USP - orl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + orq %rax, (%USP) ret - .align 4 + .align 16 DEF_C_LAB 4 (_biclear) - movl (%USP), %eax - addl $4, %USP - notl %eax - andl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + notq %rax + andq %rax, (%USP) ret - .align 4 + .align 16 DEF_C_LAB 4 (_bimask) - movl (%USP), %eax - addl $4, %USP - andl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + andq %rax, (%USP) ret - .align 4 + .align 16 DEF_C_LAB 4 (_bixor) - movl (%USP), %eax - addl $4, %USP - xorl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + xorq %rax, (%USP) ret - .align 4 + .align 16 ;;; === MACHINE INTEGER ARITHMETIC ==================================== @@ -102,19 +102,19 @@ DEF_C_LAB 4 (_mult) - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP ;;; Multiply EAX by (%USP); result goes to EDX:EAX - imull (%USP) + imulq (%USP) ;;; Return low half of result - movl %eax, (%USP) + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _DIV ;;; Signed division @@ -126,21 +126,23 @@ ;;; Move the dividend into EAX and sign-extend into EDX:EAX - movl 4(%USP), %eax - cltd + movq 8(%USP), %rax +;;; cdtq + movq %rax, %rdx + sarq $63, %rdx ;;; Divide EDX:EAX by the divisor, (%USP), ;;; leaving the quotient in EAX and remainder in EDX - idivl (%USP) + idivq (%USP) ;;; Stack the remainder, then the quotient - movl %edx, 4(%USP) - movl %eax, (%USP) + movq %rdx, 8(%USP) + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _DIVQ ;;; Signed division, quotient only @@ -152,20 +154,22 @@ ;;; Move the dividend into EAX and sign-extend into EDX:EAX - movl 4(%USP), %eax - cltd + movq 8(%USP), %rax +;;; XXXXXXXXXXX @@@@@@@ cltd + movq %rax,%rdx + sarq $63,%rdx ;;; Divide EDX:EAX by the divisor, (%USP), ;;; leaving the quotient in EAX and remainder in EDX - idivl (%USP) + idivq (%USP) ;;; Stack the quotient - movl %eax, 4(%USP) - addl $4, %USP + movq %rax, 8(%USP) + addq $8, %USP ret - .align 4 + .align 16 ;;; _M_ASH ;;; Shift a machine integer by a signed quantity. @@ -185,21 +189,21 @@ ;;; Test the sign of the shift - testl %ecx, %ecx + testq %rcx, %rcx js L1.1 ;;; Sign is positive: shift left and return - sall %cl, %eax + salq %cl, %rax ret L1.1: ;;; Sign is negative: shift right by the absolute amount and return negl %ecx - sarl %cl, %eax + sarq %cl, %rax ret - .align 4 + .align 16 ;;; _SHIFT ;;; POP interface to _M_ASH: arguments and results go via the user stack @@ -209,14 +213,14 @@ DEF_C_LAB (_shift) - movl (%USP), %ecx - addl $4, %USP - movl (%USP), %eax + movq (%USP), %rcx + addq $8, %USP + movq (%USP), %rax call C_LAB(_m_ash) - movl %eax, (%USP) + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; === POP INTEGER ARITHMETIC ======================================== @@ -231,26 +235,26 @@ ;;; Pop the first popint into EAX, and make it a machine integer - movl (%USP), %eax - addl $4, %USP - sarl $2, %eax + movq (%USP), %rax + addq $8, %USP + sarq $2, %rax ;;; Copy the second operand into EDX and clear the popint bits - movl (%USP), %edx - subl $3, %edx + movq (%USP), %rdx + subq $3, %rdx ;;; Multiply EAX by EDX; result goes to EDX:EAX - imull %edx + imulq %rdx ;;; Return lower half of result (EAX) with popint bits restored - addl $3, %eax - movl %eax, (%USP) + addq $3, %rax + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _PMULT_TESTOVF ;;; Multiply two simple pop integers with a test for overflow. @@ -263,35 +267,35 @@ ;;; Copy the first popint into EAX, and make it a machine integer - movl (%USP), %eax - sarl $2, %eax + movq (%USP), %rax + sarq $2, %rax ;;; Copy the second operand into EDX and clear the popint bits - movl 4(%USP), %edx - subl $3, %edx + movq 8(%USP), %rdx + subq $3, %rdx ;;; Multiply EAX by EDX; result goes to EDX:EAX ;;; Overflow flag will be set if EDX:EAX is not a sign-extension ;;; of EAX - imull %edx + imulq %rdx ;;; Reset the popint bits in the lower half of the result (EAX) ;;; and put on the stack; LEAL and MOVL won't change the flags - leal 3(%eax), %eax - movl %eax, 4(%USP) + leaq 3(%rax), %rax + movq %rax, 8(%USP) ;;; Return for OK, for overflow jo L1.2 - movl $C_LAB(true), (%USP) + movq $C_LAB(true), (%USP) ret -L1.2: movl $C_LAB(false), (%USP) +L1.2: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PDIV: ;;; Divide two simple pop integers with no checking (implements fi_//) @@ -304,29 +308,32 @@ ;;; Copy the dividend into EAX, convert it to a machine integer ;;; and sign-extend through EDX:EAX - movl 4(%USP), %eax - sarl $2, %eax - cltd + movq 8(%USP), %rax + sarq $2, %rax + +;;; XXXX @@@@@ cltd + movq %rax,%rdx + sarq $63,%rdx ;;; Copy the divisor to ECX and convert to a machine integer - movl (%USP), %ecx - sarl $2, %ecx + movq (%USP), %rcx + sarq $2, %rcx ;;; Divide EDX:EAX by ECX, leaving the quotient in EAX and ;;; remainder in EDX - idivl %ecx + idivq %rcx ;;; Convert quotient and remainder back to popints and return - leal 3(, %edx, 4), %edx - movl %edx, 4(%USP) - leal 3(, %eax, 4), %eax - movl %eax, (%USP) + leaq 3(, %rdx, 4), %rdx + movq %rdx, 8(%USP) + leaq 3(, %rax, 4), %rax + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _PINT_TESTOVF: ;;; Convert machine integer to pop integer, checking for overflow. @@ -341,20 +348,20 @@ ;;; The conversion is just (_I << 2 + 3), but the shift has to be ;;; done in two 1-bit steps to allow the test - movl (%USP), %eax - sall $1, %eax + movq (%USP), %rax + salq $1, %rax jo L1.3 - sall $1, %eax + salq $1, %rax jo L1.3 - addl $3, %eax - movl %eax, (%USP) - subl $4, %USP - movl $C_LAB(true), (%USP) + addq $3, %rax + movq %rax, (%USP) + subq $8, %USP + movq $C_LAB(true), (%USP) ret -L1.3: movl $C_LAB(false), (%USP) +L1.3: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PSHIFT_TESTOVF: ;;; Left-shift a simple popint by a positive machine integer amount, @@ -370,15 +377,15 @@ ;;; Copy the popint (I) to EAX and clear the popint bits. ;;; If it's zero, there's no need to shift. - movl 4(%USP), %eax - subl $3, %eax + movq 8(%USP), %rax + subq $3, %rax je L1.4 - ;;; Copy the shift amount (_N) to ECX. If it's > 30, then the shift + ;;; Copy the shift amount (_N) to ECX. If it's > 61, then the shift ;;; will definitely overflow, so jump out. - movl (%USP), %ecx - cmpl $30, %ecx + movq (%USP), %rcx + cmpq $62, %rcx jg L2.1 ;;; The left shift (SALL) only sets the overflow flag for a shift @@ -387,28 +394,28 @@ ;;; the same amount and compare the result with the copied original. ;;; If they're not the same, the left shift must have overflowed. - movl %eax, %esi - sall %cl, %eax - movl %eax, %edx - sarl %cl, %edx - cmpl %edx, %esi + movq %rax, %rsi + salq %cl, %rax + movq %rax, %rdx + sarq %cl, %rdx + cmpq %rdx, %rsi jne L2.1 ;;; No overflow -- reset the popint bits in EAX, then return it ;;; with - addl $3, %eax - movl %eax, 4(%USP) -L1.4: movl $C_LAB(true), (%USP) + addq $3, %rax + movq %rax, 8(%USP) +L1.4: movq $C_LAB(true), (%USP) ret L2.1: ;;; Overflow -- pop the stack and return - addl $4, %USP - movl $C_LAB(false), (%USP) + addq $8, %USP + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; === BIGINTEGER ARITHMETIC ========================================= @@ -426,26 +433,32 @@ ;;; Copy argument slices to EAX, EDX - movl (%USP), %eax - movl 4(%USP), %edx + movq (%USP), %rax + movq 8(%USP), %rdx ;;; Multiply EAX by EDX, leaving double length result in EDX:EAX - imull %edx + imulq %rdx ;;; Shift the top bit of the low half (EAX) into the bottom bit of ;;; the high half (EDX), then clear the top bit in EAX - shldl $1, %eax, %edx - andl $0x7FFFFFFF, %eax +;;; shldl $1, %eax, %edx +;;; andl $0x7FFFFFFF, %eax + + movq %rax, %rdx +;;; altered for AMD64 +;;; salq $1, %rdx + sarq $31, %rdx + andq $0x7FFFFFFF, %rax ;;; Return the low part, then the high part - movl %eax, 4(%USP) - movl %edx, (%USP) + movq %rax, 8(%USP) + movq %rdx, (%USP) ret - .align 4 + .align 16 ;;; _EDIV: ;;; Divide a two-slice dividend by a single divisor. @@ -457,29 +470,33 @@ ;;; Pop divisor into ECX, then move lopart/hipart into EAX/EDX - movl (%USP), %ecx - addl $4, %USP - movl (%USP), %eax - movl 4(%USP), %edx + movq (%USP), %rcx + addq $8, %USP + movq (%USP), %rax + movq 8(%USP), %rdx ;;; Combine the two slices by shifting EDX right 1, and transferring ;;; its bottom bit into the top bit of EAX. - sall $1, %eax - shrdl $1, %edx, %eax - sarl $1, %edx +;;; sall $1, %eax +;;; shrdl $1, %edx, %eax +;;; sarl $1, %edx + + salq $31, %rdx + orq %rdx, %rax + movq $0, %rdx ;;; Divide EDX:EAX by ECX - idivl %ecx + idivq %rcx ;;; Return the remainder, then the quotient - movl %edx, 4(%USP) - movl %eax, (%USP) + movq %rdx, 8(%USP) + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _BGI_MULT: ;;; Multiply a biginteger by a signed machine integer and store the @@ -498,21 +515,21 @@ ;;; ECX the carry slice ;;; Memory usage: -;;; 4(%USP) the multiplier, left on the user stack +;;; 8(%USP) the multiplier, left on the user stack ;;; SRCLIM the source limit -- points one beyond the end of the source DEF_C_LAB (_bgi_mult) ;;; Load arguments to registers - movl (%USP), %edi ;;; destination start - movl 4(%USP), %eax ;;; source limit - movl 8(%USP), %esi ;;; source start - addl $8, %USP + movq (%USP), %rdi ;;; destination start + movq 8(%USP), %rax ;;; source limit + movq 16(%USP), %rsi ;;; source start + addq $16, %USP ;;; Save the source limit - movl %eax, SRCLIM + movq %rax, SRCLIM ;;; Initialise the carry slice to zero @@ -527,7 +544,7 @@ ;;; load the next slice into EAX and multiply into EDX:EAX slodl - imull 4(%USP) + imull 8(%USP) ;;; Add the previous carry slice to the double-length result. @@ -551,17 +568,18 @@ ;;; Compare the source pointer (ESI) with the source limit; ;;; loop if ESI < SRCLIM. - cmpl %esi, SRCLIM + cmpq %rsi, SRCLIM ja L1.5 ;;; Finished -- return the carry slice, then the next destination ;;; pointer - movl %ecx, 4(%USP) - movl %edi, (%USP) + movq %rdi, (%USP) + movslq %ecx, %rdi + movq %rdi, 8(%USP) ret - .align 4 + .align 16 ;;; _BGI_MULT_ADD: ;;; Multiply a biginteger by a signed machine integer and add it into @@ -580,7 +598,7 @@ ;;; ECX the carry slice and the destination slice for the addition ;;; Memory usage: -;;; 4(%USP) the multiplier, left on the user stack +;;; 8(%USP) the multiplier, left on the user stack ;;; SRCLIM the source limit -- points one beyond the end of the source ;;; (declared above) @@ -588,14 +606,14 @@ ;;; Load arguments to registers - movl (%USP), %edi ;;; destination start - movl 4(%USP), %eax ;;; source limit - movl 8(%USP), %esi ;;; source start - addl $8, %USP + movq (%USP), %rdi ;;; destination start + movq 8(%USP), %rax ;;; source limit + movq 16(%USP), %rsi ;;; source start + addq $16, %USP ;;; Save the source limit - movl %eax, SRCLIM + movq %rax, SRCLIM ;;; Set the initial carry slice to zero @@ -610,7 +628,7 @@ ;;; load the next slice into EAX and multiply into EDX:EAX slodl - imull 4(%USP) + imull 8(%USP) ;;; Add the previous carry slice to the double-length result. @@ -622,7 +640,7 @@ ;;; Load the next destination slice into ECX and add it into ;;; EDX:EAX (just like the carry slice) - movl (%edi), %ecx + movl (%rdi), %ecx addl %ecx, %eax adcl $0, %edx sarl $31, %ecx @@ -643,17 +661,18 @@ ;;; Compare the source pointer (ESI) with the source limit; ;;; loop if ESI < SRCLIM - cmpl %esi, SRCLIM + cmpq %rsi, SRCLIM ja L1.6 ;;; Finished -- return carry slice, then the next destination ;;; pointer - movl %ecx, 4(%USP) - movl %edi, (%USP) + movq %rdi, (%USP) + movslq %ecx, %rdi + movq %rdi, 8(%USP) ret - .align 4 + .align 16 ;;; _BGI_DIV: ;;; Divide a biginteger by a signed machine integer into a destination @@ -676,10 +695,10 @@ ;;; Load arguments to registers - movl (%USP), %edi ;;; destination end - movl 4(%USP), %esi ;;; source end - movl 8(%USP), %ecx ;;; source start - addl $12, %USP + movq (%USP), %rdi ;;; destination end + movq 8(%USP), %rsi ;;; source end + movq 16(%USP), %rcx ;;; source start + addq $24, %USP ;;; Set the direction flag: ;;; division works from the last slice back to the first slice, @@ -690,8 +709,8 @@ ;;; ESI and EDI point one beyond the last source and destination ;;; slices, so do an initial adjustment - subl $4, %esi - subl $4, %edi + subq $4, %rsi + subq $4, %rdi ;;; Load the top source slice (which carries the sign bit) into EAX; ;;; sign-extend into EDX:EAX then branch to do the first division @@ -722,15 +741,16 @@ ;;; Compare the source pointer (ESI) with the source start (ECX); ;;; loop if ESI >= ECX - cmpl %esi, %ecx + cmpq %rsi, %rcx jbe L1.7 ;;; Finished -- return the last remainder - movl %edx, (%USP) + movslq %edx, %rax + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; === COMPUTE ARRAY SUBSCRIPTS ====================================== @@ -769,28 +789,28 @@ ;;; Initialise ESI to point at array parameters - leal _PD_ARRAY_TABLE(%PB), %esi + leaq _PD_ARRAY_TABLE(%PB), %rsi cld ;;; Initialise ECX with subscript offset - movl (%esi), %ecx - addl $4, %esi + movq (%rsi), %rcx + addq $8, %rsi ;;; Load first dimension to EAX: may be zero already for a ;;; 0-dimensional array - slodl - testl %eax, %eax + slodq + testq %rax, %rax jz L1.10 L1.8: ;;; Start of loop: ;;; get the next index from the stack into EDX and check it's ;;; a pop integer - movl (%USP), %edx - addl $4, %USP - testl $2, %edx + movq (%USP), %rdx + addq $8, %USP + testq $2, %rdx jz array_sub_error ;;; Subtract the next lower bound from the index and check it for @@ -798,53 +818,53 @@ ;;; Both index and lower bound are popints; the subtraction clears ;;; the bottom two bits. - subl (%esi), %edx - addl $4, %esi ;;; bump up the arg pointer - cmpl %eax, %edx + subq (%rsi), %rdx + addq $8, %rsi ;;; bump up the arg pointer + cmpq %rax, %rdx jae array_sub_error ;;; Get the dimension scaling factor in EAX and use it to scale ;;; the index (NB: 0 means 1, so don't multiply!) - slodl - testl %eax, %eax + slodq + testq %rax, %rax jz L1.9 - imull %eax, %edx + imulq %rax, %rdx L1.9: ;;; Add to the running total - addl %edx, %ecx + addq %rdx, %rcx ;;; Get the next dimension in EAX and loop if non-zero - slodl - testl %eax, %eax + slodq + testq %rax, %rax jnz L1.8 L1.10: ;;; Finished -- push total subscript to stack, push array vector ;;; to stack, and then chain subscripting procedure - subl $8, %USP - movl %ecx, 4(%USP) - movl _PD_ARRAY_VECTOR(%PB), %eax - movl %eax, (%USP) - movl _PD_ARRAY_SUBSCR_PDR(%PB), %eax - jmp *_PD_EXECUTE(%eax) + subq $16, %USP + movq %rcx, 8(%USP) + movq _PD_ARRAY_VECTOR(%PB), %rax + movq %rax, (%USP) + movq _PD_ARRAY_SUBSCR_PDR(%PB), %rax + jmp *_PD_EXECUTE(%rax) array_sub_error: ;;; Index on top of stack is invalid (either not a popint, or ;;; out of range) - subl $4, %USP ;;; reveal the last index again + subq $8, %USP ;;; reveal the last index again jmp XC_LAB(weakref Sys$-Array$-Sub_error) call XC_LAB(setpop) ;;; in case the error returns - .align 4 + .align 16 .data SRCLIM: - .long 0 + .quad 0 /***************** end labels for wrapping structures *****************/ @@ -860,16 +880,18 @@ /* --- Revision History --------------------------------------------------- +--- Waldek Hebisch, Feb 8 2005 + Converted from i386 to AMD64 --- Aaron Sloman, Jan 7 2003 - Replaced - call XC_LAB(weakref Sys$-Array$-Sub_error) - with - jmp XC_LAB(weakref Sys$-Array$-Sub_error) - as suggested by - hebisch@math.uni.wroc.pl (Waldek Hebisch) - following error report by - lucb@telus.net - both posted to comp.lang.pop + Replaced + call XC_LAB(weakref Sys$-Array$-Sub_error) + with + jmp XC_LAB(weakref Sys$-Array$-Sub_error) + as suggested by + hebisch@math.uni.wroc.pl (Waldek Hebisch) + following error report by + lucb@telus.net + both posted to comp.lang.pop --- Robert Duncan, Aug 9 1996 Removed special cases for S*CO diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/aextern.s v15.6301-amd64/pop/src/aextern.s --- v15.63/pop/src/aextern.s 1996-08-09 12:25:22.000000000 -0400 +++ v15.6301-amd64/pop/src/aextern.s 2010-01-03 05:55:39.000000000 -0500 @@ -13,8 +13,8 @@ lconstant macro ( - USP = "ebx", ;;; User stack pointer - PB = "ebp", ;;; Procedure base register + USP = "rbx", ;;; User stack pointer + PB = "rbp", ;;; Procedure base register SAVED_SP = [I_LAB(Sys$-Extern$- _saved_sp)], SAVED_USP = [I_LAB(Sys$-Extern$- _saved_usp)], @@ -22,7 +22,7 @@ _BGI_LENGTH = @@BGI_LENGTH, _BGI_SLICES = @@BGI_SLICES, _DD_1 = @@DD_1, ;;; MS half of ddecimal - _DD_2 = @@DD_2, ;;; LS half of ddecimal +;;; _DD_2 = @@DD_2, ;;; LS half of ddecimal _EFC_FUNC = @@EFC_FUNC, _EFC_ARG = @@EFC_ARG, _EFC_ARG_DEST = @@EFC_ARG_DEST, @@ -61,15 +61,7 @@ ;;; Results are returned in the three-word structure result_struct ;;; double float result first, followed by a single word result. ;;; Must be capable of dealing with callback. - -;;; Register usage: -;;; EAX argument conversion; result from the external call -;;; ECX number of arguments (_____nargs); -;;; address of result array -;;; EDX _________fltsingle bit mask -;;; ESI external type of compound arguments -;;; EDI address of the external routine (_______routine) - +;;; ;;; Memory usage: ;;; SAVED_SP ;;; pointer to the stack frame of the calling procedure; @@ -83,156 +75,271 @@ ;;; (on systems without mprotect) remembers the current ;;; break in case the external routine allocates extra store -DEF_C_LAB (_call_external) +;;; Registers: +;;; %rdi, %rsi, %rdx, %rcx, %r8, %r9 -- integer arguments +;;; %xmm0 to %xmm5 -- floating point arguments +;;; +;;; %rax -- work register, external type of compound arguments +;;; number of floating point arguments in registers +;;; at call +;;; %rbp -- frame pointer +;;; %r10 -- work register2, external type of compound arguments +;;; during conversion +;;; routne at call +;;; %r11 -- floating point argument store routine +;;; %r12 -- fltsingle +;;; %r13 -- integer argument store routine +;;; %r14 -- displacement on machine (control) stack +;;; %r15 -- displacement on Poplog (user) stack +;;; +;;; Work variables on the machine stack: +;;; -16(%rbp) -- saved rountine +;;; -24(%rbp) -- work variable for memory conversion +;;; -32(%rbp) -- number of floating point arguments in registers +;;; during conversion + + .text + +;;; Functions to store arguments, use macros to save on repetition +#_< +lvars ci = 0; +define lconstant macro gen_storei; + lvars x y; + itemread() -> x; + itemread() -> y; +'int_arg' >< ci >< ':\n'; + ci + 1 -> ci; + '\tmovq %rax', ",", '%' >< y, '\n'; + '\tmovq $int_arg' >< ci, ', %r13\n'; + '\tjmp next_arg\n\n'; +enddefine; +define lconstant macro gen_storesf; + lvars cf = 0, cfn; + while cf < 6 do + cf + 1 -> cfn; +'float_arg', >< cf, >< ':\n'; + '\incl -32(%rbp)\n'; + '\tmovq $float_arg', >< cfn, ',%r11\n'; + '\ttestl $1, %r12d\n'; + '\tjnz single_', >< cf >< '\n'; + +;;; just load the value + + '\tmovlpd -24(%rbp), %xmm' >< cf >< '\n'; + '\tsarl $1, %r12d\n'; + '\tjmp next_arg\n\n'; + +;;; convert to single + +'single_', >< cf >< ':\n'; + '\tcvtsd2ss -24(%rbp), %xmm' >< cf >< '\n'; + '\tsarl $1, %r12d\n'; + '\tjmp next_arg\n\n'; + cfn -> cf; + endwhile +enddefine; +>_# + +gen_storesf +gen_storei rdi +gen_storei rsi +gen_storei rdx +gen_storei rcx +gen_storei r8 +gen_storei r9 + +int_arg6: + movq %rax, (%rsp, %r14) + addq $8, %r14 + jmp next_arg + +float_arg6: + incl -32(%rbp) + testl $1, %r12d + jnz single_6 + movq %rax, (%rsp, %r14) + addq $8, %r14 + sarl $1, %r12d + jmp next_arg + +single_6: + cvtsd2ss -24(%rbp), %xmm7 + movss %xmm7, (%rsp, %r14) + addq $8, %r14 + sarl $1, %r12d + jmp next_arg + + +DEF_C_LAB (_call_external) #_IF CHECK_BREAK ;;; Save the current break in case the external routine allocates ;;; its own dynamic memory. - movl EXTERN_NAME(___brk_addr), %eax - movl %eax, save_curbrk + movq EXTERN_NAME(___brk_addr), %rax + movq %rax, save_curbrk #_ENDIF ;;; Save caller's stack pointer for interrupt/callback - leal 4(%esp), %eax - movl %eax, SAVED_SP + leaq 8(%rsp), %rbp + movq %rbp, SAVED_SP + + ;;; save registers. XXXX What to do about garbage collection + ;;; of Pop values ??? + push %r8 + push %r10 + push %r11 + push %r12 + push %r13 + push %r14 + push %r15 ;;; Load fixed arguments - movl (%USP), %edx ;;; _________fltsingle - movl 4(%USP), %edi ;;; _______routine - movl 8(%USP), %ecx ;;; _____nargs - addl $12, %USP - - testl %ecx, %ecx - jz do_call - - ;;; Rotate _________fltsingle to get bit for last arg at the top - - cmpl $32, %ecx - jae argloop - rorl %cl, %edx + movq (%USP), %r12 ;;; _________fltsingle + movq 8(%USP), %r10 ;;; _______routine + movq 16(%USP), %r15 ;;; _____nargs + shlq $3, %r15 ;;; convert ot byte offset; + leaq 24(%USP), %USP ;;; adjust user stack + xorl %eax,%eax + testq %r15, %r15 + jz do_call1 + +;;; We need 4 words on stack as a workplace +;;; In the worst case, when we have one argument (which always +;;; fits into a register this gives 3+nargs, push allocate 1 +;;; so we put another two into alignment code + + subq $56, %rbp + push %r10 + xorq %r14, %r14 + subq %r15, %rsp ;;; allocate space for arguments + subq $0x16, %rsp ;;; + andq $-0xf0, %rsp ;;; align the stack + movl $0, -32(%rbp) + movq %r15, -40(%rbp) + + movq $int_arg0, %r13 + movq $float_arg0, %r11 ;;; Transfer (and convert) any arguments + argloop: - movl (%USP), %eax - addl $4, %USP + movq -8(%USP, %r15), %rax - testl $1, %eax ;;; issimple + testq $1, %rax ;;; issimple jz L2.1 - testl $2, %eax ;;; isinteger - jz L1.1 - - ;;; Pop integer: convert to m/c integer and push - - sarl $2, %eax - pushl %eax - jmp nextarg - -L1.1: ;;; Pop decimal: convert to m/c single float and push - - subl $1, %eax - pushl %eax - - ;;; If the sign bit of _________fltsingle is not set, convert to double - - testl %edx, %edx - js nextarg - flds (%esp) ;;; Load from stack as single - subl $4, %esp - fstpl (%esp) ;;; Store back as double - jmp nextarg + testq $2, %rax ;;; isinteger + jz L1.1 + + ;;; Pop integer: convert to m/c integer and call store + ;;; routine + + sarq $2, %rax + jmp *%r13 + +L1.1: ;;; Pop decimal: store in memory for conversionconvert to m/c single float and push + + subq $1, %rax + movq %rax, -24(%rbp) + ;;; call conversion & store + jmp *%r11 L2.1: ;;; Pop structure: get extern type from key into ESI - movl _KEY(%eax), %esi - movzbl _K_EXTERN_TYPE(%esi), %esi + movq _KEY(%rax), %r10 + movzbl _K_EXTERN_TYPE(%r10), %r10d - testl %esi, %esi + testl %r10d, %r10d jnz L3.1 ;;; EXTERN_TYPE_NORMAL (0): push unchanged - pushl %eax - jmp nextarg + jmp *%r13 -L3.1: cmpl $_:EXTERN_TYPE_DEREF, %esi +L3.1: cmpl $_:EXTERN_TYPE_DEREF, %r10d jne L4.1 ;;; External pointer: push dereferenced - pushl _XP_PTR(%eax) - jmp nextarg + movq _XP_PTR(%rax), %rax + jmp *%r13 -L4.1: cmpl $_:EXTERN_TYPE_DDEC, %esi +L4.1: cmpl $_:EXTERN_TYPE_DDEC, %r10d jne L5.1 ;;; Ddecimal: push the two halves - pushl _DD_1(%eax) - pushl _DD_2(%eax) + movq _DD_1(%rax), %r10 + movq %r10, -24(%rbp) + jmp *%r11 ;;; If the sign bit of _________fltsingle is set, convert to single float - testl %edx, %edx - jns nextarg - fldl (%esp) ;;; Load from stack as double - addl $4, %esp - fstps (%esp) ;;; Store back as single - jmp nextarg - L5.1: ;;; Must be biginteger: load first slice to ESI - movl _BGI_SLICES(%eax), %esi - - ;;; If there's more than one slice, pull in the bottom bit of the - ;;; second + ;;; If there's more than one slice, pull in the high bits first - cmpl $1, _BGI_LENGTH(%eax) + cmpl $3, _BGI_LENGTH(%rax) + jb L5.2 + movl _BGI_SLICES+8(%rax), %r10d + shl $62, %r10 + ;;; spill to the stack + movq %r10, -24(%rbp) + movl _BGI_SLICES+4(%rax),%r10d + shlq $31, %r10 + movl _BGI_SLICES(%rax), %eax + orq %r10, %rax + orq -24(%rbp), %rax + jmp *%r13 + + ;;; At most two slices, pull in the lowest part first +L5.2: + movl _BGI_SLICES(%rax), %r10d + cmpl $1, _BGI_LENGTH(%rax) je L6.1 - movl _BGI_SLICES+4(%eax), %eax - shll $1, %esi - shrdl $1, %eax, %esi + movl _BGI_SLICES+4(%rax), %eax + shrq $1, %rax + orq %r10, %rax + jmp *%r13 L6.1: ;;; Push the result - pushl %esi + movq %r10, %rax + jmp *%r13 -nextarg: +next_arg: + subq $8, %r15 + jnz argloop - subl $1, %ecx - jz do_call - - ;;; Shift up _________fltsingle - - cmpl $32, %ecx - jae argloop - shll $1, %edx - jmp argloop + addq -40(%rbp), %USP + movq -16(%rbp), %r10 do_call: - + movb -32(%rbp), %al +do_call1: cld ;;; clear direction flag - movl %USP, SAVED_USP ;;; save USP for callback - movl %esp, EXTERN_NAME(__pop_in_user_extern) + movq %USP, SAVED_USP ;;; save USP for callback + movq %rsp, EXTERN_NAME(__pop_in_user_extern) ;;; enable async callback - call *%edi - movl $0, EXTERN_NAME(__pop_in_user_extern) + call *%r10 + movq $0, EXTERN_NAME(__pop_in_user_extern) ;;; disable async callback - movl SAVED_USP, %USP ;;; restore USP + movq SAVED_USP, %USP ;;; restore USP ;;; Copy possible results into result_struct: ;;; double result from ST(0) first, then word result from EAX - leal C_LAB(Sys$-Extern$-result_struct), %ecx - - movl %eax, 8(%ecx) ;;; word result + leaq C_LAB(Sys$-Extern$-result_struct), %rcx + movq %rax, 8(%rcx) ;;; word result + movq %xmm0, (%rcx) ;;; double result +#_IF false ;;; See if there's a double result (i.e something in ST(0)): ;;; use FXAM, and copy the resulting status word to EAX. ;;; Mask out everything except bits C0 and C3; if these are both @@ -245,19 +352,28 @@ je L7.1 fstpl (%ecx) ;;; double result +#_ENDIF L7.1: ;;; Reset stack pointer - movl SAVED_SP, %eax - leal -4(%eax), %esp - movl $0, SAVED_SP ;;; Indicates external call over + movq SAVED_SP, %rax + movq (%rax), %rbp + movq -16(%rax), %r8 + movq -24(%rax), %r10 + movq -32(%rax), %r11 + movq -40(%rax), %r12 + movq -48(%rax), %r13 + movq -56(%rax), %r14 + movq -64(%rax), %r15 + leaq -8(%rax), %rsp + movq $0, SAVED_SP ;;; Indicates external call over #_IF CHECK_BREAK ;;; Check for change in the break - movl save_curbrk, %eax - cmpl %eax, EXTERN_NAME(___brk_addr) + movq save_curbrk, %rax + cmpq %rax, EXTERN_NAME(___brk_addr) je L0.1 jmp XC_LAB(Sys$-Mem_break_changed) @@ -266,31 +382,43 @@ L0.1: ret - .align 4 + .align 16 ;;; _EXFUNC_CLOS_ACTION: ;;; called from the code in an exfunc_closure (see asmout.p), with -;;; the top of stack pointing to (exfunc_clos address)+8 +;;; the top of stack pointing to (exfunc_clos address)+10 -DEF_C_LAB(Sys$- _exfunc_clos_action) + .data +mess2: + .string "untested _exfunc_clos_action called\\nlook in aextern.s to enable\\n" + .text +_exfunc_clos_action_message: ;;; Load address of external closure record to eax + movq $mess2, %rdi + movl $0, %eax + call printf + movl $1, %edi + call exit - popl %eax - leal -8(%eax), %eax +DEF_C_LAB(Sys$- _exfunc_clos_action) + ;;; Comment out the jump to enable +;;; jmp _exfunc_clos_action_message + movq (%rsp), %r11 + leaq -11(%r11), %r11 ;;; Store frozen argument to destination - movl _EFC_ARG_DEST(%eax), %edx - movl _EFC_ARG(%eax), %ecx - movl %ecx, (%edx) + movq _EFC_ARG_DEST(%r11), %r10 + movq _EFC_ARG(%r11), %r11 + movq %r11, (%r10) ;;; Chain function via external ptr - movl _EFC_FUNC(%eax), %eax - jmp *(%eax) - - .align 4 + popq %r11 + movq _EFC_FUNC-11(%r11), %r11 + jmp *(%r11) + .align 16 ;;; _POP_EXTERNAL_CALLBACK: @@ -302,56 +430,74 @@ ;;; Arguments: ;;; argp[0] is the function code for -Callback- + .data +mess3: + .string "untested _pop_external_callback called\\nlook in aextern.s to enable\\n" + .text +_pop_external_callback_message: + ;;; Load address of external closure record to eax + movq $mess3, %rdi + movl $0, %eax + call printf + movl $1, %edi + call exit + ;;; safety loop + sloop1: + jmp sloop1 + +;;; .globl EXTERN_NAME(debug_pop) + + .globl EXTERN_NAME(_pop_external_callback) EXTERN_NAME(_pop_external_callback): ;;; for indirect weak reference DEF_C_LAB(Sys$- _external_callback_func) - - ;;; Save user registers - - pushl %ebx - pushl %ebp - pushl %esi - pushl %edi +;;; jmp _pop_external_callback_message + ;;; Save user registers + pushq %rbx + pushq %rbp + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 ;;; Save __pop_in_user_extern - pushl EXTERN_NAME(__pop_in_user_extern) + pushq EXTERN_NAME(__pop_in_user_extern) ;;; Create 3 word dummy stack frame for SF_NEXT_SEG_SP ;;; and SF_NEXT_SEG_HI - leal -12(%esp), %esp + leaq -24(%rsp), %rsp ;;; Disable async callback - movl $0, EXTERN_NAME(__pop_in_user_extern) + movq $0, EXTERN_NAME(__pop_in_user_extern) ;;; Restore procedure base register and saved USP - movl SAVED_SP, %eax - movl (%eax), %PB - movl SAVED_USP, %USP + movq SAVED_SP, %rax + movq (%rax), %PB + movq SAVED_USP, %USP ;;; Push argp - subl $8, %USP - movl 36(%esp), %eax - movl %eax, 4(%USP) + subq $16, %USP + movq %rdi, 8(%USP) #_IF CHECK_BREAK ;;; Push any change in the break - movl save_curbrk, %eax - subl EXTERN_NAME(___brk_addr), %eax - movl %eax, (%USP) + movq save_curbrk, %rax + subq EXTERN_NAME(___brk_addr), %rax + movq %rax, (%USP) #_ELSE ;;; No need to worry about the break: push a dummy argument - movl $0, (%USP) + movq $0, (%USP) #_ENDIF @@ -363,50 +509,71 @@ ;;; Resave current break - movl EXTERN_NAME(___brk_addr), %eax - movl %eax, save_curbrk + movq EXTERN_NAME(___brk_addr), %rax + movq %rax, save_curbrk #_ENDIF ;;; Return status code - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP ;;; Resave USP - movl %USP, SAVED_USP + movq %USP, SAVED_USP ;;; Remove stack frame - leal 12(%esp), %esp + leaq 24(%rsp), %rsp ;;; Re-enable async callback (restoring saved __pop_in_user_extern) - popl EXTERN_NAME(__pop_in_user_extern) + popq EXTERN_NAME(__pop_in_user_extern) ;;; Restore registers and return cld - popl %edi - popl %esi - popl %ebp - popl %ebx - + popq %r15 + popq %r14 + popq %r13 + popq %r12 + popq %rbp + popq %rbx ret - .align 4 + .align 16 +EXTERN_NAME(pop_print): +#_IF CHECK_BREAK + + ;;; Save the current break so that callback code has correct + ;;; info + + movq EXTERN_NAME(___brk_addr), %rax + movq %rax, save_curbrk + movl $0, %eax +#_ENDIF + movq %rdi, SAVED_SP + movq %rsi, SAVED_USP + pushq %rdx + movq $C_LAB(sys_syspr), %rdi + movq %rsp, %rsi + call pop_call + addq $8, %rsp + ret + .align 16 + .data #_IF CHECK_BREAK ;;; SAVE_CURBRK: ;;; Saves the break value across an external call - + .align 8 save_curbrk: - .long 0 + .quad 0 #_ENDIF diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/afloat.s v15.6301-amd64/pop/src/afloat.s --- v15.63/pop/src/afloat.s 1997-11-18 05:22:30.000000000 -0500 +++ v15.6301-amd64/pop/src/afloat.s 2005-03-11 05:30:39.000000000 -0500 @@ -17,13 +17,13 @@ ;;; User stack pointer - USP = "ebx", + USP = "rbx", ;;; Pop ddecimal structure fields: ;;; _DD_1 = MS part, _DD_2 = LS part _DD_1 = @@DD_1, - _DD_2 = @@DD_2, +;;; _DD_2 = @@DD_2, ); @@ -34,10 +34,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -46,9 +46,9 @@ .data CW: ;;; For changing the control word - .long 0 + .quad 0 WORK: - .long 0, 0 + .quad 0, 0 .text @@ -75,7 +75,7 @@ fldcw CW ret - .align 4 + .align 16 ;;; === MOVEMENT AND TYPE CONVERSION ================================== @@ -92,19 +92,17 @@ DEF_C_LAB (_pfcopy) - movl (%USP), %esi - movl 4(%USP), %edi - addl $8, %USP + movq (%USP), %rsi + movq 8(%USP), %rdi + addq $16, %USP - ;;; Move the double float in two longword slices + ;;; Do the move - movl (%esi), %eax - movl %eax, (%edi) - movl 4(%esi), %eax - movl %eax, 4(%edi) + movq (%rsi), %rax + movq %rax, (%rdi) ret - .align 4 + .align 16 ;;; _PF_SFLOAT_DEC: ;;; Float a pop decimal. @@ -114,10 +112,11 @@ DEF_C_LAB (_pf_sfloat_dec) - decl (%USP) +;;; decl (%USP) + decq (%USP) ret - .align 4 + .align 16 ;;; _PF_DFLOAT_INT: ;;; Double float a system integer. @@ -131,14 +130,14 @@ DEF_C_LAB (_pf_dfloat_int) - movl (%USP), %edi - fildl 4(%USP) - addl $8, %USP - fstpl (%edi) + movq (%USP), %rdi + fildq 8(%USP) + addq $16, %USP + fstpl (%rdi) wait ret - .align 4 + .align 16 ;;; _PF_DFLOAT_DEC: ;;; Double float a pop decimal. @@ -152,18 +151,20 @@ DEF_C_LAB (_pf_dfloat_dec) - movl (%USP), %edi + movq (%USP), %rdi ;;; Clear the bottom tag bit of DEC before loading - decl 4(%USP) - flds 4(%USP) - addl $8, %USP - fstpl (%edi) + movq 8(%USP), %rax + decq %rax +;;; fldl 8(%USP) + addq $16, %USP +;;; fstpl (%rdi) + movq %rax, (%rdi) wait ret - .align 4 + .align 16 ;;; _PF_DFLOAT_DDEC: ;;; Double float a pop ddecimal. @@ -181,16 +182,16 @@ ;;; Copy the low and high halves of the pop ddecimal in two ;;; longword moves - movl (%USP), %edi - movl 4(%USP), %esi - addl $8, %USP - movl _DD_2(%esi), %eax - movl %eax, (%edi) - movl _DD_1(%esi), %eax - movl %eax, 4(%edi) + movq (%USP), %rdi + movq 8(%USP), %rsi + addq $16, %USP +;;; movl _DD_2(%esi), %eax +;;; movl %eax, (%rdi) + movq _DD_1(%rsi), %rax + movq %rax, (%rdi) ret - .align 4 + .align 16 ;;; _PF_CVT_TO_DEC: ;;; Convert a machine double float to a pop decimal. @@ -213,13 +214,14 @@ ;;; Load the double float to EDX:EAX - movl (%USP), %esi - movl (%esi), %eax - movl 4(%esi), %edx + movq (%USP), %rsi + movq (%rsi), %rax +;;; movl 4(%esi), %edx ;;; Set bits in the low word to force rounding of 22nd bit of ;;; mantissa except where 'tied' and 21st bit is 0 (even) +#_IF false cmpl $0x40000000, %eax je L1.1 orl $0x38000000, %eax @@ -243,8 +245,19 @@ movl WORK, %eax andb $0xfc, %al orb $1, %al - movl %eax, (%USP) +#_ENDIF + andq $-3, %rax + orq $1, %rax + movq %rax, (%USP) + shrq $32, %rax + testl $D_EXP, %eax + jz L1.2 + ret +L1.2: + movq $1, (%USP) + ret +#_IF false ;;; Now check for overflow/underflow by examining the exponent of ;;; the result @@ -274,8 +287,8 @@ movl $C_LAB(false), (%USP) ret - - .align 4 +#_ENDIF + .align 16 ;;; _PF_CVT_TO_DDEC: ;;; Convert machine double float to pop ddecimal, converting -0.0 and @@ -291,17 +304,21 @@ DEF_C_LAB (_pf_cvt_to_ddec) - movl (%USP), %edi - movl 4(%USP), %esi - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + addq $16, %USP ;;; Load high part of dfloat. ;;; Test the exponent for zero (implies zero or denormal) - movl 4(%esi), %eax + movq (%rsi), %rax + movq %rax, _DD_1(%rdi) + shrq $32, %rax testl $D_EXP, %eax jz L1.3 + ret +#_IF false ;;; Non-zero number: store high and low halves in the pop structure ;;; and return @@ -310,13 +327,13 @@ movl %eax, _DD_2(%edi) ret +#_ENDIF L1.3: ;;; Zero or denormal: make the pop ddecimal really zero - movl $0, _DD_1(%edi) - movl $0, _DD_2(%edi) + movq $0, _DD_1(%rdi) ret - .align 4 + .align 16 ;;; _PF_ROUND_D_TO_S: ;;; Round a machine double float to a single float. The double float @@ -334,29 +351,29 @@ ;;; Load the argument to the 387 as a double and store as a single - movl (%USP), %esi - fldl (%esi) - fstps (%esi) + movq (%USP), %rsi + fldl (%rsi) + fstps (%rsi) wait ;;; Examine the result for infinity/NaN: return if so - movl (%esi), %eax + movl (%rsi), %eax andl $S_EXP, %eax cmpl $S_EXP, %eax je L1.4 ;;; Result OK: return - movl $C_LAB(true), (%USP) + movq $C_LAB(true), (%USP) ret L1.4: ;;; Overflow: return - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PF_EXTEND_S_TO_D: ;;; Extend a machine single float to a double float. The argument @@ -374,8 +391,8 @@ DEF_C_LAB (_pf_extend_s_to_d) - movl (%USP), %esi - movl (%esi), %eax + movq (%USP), %rsi + movl (%rsi), %eax ;;; Check exponent for Inf or NaN @@ -385,17 +402,17 @@ ;;; OK -- do the conversion - flds (%esi) ;;; Load as single - fstpl (%esi) ;;; Store as double + flds (%rsi) ;;; Load as single + fstpl (%rsi) ;;; Store as double wait ret L1.5: ;;; Inf or NaN -- return - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PF_CHECK_D: ;;; Check double float for Inf or NaN. @@ -410,16 +427,16 @@ DEF_C_LAB(_pf_check_d) - movl (%USP), %esi - movl 4(%esi), %eax + movq (%USP), %rsi + movl 4(%rsi), %eax andl $D_EXP, %eax cmpl $D_EXP, %eax je L1.6 ret -L1.6: movl $C_LAB(false), (%USP) +L1.6: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; === DISSECTING FLOATS ============================================= @@ -445,8 +462,8 @@ ;;; Get the address of the dfloat argument in ESI and load the ;;; argument to the 387 - movl (%USP), %esi - fldl (%esi) + movq (%USP), %rsi + fldl (%rsi) ;;; Change the rounding mode of the 387 to "chop" by setting bits ;;; 10 & 11 of the control word @@ -462,31 +479,31 @@ ;;; guard the operation with an exception handler which will catch ;;; any 'Invalid Operation' exception arising from the store - movl $pf_intof_exception, EXTERN_NAME(__pop_fpe_handler) - fistpl (%USP) + movq $pf_intof_exception, EXTERN_NAME(__pop_fpe_handler) + fistpq (%USP) wait ;;; Flushes out any exceptions - movl $0, EXTERN_NAME(__pop_fpe_handler) + movq $0, EXTERN_NAME(__pop_fpe_handler) ;;; Restore the original control word and return fldcw CW - subl $4, %USP - movl $C_LAB(true), (%USP) + subq $8, %USP + movq $C_LAB(true), (%USP) ret - .align 4 + .align 16 pf_intof_exception: ;;; Invalid operation exception - value too big for an integer store. ;;; Reset the FPU and return to indicate overflow. - movl $0, EXTERN_NAME(__pop_fpe_handler) + movq $0, EXTERN_NAME(__pop_fpe_handler) call fpu_init - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PFMODF: ;;; Extract integer and fractional parts of a double float (both parts @@ -508,15 +525,15 @@ DEF_C_LAB (_pfmodf) - movl (%USP), %esi - movl 4(%USP), %edi - addl $8, %USP + movq (%USP), %rsi + movq 8(%USP), %rdi + addq $16, %USP ;;; Load the source dfloat to ST and truncate to an integer: ;;; this means changing the rounding mode to "chop" by setting ;;; bits 10 & 11 of the control word - fldl (%esi) + fldl (%rsi) fstcw CW wait movw CW, %ax @@ -533,17 +550,17 @@ ;;; Reverse-subtract the original value to leave fractional part ;;; in ST - fsubrl (%esi) + fsubrl (%rsi) ;;; Store results - fstpl (%edi) - fstpl (%esi) + fstpl (%rdi) + fstpl (%rsi) wait ret - .align 4 + .align 16 ;;; _PF_EXPOF: ;;; Get and set the exponent, E, of a double float, where E is the @@ -565,8 +582,8 @@ ;;; Load high part of argument to EAX - movl (%USP), %esi - movl 4(%esi), %eax + movq (%USP), %rsi + movl 4(%rsi), %eax ;;; Mask out everything except the exponent and shift it to the ;;; bottom of EAX @@ -577,28 +594,29 @@ ;;; Unbias the exponent by subtracting 1022 and return subl $1022, %eax - movl %eax, (%USP) + movslq %eax, %rsi + movq %rsi, (%USP) ret - .align 4 + .align 16 DEF_C_LAB(-> _pf_expof) ;;; Load high part of the argument to EAX, new exponent to ECX - movl (%USP), %esi - movl 4(%esi), %eax - movl 4(%USP), %ecx - addl $4, %USP + movq (%USP), %rsi + movl 4(%rsi), %eax + movq 8(%USP), %rcx + addq $8, %USP ;;; Bias the exponent by adding 1022: check it's in the 11-bit ;;; range 0 - 2047 and return if not. ;;; Shift it up to the correct place in the word - addl $1022, %ecx - cmpl $2047, %ecx + addq $1022, %rcx + cmpq $2047, %rcx ja L1.7 - shll $20, %ecx + shlq $20, %rcx ;;; Mask out the exponent from EAX and OR in the new one; ;;; store it back to the argument and return @@ -609,16 +627,16 @@ andl $-1!D_EXP, %eax #_ENDIF orl %ecx, %eax - movl %eax, 4(%esi) - movl $C_LAB(true), (%USP) + movl %eax, 4(%rsi) + movq $C_LAB(true), (%USP) ret L1.7: ;;; New exponent out of range: return - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; === PREDICATES ON DOUBLE FLOATS =================================== @@ -633,21 +651,21 @@ ;;; Get the dfloat address in ESI - movl (%USP), %esi + movq (%USP), %rsi ;;; Test all but the sign bit of the high word for zero - testl $0x7fffffff, 4(%esi) + testl $0x7fffffff, 4(%rsi) jnz L1.8 ;;; Test the low word for zero - cmpl $0, (%esi) + cmpl $0, (%rsi) je return_true -L1.8: movl $C_LAB(false), (%USP) +L1.8: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PFNEG: ;;; Test a machine double float for genuine negative (not -0.0). @@ -659,8 +677,8 @@ ;;; Get the dfloat address in ESI and the high word in EAX - movl (%USP), %esi - movl 4(%esi), %eax + movq (%USP), %rsi + movl 4(%rsi), %eax ;;; Test the sign bit: return if not set @@ -671,12 +689,12 @@ testl $0x7fffffff, %eax jnz return_true - cmpl $0, (%esi) + cmpl $0, (%rsi) jne return_true -L1.9: movl $C_LAB(false), (%USP) +L1.9: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PFEQ: ;;; Test two double floats for identity. @@ -688,25 +706,23 @@ ;;; Load addresses to ESI/EDI - movl (%USP), %esi - movl 4(%USP), %edi - addl $4, %USP + movq (%USP), %rsi + movq 8(%USP), %rdi + addq $8, %USP ;;; Compare high words - movl 4(%esi), %eax - cmpl %eax, 4(%edi) + movq (%rsi), %rax + cmpq %rax, (%rdi) jne L1.10 ;;; Compare low words - movl (%esi), %eax - cmpl %eax, (%edi) je return_true -L1.10: movl $C_LAB(false), (%USP) +L1.10: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PFSGR: ;;; _PFSGREQ: @@ -732,7 +748,7 @@ movw $0x4100, %cx jmp pfcmp - .align 4 + .align 16 DEF_C_LAB (_pfsgr) @@ -745,11 +761,11 @@ ;;; Load DFLOAT1 into ST(1) and DFLOAT2 into ST(0). - movl 4(%USP), %esi - fldl (%esi) - movl (%USP), %esi - fldl (%esi) - addl $4, %USP + movq 8(%USP), %rsi + fldl (%rsi) + movq (%USP), %rsi + fldl (%rsi) + addq $8, %USP ;;; Compare and pop ST(0) & ST(1). Transfer the flags to AX. @@ -760,17 +776,17 @@ testw %cx, %ax jnz return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 return_true: - movl $C_LAB(true), (%USP) + movq $C_LAB(true), (%USP) ret - .align 4 + .align 16 ;;; === FLOATING POINT ARITHMETIC ===================================== @@ -783,15 +799,15 @@ DEF_C_LAB (_pfabs) - movl (%USP), %esi - addl $4, %USP + movq (%USP), %rsi + addq $8, %USP ;;; Clear the sign bit in the high word of the argument - andl $0x7fffffff, 4(%esi) + andl $0x7fffffff, 4(%rsi) ret - .align 4 + .align 16 ;;; _PFNEGATE: ;;; Negate a double float. @@ -801,15 +817,15 @@ DEF_C_LAB (_pfnegate) - movl (%USP), %esi - addl $4, %USP + movq (%USP), %rsi + addq $8, %USP ;;; Complement the sign bit in the high word of the argument - btcl $31, 4(%esi) + btcl $31, 4(%rsi) ret - .align 4 + .align 16 ;;; _PFADD: ;;; _PFSUB: @@ -831,84 +847,84 @@ DEF_C_LAB (_pfadd) - movl (%USP), %esi - movl 4(%USP), %edi - fldl (%edi) - faddl (%esi) + movq (%USP), %rsi + movq 8(%USP), %rdi + fldl (%rdi) + faddl (%rsi) jmp overflow_check - .align 4 + .align 16 DEF_C_LAB (_pfsub) - movl (%USP), %esi - movl 4(%USP), %edi - fldl (%edi) - fsubl (%esi) + movq (%USP), %rsi + movq 8(%USP), %rdi + fldl (%rdi) + fsubl (%rsi) jmp overflow_check - .align 4 + .align 16 DEF_C_LAB (_pfmult) - movl (%USP), %esi - movl 4(%USP), %edi - fldl (%edi) - fmull (%esi) + movq (%USP), %rsi + movq 8(%USP), %rdi + fldl (%rdi) + fmull (%rsi) jmp overflow_check - .align 4 + .align 16 DEF_C_LAB (_pfdiv) - movl (%USP), %esi - movl 4(%USP), %edi - fldl (%edi) + movq (%USP), %rsi + movq 8(%USP), %rdi + fldl (%rdi) ;;; Guard the division with an exception handler to catch ;;; any invalid operation exceptions (for 0.0/0.0) - movl $pfdiv_exception, EXTERN_NAME(__pop_fpe_handler) - fdivl (%esi) + movq $pfdiv_exception, EXTERN_NAME(__pop_fpe_handler) + fdivl (%rsi) wait ;;; Flush any exceptions - movl $0, EXTERN_NAME(__pop_fpe_handler) + movq $0, EXTERN_NAME(__pop_fpe_handler) overflow_check: ;;; Pop result from ST(0) back to DFLOAT1 and pop the user stack - fstpl (%edi) - addl $4, %USP + fstpl (%rdi) + addq $8, %USP wait ;;; Load high word of result and check for exponent all 1's ;;; (implies infinity/NaN). If OK, return . - movl 4(%edi), %eax + movl 4(%rdi), %eax andl $D_EXP, %eax cmpl $D_EXP, %eax je L1.11 - movl $C_LAB(true), (%USP) + movq $C_LAB(true), (%USP) ret L1.11: ;;; Overflow: return - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 pfdiv_exception: ;;; Invalid operation: reset the FPU and return false - movl $0, EXTERN_NAME(__pop_fpe_handler) + movq $0, EXTERN_NAME(__pop_fpe_handler) call fpu_init - addl $4, %USP - movl $C_LAB(false), (%USP) + addq $8, %USP + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _PFQREM: ;;; Divide two double floats and return quotient and remainder. @@ -918,7 +934,7 @@ jmp XC_LAB(Sys$-Float_qrem) - .align 4 + .align 16 /***************** end labels for wrapping structures *****************/ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/alisp.s v15.6301-amd64/pop/src/alisp.s --- v15.63/pop/src/alisp.s 1994-01-26 05:31:21.000000000 -0500 +++ v15.6301-amd64/pop/src/alisp.s 2005-03-11 05:30:39.000000000 -0500 @@ -16,7 +16,7 @@ ;;; User stack pointer - USP = "ebx", + USP = "rbx", ); @@ -27,10 +27,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -65,25 +65,26 @@ ;;; in EAX. The two arguments are in popint words; subtracting ;;; 6 from the total converts to sysint bytes. - movl (%USP), %eax - addl 4(%USP), %eax - subl $6, %eax - addl $8, %USP + movq (%USP), %rax + addq 8(%USP), %rax + subq $6, %rax + shlq $1, %rax + addq $16, %USP ;;; Compute the desired stack pointer (_userhi - desired_length) ;;; in ECX - movl I_LAB(_userhi), %ecx - subl %eax, %ecx + movq I_LAB(_userhi), %rcx + subq %rax, %rcx ;;; Compare desired and actual stack pointers: if different, ;;; jump to fix - cmpl %ecx, %USP + cmpq %rcx, %USP jne C_LAB(_setstklen_diff) ret - .align 4 + .align 16 DEF_C_LAB (_setstklen_diff) @@ -95,16 +96,16 @@ L1.1: ;;; Actual stack is too short: push nils until the desired size ;;; is reached - subl $4, %USP - movl $C_LAB(nil), (%USP) - cmpl %ecx, %USP + subq $8, %USP + movq $C_LAB(nil), (%USP) + cmpq %rcx, %USP jne L1.1 ret L2.1: ;;; Actual stack is too long: erase the extra results simply by ;;; setting USP to the desired value - movl %ecx, %USP + movq %rcx, %USP ret .align 4 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/amain.s v15.6301-amd64/pop/src/amain.s --- v15.63/pop/src/amain.s 2008-12-02 11:23:55.000000000 -0500 +++ v15.6301-amd64/pop/src/amain.s 2009-12-25 02:56:37.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex, University of Birmingham 2008. All rights reserved. ---------- +/* --- Copyright University of Sussex 1996. All rights reserved. ---------- * File: S.pcunix/src/amain.s * Purpose: Poplog entry point for Intel 80x86 (Unix assembler) * Author: Robert Duncan, Oct 31 1988 (see revisions) @@ -10,7 +10,7 @@ #_INCLUDE 'declare.ph' lconstant macro ( - USP = "ebx", + USP = "rbx", SAVED_USP = [I_LAB(Sys$-Extern$- _saved_usp)], ); @@ -29,10 +29,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -53,24 +53,17 @@ ;;; Clear __pop_in_user_extern - movl $0, EXTERN_NAME(__pop_in_user_extern) + movq $0, EXTERN_NAME(__pop_in_user_extern) ;;; Save pointer to argument vector (argv) - movl 8(%esp), %eax - movl %eax, I_LAB(Sys$- _init_args) - + movq %rsi, I_LAB(Sys$- _init_args) #_IF DEF LINUX - ;;; set personality (AS, from Waldek Hebisch. 2 Dec 2008) - movl 12(%esp), %edx - movl 4(%esp), %ecx - push %edx - push %eax - push %ecx + ;;; set personality + call linux_setper - addl $12, %esp #_ENDIF @@ -80,18 +73,22 @@ ;;; Set up a temporary user stack pointer - movl SAVED_USP, %USP - - ;;; Start the system + movq SAVED_USP, %USP + ;;; clear Pop registers + movq $3, %r13 + movq $3, %r14 + movq $3, %r15 + + ;;; Start the system call XC_LAB(setpop) ;;; Exit with 0 - pushl $0 + movl $0, %edi call EXTERN_NAME(_exit) - .align 4 + .align 16 /***************** end labels for wrapping structures *****************/ @@ -106,9 +103,6 @@ /**********************************************************************/ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, 2 Dec 2008 - Installed call of linux_setper, using code provided by - Waldek Hebisch, to make running with 'setarch' unnecessary. --- Robert Duncan, Aug 9 1996 Removed special cases for S*CO --- Poplog System, Jan 18 1995 Only in v15.63/pop/src: amain.s.1996 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/amisc.s v15.6301-amd64/pop/src/amisc.s --- v15.63/pop/src/amisc.s 1997-02-10 12:17:29.000000000 -0500 +++ v15.6301-amd64/pop/src/amisc.s 2009-12-27 15:49:45.000000000 -0500 @@ -17,16 +17,17 @@ constant procedure (Call_overflow, User_overflow, Callstack_reset, - Conspair, Plog$-Area_overflow, Async_raise_signal) + Conspair, Plog$-Area_overflow, Async_raise_signal, + dummy_procedure_callback_helper) ; endsection; lconstant macro ( - USP = "ebx", - PB = "ebp", - CHAIN_REG = "edx", + USP = "rbx", + PB = "rbp", + CHAIN_REG = "rdx", _KEY = @@KEY, _K_APPLY = @@K_APPLY, @@ -42,6 +43,14 @@ ); +lconstant macro MOVFL = if DEF FRAME_LEN_16BIT then "movzwl" + elseif DEF FRAME_LEN_32BIT then "movl" + else "movzbl" + endif; + +lconstant macro RAX = if DEF FRAME_LEN_32BIT then "eax" else "rax" endif; +lconstant macro RCX = if DEF FRAME_LEN_32BIT then "ecx" else "rcx" endif; + >_# .file "amisc.s" @@ -49,10 +58,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -78,50 +87,50 @@ ;;; Test object for simple or compound - testl $1, %eax + testq $1, %rax jnz L1.1 ;;; Object is compound: compare key with procedure key - cmpl $C_LAB(procedure_key), _KEY(%eax) + cmpq $C_LAB(procedure_key), _KEY(%rax) jne L3.1 ;;; Applying a procedure: jump to its execute address - jmp *_PD_EXECUTE(%eax) + jmp *_PD_EXECUTE(%rax) L1.1: ;;; Applying a (simple) number: ;;; push the number and run the appropriate key apply procedure ;;; (integer or decimal) - subl $4, %USP - movl %eax, (%USP) - testl $2, %eax + subq $8, %USP + movq %rax, (%USP) + testq $2, %rax jz L2.1 ;;; Applying an integer - movl C_LAB(integer_key) + _K_APPLY, %eax - movl _RF_CONT(%eax), %eax - jmp *_PD_EXECUTE(%eax) + movq C_LAB(integer_key) + _K_APPLY, %rax + movq _RF_CONT(%rax), %rax + jmp *_PD_EXECUTE(%rax) L2.1: ;;; Applying a decimal - movl C_LAB(weakref decimal_key) + _K_APPLY, %eax - movl _RF_CONT(%eax), %eax - jmp *_PD_EXECUTE(%eax) + movq C_LAB(weakref decimal_key) + _K_APPLY, %rax + movq _RF_CONT(%rax), %rax + jmp *_PD_EXECUTE(%rax) L3.1: ;;; Applying a structure: ;;; push the object and run the key apply procedure - subl $4, %USP - movl %eax, (%USP) - movl _KEY(%eax), %eax - movl _K_APPLY(%eax), %eax - movl _RF_CONT(%eax), %eax - jmp *_PD_EXECUTE(%eax) + subq $8, %USP + movq %rax, (%USP) + movq _KEY(%rax), %rax + movq _K_APPLY(%rax), %rax + movq _RF_CONT(%rax), %rax + jmp *_PD_EXECUTE(%rax) - .align 4 + .align 16 ;;; _POPUENTER: @@ -145,12 +154,12 @@ ;;; Test object for simple or compound - testl $1, %eax + testq $1, %rax jnz L1.2 ;;; Object is compound: compare key with procedure key - cmpl $C_LAB(procedure_key), _KEY(%eax) + cmpq $C_LAB(procedure_key), _KEY(%rax) jne L3.2 ;;; Applying the updater of a procedure: fall through to the @@ -162,68 +171,68 @@ ;;; copy it to ECX for possible use as an argument to the error ;;; routine, then get its updater - movl %eax, %ecx - movl _PD_UPDATER(%eax), %eax + movq %rax, %rcx + movq _PD_UPDATER(%rax), %rax ;;; If the updater is (non-existent) jump to the error case - cmpl $C_LAB(false), %eax + cmpq $C_LAB(false), %rax je no_updater ;;; Otherwise go to the updater's execute address - jmp *_PD_EXECUTE(%eax) + jmp *_PD_EXECUTE(%rax) L1.2: ;;; Applying the updater of a number: ;;; copy the number to ECX (to be pushed as an argument later) ;;; then get the appropriate key apply procedure (integer or decimal) ;;; in EAX. Jump to check (and apply) its updater - movl %eax, %ecx - testl $2, %eax + movq %rax, %rcx + testq $2, %rax jz L2.2 ;;; Integer key - movl C_LAB(integer_key) + _K_APPLY, %eax + movq C_LAB(integer_key) + _K_APPLY, %rax jmp L4.1 L2.2: ;;; Decimal key - movl C_LAB(weakref decimal_key) + _K_APPLY, %eax + movq C_LAB(weakref decimal_key) + _K_APPLY, %rax jmp L4.1 L3.2: ;;; Applying the updater of a structure: ;;; copy the object to ECX (to be pushed as an argument later) ;;; then get its key apply procedure in EAX - movl %eax, %ecx - movl _KEY(%eax), %eax - movl _K_APPLY(%eax), %eax + movq %rax, %rcx + movq _KEY(%rax), %rax + movq _K_APPLY(%rax), %rax L4.1: ;;; Check the updater of the key apply procedure in EAX - movl _RF_CONT(%eax), %eax - movl _PD_UPDATER(%eax), %eax - cmpl $C_LAB(false), %eax + movq _RF_CONT(%rax), %rax + movq _PD_UPDATER(%rax), %rax + cmpq $C_LAB(false), %rax je no_updater ;;; Updater OK -- push the original object (now in ECX) as an ;;; argument to it, and jump to its execute address - subl $4, %USP - movl %ecx, (%USP) - jmp *_PD_EXECUTE(%eax) + subq $8, %USP + movq %rcx, (%USP) + jmp *_PD_EXECUTE(%rax) no_updater: ;;; Object in ECX has no updater -- raise an error - subl $4, %USP - movl %ecx, (%USP) + subq $8, %USP + movq %rcx, (%USP) jmp XC_LAB(-> Sys$-Exec_nonpd) - .align 4 + .align 16 ;;; === CALLSTACK MANIPULATION ======================================== @@ -235,11 +244,11 @@ DEF_C_LAB (_erase_sp_1) - popl %eax - movl %eax, (%esp) + popq %rax + movq %rax, (%rsp) jmp XC_LAB(Sys$-Callstack_reset) - .align 4 + .align 16 ;;; _NEXTFRAME: @@ -252,25 +261,25 @@ ;;; Load frame pointer to EAX - movl (%USP), %eax + movq (%USP), %rax ;;; Owner address in ECX - movl _SF_OWNER(%eax), %ecx + movq _SF_OWNER(%rax), %rcx ;;; Find the length of the frame (in longwords) from the owner's ;;; procedure header - movzbl _PD_FRAME_LEN(%ecx), %ecx + MOVFL _PD_FRAME_LEN(%rcx), %ecx ;;; Add the frame length in bytes (ECX * 4) to the given frame ;;; pointer to get the next frame pointer. - leal (%eax, %ecx, 4), %eax - movl %eax, (%USP) + leaq (%rax, %rcx, 8), %rax + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _UNWIND_FRAME: @@ -298,22 +307,22 @@ ;;; Extract the length of the previous stack frame (in longwords) ;;; from its owner procedure, whose address should be in PB - movzbl _PD_FRAME_LEN(%PB), %eax + MOVFL _PD_FRAME_LEN(%PB), %eax ;;; The last word in that frame will be the return address: ;;; copy that to CHAIN_REG, then replace it with our return - leal 4(%esp, %eax, 4), %eax - movl (%eax), %CHAIN_REG - popl (%eax) + leaq 8(%rsp, %rax, 8), %rax + movq (%rax), %CHAIN_REG + popq (%rax) ;;; Clear the unwanted return address from the stack and go into ;;; the procedure's exit code - addl $4, %esp + addq $8, %rsp jmp *_PD_EXIT(%PB) - .align 4 + .align 16 ;;; === CHAINING A POP PROCEDURE ====================================== @@ -337,7 +346,7 @@ ;;; Set up a dummy return address for _UNWIND_FRAME and call it; ;;; this will leave the caller's return address in CHAIN_REG - pushl $0 + pushq $0 call C_LAB(_unwind_frame) ;;; Fall through to direct chain @@ -346,22 +355,22 @@ ;;; Reinstate the return address from CHAIN_REG - pushl %CHAIN_REG + pushq %CHAIN_REG ;;; Get the object to chain from the stack and run it - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP jmp C_LAB(_popenter) - .align 4 + .align 16 DEF_C_LAB (_sysncchain_caller) ;;; Set up a dummy return address for _UNWIND_FRAME and call it; ;;; this will leave the caller's return address in CHAIN_REG - pushl $0 + pushq $0 call C_LAB(_unwind_frame) ;;; Fall through to direct chain @@ -370,16 +379,16 @@ ;;; Reinstate the return address from CHAIN_REG - pushl %CHAIN_REG + pushq %CHAIN_REG ;;; Get the procedure to chain from the stack and go to its execute ;;; address - movl (%USP), %eax - addl $4, %USP - jmp *_PD_EXECUTE(%eax) + movq (%USP), %rax + addq $8, %USP + jmp *_PD_EXECUTE(%rax) - .align 4 + .align 16 ;;; === PREDICATES ON POP OBJECTS ===================================== @@ -398,67 +407,67 @@ ;;; Object is a pop pointer -- bottom bit clear - testl $1, (%USP) + testq $1, (%USP) jz return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB (_issimple) ;;; Object is not a pop pointer -- bottom bit set - testl $1, (%USP) + testq $1, (%USP) jnz return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB (_isinteger) ;;; Object is a pop integer -- second bit set - testl $2, (%USP) + testq $2, (%USP) jnz return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB (_neg) ;;; Object is negative - cmpl $0, (%USP) + cmpq $0, (%USP) jl return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB (_zero) ;;; Object is (machine) zero - cmpl $0, (%USP) + cmpq $0, (%USP) je return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB (_not) ;;; Object is false - cmpl $C_LAB(false), (%USP) + cmpq $C_LAB(false), (%USP) je return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _EQ: ;;; _NEQ: @@ -477,145 +486,145 @@ ;;; Identity (pop ==) - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) je return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 7 (_neq) ;;; Non-identity (pop /==) - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jne return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_gr) ;;; Unsigned greater than - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) ja return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_greq) ;;; Unsigned greater than or equal - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jae return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_lt) ;;; Unsigned less than - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jb return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_lteq) ;;; Unsigned less than or equal - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jbe return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_sgr) ;;; Signed greater than - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jg return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_sgreq) ;;; Signed greater than or equal - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jge return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_slt) ;;; Signed less than - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jl return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 DEF_C_LAB 6 (_slteq) ;;; Signed less than or equal - movl (%USP), %eax - addl $4, %USP - cmpl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + cmpq %rax, (%USP) jle return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _BITST: ;;; Logical AND two items and test for non-zero (pop &&/=_0) DEF_C_LAB 4 (_bitst) - movl (%USP), %eax - addl $4, %USP - testl %eax, (%USP) + movq (%USP), %rax + addq $8, %USP + testq %rax, (%USP) jnz return_true - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 ;;; _HASKEY: ;;; tests whether the first item on stack is the key of the second item. @@ -634,32 +643,32 @@ ;;; Load key to ECX - movl (%USP), %ecx - addl $4, %USP + movq (%USP), %rcx + addq $8, %USP ;;; Load item to EAX and test for compound: ;;; return if not - movl (%USP), %eax - testl $1, %eax + movq (%USP), %rax + testq $1, %rax jnz L1.3 ;;; Compare keys - cmpl %ecx, _KEY(%eax) + cmpq %rcx, _KEY(%rax) je return_true -L1.3: movl $C_LAB(false), (%USP) +L1.3: movq $C_LAB(false), (%USP) ret - .align 4 + .align 16 return_true: - movl $C_LAB(true), (%USP) + movq $C_LAB(true), (%USP) ret - .align 4 + .align 16 ;;; === OPTIMISED DATA ROUTINES ======================================= @@ -674,33 +683,33 @@ ;;; Get the free pair list - movl I_LAB(Sys$- _free_pairs), %eax + movq I_LAB(Sys$- _free_pairs), %rax ;;; If its simple, there's nothing left -- chain the storage ;;; allocater - testl $1, %eax + testq $1, %rax jnz XC_LAB(Sys$-Conspair) ;;; Otherwise, take the first pair from the free list - movl _P_BACK(%eax), %ecx - movl %ecx, I_LAB(Sys$- _free_pairs) + movq _P_BACK(%rax), %rcx + movq %rcx, I_LAB(Sys$- _free_pairs) ;;; Initialise the new pair with the values from the stack - movl (%USP), %ecx - movl %ecx, _P_BACK(%eax) - movl 4(%USP), %ecx - movl %ecx, _P_FRONT(%eax) + movq (%USP), %rcx + movq %rcx, _P_BACK(%rax) + movq 8(%USP), %rcx + movq %rcx, _P_FRONT(%rax) ;;; Return the pair - addl $4, %USP - movl %eax, (%USP) + addq $8, %USP + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _DATAKEY: @@ -713,33 +722,33 @@ ;;; Load item to EAX and test for compound - movl (%USP), %eax - testl $1, %eax + movq (%USP), %rax + testq $1, %rax jnz L1.5 ;;; Object is compound: extract key and return - movl _KEY(%eax), %eax - movl %eax, (%USP) + movq _KEY(%rax), %rax + movq %rax, (%USP) ret L1.5: ;;; Object is a (simple) number: ;;; return integer or decimal key as appropriate - testl $2, %eax + testq $2, %rax jz L2.3 ;;; Object is an integer - movl $C_LAB(integer_key), (%USP) + movq $C_LAB(integer_key), (%USP) ret L2.3: ;;; Object is a decimal - movl $C_LAB(weakref decimal_key), (%USP) + movq $C_LAB(weakref decimal_key), (%USP) ret - .align 4 + .align 16 ;;; === STRING HANDLING =============================================== @@ -757,23 +766,23 @@ DEF_C_LAB (_subss) - movl (%USP), %esi - movl 4(%USP), %ecx - addl $4, %USP + movq (%USP), %rsi + movq 8(%USP), %rcx + addq $8, %USP ;;; Convert index to a machine integer and load the indexed byte ;;; (zero extended) into EAX - sarl $2, %ecx - movzbl _V_BYTES-1(%esi, %ecx), %eax + sarq $2, %rcx + movzbq _V_BYTES-1(%rsi, %rcx), %rax ;;; Return character as a popint - leal 3(, %eax, 4), %eax - movl %eax, (%USP) + leaq 3(, %rax, 4), %rax + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _U_SUBSS: ;;; Fast pop string update (implements updaterof -fast_subscrs-). @@ -789,20 +798,20 @@ DEF_C_LAB (-> _subss) DEF_C_LAB (_u_subss) - movl (%USP), %edi - movl 4(%USP), %ecx - movl 8(%USP), %eax - addl $12, %USP + movq (%USP), %rdi + movq 8(%USP), %rcx + movq 16(%USP), %rax + addq $24, %USP ;;; Convert character and index to machine integers; ;;; insert the new byte and return - sarl $2, %eax - sarl $2, %ecx - movb %al, _V_BYTES-1(%edi, %ecx) + sarq $2, %rax + sarq $2, %rcx + movb %al, _V_BYTES-1(%rdi, %rcx) ret - .align 4 + .align 16 ;;; _LOCC: @@ -822,20 +831,20 @@ DEF_C_LAB (_locc) - movl (%USP), %eax - movl 4(%USP), %ecx - addl $8, %USP + movq (%USP), %rax + movq 8(%USP), %rcx + addq $16, %USP ;;; Test the byte-count in ECX for zero: ;;; if so, nothing to search, so return -1 immediately - cmpl $0, %ecx + cmpq $0, %rcx je L1.6 ;;; Load the string address into EDI, and copy into ESI offset by 1 - movl (%USP), %edi - leal 1(%edi), %esi + movq (%USP), %rdi + leaq 1(%rdi), %rsi ;;; Clear the direction flag to increment EDI during the scan @@ -854,16 +863,16 @@ ;;; Otherwise, EDI points one beyond the matching byte: ;;; compute offset by subtracting ESI (already adjusted by 1) - subl %esi, %edi - movl %edi, (%USP) + subq %rsi, %rdi + movq %rdi, (%USP) ret L1.6: ;;; Search failed -- return -1 - movl $-1, (%USP) + movq $-1, (%USP) ret - .align 4 + .align 16 ;;; _SKPC: @@ -883,20 +892,20 @@ DEF_C_LAB (_skpc) - movl (%USP), %eax - movl 4(%USP), %ecx - addl $8, %USP + movq (%USP), %rax + movq 8(%USP), %rcx + addq $16, %USP ;;; Test the byte-count in ECX for zero: ;;; if so, nothing to search, so return -1 immediately - cmpl $0, %ecx + cmpq $0, %rcx je L1.7 ;;; Load the string address into EDI and copy to ESI offset by 1 - movl (%USP), %edi - leal 1(%edi), %esi + movq (%USP), %rdi + leaq 1(%rdi), %rsi ;;; Clear the direction flag to increment EDI during the scan @@ -915,16 +924,16 @@ ;;; Otherwise, EDI points one beyond the matching byte: ;;; compute offset by subtracting ESI (already adjusted by 1) - subl %esi, %edi - movl %edi, (%USP) + subq %rsi, %rdi + movq %rdi, (%USP) ret L1.7: ;;; Search failed -- return -1 - movl $-1, (%USP) + movq $-1, (%USP) ret - .align 4 + .align 16 ;;; === PROCEDURE ENTRY CHECKS ======================================== @@ -935,36 +944,36 @@ DEF_C_LAB (_checkplogall) - movl $C_LAB(_special_var_block), %eax - movl _SVB_OFFS(_plog_trail_sp)(%eax), %ecx - cmpl %ecx, _SVB_OFFS(_plog_trail_lim)(%eax) + movq $C_LAB(_special_var_block), %rax + movq _SVB_OFFS(_plog_trail_sp)(%rax), %rcx + cmpq %rcx, _SVB_OFFS(_plog_trail_lim)(%rax) ja checkall jmp XC_LAB(weakref[prologvar_key] Sys$-Plog$-Area_overflow) - .align 4 + .align 16 ;;; _CHECKALL: ;;; Check normal stacks on procedure entry. DEF_C_LAB (_checkall) - movl $C_LAB(_special_var_block), %eax + movq $C_LAB(_special_var_block), %rax checkall: ;;; Check for callstack overflow - cmpl %esp, _SVB_OFFS(_call_stack_lim)(%eax) + cmpq %rsp, _SVB_OFFS(_call_stack_lim)(%rax) ja L1.10 ;;; Check for userstack overflow - cmpl %USP, _SVB_OFFS(_userlim)(%eax) + cmpq %USP, _SVB_OFFS(_userlim)(%rax) ja L2.6 L0.1: ;;; Check interrupt trap bit - testl $1, _SVB_OFFS(_trap)(%eax) + testq $1, _SVB_OFFS(_trap)(%rax) jnz L3.5 ;;; Everything OK @@ -974,25 +983,25 @@ L1.10: ;;; Callstack overflow: if not disabled, jump to repair, otherwise ;;; go back to test for interrupts - testl $2, I_LAB(_disable) + testq $2, I_LAB(_disable) jnz L0.1 jmp XC_LAB(Sys$-Call_overflow) L2.6: ;;; Userstack overflow: if not disabled, jump to repair, otherwise ;;; go back to test for interrupts - testl $2, I_LAB(_disable) + testq $2, I_LAB(_disable) jnz L0.1 jmp XC_LAB(Sys$-User_overflow) L3.5: ;;; Interrupt: if not disabled, jump to handler, otherwise return - testl $1, I_LAB(_disable) + testq $1, I_LAB(_disable) jz XC_LAB(Sys$-Async_raise_signal) ret - .align 4 + .align 16 ;;; _CHECKINTERRUPT: @@ -1000,12 +1009,37 @@ DEF_C_LAB (_checkinterrupt) - testl $1, I_LAB(_trap) + testq $1, I_LAB(_trap) jnz C_LAB(_checkall) ret - .align 4 + .align 16 + .data +mess33: + .string "sp = 0x%lx\\n" + + .text +EXTERN_NAME(pop_print_sp): + movq $mess33, %rdi + movq %rsp, %rsi + movl $0, %eax + call printf + ret + +/* +EXTERN_NAME(pop_print): + pushq %rbp + mov XC_LAB(Sys$-dummy_procedure_callback_helper),%rbp + pushq %rbp + subq $8, %USP + movq %rdi, (%USP) + call XC_LAB(sys_syspr) + popq %rbp + popq %rbp + ret + .align 16 +*/ /***************** end labels for wrapping structures *****************/ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/amove.s v15.6301-amd64/pop/src/amove.s --- v15.63/pop/src/amove.s 1996-08-09 13:13:57.000000000 -0400 +++ v15.6301-amd64/pop/src/amove.s 2005-03-11 05:30:39.000000000 -0500 @@ -10,7 +10,7 @@ #_INCLUDE 'declare.ph' lconstant macro ( - USP = "ebx", + USP = "rbx", ); >_# @@ -20,10 +20,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -47,14 +47,14 @@ DEF_C_LAB (_bcmp) - movl (%USP), %edi - movl 4(%USP), %esi - movl 8(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + movq 16(%USP), %rcx + addq $16, %USP ;;; If size (ECX) is zero, then return immediately - cmpl $0, %ecx + cmpq $0, %rcx je L1.1 ;;; Clear the direction flag to increment ESI/EDI @@ -70,12 +70,12 @@ ;;; otherwise return je L1.1 - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret -L1.1: movl $C_LAB(true), (%USP) +L1.1: movq $C_LAB(true), (%USP) ret - .align 4 + .align 16 ;;; _SCMP: ;;; Compare two short (word) regions of the same length @@ -90,15 +90,15 @@ DEF_C_LAB (_scmp) - movl (%USP), %edi - movl 4(%USP), %esi - movl 8(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + movq 16(%USP), %rcx + addq $16, %USP ;;; Convert ECX to size in words; if zero, then return ;;; immediately - sarl $1, %ecx + sarq $1, %rcx jz L1.2 ;;; Clear the direction flag to increment ESI/EDI @@ -114,12 +114,12 @@ ;;; otherwise return je L1.2 - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret -L1.2: movl $C_LAB(true), (%USP) +L1.2: movq $C_LAB(true), (%USP) ret - .align 4 + .align 16 ;;; _ICMP: ;;; _CMP: @@ -136,15 +136,15 @@ DEF_C_LAB (_icmp) DEF_C_LAB (_cmp) - movl (%USP), %edi - movl 4(%USP), %esi - movl 8(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + movq 16(%USP), %rcx + addq $16, %USP ;;; Convert ECX to size in longs; if zero, then return ;;; immediately - sarl $2, %ecx + sarq $2, %rcx jz L1.3 ;;; Clear the direction flag to increment ESI/EDI @@ -160,12 +160,12 @@ ;;; otherwise return je L1.3 - movl $C_LAB(false), (%USP) + movq $C_LAB(false), (%USP) ret -L1.3: movl $C_LAB(true), (%USP) +L1.3: movq $C_LAB(true), (%USP) ret - .align 4 + .align 16 ;;; === MOVES ========================================================= @@ -186,19 +186,19 @@ DEF_C_LAB (_moveq) - movl (%USP), %edi - movl 4(%USP), %esi - movl 8(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + movq 16(%USP), %rcx + addq $16, %USP ;;; Compare source and destination pointers and quit if the same - cmpl %esi, %edi + cmpq %rsi, %rdi je L2.1 ;;; Convert the byte-length in ECX to longwords and quit if zero - sarl $2, %ecx + sarq $2, %rcx jz L1.4 ;;; Do the move @@ -209,17 +209,17 @@ L1.4: ;;; Return the next destination address - movl %edi, (%USP) + movq %rdi, (%USP) ret L2.1: ;;; Source and destination the same: ;;; compute and return the next destination address - addl %ecx, %edi - movl %edi, (%USP) + addq %rcx, %rdi + movq %rdi, (%USP) ret - .align 4 + .align 16 ;;; _BMOVE: ;;; _SMOVE: @@ -240,21 +240,21 @@ ;;; Set register arguments for -movchars- - movl (%USP), %edi - movl 4(%USP), %esi - movl 8(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + movq 16(%USP), %rcx + addq $16, %USP ;;; Push the next destination address as the return value - leal (%edi, %ecx), %eax - movl %eax, (%USP) + leaq (%rdi, %rcx), %rax + movq %rax, (%USP) ;;; Do the move jmp movchars - .align 4 + .align 16 DEF_C_LAB (_imove) DEF_C_LAB (_dmove) @@ -262,21 +262,21 @@ ;;; Set register arguments for movchars - movl (%USP), %edi - movl 4(%USP), %esi - movl 8(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rsi + movq 16(%USP), %rcx + addq $16, %USP ;;; Push the next destination address as the return value - leal (%edi, %ecx), %eax - movl %eax, (%USP) + leaq (%rdi, %rcx), %rax + movq %rax, (%USP) ;;; Do the move in longword steps jmp movchars_l - .align 4 + .align 16 ;;; MOVCHARS: ;;; MOVCHARS_L: @@ -301,14 +301,14 @@ ;;; OR together the bits of the source address, destination address ;;; and byte count to test for word alignment - movl %esi, %eax - orl %edi, %eax - orl %ecx, %eax + movq %rsi, %rax + orq %rdi, %rax + orq %rcx, %rax ;;; If neither of the bottom two bits is set, the move is longword ;;; aligned so move a longword at a time - testl $3, %eax + testq $3, %rax jz movchars_l ;;; Otherwise, move a byte at a time @@ -317,7 +317,7 @@ ;;; If ECX is zero there's nothing to move, so exit - cmpl $0, %ecx + cmpq $0, %rcx je L2.2 ;;; Clear the direction flag for a default downwards move @@ -328,7 +328,7 @@ ;;; if ESI > EDI, then the move is down, so jump straight to it; ;;; if ESI = EDI, then there's no move at all, so return - cmpl %edi, %esi + cmpq %rdi, %rsi ja L1.5 je L2.2 @@ -337,8 +337,8 @@ ;;; byte in each region rather than the first std - leal -1(%esi, %ecx), %esi - leal -1(%edi, %ecx), %edi + leaq -1(%rsi, %rcx), %rsi + leaq -1(%rdi, %rcx), %rdi L1.5: ;;; Do the move @@ -349,14 +349,14 @@ ret - .align 4 + .align 16 movchars_l: ;;; Convert ECX to the length of the move in longwords; if zero, ;;; jump to the end. - sarl $2, %ecx + sarq $2, %rcx jz L2.3 ;;; Clear the direction flag for a default downwards move @@ -367,7 +367,7 @@ ;;; if ESI > EDI, then the move is down, so jump straight to it; ;;; if ESI = EDI, then there's no move at all, so return - cmpl %edi, %esi + cmpq %rdi, %rsi ja L1.6 je L2.3 @@ -376,8 +376,8 @@ ;;; word in each region rather than the first std - leal -4(%esi, %ecx, 4), %esi - leal -4(%edi, %ecx, 4), %edi + leaq -4(%rsi, %rcx, 4), %rsi + leaq -4(%rdi, %rcx, 4), %rdi L1.6: ;;; Do the move @@ -388,7 +388,7 @@ ret - .align 4 + .align 16 ;;; === FILLING ======================================================= @@ -406,10 +406,10 @@ DEF_C_LAB (_bfill) - movl (%USP), %edi - movl 4(%USP), %ecx - movl 8(%USP), %eax - addl $12, %USP + movq (%USP), %rdi + movq 8(%USP), %rcx + movq 16(%USP), %rax + addq $24, %USP ;;; Clear the direction flag to increment EDI and do the fill @@ -418,7 +418,7 @@ sstob ret - .align 4 + .align 16 ;;; _IFILL: ;;; _FILL: @@ -433,23 +433,40 @@ ;;; EDI destination pointer DEF_C_LAB (_ifill) -DEF_C_LAB (_fill) - movl (%USP), %edi - movl 4(%USP), %ecx - movl 8(%USP), %eax - addl $12, %USP + movq (%USP), %rdi + movq 8(%USP), %rcx + movq 16(%USP), %rax + addq $24, %USP ;;; Clear the direction flag to increment EDI, convert ECX to ;;; length in longwords and do the filling cld - sarl $2, %ecx + sarq $2, %rcx rep sstol ret - .align 4 + .align 16 + +DEF_C_LAB (_fill) + + movq (%USP), %rdi + movq 8(%USP), %rcx + movq 16(%USP), %rax + addq $24, %USP + + ;;; Clear the direction flag to increment EDI, convert ECX to + ;;; length in longwords and do the filling + + cld + sarq $3, %rcx + rep + sstoq + ret + + .align 4 ;;; === RELOCATING POPLOG MEMORY REGIONS ============================== @@ -471,12 +488,12 @@ ;;; Load the amount to shift (in bytes) into EAX - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP ;;; Test the direction of the move - testl %eax, %eax + testq %rax, %rax jl move_userstack_down jg move_userstack_up @@ -484,7 +501,7 @@ ret - .align 4 + .align 16 move_userstack_down: @@ -492,27 +509,27 @@ ;;; Adjust the value of USERHI - movl I_LAB(_userhi), %ecx - addl %eax, %ecx - movl %ecx, I_LAB(_userhi) + movq I_LAB(_userhi), %rcx + addq %rax, %rcx + movq %rcx, I_LAB(_userhi) ;;; Adjust the stack pointer and make the old value the source ;;; pointer and the new value the destination pointer - movl %USP, %esi - addl %eax, %USP - movl %USP, %edi + movq %USP, %rsi + addq %rax, %USP + movq %USP, %rdi ;;; Compute the length of the move (USERHI - USP) in ECX and do it - subl %USP, %ecx - sarl $2, %ecx + subq %USP, %rcx + sarq $3, %rcx cld rep - smovl + smovq ret - .align 4 + .align 16 move_userstack_up: @@ -522,26 +539,26 @@ ;;; the destination pointer. Pointers are offset by 4 bytes because ;;; USERHI points one word beyond the top of stack. - movl I_LAB(_userhi), %ecx - leal -4(%ecx), %esi - addl %eax, %ecx - leal -4(%ecx), %edi - movl %ecx, I_LAB(_userhi) + movq I_LAB(_userhi), %rcx + leaq -8(%rcx), %rsi + addq %rax, %rcx + leaq -8(%rcx), %rdi + movq %rcx, I_LAB(_userhi) ;;; Adjust the stack pointer - addl %eax, %USP + addq %rax, %USP ;;; Compute the length of the move (USERHI - USP) in ECX and do it - subl %USP, %ecx - sarl $2, %ecx + subq %USP, %rcx + sarq $3, %rcx std rep - smovl + smovq ret - .align 4 + .align 16 ;;; _MOVE_CALLSTACK: ;;; Relocate the top part of the callstack between the stack pointer @@ -561,13 +578,13 @@ ;;; Load limit address to ECX, byte offset to EAX - movl (%USP), %ecx - movl 4(%USP), %eax - addl $8, %USP + movq (%USP), %rcx + movq 8(%USP), %rax + addq $16, %USP ;;; Test the direction of the move - testl %eax, %eax + testq %rax, %rax jl move_callstack_down jg move_callstack_up @@ -575,7 +592,7 @@ ret - .align 4 + .align 16 move_callstack_down: @@ -583,24 +600,24 @@ ;;; The length of the move is (_LIMIT - ESP) - subl %esp, %ecx + subq %rsp, %rcx ;;; Adjust the stack pointer and make the old value the source ;;; pointer and the new value the destination pointer - movl %esp, %esi - addl %eax, %esp - movl %esp, %edi + movq %rsp, %rsi + addq %rax, %rsp + movq %rsp, %rdi ;;; Do the move - sarl $2, %ecx + sarq $3, %rcx cld rep - smovl + smovq ret - .align 4 + .align 16 move_callstack_up: @@ -609,27 +626,27 @@ ;;; Make _LIMIT the source address (offset by 4 to point to the ;;; first word to be moved) and (SOURCE + _BYTE_OFFS) the destination - leal -4(%ecx), %esi - leal (%esi, %eax), %edi + leaq -8(%rcx), %rsi + leaq (%rsi, %rax), %rdi ;;; The length of the move is (_LIMIT - ESP) - subl %esp, %ecx + subq %rsp, %rcx ;;; Do the move - sarl $2, %ecx + sarq $3, %rcx std rep - smovl + smovq ;;; Set the new stack pointer - leal 4(%edi), %esp + leaq 8(%rdi), %rsp ret - .align 4 + .align 16 ;;; === BITFIELD OPERATIONS =========================================== @@ -652,71 +669,71 @@ ;;; Copy bit offset to ECX - movl %eax, %ecx + movq %rax, %rcx ;;; Convert bit offset to word index - sarl $5, %eax + sarq $6, %rax ;;; Compute address of the first word of the bitfield in EDI. ;;; Load first word to EAX and second to EDI in case of overspill. - leal (%edi, %eax, 4), %edi - movl (%edi), %eax - movl 4(%edi), %edi + leaq (%rdi, %rax, 8), %rdi + movq (%rdi), %rax + movq 8(%rdi), %rdi ;;; Mask the copied offset in ECX to get a bit-within-word offset ;;; and shift EAX down by that amount to right-align the field ;;; (bits are pulled in to the top end from EDI) - andl $31, %ecx - shrdl %edi, %eax + andq $63, %rcx + shrdq %rdi, %rax ;;; Zero the top (32 - field-width) bits - movl $32, %ecx - subl %edx, %ecx - sall %cl, %eax - shrl %cl, %eax + movq $64, %rcx + subq %rdx, %rcx + salq %cl, %rax + shrq %cl, %rax ret - .align 4 + .align 16 DEF_C_LAB(_sbfield) ;;; Copy bit offset to ECX - movl %eax, %ecx + movq %rax, %rcx ;;; Convert bit offset to word index - sarl $5, %eax + sarq $6, %rax ;;; Compute address of the first word of the bitfield in EDI. ;;; Load first word to EAX and second to EDI in case of overspill. - leal (%edi, %eax, 4), %edi - movl (%edi), %eax - movl 4(%edi), %edi + leaq (%rdi, %rax, 8), %rdi + movq (%rdi), %rax + movq 8(%rdi), %rdi ;;; Mask the copied offset in ECX to get a bit-within-word offset ;;; and shift EAX down by that amount to right-align the field ;;; (bits are pulled in to the top end from EDI) - andl $31, %ecx - shrdl %edi, %eax + andq $63, %rcx + shrdq %rdi, %rax ;;; Sign-extend the field into the top (32 - field-width) bits - movl $32, %ecx - subl %edx, %ecx - sall %cl, %eax - sarl %cl, %eax + movq $64, %rcx + subq %rdx, %rcx + salq %cl, %rax + sarq %cl, %rax ret - .align 4 + .align 16 ;;; _UBFIELD: ;;; Update a bitfield within a structure. Not called directly from POP @@ -738,41 +755,41 @@ DEF_C_LAB (_ubfield) - ;;; Compute (32 - field-width) in ECX + ;;; Compute (64 - field-width) in ECX - movl $32, %ecx - subl %edx, %ecx + movq $64, %rcx + subq %rdx, %rcx ;;; Copy the bit offset into EDX - movl %eax, %edx + movq %rax, %rdx ;;; Convert bit offset to word index and add to the structure ;;; address to get a pointer to the first word of the bitfield - sarl $5, %eax - leal (%edi, %eax, 4), %edi + sarq $6, %rax + leaq (%rdi, %rax, 8), %rdi ;;; Get the new value of the field from the stack top to EAX ;;; EAX = [ ___ | MMM' ] - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP ;;; Shift left by (32 - field-width) to left-align it in EAX ;;; EAX = [ MMM' | ___ ] - shll %cl, %eax + shlq %cl, %rax ;;; Mask the copied bit offset in EDX to get a bit-within-word ;;; offset - andl $31, %edx + andq $63, %rdx ;;; Subtract from the value in ECX: this gives the number of unwanted ;;; bits in the high end of the first word - subl %edx, %ecx + subq %rdx, %rcx ;;; If negative, the field must overspill into a second word, ;;; so jump to handle that @@ -782,68 +799,68 @@ ;;; Otherwise, load the current value of the target word into ESI ;;; ESI = [ HHH | MMM | LLL ] - movl (%edi), %esi + movq (%rdi), %rsi ;;; Rotate to move the current field value to the top ;;; ESI = [ MMM | LLL | HHH ] - roll %cl, %esi + rolq %cl, %rsi ;;; Reinstate the shift count and pull the extra bits from ESI ;;; into the top of EAX ;;; EAX = [ LLL | HHH | MMM' ] - addl %edx, %ecx - shrdl %esi, %eax + addq %rdx, %rcx + shrdq %rsi, %rax ;;; Rotate the low order bits to their correct place ;;; EAX = [ HHH | MMM' | LLL ] - movl %edx, %ecx - roll %cl, %eax + movq %rdx, %rcx + rolq %cl, %rax ;;; Store the updated word and return - movl %eax, (%edi) + movq %rax, (%rdi) ret L1.7: ;;; Field overspills into a second word -- load that first ;;; ESI = [ HHH | MMH ] - movl 4(%edi), %esi + movq 8(%rdi), %rsi ;;; The size of the overspill is the absolute value of ECX; ;;; shift ESI by that amount, then pull in the top bits of the ;;; new value. Drop the corresponding bits from EAX. - negl %ecx - shrl %cl, %esi ;;; ESI = [ 000 | HHH ] - shldl %eax, %esi ;;; ESI = [ HHH | MMH' ] - shll %cl, %eax ;;; EAX = [ MML' | 000 ] + negq %rcx + shrq %cl, %rsi ;;; ESI = [ 000 | HHH ] + shldq %rax, %rsi ;;; ESI = [ HHH | MMH' ] + shlq %cl, %rax ;;; EAX = [ MML' | 000 ] ;;; Store the updated high word - movl %esi, 4(%edi) + movq %rsi, 8(%rdi) ;;; Now get the low word ;;; ESI = [ MML | LLL ] - movl (%edi), %esi + movq (%rdi), %rsi ;;; Only the bottom bits of this are wanted, the count being in ;;; EDX. Shift them into the high part of EAX, then rotate to ;;; place them in the low part - movl %edx, %ecx - shrdl %esi, %eax ;;; EAX = [ LLL | MML' ] - roll %cl, %eax ;;; EAX = [ MML' | LLL ] + movq %rdx, %rcx + shrdq %rsi, %rax ;;; EAX = [ LLL | MML' ] + rolq %cl, %rax ;;; EAX = [ MML' | LLL ] ;;; Store the low word and return - movl %eax, (%edi) + movq %rax, (%rdi) ret - .align 4 + .align 16 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/aprocess.s v15.6301-amd64/pop/src/aprocess.s --- v15.63/pop/src/aprocess.s 1996-08-09 13:16:33.000000000 -0400 +++ v15.6301-amd64/pop/src/aprocess.s 2009-12-24 15:36:33.000000000 -0500 @@ -12,9 +12,9 @@ lconstant macro ( - USP = "ebx", - PB = "ebp", - CHAIN_REG = "edx", + USP = "rbx", + PB = "rbp", + CHAIN_REG = "rdx", _ID_VALOF = @@ID_VALOF, _PD_EXECUTE = @@PD_EXECUTE, @@ -31,6 +31,11 @@ _PS_STATE = @@PS_STATE, ); +lconstant macro MOVFL = if DEF FRAME_LEN_16BIT then "movzwl" + elseif DEF FRAME_LEN_32BIT then "movl" + else "movzbl" + endif; + >_# .file "aprocess.s" @@ -38,10 +43,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -52,15 +57,15 @@ .data PROCESS: ;;; Process record - .long 0 + .quad 0 LIMIT: ;;; Limit of the callstack save area - .long 0 + .quad 0 NEXT_FRAME: ;;; Pointer to the next frame in the saved callstack - .long 0 + .quad 0 .text -.set BRANCH_std, 7 ;;; Size of a standard branch instruction +.set BRANCH_std, 9 ;;; Size of a standard branch instruction ;;; (as placed by I_BRANCH_std) ;;; _SWAP_OUT_CALLSTACK: @@ -72,13 +77,13 @@ DEF_C_LAB (_swap_out_callstack) - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP - movl %eax, PROCESS ;;; Save the process record - movl _PS_CALLSTACK_LIM(%eax), %edi ;;; Start of saved callstack - movl _PS_STATE(%eax), %eax - movl %eax, LIMIT ;;; End of saved callstack + movq %rax, PROCESS ;;; Save the process record + movq _PS_CALLSTACK_LIM(%rax), %rdi ;;; Start of saved callstack + movq _PS_STATE(%rax), %rax + movq %rax, LIMIT ;;; End of saved callstack jmp sotest soloop: @@ -87,12 +92,12 @@ ;;; save the return address in ECX, then set the procedure base ;;; register from the owner address on the stack top - popl %ecx - movl (%esp), %PB + popq %rcx + movq (%rsp), %PB ;;; Make the return address relative to the procedure base - subl %PB, %ecx + subq %PB, %rcx ;;; Test if the procedure has dlocal expression code to run @@ -107,31 +112,31 @@ ;;; record; we compute the position of the next frame by subtracting ;;; the length of the current stack frame - movzbl _PD_FRAME_LEN(%PB), %eax - sall $2, %eax - subl %eax, %edi - movl %edi, NEXT_FRAME + MOVFL _PD_FRAME_LEN(%PB), %eax + salq $3, %rax + subq %rax, %rdi + movq %rdi, NEXT_FRAME ;;; Save relative return address and owner address in the process ;;; record - movl %ecx, (%edi) - movl %PB, 4(%edi) - addl $8, %edi + movq %rcx, (%rdi) + movq %PB, 8(%rdi) + addq $16, %rdi ;;; Copy any on-stack lvars into the process record cld - movzbl _PD_NUM_STK_VARS(%PB), %ecx - leal 4(%esp), %esi + MOVFL _PD_NUM_STK_VARS(%PB), %ecx + leaq 8(%rsp), %rsi rep - smovl - movl %esi, %esp + smovq + movq %rsi, %rsp ;;; Test if there are any dynamic locals - movzbl _PD_NLOCALS(%PB), %ecx - cmpl $0, %ecx + MOVFL _PD_NLOCALS(%PB), %ecx + cmpq $0, %rcx je L2.1 ;;; If so, copy the current values of the locals into the @@ -140,38 +145,38 @@ ;;; ESI is initialised to point to the last entry in the procedure's ;;; identifier table - leal _PD_TABLE-4(%PB, %ecx, 4), %esi + leaq _PD_TABLE-8(%PB, %rcx, 8), %rsi L1.1: ;;; Loop: - movl (%esi), %edx ;;; ident to EDX - movl _ID_VALOF(%edx), %eax ;;; idval to EAX - sstol ;;; save idval in process record - popl _ID_VALOF(%edx) ;;; restore previous idval from stack - subl $4, %esi ;;; decrement ESI + movq (%rsi), %rdx ;;; ident to EDX + movq _ID_VALOF(%rdx), %rax ;;; idval to EAX + sstoq ;;; save idval in process record + popq _ID_VALOF(%rdx) ;;; restore previous idval from stack + subq $8, %rsi ;;; decrement ESI loop L1.1 L2.1: ;;; Stack frame saved -- restore EDI to point to where the next ;;; should go - movl NEXT_FRAME, %edi + movq NEXT_FRAME, %rdi sotest: ;;; Test if there are any more stack frames to swap out - cmpl %edi, LIMIT + cmpq %rdi, LIMIT jb soloop sodone: ;;; Finished swapping out -- chain procedure on stack - movl PROCESS, %eax - movl $0, _PS_CALLSTACK_PARTIAL(%eax) - movw $0, _PS_FLAGS(%eax) ;;; 0 flags = suspended - movl (%USP), %eax - addl $4, %USP - jmp *_PD_EXECUTE(%eax) ;;; chain procedure + movq PROCESS, %rax + movq $0, _PS_CALLSTACK_PARTIAL(%rax) + movw $0, _PS_FLAGS(%rax) ;;; 0 flags = suspended + movq (%USP), %rax + addq $8, %USP + jmp *_PD_EXECUTE(%rax) ;;; chain procedure sobrk: @@ -179,46 +184,46 @@ ;;; appropriate part of the exit code of the procedure. ;;; The process is passed in CHAIN_REG - movl PROCESS, %CHAIN_REG + movq PROCESS, %CHAIN_REG ;;; Save relative return address and callstack save pointer in the ;;; process record - movl %ecx, _PS_PARTIAL_RETURN(%CHAIN_REG) - movl %edi, _PS_CALLSTACK_PARTIAL(%CHAIN_REG) + movq %rcx, _PS_PARTIAL_RETURN(%CHAIN_REG) + movq %rdi, _PS_CALLSTACK_PARTIAL(%CHAIN_REG) ;;; Go to the procedure's suspend code - movl _PD_EXIT(%PB), %eax - subl $BRANCH_std << 1, %eax - jmp *%eax + movq _PD_EXIT(%PB), %rax + subq $BRANCH_std << 1, %rax + jmp *%rax - .align 4 + .align 16 DEF_C_LAB (_swap_out_continue) ;;; The suspend code returns here to resume the swapout loop ;;; The process will still be in CHAIN_REG - movl %CHAIN_REG, PROCESS + movq %CHAIN_REG, PROCESS ;;; Restore callstack save pointer, relative return address and ;;; save limit from the process record - movl _PS_CALLSTACK_PARTIAL(%CHAIN_REG), %edi - movl _PS_PARTIAL_RETURN(%CHAIN_REG), %ecx - movl _PS_STATE(%CHAIN_REG), %eax - movl %eax, LIMIT + movq _PS_CALLSTACK_PARTIAL(%CHAIN_REG), %rdi + movq _PS_PARTIAL_RETURN(%CHAIN_REG), %rcx + movq _PS_STATE(%CHAIN_REG), %rax + movq %rax, LIMIT ;;; Restore procedure base from the stack top - movl (%esp), %PB + movq (%rsp), %PB ;;; Continue the swapout loop jmp socont - .align 4 + .align 16 ;;; _SWAP_IN_CALLSTACK: @@ -230,17 +235,17 @@ DEF_C_LAB (_swap_in_callstack) - movl (%USP), %eax - addl $4, %USP + movq (%USP), %rax + addq $8, %USP - movl %eax, PROCESS ;;; Save the process record + movq %rax, PROCESS ;;; Save the process record ;;; Get a pointer to the start of the saved callstack in ESI ;;; and the limit in LIMIT - movl _PS_STATE(%eax), %esi - movl _PS_CALLSTACK_LIM(%eax), %eax - movl %eax, LIMIT + movq _PS_STATE(%rax), %rsi + movq _PS_CALLSTACK_LIM(%rax), %rax + movq %rax, LIMIT jmp sitest siloop: @@ -248,21 +253,21 @@ ;;; ESI points to the saved stack frame in the process record. ;;; Restore the procedure base register from the saved owner address. - movl 4(%esi), %PB + movq 8(%rsi), %PB ;;; Compute the position of the next frame in the record by adding ;;; the length of the current frame - movzbl _PD_FRAME_LEN(%PB), %eax - leal (%esi, %eax, 4), %esi - movl %esi, NEXT_FRAME - subl $4, %esi + MOVFL _PD_FRAME_LEN(%PB), %eax + leaq (%rsi, %rax, 8), %rsi + movq %rsi, NEXT_FRAME + subq $8, %rsi ;;; Check for any dynamic locals std - movzbl _PD_NLOCALS(%PB), %ecx - cmpl $0, %ecx + MOVFL _PD_NLOCALS(%PB), %ecx + cmpq $0, %rcx je L2.2 ;;; If so, push the current values of the locals on the stack @@ -270,37 +275,37 @@ ;;; EDI is initialised to point to the first entry in the procedure's ;;; identifier table - leal _PD_TABLE(%PB), %edi + leaq _PD_TABLE(%PB), %rdi L1.2: ;;; Loop: - movl (%edi), %edx ;;; ident to EDX - pushl _ID_VALOF(%edx) ;;; push the idval - slodl ;;; new idval from process record to EAX - movl %eax, _ID_VALOF(%edx) ;;; set new idval - addl $4, %edi ;;; increment EDI + movq (%rdi), %rdx ;;; ident to EDX + pushq _ID_VALOF(%rdx) ;;; push the idval + slodq ;;; new idval from process record to EAX + movq %rax, _ID_VALOF(%rdx) ;;; set new idval + addq $8, %rdi ;;; increment EDI loop L1.2 L2.2: ;;; Copy any on-stack lvars from the saved frame, ;;; adjusting ESP first in case of interrupts - movzbl _PD_NUM_STK_VARS(%PB), %ecx - leal -4(%esp), %edi + MOVFL _PD_NUM_STK_VARS(%PB), %ecx + leaq -8(%rsp), %rdi - leal (, %ecx, 4), %eax - subl %eax, %esp + leaq (, %rcx, 8), %rax + subq %rax, %rsp rep - smovl + smovq ;;; Push the owner address from the procedure base register ;;; and set ECX to be the saved relative return address - pushl %PB - movl -4(%esi), %ecx + pushq %PB + movq -8(%rsi), %rcx ;;; Set ESI to point to the next frame - movl NEXT_FRAME, %esi + movq NEXT_FRAME, %rsi ;;; Test for dlocal expression code to run @@ -313,25 +318,25 @@ ;;; Make the relative return address in ECX absolute and push it - addl %PB, %ecx - pushl %ecx + addq %PB, %rcx + pushq %rcx sitest: ;;; Test if there are more frames to swap in - cmpl %esi, LIMIT + cmpq %rsi, LIMIT ja siloop sidone: ;;; Finished swapping in - chain procedure from stack - movl PROCESS, %eax - movl $0, _PS_CALLSTACK_PARTIAL(%eax) - movl (%USP), %eax - addl $4, %USP - jmp *_PD_EXECUTE(%eax) ;;; chain procedure + movq PROCESS, %rax + movq $0, _PS_CALLSTACK_PARTIAL(%rax) + movq (%USP), %rax + addq $8, %USP + jmp *_PD_EXECUTE(%rax) ;;; chain procedure sibrk: @@ -339,46 +344,46 @@ ;;; appropriate part of the exit code of the procedure. ;;; The process is passed in CHAIN_REG - movl PROCESS, %CHAIN_REG + movq PROCESS, %CHAIN_REG ;;; Save relative return address and callstack save pointer in the ;;; process record - movl %ecx, _PS_PARTIAL_RETURN(%CHAIN_REG) - movl %esi, _PS_CALLSTACK_PARTIAL(%CHAIN_REG) + movq %rcx, _PS_PARTIAL_RETURN(%CHAIN_REG) + movq %rsi, _PS_CALLSTACK_PARTIAL(%CHAIN_REG) ;;; Go to the procedure's resume code - movl _PD_EXIT(%PB), %eax - subl $BRANCH_std, %eax - jmp *%eax + movq _PD_EXIT(%PB), %rax + subq $BRANCH_std, %rax + jmp *%rax - .align 4 + .align 16 DEF_C_LAB (_swap_in_continue) ;;; The resume code returns here to continue the swapin loop ;;; The process will still be in CHAIN_REG - movl %CHAIN_REG, PROCESS + movq %CHAIN_REG, PROCESS ;;; Restore callstack save pointer, relative return address and ;;; save limit from the process record - movl _PS_CALLSTACK_PARTIAL(%CHAIN_REG), %esi - movl _PS_PARTIAL_RETURN(%CHAIN_REG), %ecx - movl _PS_CALLSTACK_LIM(%CHAIN_REG), %eax - movl %eax, LIMIT + movq _PS_CALLSTACK_PARTIAL(%CHAIN_REG), %rsi + movq _PS_PARTIAL_RETURN(%CHAIN_REG), %rcx + movq _PS_CALLSTACK_LIM(%CHAIN_REG), %rax + movq %rax, LIMIT ;;; Restore the procedure base from the stack top - movl (%esp), %PB + movq (%rsp), %PB ;;; Continue the swapin loop jmp sicont - .align 4 + .align 16 ;;; === SWAPPING THE USERSTACK ======================================== @@ -391,43 +396,43 @@ DEF_C_LAB (_ussave) - movl (%USP), %edi - movl 4(%USP), %ecx - addl $8, %USP + movq (%USP), %rdi + movq 8(%USP), %rcx + addq $16, %USP std ;;; Make ESI point to the first word on the stack, ;;; and EDI point to the end of the save area - movl I_LAB(_userhi), %esi - subl $4, %esi - movl %esi, %edx ;;; Save for later - leal -4(%edi, %ecx), %edi + movq I_LAB(_userhi), %rsi + subq $8, %rsi + movq %rsi, %rdx ;;; Save for later + leaq -8(%rdi, %rcx), %rdi ;;; Do the save - sarl $2, %ecx + sarq $3, %rcx rep - smovl + smovq ;;; Make EDI point to the stack end - movl %edx, %edi + movq %rdx, %rdi ;;; Compute the amount of stack left and shift it up - leal 4(%esi), %ecx - subl %USP, %ecx - sarl $2, %ecx + leaq 8(%rsi), %rcx + subq %USP, %rcx + sarq $3, %rcx rep - smovl + smovq ;;; Set the stack pointer and return - leal 4(%edi), %USP + leaq 8(%rdi), %USP ret - .align 4 + .align 16 ;;; _USRESTORE: ;;; Restore a number of bytes at the end of the user stack @@ -437,35 +442,35 @@ DEF_C_LAB (_usrestore) - movl (%USP), %eax - movl 4(%USP), %edx - addl $8, %USP + movq (%USP), %rax + movq 8(%USP), %rdx + addq $16, %USP cld ;;; Shift existing stack down, leaving room for restored stuff - movl I_LAB(_userhi), %ecx - subl %USP, %ecx - sarl $2, %ecx ;;; Length of existing stack in words - movl %USP, %esi ;;; Source address is current USP - subl %edx, %USP ;;; New USP ... - movl %USP, %edi ;;; ... becomes destination address + movq I_LAB(_userhi), %rcx + subq %USP, %rcx + sarq $3, %rcx ;;; Length of existing stack in words + movq %USP, %rsi ;;; Source address is current USP + subq %rdx, %USP ;;; New USP ... + movq %USP, %rdi ;;; ... becomes destination address rep - smovl + smovq ;;; Now copy the new stuff in - movl %eax, %esi ;;; Source of new stuff - movl I_LAB(_userhi), %edi - subl %edx, %edi ;;; Destination - movl %edx, %ecx - sarl $2, %ecx ;;; Length in words + movq %rax, %rsi ;;; Source of new stuff + movq I_LAB(_userhi), %rdi + subq %rdx, %rdi ;;; Destination + movq %rdx, %rcx + sarq $3, %rcx ;;; Length in words rep - smovl + smovq ret - .align 4 + .align 16 ;;; _USERASUND: ;;; Erase a number of bytes from the end of the user stack @@ -475,22 +480,22 @@ DEF_C_LAB (_userasund) - movl (%USP), %eax ;;; Load length to erase to EAX - addl $4, %USP - movl I_LAB(_userhi), %ecx - leal -4(%ecx), %edi ;;; Destination is first word on the stack - addl %eax, %USP ;;; New stack pointer - subl %USP, %ecx ;;; New stack length (= length of move) + movq (%USP), %rax ;;; Load length to erase to EAX + addq $8, %USP + movq I_LAB(_userhi), %rcx + leaq -8(%rcx), %rdi ;;; Destination is first word on the stack + addq %rax, %USP ;;; New stack pointer + subq %USP, %rcx ;;; New stack length (= length of move) jz L1.3 ;;; If zero, nothing to do - movl %edi, %esi ;;; Source is destination ... - subl %eax, %esi ;;; ... offset by the amount being erased - sarl $2, %ecx ;;; Length of move in words + movq %rdi, %rsi ;;; Source is destination ... + subq %rax, %rsi ;;; ... offset by the amount being erased + sarq $3, %rcx ;;; Length of move in words std rep - smovl + smovq L1.3: ret - .align 4 + .align 16 /***************** end labels for wrapping structures *****************/ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/aprolog.s v15.6301-amd64/pop/src/aprolog.s --- v15.63/pop/src/aprolog.s 1996-08-09 12:20:05.000000000 -0400 +++ v15.6301-amd64/pop/src/aprolog.s 2005-03-11 05:30:39.000000000 -0500 @@ -24,7 +24,7 @@ ;;; User stack pointer - USP = "ebx", + USP = "rbx", ;;; Structure offsets @@ -48,10 +48,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -81,49 +81,49 @@ DEF_C_LAB (_prolog_save_check) - movl $C_LAB(_special_var_block), %esi + movq $C_LAB(_special_var_block), %rsi ;;; Save next_free_var pointer - movl _SVB_OFFS(_plog_next_var)(%esi), %eax - movl %eax, _SF_PLGSV_NEXT_VAR+4(%esp) + movq _SVB_OFFS(_plog_next_var)(%rsi), %rax + movq %rax, _SF_PLGSV_NEXT_VAR+8(%rsp) ;;; Save trail end pointer, relative to trail barrier - movl _SVB_OFFS(_plog_trail_sp)(%esi), %eax - movl %eax, %ecx ;;; wanted later - subl _SVB_OFFS(_plog_trail_barrier)(%esi), %eax - movl %eax, _SF_PLGSV_TRAIL_SP+4(%esp) + movq _SVB_OFFS(_plog_trail_sp)(%rsi), %rax + movq %rax, %rcx ;;; wanted later + subq _SVB_OFFS(_plog_trail_barrier)(%rsi), %rax + movq %rax, _SF_PLGSV_TRAIL_SP+8(%rsp) ;;; Save continuation stack top and pointer - movl _SVB_OFFS(_plog_contn_sp)(%esi), %eax - movl %eax, _SVB_OFFS(_plog_save_contn_sp)(%esi) - movl _SVB_OFFS(_plog_contn_top)(%esi), %eax - movl %eax, _SF_PLGSV_CONTN_TOP+4(%esp) + movq _SVB_OFFS(_plog_contn_sp)(%rsi), %rax + movq %rax, _SVB_OFFS(_plog_save_contn_sp)(%rsi) + movq _SVB_OFFS(_plog_contn_top)(%rsi), %rax + movq %rax, _SF_PLGSV_CONTN_TOP+8(%rsp) ;;; Check for trail overflow - cmpl %ecx, _SVB_OFFS(_plog_trail_lim)(%esi) + cmpq %rcx, _SVB_OFFS(_plog_trail_lim)(%rsi) jbe C_LAB(_checkplogall) ;;; Check system stack overflow - cmpl %esp, _SVB_OFFS(_call_stack_lim)(%esi) + cmpq %rsp, _SVB_OFFS(_call_stack_lim)(%rsi) ja C_LAB(_checkplogall) ;;; Check userstack overflow - cmpl %USP, _SVB_OFFS(_userlim)(%esi) + cmpq %USP, _SVB_OFFS(_userlim)(%rsi) ja C_LAB(_checkplogall) ;;; Test interrupt bit - testl $1, _SVB_OFFS(_trap)(%esi) + testq $1, _SVB_OFFS(_trap)(%rsi) jnz C_LAB(_checkplogall) ret - .align 4 + .align 16 ;;; _PROLOG_RESTORE: ;;; restores prolog continuation stack, trail and next_free_var pointer @@ -140,44 +140,44 @@ DEF_C_LAB (_prolog_restore) - movl $C_LAB(_special_var_block), %edi + movq $C_LAB(_special_var_block), %rdi ;;; Restore next_free_var pointer - movl _SF_PLGSV_NEXT_VAR+4(%esp), %eax - movl %eax, _SVB_OFFS(_plog_next_var)(%edi) + movq _SF_PLGSV_NEXT_VAR+8(%rsp), %rax + movq %rax, _SVB_OFFS(_plog_next_var)(%rdi) ;;; Restore continuation stack top and pointer - movl _SVB_OFFS(_plog_save_contn_sp)(%edi), %eax - movl %eax, _SVB_OFFS(_plog_contn_sp)(%edi) - movl _SF_PLGSV_CONTN_TOP+4(%esp), %eax - movl %eax, _SVB_OFFS(_plog_contn_top)(%edi) + movq _SVB_OFFS(_plog_save_contn_sp)(%rdi), %rax + movq %rax, _SVB_OFFS(_plog_contn_sp)(%rdi) + movq _SF_PLGSV_CONTN_TOP+8(%rsp), %rax + movq %rax, _SVB_OFFS(_plog_contn_top)(%rdi) ;;; Compare current trail end pointer with the saved value ;;; (saved relative to trail barrier) - movl _SF_PLGSV_TRAIL_SP+4(%esp), %esi - addl _SVB_OFFS(_plog_trail_barrier)(%edi), %esi - movl _SVB_OFFS(_plog_trail_sp)(%edi), %ecx - cmpl %ecx, %esi + movq _SF_PLGSV_TRAIL_SP+8(%rsp), %rsi + addq _SVB_OFFS(_plog_trail_barrier)(%rdi), %rsi + movq _SVB_OFFS(_plog_trail_sp)(%rdi), %rcx + cmpq %rcx, %rsi je L2.1 ;;; Restore the trail end pointer ... - movl %esi, _SVB_OFFS(_plog_trail_sp)(%edi) + movq %rsi, _SVB_OFFS(_plog_trail_sp)(%rdi) ;;; ... and uninstantiate the variables on it cld -L1.3: slodl ;;; plogvar in EAX - movl %eax, _PGV_CONT(%eax) ;;; assigned to its own PGV_CONT - cmpl %ecx, %esi +L1.3: slodq ;;; plogvar in EAX + movq %rax, _PGV_CONT(%rax) ;;; assigned to its own PGV_CONT + cmpq %rcx, %rsi jne L1.3 L2.1: ret - .align 4 + .align 16 ;;; === HEAD MATCHING ================================================= @@ -202,43 +202,43 @@ L1.4: ;;; Start of dereferencing loop: ;;; break out if item is simple - testl $1, %eax + testq $1, %rax jnz L2.2 ;;; Item is compound: ;;; break out unless item is plogvar - cmpl $C_LAB(prologvar_key), _KEY(%eax) + cmpq $C_LAB(prologvar_key), _KEY(%rax) jne L2.2 ;;; Dereference one link of plogvar: ;;; loop unless (var!PGV_CONT) == var - movl %eax, %esi - movl _PGV_CONT(%eax), %eax - cmpl %eax, %esi + movq %rax, %rsi + movq _PGV_CONT(%rax), %rax + cmpq %rax, %rsi jne L1.4 ;;; Argument is an uninstantiated plogvar: ;;; assign the atom in ECX to it and push it on the trail - movl %ecx, _PGV_CONT(%eax) - movl I_LAB(_plog_trail_sp), %edi - movl %eax, (%edi) - addl $4, %edi - movl %edi, I_LAB(_plog_trail_sp) + movq %rcx, _PGV_CONT(%rax) + movq I_LAB(_plog_trail_sp), %rdi + movq %rax, (%rdi) + addq $8, %rdi + movq %rdi, I_LAB(_plog_trail_sp) ;;; Set flags to equal to indicate success and return - cmpl %eax, %eax + cmpq %rax, %rax ret L2.2: ;;; Item in EAX is non-var: compare with atom in ECX and return - cmpl %eax, %ecx + cmpq %rax, %rcx ret - .align 4 + .align 16 ;;; _PROLOG_PAIR_SWITCH: ;;; tests if an argument can be unified with a pair @@ -268,38 +268,38 @@ L1.5: ;;; Dereferencing loop: ;;; break out if argument is simple (and go straight to failure) - testl $1, %eax + testq $1, %rax jnz L3.1 ;;; Argument is compound: ;;; break out if not a prologvar - cmpl $C_LAB(prologvar_key), _KEY(%eax) + cmpq $C_LAB(prologvar_key), _KEY(%rax) jne L2.3 ;;; Argument is a prologvar: ;;; dereference one link, then test for the end of the chain ;;; (var!PGV_CONT == var); loop if not - movl %eax, %esi - movl _PGV_CONT(%eax), %eax - cmpl %eax, %esi + movq %rax, %rsi + movq _PGV_CONT(%rax), %rax + cmpq %rax, %rsi jne L1.5 ;;; Uninstantiated prologvar: push it on the stack - subl $4, %USP - movl %eax, (%USP) + subq $8, %USP + movq %rax, (%USP) ;;; Set flags to UGT and return - testl %eax, %eax ;;; address of prologvar must be > 0 + testq %rax, %rax ;;; address of prologvar must be > 0 ret L2.3: ;;; Argument is compound: test for a pair and return with flags ;;; set to EQ if so - cmpl $C_LAB(pair_key), _KEY(%eax) + cmpq $C_LAB(pair_key), _KEY(%rax) jne L3.1 ret @@ -309,7 +309,7 @@ stc ret - .align 4 + .align 16 ;;; _PROLOG_TERM_SWITCH: ;;; tests if an argument can be unified with a term of particular functor @@ -342,44 +342,44 @@ L1.6: ;;; Dereferencing loop: ;;; break out if argument is simple (and go straight to failure) - testl $1, %eax + testq $1, %rax jnz L3.2 ;;; Argument is compound: ;;; break out if not a prologvar - cmpl $C_LAB(prologvar_key), _KEY(%eax) + cmpq $C_LAB(prologvar_key), _KEY(%rax) jne L2.4 ;;; Argument is a prologvar: ;;; dereference one link, then test for the end of the chain ;;; (var!PGV_CONT == var); loop if not - movl %eax, %esi - movl _PGV_CONT(%eax), %eax - cmpl %eax, %esi + movq %rax, %rsi + movq _PGV_CONT(%rax), %rax + cmpq %rax, %rsi jne L1.6 ;;; Uninstantiated prologvar: push it on the stack - subl $4, %USP - movl %eax, (%USP) + subq $8, %USP + movq %rax, (%USP) ;;; Set flags to UGT and return - testl %eax, %eax ;;; address of prologvar must be > 0 + testq %rax, %rax ;;; address of prologvar must be > 0 ret L2.4: ;;; Argument is compound: ;;; test for prologterm with same functor and arity, and return ;;; with flags set to EQ if so - cmpl $C_LAB(prologterm_key), _KEY(%eax) + cmpq $C_LAB(prologterm_key), _KEY(%rax) jne L3.2 - cmpl %ecx, _PGT_FUNCTOR(%eax) + cmpq %rcx, _PGT_FUNCTOR(%rax) jne L3.2 - sarl $2, %edx ;;; convert length to sysint - cmpl %edx, _PGT_LENGTH(%eax) + sarq $2, %rdx ;;; convert length to sysint + cmpq %rdx, _PGT_LENGTH(%rax) jne L3.2 ret @@ -388,7 +388,7 @@ stc ret - .align 4 + .align 16 ;;; === ASSIGNING TO PROLOG VARIABLES ================================= @@ -406,23 +406,23 @@ DEF_C_LAB (_prolog_assign) - movl (%USP), %eax - movl 4(%USP), %ecx - addl $8, %USP + movq (%USP), %rax + movq 8(%USP), %rcx + addq $16, %USP ;;; Assign item to var!PGV_CONT - movl %eax, _PGV_CONT(%ecx) + movq %rax, _PGV_CONT(%rcx) ;;; Push var on the trail - movl I_LAB(_plog_trail_sp), %edi - movl %ecx, (%edi) - addl $4, %edi - movl %edi, I_LAB(_plog_trail_sp) + movq I_LAB(_plog_trail_sp), %rdi + movq %rcx, (%rdi) + addq $8, %rdi + movq %rdi, I_LAB(_plog_trail_sp) ret - .align 4 + .align 16 ;;; _PROLOG_ASSIGN_PAIR: ;;; optimised version of _prolog_assign(conspair()) @@ -441,37 +441,37 @@ ;;; If simple, there are no free pairs left so chain ;;; -Assign_pair- to allocate more store - movl I_LAB(Sys$- _free_pairs), %eax - testl $1, %eax + movq I_LAB(Sys$- _free_pairs), %rax + testq $1, %rax jnz XC_LAB(Sys$-Plog$-Assign_pair) ;;; Otherwise, take the first pair from the free list - movl _P_BACK(%eax), %ecx - movl %ecx, I_LAB(Sys$- _free_pairs) + movq _P_BACK(%rax), %rcx + movq %rcx, I_LAB(Sys$- _free_pairs) ;;; Initialise the new pair with the values from the stack - movl (%USP), %ecx - movl %ecx, _P_BACK(%eax) - movl 4(%USP), %ecx - movl %ecx, _P_FRONT(%eax) + movq (%USP), %rcx + movq %rcx, _P_BACK(%rax) + movq 8(%USP), %rcx + movq %rcx, _P_FRONT(%rax) ;;; Assign the new pair to the prologvar - movl 8(%USP), %ecx - addl $12, %USP - movl %eax, _PGV_CONT(%ecx) + movq 16(%USP), %rcx + addq $24, %USP + movq %rax, _PGV_CONT(%rcx) ;;; and push the var on the trail - movl I_LAB(_plog_trail_sp), %edi - movl %ecx, (%edi) - addl $4, %edi - movl %edi, I_LAB(_plog_trail_sp) + movq I_LAB(_plog_trail_sp), %rdi + movq %rcx, (%rdi) + addq $8, %rdi + movq %rdi, I_LAB(_plog_trail_sp) ret - .align 4 + .align 16 ;;; === OPTIONAL OPTIMISATIONS ======================================== @@ -491,33 +491,33 @@ ;;; Load item to EAX - movl (%USP), %eax + movq (%USP), %rax L1.9: ;;; Start of dereferencing loop: quit if item is simple - testl $1, %eax + testq $1, %rax jnz L2.5 ;;; Item is compound: quit if not prologvar - cmpl $C_LAB(prologvar_key), _KEY(%eax) + cmpq $C_LAB(prologvar_key), _KEY(%rax) jne L2.5 ;;; Item is prologvar: ;;; dereference one link, then test for end of chain ;;; (var!PGV_CONT == var) - movl %eax, %ecx - movl _PGV_CONT(%eax), %eax - cmpl %eax, %ecx + movq %rax, %rcx + movq _PGV_CONT(%rax), %rax + cmpq %rax, %rcx jne L1.9 L2.5: ;;; Finished -- return the dereferenced item - movl %eax, (%USP) + movq %rax, (%USP) ret - .align 4 + .align 16 ;;; _PROLOG_NEWVAR: ;;; returns a new prologvar from the free block. If there are none left, @@ -533,27 +533,27 @@ ;;; Load the next var in the block to EAX - movl I_LAB(_plog_next_var), %eax + movq I_LAB(_plog_next_var), %rax ;;; If it's the end-of-block ref, go to the storage allocator - cmpl $C_LAB(ref_key), _KEY(%eax) + cmpq $C_LAB(ref_key), _KEY(%rax) je XC_LAB(Sys$-Plog$-New_var) ;;; Otherwise it's a new variable: ;;; make it undef, and push it on the stack - movl %eax, _PGV_CONT(%eax) - subl $4, %USP - movl %eax, (%USP) + movq %rax, _PGV_CONT(%rax) + subq $8, %USP + movq %rax, (%USP) ;;; Increment the -next_var- pointer and return - addl $_PGV_SIZE, %eax ;;; == @@(struct PLOGVAR)[_1] - movl %eax, I_LAB(_plog_next_var) + addq $_PGV_SIZE, %rax ;;; == @@(struct PLOGVAR)[_1] + movq %rax, I_LAB(_plog_next_var) ret - .align 4 + .align 16 /***************** end labels for wrapping structures *****************/ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/array_cons.p v15.6301-amd64/pop/src/array_cons.p --- v15.63/pop/src/array_cons.p 1994-09-01 05:42:11.000000000 -0400 +++ v15.6301-amd64/pop/src/array_cons.p 2005-03-11 05:30:39.000000000 -0500 @@ -25,13 +25,14 @@ ;;; Macros for dropping code at __________drop_ptr lconstant macro ( - LONG = [_drop_ptr!(l)++ -> _drop_ptr], + QUAD = [_drop_ptr!(l)++ -> _drop_ptr], + LONG = [_drop_ptr!(i)++ -> _drop_ptr], SHORT = [_drop_ptr!(s)++ -> _drop_ptr], BYTE = [_drop_ptr!(b)++ -> _drop_ptr], ); - ;;; Get procedure record -- 18 bytes of code - @@PD_ARRAY_TABLE{_tabsize} _add @@(w)[_18|b.r] _sub @@POPBASE -> _size; + ;;; Get procedure record -- 26 bytes of code + @@PD_ARRAY_TABLE{_tabsize} _add @@(w)[_26|b.r] _sub @@POPBASE -> _size; Get_store(_size) -> _arrayp; ;;; initialise some of procedure header @@ -48,25 +49,33 @@ _arrayp@PD_ARRAY_TABLE{_tabsize} ->> _drop_ptr -> _arrayp!PD_EXECUTE; ;;; Create stack frame - ;;; movl %eax, %PB - _16:C589 -> SHORT; ;;; 2 bytes - ;;; pushl %PB + ;;; movl %rax, %PB + _16:48 -> BYTE; + _16:C589 -> SHORT; ;;; 1 + 2 = 3 bytes + ;;; pushl %PB _16:55 -> BYTE; ;;; 1 byte ;;; Call the array subscript routine ;;; (picks up parameters from PD_ARRAY_TABLE, stacks computed ;;; subscript and PD_ARRAY_VECTOR, and then chains PD_ARRAY_SUBSCR_PDR) ;;; movl $[_array_sub], %eax - _16:B8 -> BYTE, _array_sub -> LONG; ;;; 5 bytes - ;;; call *%eax + _16:48 -> BYTE; + _16:B8 -> BYTE, + _array_sub -> QUAD; ;;; 10 bytes + ;;; call *%rax _16:D0FF -> SHORT; ;;; 2 bytes ;;; Unwind stack frame and return _drop_ptr -> _arrayp!PD_EXIT; - ;;; addl $4, %esp - _16:C483 -> SHORT, _4 -> BYTE; ;;; 3 bytes - ;;; movl 4(%esp), %PB - _16:6C8B -> SHORT, _16:24 -> BYTE, _4 -> BYTE; ;;; 4 bytes + ;;; addl $8, %rsp + _16:48 -> BYTE; + _16:C483 -> SHORT, + _8 -> BYTE; ;;; 4 bytes + ;;; movl 8(%rsp), %PB + _16:48 -> BYTE; + _16:6C8B -> SHORT, + _16:24 -> BYTE, + _8 -> BYTE; ;;; 5 bytes ;;; ret _16:C3 -> BYTE; ;;; 1 bytes enddefine; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/asignals.s v15.6301-amd64/pop/src/asignals.s --- v15.63/pop/src/asignals.s 1996-04-25 11:16:35.000000000 -0400 +++ v15.6301-amd64/pop/src/asignals.s 2009-12-26 14:02:54.000000000 -0500 @@ -25,8 +25,8 @@ lconstant macro ( - USP = "ebx", ;;; User stack pointer - PB = "ebp", ;;; Procedure base register + USP = "rbx", ;;; User stack pointer + PB = "rbp", ;;; Procedure base register SAVED_SP = [I_LAB(Sys$-Extern$- _saved_sp)], @@ -39,10 +39,10 @@ /************************* wrapping structures ************************/ .text - .long Ltext_size, C_LAB(Sys$-objmod_pad_key) + .quad Ltext_size, C_LAB(Sys$-objmod_pad_key) Ltext_start: .data - .long Ldata_size, C_LAB(Sys$-objmod_pad_key) + .quad Ldata_size, C_LAB(Sys$-objmod_pad_key) Ldata_start: /**********************************************************************/ @@ -59,25 +59,25 @@ ;;; Save return address, as stack may be adjusted later - popl %eax + popq %rax ;;; Restore environment - movl $0, EXTERN_NAME(__pop_in_user_extern) ;;; just in case - movl I_LAB(_userhi), %USP ;;; reset user stack - movl $0, EXTERN_NAME(__pop_fpe_handler) ;;; clear FPE handler + movq $0, EXTERN_NAME(__pop_in_user_extern) ;;; just in case + movq I_LAB(_userhi), %USP ;;; reset user stack + movq $0, EXTERN_NAME(__pop_fpe_handler) ;;; clear FPE handler ;;; If saved stack pointer is non-zero, we're in an external call - cmpl $0, SAVED_SP + cmpq $0, SAVED_SP je L1.1 - movl SAVED_SP, %esp ;;; reset stack pointer - movl $0, SAVED_SP ;;; clear saved stack pointer - movl (%esp), %PB ;;; restore procedure base + movq SAVED_SP, %rsp ;;; reset stack pointer + movq $0, SAVED_SP ;;; clear saved stack pointer + movq (%rsp), %PB ;;; restore procedure base -L1.1: jmp *%eax ;;; return to caller +L1.1: jmp *%rax ;;; return to caller - .align 4 + .align 16 ;;; __POP_ERRSIG: @@ -89,7 +89,7 @@ call reset_pop_environ call XC_LAB(Sys$-Error_signal) ;;; never returns - .align 4 + .align 16 ;;; __POP_ERROR_RETURN: @@ -99,11 +99,11 @@ .globl EXTERN_NAME(__pop_error_return) EXTERN_NAME(__pop_error_return): - movl 4(%esp), %eax - movl %eax, 68(%ebp) + movq 8(%rsp), %rax + movq %rax, 68(%rbp) ret - .align 4 + .align 16 ;;; -- SYSTEM CALL INTERFACE ---------------------------------------------- @@ -116,31 +116,31 @@ DEF_C_LAB (Sys$- _do_vfork) call _vfork - testl %eax, %eax + testq %rax, %rax js L2.1 jz L1.2 ;;; Parent process: - movl $0, SAVED_SP ;;; in case child in extern call - subl $8, %USP - movl %eax, 4(%USP) ;;; child PID - movl $C_LAB(weakref Sys$-Vfork_parent), (%USP) + movq $0, SAVED_SP ;;; in case child in extern call + subq $16, %USP + movq %eax, 8(%USP) ;;; child PID + movq $C_LAB(weakref Sys$-Vfork_parent), (%USP) call XC_LAB(Sys$-Callstack_reset) ;;; never returns L1.2: ;;; Child process: - subl $4, %USP - movl $0, (%USP) + subq $8, %USP + movq $0, (%USP) ret L2.1: ;;; Vfork failed: - subl $4, %USP - movl $(-1), (%USP) + subq $8, %USP + movq $(-1), (%USP) ret - .align 4 + .align 16 #_ENDIF @@ -165,43 +165,95 @@ ;;; Save pointer to caller's stack frame in case of interrupts - leal 4(%esp), %eax - movl %eax, SAVED_SP - - ;;; Get the system call address in EDX and the argument count in ECX - - movl (%USP), %edx - movl 4(%USP), %ecx - addl $8, %USP + leaq 8(%rsp), %rax + movq %rax, SAVED_SP + pushq %r8 + pushq %r10 + pushq %r11 + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 + + ;;; Get the system call address in R10 and the argument count in RAX + + movq (%USP), %r10 + movq 8(%USP), %rax + addq $16, %USP ;;; Copy any arguments to the system stack - cmpl $0, %ecx + cmpq $0, %rax + je L2.2 + movq %rax, %rcx + subq $6, %rcx + jbe L1.4 + movq $6, %rax + +L1.3: pushq (%USP) + addq $8, %USP + decq %rcx + jnz L1.3 + +L1.4: + leaq (%USP, %rax, 8), %USP + cmpq $0, %rax je L2.2 -L1.3: pushl (%USP) - addl $4, %USP - loop L1.3 + movq -8(%USP), %rdi + decq %rax + + cmpq $0, %rax + je L2.2 + movq -16(%USP), %rsi + decq %rax + + cmpq $0, %rax + je L2.2 + movq -24(%USP), %rdx + decq %rax + + cmpq $0, %rax + je L2.2 + movq -32(%USP), %rcx + decq %rax + + cmpq $0, %rax + je L2.2 + movq -40(%USP), %r8 + decq %rax + + cmpq $0, %rax + je L2.2 + movq -48(%USP), %r9 + decq %rax L2.2: ;;; Make the call: ;;; clear the direction flag first, as Sequent's library routines ;;; seem to expect it like that! cld - call *%edx + call *%r10 ;;; Stack the result (from EAX) - subl $4, %USP - movl %eax, (%USP) + subq $8, %USP + movq %rax, (%USP) ;;; Restore the stack pointer and return - movl SAVED_SP, %eax - leal -4(%eax), %esp - movl $0, SAVED_SP ;;; indicates external call over + movq SAVED_SP, %rax + movq -16(%rax), %r8 + movq -24(%rax), %r10 + movq -32(%rax), %r11 + movq -40(%rax), %r12 + movq -48(%rax), %r13 + movq -56(%rax), %r14 + movq -64(%rax), %r15 + leaq -8(%rax), %rsp + movq $0, SAVED_SP ;;; indicates external call over ret - .align 4 + .align 16 ;;; --- C-ACCESSIBLE VARIABLES, ETC ------------------------------------- @@ -209,7 +261,7 @@ .data .globl EXTERN_NAME(__pop_fpe_handler) EXTERN_NAME(__pop_fpe_handler): - .long 0 + .quad 0 /***************** end labels for wrapping structures *****************/ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/ass.p v15.6301-amd64/pop/src/ass.p --- v15.63/pop/src/ass.p 1996-09-30 08:33:01.000000000 -0400 +++ v15.6301-amd64/pop/src/ass.p 2009-12-26 17:40:45.000000000 -0500 @@ -64,7 +64,8 @@ section $-Sys$-Vm; lvars - _strsize, ;;; size of structure table in bytes + _regmask, + _strsize, ;;; size of structure table in bytes ; @@ -81,6 +82,13 @@ _WORD = _16:66, ;;; 16-bit operand size + _REX_W = _16:48, ;;; 64-bit operand size + _REX_R = _16:4, + _REX_X = _16:2, + _REX_B = _16:1, + + _NO_REX_W = _16:1000, + ;;; Opcode bytes _ADD = _16:01, @@ -93,19 +101,24 @@ _JMP = _16:E9, ;;; jump EIP-relative _LEA = _16:8D, _MOV = _16:89, ;;; standard R/M -> R/M move + _MOV32 = _MOV _biset _NO_REX_W, _MOVI = _16:C7, ;;; move Imm -> R/M _MOVIs = _16:B8, ;;; short (1-byte) Imm -> Reg move + _MOVSXD = _16:63, ;;; 32->64 bit sign-extend + _MOVZXD = _MOVSXD _biset _NO_REX_W, ;;; zero extend _MOVX = _16:0F, ;;; move and extend (followed by SX or ZX) - _MOVSX = _16:BF, ;;; move and sign-extend R/M-16 -> Reg32 - _MOVZX = _16:B7, ;;; move and zero-extend R/M-16 -> Reg32 + _MOVSX = _16:BF _biset _NO_REX_W, ;;; move and sign-extend R/M-16 -> Reg32 + _MOVZX = _16:B7 _biset _NO_REX_W, ;;; move and zero-extend R/M-16 -> Reg32 _NOP = _16:90, _POP = _16:8F, + _POPs = _16:58, ;;; short (1-byte) form _PUSH = _16:FF, _PUSHI = _16:68, - _PUSHs = _16:50, ;;; short (1-byte) form + _PUSHs = _16:50, ;;; short (1-byte) form _RET = _16:C3, _SHIFTI = _16:C1, ;;; shift/rotate by imm8 (modified by TTT) _SUB = _16:29, + _TEST = _16:85, _TESTI = _16:F7, ;;; test Imm -> R/M _TESTIs = _16:A9, ;;; test Imm -> EAX _XCHG = _16:87, @@ -116,6 +129,7 @@ _CALL = _2:010, _CHAIN = _2:100, ;;; i.e. indirect jump _CMPI = _2:111, + _SAL = _2:100, _SAR = _2:111, _SUBI = _2:101, @@ -151,6 +165,15 @@ _ESI = _2:110, _EDI = _2:111, + _R8 = _2:1000, + _R9 = _2:1001, + _R10 = _2:1010, + _R11 = _2:1011, + _R12 = _2:1100, + _R13 = _2:1101, + _R14 = _2:1110, + _R15 = _2:1111, + _reg_SIB = _2:100, ;;; escape to 2-byte form _reg_ABS = _2:101, ;;; no register: absolute 32-bit address @@ -189,7 +212,7 @@ ;;; NAMED REGISTERS _SP = _ESP, ;;; system stack pointer - _USP = _EBX, ;;; user stack pointer + _USP = _EBX, ;;; user stack pointer _PB = _EBP, ;;; procedure base register _ARG_REG_0 = _EAX, ;;; for arguments to subroutines @@ -207,6 +230,7 @@ ;;; (available to the VM) ;;; The value is a popint register number shifted left 1 + ;;; plus bit 0 if pop reg ;;; arg_reg_0, _1, & _2 : ;;; for passing arguments to subroutines. _1 & _2 are (currently) used @@ -222,23 +246,41 @@ chain_reg = _pint(_CHAIN_REG) << 1, ;;; EDX + pop_reg_A = _pint(_R13) <<1 || 1, + pop_reg_B = _pint(_R14) <<1 || 1, + pop_reg_C = _pint(_R15) <<1 || 1, + nonpop_reg_A = _pint(_R8) <<1, + nonpop_reg_B = _pint(_R10) <<1, + nonpop_reg_C = _pint(_R11) <<1, + nonpop_reg_D = _pint(_R12) <<1, + ; constant ;;; REGISTER LVARS - ;;; (there aren't any!) - asm_pop_registers = [[]], - asm_nonpop_registers = [[]], + asm_pop_registers = [[]], + asm_nonpop_registers = [[]], + +/* + + asm_pop_registers = [%[], ident pop_reg_A, ident pop_reg_B, + ident pop_reg_C %], + asm_nonpop_registers = [%[], ident nonpop_reg_A, ident nonpop_reg_B, + ident nonpop_reg_C, ident nonpop_reg_D %], + + asm_nonpop_registers = [%[], ident nonpop_reg_A, ident nonpop_reg_D %], +*/ ; + lvars _USP_offset, ;;; "static offset" for accumulating adjustments to USP ; -lconstant procedure flush_USP_offset; ;;; forward reference +constant procedure flush_USP_offset; ;;; forward reference define Is_address_reg() with_nargs 1; Is_register() ;;; every reg is an address reg @@ -247,13 +289,16 @@ ;;; === CODE-PLANTING PROCEDURES ====================================== -;;; Drop_b, Drop_w, Drop_l: -;;; put a byte/word/longword in the procedure record +;;; Drop_b, Drop_w, Drop_l, Drop_d: +;;; put a byte/word/longword/quadword in the procedure record define Drop_b(_byte); lvars _byte; unless _asm_pass then ;;; only output the data on the last pass +;;; _extern printf('Drop_b(0x%02x)\n', _byte); +;;; _extern printf('%c', _byte); +;;; _extern fflush (_0); _byte -> _asm_drop_ptr!(b)++ -> _asm_drop_ptr; endunless; @@(b){_asm_code_offset}++ -> _asm_code_offset; @@ -261,8 +306,14 @@ define Drop_w(_word); lvars _word; +;;; lvars _pword = _word; unless _asm_pass then ;;; only output the data on the last pass +;;; _extern printf('Drop_w(0x%04x)\n', _word); +;;; _extern printf('%c', _pword); +;;; _shift(_pword, _-8) - > _pword; +;;; _extern printf('%c', _pword); +;;; _extern fflush (_0); _word -> _asm_drop_ptr!(s)++ -> _asm_drop_ptr; endunless; @@(s){_asm_code_offset}++ -> _asm_code_offset; @@ -270,23 +321,102 @@ define Drop_l(_long); lvars _long; +;;; lvars _pword = _long; unless _asm_pass then ;;; only output the data on the last pass - _long -> _asm_drop_ptr!(l)++ -> _asm_drop_ptr; +;;; _extern printf('Drop_l(0x%08x)\n', _long); +#_IF false + _extern printf('%c', _pword); + _shift(_pword, _-8) - > _pword; + _extern printf('%c', _pword); + _shift(_pword, _-8) - > _pword; + _extern printf('%c', _pword); + _shift(_pword, _-8) - > _pword; + _extern printf('%c', _pword); + _extern fflush (_0); +#_ENDIF + _long -> _asm_drop_ptr!(i)++ -> _asm_drop_ptr; endunless; - @@(l){_asm_code_offset}++ -> _asm_code_offset; + @@(i){_asm_code_offset}++ -> _asm_code_offset; enddefine; + +define Drop_d(_double); + lvars _double; + unless _asm_pass then + ;;; only output the data on the last pass + _double -> _asm_drop_ptr!(l)++ -> _asm_drop_ptr; + endunless; + @@(l){_asm_code_offset}++ -> _asm_code_offset; +enddefine; + +define constant Get_rex_sib(_rr, _rx, _rb); + lvars _rr, _rx, _rb, _rex = _REX_W; + if _rr _greq _R8 then +;;; _rr _sub _R8 -> _rr; + _rex _add _REX_R -> _rex; + endif; + if _rx _greq _R8 then +;;; _rx _bimask _7 -> _rb; + _rex _add _REX_X -> _rex; + endif; + if _rb _greq _R8 then +;;; _rb _sub _R8 -> _rb; + _rex _add _REX_B -> _rex; + endif; + _rex +enddefine; + +define constant Get_rex_rm(_rr, _rm); + Get_rex_sib(_rr, _EAX, _rm); +enddefine; + +define constant Get_rex_short(_reg); + Get_rex_sib(_EAX, _EAX, _reg); +enddefine; + +define constant is_large_int(_src); + lvars src; + if _src _slt _-2147483648 or _src _sgr 2147483647 then + true + else + false + endif +enddefine; + + ;;; Drop_short: ;;; output a short (1-byte) instruction, with format: ;;; [opcode|reg] ;;; 5 3 -define lconstant Drop_short(/* _opcode, _reg */) with_nargs 2; - Drop_b(nonop _add(/* _opcode, _reg */)); +define constant Drop_short( _opcode, _reg ) with_nargs 2; + lvars _opcode, _reg, _rex = Get_rex_short(_reg); + _reg _bimask _7 -> _reg; + if _not(_opcode == _PUSHs or _opcode == _POPs) or _rex /== _REX_W then + Drop_b(_rex); + endif; + Drop_b(_opcode _add _reg); +enddefine; + +define constant Drop_rex(_opcode, _rex) -> _opcode; + lvars _opcode, _rex; + if (_opcode == _MOVSX or _opcode == _MOVZX) + and _rex /== _REX_W then + mishap(0, 'Drop_rex: MOV[SZ]X CAN NOT USE EXTENDED REGISTERS'); + endif; + if _opcode _bitst _NO_REX_W then + if _rex /== _REX_W then + Drop_b(_rex _sub _8); + endif; + _opcode _sub _NO_REX_W -> _opcode; + elseif _opcode /== _BR_IND or _rex /== _REX_W then + Drop_b(_rex); + endif; enddefine; + ;;; Drop_std: ;;; output a "standard" instruction, with format: @@ -296,20 +426,33 @@ ;;; Also handles system stack indirections, which should be of this form ;;; but need an extra SIB byte. -define lconstant Drop_std(/* _opcode, */ _reg, _mod, _rm, _disp) with_nargs 5; - lvars _reg, _mod, _rm, _disp; - Drop_b(/* _opcode */); - Drop_b(_mod _add _shift(_reg, _3) _add _rm); - if _rm == _ESP and _mod /== _REG then +define constant Drop_std(_opcode, _reg, _mod, _rm, _disp) with_nargs 5; + lvars _reg, _mod, _rm, _disp, _rex = Get_rex_rm(_reg, _rm); + _reg _bimask _7 -> _reg; + _rm _bimask _7 -> _rm; + if is_large_int(_disp) then + mishap(0, 'Drop_std: DISPLACEMENT TOO BIG FOR 32-BITS'); + endif; + Drop_rex(_opcode, _rex) -> _opcode; + Drop_b( _opcode); + if _mod == _ABS and _rm == _reg_ABS then + ;;; amd64 supports SIB form, + ;;; rm variant means RIP relative addressing + Drop_b(_mod _add _shift(_reg, _3) _add _reg_SIB); + Drop_b(_NOINDEX _add _reg_ABS); + Drop_l(_disp); + else + Drop_b(_mod _add _shift(_reg, _3) _add _rm); + + if _rm == _ESP and _mod /== _REG then ;;; stack references need an extra byte Drop_b(_NOINDEX _add _ESP); - endif; - if _mod == _DISP32 - or _mod == _ABS and _rm == _reg_ABS - then + endif; + if _mod == _DISP32 then Drop_l(_disp); - elseif _mod == _DISP8 then + elseif _mod == _DISP8 then Drop_b(_disp); + endif; endif; enddefine; @@ -319,9 +462,18 @@ ;;; [opcode] [mod|reg|2:100] [s|index|base] [displacement] ;;; 8 8 8 0/8/32 -define lconstant Drop_extd(/* _opcode, */ _reg, _mod, _base, _disp, _index, _s) with_nargs 7; - lvars _reg, _mod, _base, _disp, _index, _s; - Drop_b(/* _opcode */); +define constant Drop_extd( _opcode, _reg, _mod, _base, _disp, _index, _s) with_nargs 7; + lvars _reg, _mod, _base, _disp, _index, _s, + _rex = Get_rex_sib(_reg, _index, _base); + _reg _bimask _7 -> _reg; + _index _bimask _7 -> _index; + _base _bimask _7 -> _base; + + if is_large_int(_disp) then + mishap(0, 'Drop_extd: DISPLACEMENT TOO BIG FOR 32-BITS'); + endif; + Drop_rex(_opcode, _rex) -> _opcode; + Drop_b(_opcode); Drop_b(_mod _add _shift(_reg, _3) _add _reg_SIB); Drop_b(_s _add _shift(_index, _3) _add _base); if _mod == _DISP32 @@ -342,8 +494,11 @@ ;;; The opcode given may be adjusted by having its SBIT set when ;;; the immediate value can be represented in 8 bits. -define lconstant Drop_imm(_opcode, _ttt, _imm, _mod, _rm, _disp); +define constant Drop_imm(_opcode, _ttt, _imm, _mod, _rm, _disp); lvars _opcode, _ttt, _imm, _mod, _rm, _disp; + if is_large_int(_imm) then + mishap(0, 'Drop_imm: IMMEDIATE TOO BIG FOR 32-BITS'); + endif; if _-128 _slteq _imm and _imm _slteq _127 then Drop_std(_opcode _biset _SBIT, _ttt, _mod, _rm, _disp), Drop_b(_imm); else @@ -351,38 +506,62 @@ endif; enddefine; +;;; define Drop_imm_to_r9(_imm); +;;; lvars _imm; +;;; Drop_b(_16:49); +;;; Drop_b(_16:B9); +;;; Drop_d(_imm); +;;; enddefine; + ;;; Drop_move_imm: ;;; plant an immediate move, which doesn't fit the above format! -define lconstant Drop_move_imm(_imm, _mod, _rm, _disp); +define constant Drop_move_imm(_imm, _mod, _rm, _disp); lvars _imm, _mod, _rm, _disp; if _mod == _REG then ;;; use a short form of MOV Drop_short(_MOVIs, _rm); - else + Drop_d(_imm); + else if _-2147483648 _slteq _imm and _imm _slteq _2147483647 then Drop_std(_MOVI, _0, _mod, _rm, _disp); + Drop_l(_imm); + else + ;;; moveq imm, %r9 + Drop_move_imm(_imm, _REG, _R9, false); +;;; Drop_b(_16:49); +;;; Drop_b(_16:B9); +;;; Drop_d(_imm); + Drop_std(_MOV, _R9, _mod, _rm, _disp); + ;;; mishap(0, 'IMMEDIATE TOO BIG FOR 32-BISTS'); + endif; endif; - Drop_l(_imm); enddefine; ;;; Drop_test_imm: ;;; plant test against immediate value (different format again) -define lconstant Drop_test_imm(_imm, _mod, _rm, _disp); - if _mod == _REG and _rm == _EAX then - ;;; short form - Drop_b(_TESTIs); - else - Drop_std(_TESTI, _0, (_mod, _rm, _disp)); - endif; - Drop_l(_imm); +define constant Drop_test_imm(_imm, _mod, _rm, _disp); + lvars _imm, _mod, _rm, _disp; + if _-2147483648 _slteq _imm and _imm _slteq _2147483647 then + if _mod == _REG and _rm == _EAX then + ;;; short form + Drop_b(_REX_W); + Drop_b(_TESTIs); + else + Drop_std(_TESTI, _0, (_mod, _rm, _disp)); + endif; + Drop_l(_imm); + else + Drop_move_imm(_imm, _REG, _R9, false); + Drop_std(_TEST, _R9, _mod, _rm, _disp); + endif; enddefine; ;;; Drop_call_indir: ;;; plant an indirect subroutine call: the target is the absolute ;;; address at the given effective address. -define lconstant Drop_call_indir(_mod, _rm, _disp); +define constant Drop_call_indir(_mod, _rm, _disp); lvars _mod, _rm, _disp; flush_USP_offset(); Drop_std(_BR_IND, _CALL, _mod, _rm, _disp); @@ -394,7 +573,7 @@ ;;; This can't be done directly: the address must be loaded to _CALLREG ;;; and the call done indirect via that. -define lconstant Drop_call_or_chain_abs(_routine, _mode); +define constant Drop_call_or_chain_abs(_routine, _mode); lvars _routine, _mode; ;;; Align the user stack flush_USP_offset(); @@ -404,11 +583,11 @@ Drop_std(_BR_IND, _mode, (_REG, _CALLREG, false)); enddefine; -define lconstant Drop_call_abs(/* _routine */) with_nargs 1; +define constant Drop_call_abs(/* _routine */) with_nargs 1; Drop_call_or_chain_abs(/* _routine, */ _CALL); enddefine; -define lconstant Drop_chain_abs(/* _routine */) with_nargs 1; +define constant Drop_chain_abs(/* _routine */) with_nargs 1; Drop_call_or_chain_abs(/* _routine, */ _CHAIN); enddefine; @@ -420,7 +599,7 @@ ;;; Get_imm_efa: ;;; the effective address of an immediate operand -define lconstant Get_imm_efa(_imm); +define constant Get_imm_efa(_imm); lvars _imm; (_IMM, false, _imm); enddefine; @@ -428,7 +607,7 @@ ;;; Get_abs_efa: ;;; the effective address of an absolute operand -define lconstant Get_abs_efa(_addr); +define constant Get_abs_efa(_addr); lvars _addr; (_ABS, _reg_ABS, _addr); enddefine; @@ -436,7 +615,7 @@ ;;; Get_reg_efa: ;;; the effective address of a register operand -define lconstant Get_reg_efa(_reg); +define constant Get_reg_efa(_reg); lvars _reg; (_REG, _reg, false); enddefine; @@ -444,7 +623,7 @@ ;;; Get_regindir_efa: ;;; the effective address of a register-indirect operand -define lconstant Get_regindir_efa(_reg, _disp); +define constant Get_regindir_efa(_reg, _disp); lvars _reg, _disp; if _zero(_disp) and _reg /== _EBP then _DISP0 @@ -462,7 +641,7 @@ ;;; intermediate load; if -defer- is , the result is an ordinary ;;; register-indirect efa. -define lconstant Get_regdindir_efa(_reg, _disp, defer, _tmp_reg); +define constant Get_regdindir_efa(_reg, _disp, defer, _tmp_reg); lvars _reg, _disp, defer, _tmp_reg; if defer then ;;; movl [disp](%reg), %tmp_reg @@ -480,7 +659,7 @@ ;;; _tmp_reg is a register to use if a dereference requires an extra ;;; load. -define lconstant Get_structure_efa(_arg, defer, _tmp_reg); +define constant Get_structure_efa(_arg, defer, _tmp_reg); lvars structure, defer, _arg, _tmp_reg, _reg; asm_instr!INST_ARGS[_arg] -> structure; if iscompound(structure) and structure >=@(w) _system_end then @@ -517,21 +696,21 @@ ;;; Effective addresses for user-stack operands: -define lconstant Get_upush_efa(); - --@@(w){_USP_offset} -> _USP_offset; +define constant Get_upush_efa(); + --@@(l){_USP_offset} -> _USP_offset; Get_regindir_efa(_USP, _USP_offset); enddefine; -define lconstant Get_upop_efa(); +define constant Get_upop_efa(); Get_regindir_efa(_USP, _USP_offset); - @@(w){_USP_offset}++ -> _USP_offset; + @@(l){_USP_offset}++ -> _USP_offset; enddefine; -define lconstant Get_utop_efa(); +define constant Get_utop_efa(); Get_regindir_efa(_USP, _USP_offset); enddefine; -define lconstant Get_usubscr_efa(_i); +define constant Get_usubscr_efa(_i); lvars _i; Get_regindir_efa(_USP, _USP_offset _add @@(w)[_i]); enddefine; @@ -540,7 +719,7 @@ ;;; adjust the userstack pointer to account for any accumulated static ;;; offset. -define lconstant flush_USP_offset(); +define constant flush_USP_offset(); unless _zero(_USP_offset) then ;;; leal [_USP_offset](%USP), %USP Drop_std(_LEA, _USP, Get_utop_efa()); @@ -559,7 +738,7 @@ ;;; If there's no explicit destination, a push on the user stack is ;;; assumed. -define lconstant Get_dst_efa(); +define constant Get_dst_efa(); if asm_instr!V_LENGTH == _2 then ;;; destination is a stack push Get_upush_efa() @@ -571,8 +750,10 @@ ;;; Drop_move: ;;; plant a move from a general source to a general destination. -define lconstant Drop_move(_src_mod, _src_rm, _src_disp, _dst_mod, _dst_rm, _dst_disp); +define constant Drop_move(_src_mod, _src_rm, _src_disp, _dst_mod, _dst_rm, _dst_disp); lvars _src_mod, _src_rm, _src_disp, _dst_mod, _dst_rm, _dst_disp; +;;; _extern printf('Drop_move\n') -> _ ; +;;; _extern fflush(_0) -> _ ; if _src_mod == _IMM then Drop_move_imm(_src_disp, _dst_mod, _dst_rm, _dst_disp); elseif _src_mod == _REG then @@ -660,16 +841,20 @@ t_SGN_BYTE = t_BYTE || t_SIGNED, t_SGN_SHORT = t_SHORT || t_SIGNED, + t_SGN_INT = t_INT || t_SIGNED, t_SGN_WORD = t_WORD || t_SIGNED, ;;; Opcodes for accessing fields field_access_ops = list_assoc_val(% [% - t_BYTE, [% _pint(_MOVX), _pint(_MOVZX _biclear _WBIT) %], - t_SHORT, [% _pint(_MOVX), _pint(_MOVZX) %], - t_WORD, [% _pint(_MOV_IN) %], - t_SGN_BYTE, [% _pint(_MOVX), _pint(_MOVSX _biclear _WBIT) %], - t_SGN_SHORT, [% _pint(_MOVX), _pint(_MOVSX) %], + t_BYTE, [% _pint(_MOVX), _pint(_MOVZX _biclear _WBIT) %], + t_SHORT, [% _pint(_MOVX), _pint(_MOVZX) %], + t_INT, [% _pint(_MOVZXD) %], + t_WORD, [% _pint(_MOV_IN) %], + t_SGN_BYTE, [% _pint(_REX_W), _pint(_MOVX), + _pint(_MOVSX _biclear _WBIT) %], + t_SGN_SHORT, [% _pint(_REX_W), _pint(_MOVX), _pint(_MOVSX) %], + t_SGN_INT, [% _pint(_MOVSXD) %], t_SGN_WORD, [% _pint(_MOV_IN) %], %] %), @@ -677,10 +862,12 @@ field_update_ops = list_assoc_val(% [% t_BYTE, [% _pint(_MOV _biclear _WBIT) %], - t_SHORT, [% _pint(_WORD), _pint(_MOV) %], + t_SHORT, [% _pint(_WORD), _pint(_MOV32) %], + t_INT, [% _pint(_MOV32) %], t_WORD, [% _pint(_MOV) %], t_SGN_BYTE, [% _pint(_MOV _biclear _WBIT) %], - t_SGN_SHORT, [% _pint(_WORD), _pint(_MOV) %], + t_SGN_SHORT, [% _pint(_WORD), _pint(_MOV32) %], + t_SGN_INT, [% _pint(_MOV32) %], t_SGN_WORD, [% _pint(_MOV) %], %] %), @@ -693,11 +880,13 @@ field_size = list_assoc_val(% [% t_BYTE, 1, t_SHORT, 2, - t_WORD, 4, + t_INT, 4, + t_WORD, 8, t_DOUBLE, 8, t_SGN_BYTE, 1, t_SGN_SHORT, 2, - t_SGN_WORD, 4, + t_SGN_INT, 4, + t_SGN_WORD, 8, %] %), ;;; Index-scale codes for the possible field sizes @@ -715,7 +904,7 @@ ;;; given a list of opcode bytes, plant all the prefix bytes and ;;; return the opcode proper. -define lconstant Drop_pfx(opcodes); +define constant Drop_pfx(opcodes); lvars opcodes; until (fast_destpair(opcodes) ->> opcodes) == [] do Drop_b(_int(/* prefix */)); @@ -727,7 +916,7 @@ ;;; checks that -structure- refers to a direct, on-stack lvar ;;; and returns the appropriate offset as a sysint -define lconstant stack_offset(/* structure */) with_nargs 1; +define constant stack_offset(/* structure */) with_nargs 1; lvars structure; if isinteger(Trans_structure(/* structure */) ->> structure) and structure fi_< 0 @@ -743,7 +932,7 @@ ;;; convert a vector index to an offset, i.e. convert to system integer ;;; and multiply by field size -define lconstant Drop_vecsub_mult(_reg, _size); +define constant Drop_vecsub_mult(_reg, _size); lvars _reg, _size; ;;; sarl $2, %reg Drop_std(_SHIFTI, _SAR, (_REG, _reg, false)), Drop_b(_2); @@ -756,14 +945,14 @@ ;;; Drop_exptr_deref: ;;; deref an external pointer -n- times -define lconstant Drop_exptr_deref(exptr, _reg); +define constant Drop_exptr_deref(exptr, _reg); lvars exptr, _reg; fast_repeat exptr times Drop_std(_MOV_IN, _reg, Get_regindir_efa(_reg, _0)) endrepeat enddefine; -define lconstant Do_bitfield(type, _size, structure, offset, upd, exptr); +define constant Do_bitfield(type, _size, structure, offset, upd, exptr); lvars type, structure, offset, upd, exptr, _size, _disp; ;;; Get structure address in EDI if not(structure) then @@ -812,10 +1001,13 @@ Drop_call_indir((_REG, _ESI, false)); enddefine; -define lconstant Do_field(type, structure, _size, offset, defer, upd, exptr); +define constant Do_field(type, structure, _size, offset, defer, upd, exptr); lvars ops, type, structure, offset, defer, upd, exptr, _size, _reg, _disp, _n; +;;; _extern printf('Do_field\n') -> _; +;;; _extern fflush(_0) -> _; + ;;; Get appropriate opcode bytes for type and direction of move if upd then field_update_ops(type) @@ -835,7 +1027,7 @@ ;;; structure is in a stack lvar (from -conskey-) Drop_std(_MOV_IN, _reg, Get_regindir_efa(_SP, _disp)); else - mishap(0, 'SYSTEM ERROR 1 IN Do_field'); + mishap(structure, 1, 'SYSTEM ERROR 1 IN Do_field'); endif; ;;; If it's an external structure, get the real address if exptr then @@ -860,11 +1052,13 @@ ;;; index is in a stack lvar (from -conskey-) Drop_std(_MOV_IN, _ECX, Get_regindir_efa(_SP, _disp)); else - mishap(0, 'SYSTEM ERROR 2 IN Do_field'); + mishap(offset, 1, 'SYSTEM ERROR 2 IN Do_field'); endif; ;;; If updating, load new value from stack to EAX if upd then Drop_std(_MOV_IN, _EAX, Get_upop_efa()) endif; ;;; Get the size in bytes of this field type +;;; printf( type, 'type = %p\n'); +;;; _extern fflush(_0) -> _; field_size(type) -> _n; if _size == 1 then ;;; Compute a displacement to be added to the index which accounts @@ -940,7 +1134,7 @@ ;;; instruction. It could be a MOVE instruction (representing a push ;;; not yet done) or if the item is already on the stack. -define lconstant Get_fsrc_efa(_arg, _tmp_reg); +define constant Get_fsrc_efa(_arg, _tmp_reg); lvars op, _arg, _tmp_reg; dlocal asm_instr; if asm_instr!INST_ARGS[_arg] ->> asm_instr then @@ -964,7 +1158,7 @@ ;;; This should be a push on the user stack, but it can be optimised ;;; away if there's an immediately-following POP instruction. -define lconstant Get_fdst_efa(); +define constant Get_fdst_efa(); lvars instr; dlocal asm_instr; ;;; Look out for a following POP instruction @@ -984,7 +1178,7 @@ ;;; Drop_fsrc: ;;; move an operand of a "fast_" procedure to a register. -define lconstant Drop_fsrc(_arg, _reg); +define constant Drop_fsrc(_arg, _reg); lvars _arg, _reg; Drop_move(Get_fsrc_efa(_arg, _ESI), (_REG, _reg, false)); enddefine; @@ -994,6 +1188,8 @@ define I_FASTFIELD(); lvars _offs; +;;; _extern printf('I_FASTFIELD\n') -> _; +;;; _extern fflush(_0) -> _; Drop_fsrc(_1, _ESI); if asm_instr!INST_ARGS[_0] ->> _offs then _int(_offs) -> _offs; @@ -1002,6 +1198,7 @@ Drop_move(Get_regindir_efa(_ESI, @@P_FRONT), Get_upush_efa()); @@P_BACK -> _offs; endif; +;;; Get_regindir_efa(_ESI, _offs) -> _reg, -> _disp; Drop_move(Get_regindir_efa(_ESI, _offs), Get_fdst_efa()); enddefine; @@ -1012,19 +1209,21 @@ define I_FASTSUBV(); lvars _mod, _rm, _disp, _offs; +;;; _extern printf('I_FASTSUBV\n') -> _; +;;; _extern fflush(_0) -> _; ;;; Structure in ESI Drop_fsrc(_1, _ESI); ;;; Popint index from stack to ECX Drop_std(_MOV_IN, _ECX, Get_upop_efa()); ;;; Arg 0 is offset to first vector element (as popint) ;;; -- subtract popint 1 to account for base 1 subscript and popint bits - _int(asm_instr!INST_ARGS[_0]) _sub 1 -> _offs; + _int(asm_instr!INST_ARGS[_0]) _sub _14 -> _offs; if (Get_fdst_efa() -> _disp -> _rm ->> _mod) == _REG then ;;; movl [offs](%esi, %ecx), %rm - Drop_extd(_MOV_IN, _rm, Get_regindir_efa(_ESI, _offs), _ECX, _s1); + Drop_extd(_MOV_IN, _rm, Get_regindir_efa(_ESI, _offs), _ECX, _s2); else ;;; movl [offs](%esi, %ecx), %eax - Drop_extd(_MOV_IN, _EAX, Get_regindir_efa(_ESI, _offs), _ECX, _s1); + Drop_extd(_MOV_IN, _EAX, Get_regindir_efa(_ESI, _offs), _ECX, _s2); ;;; movl %eax, dst Drop_std(_MOV, _EAX, (_mod, _rm, _disp)); endif; @@ -1038,11 +1237,11 @@ Drop_std(_MOV_IN, _ECX, Get_upop_efa()); ;;; Arg 0 is offset to first vector element (as popint) ;;; -- subtract popint 1 to account for base 1 subscript and popint bits - _int(asm_instr!INST_ARGS[_0]) _sub 1 -> _offs; + _int(asm_instr!INST_ARGS[_0]) _sub _14 -> _offs; ;;; New value from stack to EAX Drop_std(_MOV_IN, _EAX, Get_upop_efa()); ;;; movl %eax, [offs](%edi, %ecx) - Drop_extd(_MOV, _EAX, Get_regindir_efa(_EDI, _offs), _ECX, _s1); + Drop_extd(_MOV, _EAX, Get_regindir_efa(_EDI, _offs), _ECX, _s2); enddefine; @@ -1112,7 +1311,7 @@ ;;; output an indirect jump: the target is the absolute address at the ;;; given effective address -define lconstant Drop_jmp_indir(_mod, _rm, _disp); +define constant Drop_jmp_indir(_mod, _rm, _disp); lvars _mod, _rm, _disp; flush_USP_offset(); Drop_std(_BR_IND, _CHAIN, (_mod, _rm, _disp)); @@ -1125,7 +1324,7 @@ ;;; This always plants a long (5-byte) instruction; there's no attempt ;;; to optimise short jumps. -define lconstant Drop_jmp_rel(/* _offs */) with_nargs 1; +define constant Drop_jmp_rel(/* _offs */) with_nargs 1; flush_USP_offset(); Drop_b(_JMP); Drop_l((/* _offs */ _sub _asm_code_offset) _sub _4); @@ -1134,7 +1333,7 @@ ;;; Drop_jcc: ;;; output a conditional jump. The offset argument is as above. -define lconstant Drop_jcc(_cc, _offs); +define constant Drop_jcc(_cc, _offs); lvars _cc, _offs; flush_USP_offset(); Drop_b(_Jcc); @@ -1157,7 +1356,8 @@ define I_BR_std(_broffset, _arg); lvars _broffset, _arg; Drop_jmp_rel(_broffset); - Drop_b(_NOP), Drop_b(_NOP); ;;; ** Extra 2 bytes to match M-code version + ;;; ** Extra 4 bytes to match M-code version + Drop_b(_NOP), Drop_b(_NOP), Drop_b(_NOP), Drop_b(_NOP); enddefine; ;;; I_BR: @@ -1181,7 +1381,7 @@ ;;; instruction (I_IF_opt or I_BOOL_opt). Currently, this will ;;; always be I_BRCOND. -define lconstant Drop_if(/* _ifso, _ifnot, */ instr) with_nargs 3; +define constant Drop_if(/* _ifso, _ifnot, */ instr) with_nargs 3; lvars instr; fast_apply(/* _ifso, _ifnot, */ instr!INST_ARGS[_1], ;;; flag selecting appropriate condition @@ -1318,23 +1518,26 @@ ;;; of the jump offset table: the _17 is the length of the four ;;; instructions between here and the first entry in the table, ;;; the _4 accounts for the extra (0) entry in the table. - _asm_code_offset _add _17 _add _int(_ncases * 4) _add _4 -> _tabend; + _asm_code_offset _add _19 _add _int(_ncases * 4) _add _4 -> _tabend; ;;; If the argument was out of range, jump to after the table ;;; The unsigned condition accounts for both arg < 0 and arg > ncases Drop_jcc(_cc_A, _tabend); ;;; 6 bytes ;;; Use the argument in EAX as an index into the jump offset table - ;;; and load the corrseponding offset value into ECX - ;;; The _11 is the length of the three instructions up to the table start + ;;; and load the corresponding offset value into ECX + ;;; The _13 is the length of the three instructions up to the table start ;;; and the _3 converts EAX into a sysint number of bytes. ;;; movl [offs](%PB, %eax), %ecx - @@PD_TABLE{_strsize _add _asm_code_offset _add _11 _sub _3} -> _offs; - Drop_extd(_MOV_IN, _ECX, (_DISP32, _PB, _offs), _EAX, _s1); ;;; 7 bytes + @@PD_TABLE{_strsize _add _asm_code_offset _add _13 _sub _3} -> _offs; + if is_large_int(_offs) then + mishap(0, 'I_SWITCH: OFFSET TOO BIG FOR 32-BITS'); + endif; + Drop_extd(_MOVSXD, _ECX, (_DISP32, _PB, _offs), _EAX, _s1); ;;; 8 bytes ;;; Add PB to ECX to get an absolute address ;;; addl %PB, %ecx - Drop_std(_ADD, _PB, (_REG, _ECX, false)); ;;; 2 bytes + Drop_std(_ADD, _PB, (_REG, _ECX, false)); ;;; 3 bytes ;;; Go to it ;;; jmp *(%ecx) @@ -1396,7 +1599,7 @@ /* Procedure Calls */ -define lconstant Drop_call(on_stack, defer, _routine); +define constant Drop_call(on_stack, defer, _routine); lvars on_stack, defer, _routine; ;;; Get procedure in ARG_REG_0: if on_stack then @@ -1499,13 +1702,24 @@ /* Procedure Entry and Exit */ define I_CREATE_SF(); - lvars _offs; + lvars _offs, _num; ;;; Set the procedure base register. ;;; If all is well, the procedure address should be in ARG_REG_0. ;;; movl %ARG_REG_0, %PB Drop_std(_MOV, _ARG_REG_0, (_REG, _PB, false)); + ;;; save registers + unless _zero(_regmask) then + _8 -> _num; + until _num == _16 do + if _regmask _bitst _shift(_1, _num) then + Drop_short(_PUSHs, _num); + endif; + _num _add _1 -> _num; + enduntil; + endunless; + ;;; Save dynamic locals @@PD_TABLE -> _offs; fast_repeat _pint(_Nlocals) times @@ -1535,7 +1749,7 @@ define I_UNWIND_SF(); - lvars _offs; + lvars _offs, _num; ;;; Remove owner address and on-stack lvars Drop_imm(_ARITHI, _ADDI, @@(w)[_Nstkvars _add _1], (_REG, _SP, false)); @@ -1550,10 +1764,21 @@ Drop_std(_POP, _0, _DISP0, _EAX, _0); endrepeat; + ;;; restore registers + unless _zero(_regmask) then + _15 -> _num; + until _num == _7 do + if _regmask _bitst _shift(_1, _num) then + Drop_std(_POP, _0, _REG, _num, false); + endif; + _num _sub _1 -> _num; + enduntil; + endunless; + ;;; Restore procedure base register by reaching over return address ;;; to get the previous stack-frame owner: ;;; movl [4](%SP), %PB - Drop_std(_MOV_IN, _PB, _DISP8, _SP, _4); + Drop_std(_MOV_IN, _PB, _DISP8, _SP, _8); enddefine; @@ -1573,9 +1798,14 @@ Drop_move((_ABS, _reg_ABS, ident _userhi), (_REG, _EAX, false)); ;;; subl %USP, %eax Drop_std(_SUB, _USP, (_REG, _EAX, false)); - ;;; Add in the popint bits and adjust for the stack offset - ;;; addl $[3 - USP_offset], %eax - Drop_imm(_ARITHI, _ADDI, _3 _sub _USP_offset, (_REG, _EAX, false)); + ;;; Adjust for the stack offset +;;; Drop_imm(_ARITHI, _SUBI, _USP_offset, (_REG, _EAX, false)); + ;;; Adjust for the word size + Drop_std(_SHIFTI, _SAR, (_REG, _EAX, false)), Drop_b(_1); + ;;; Add in the popint bits and adjust for the stack offset + ;;; addl $[3 - _USP_offset>>1], %eax + Drop_imm(_ARITHI, _ADDI, _3 _sub _shift(_USP_offset, -1), + (_REG, _EAX, false)); ;;; Push EAX Drop_std(_MOV, _EAX, Get_upush_efa()); enddefine; @@ -1598,6 +1828,9 @@ ;;; Add -nresults- to saved stacklength in EAX; the _-6 accounts for ;;; the popint bits in the stacklength and nresults Drop_imm(_ARITHI, _ADDI, _nresults _sub _6, (_REG, _EAX, false)); + ;;; Adjust for the word size + Drop_std(_SHIFTI, _SAL, (_REG, _EAX, false)), Drop_b(_1); + ;;; movl _userhi, %ecx Drop_std(_MOV_IN, _ECX, (_ABS, _reg_ABS, ident _userhi)); ;;; subl %eax, %ecx @@ -1674,16 +1907,27 @@ ;;; input define Do_consprocedure(codelist, reg_locals) -> pdr; - lvars codelist, reg_locals, pdr, _code_offset, _size, _reg_spec; - dlocal _asm_drop_ptr, _asm_pass, _strsize; - + lvars codelist, reg_locals, pdr, _code_offset, _size, _reg_spec; + lvars reg, _buff, _cnt; + dlocal _regmask, _asm_drop_ptr, _asm_pass, _strsize; +/* ;;; Check there are no register locals and set _reg_spec to 0 +;;; _extern printf('Do_consprocedure, Pass 1\n'); +;;; _extern fflush (_0); unless null(reg_locals) then mishap(reg_locals, 1, 'UNEXPECTED REGISTER LOCALS'); endunless; +*/ _0 -> _reg_spec; + ;;; construct reg mask from reg_locals + _0 -> _regmask; + for reg in reg_locals do + _shift(_1, _int(Is_register(reg))) _biset _regmask -> _regmask + endfor; + + ;;; Pass 1 -- calculate instruction offsets _0 ->> _USP_offset -> _strsize; Code_pass(0, codelist) -> _code_offset; @@ -1707,8 +1951,22 @@ @@PD_TABLE{_strsize _add _code_offset | b.r} _sub @@POPBASE -> _size; Get_procedure(_size, _reg_spec) -> pdr; + _asm_drop_ptr -> _buff; ;;; Final pass -- plants the code Code_pass(false, codelist) -> ; + _asm_drop_ptr _sub _buff -> _cnt; +;;; +;;; Helper to show location of planted code (allow disassembling). +;;; +;;; _extern printf('writing %ld bytes at 0x%lx for 0x%lx\n', +;;; _cnt, _buff, pdr) -> _ ; +;;; _extern fflush(_0) -> _ ; +;;; +;;; Extra help: dump generated code to a file. +;;; +;;; _extern write(_7, _buff, _cnt) -> _ ; +;;; _extern printf('wrote bytes\n') -> _ ; +;;; _extern fflush(_0) -> _ ; enddefine; endsection; /* $-Sys$-Vm */ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/closure_cons.p v15.6301-amd64/pop/src/closure_cons.p --- v15.63/pop/src/closure_cons.p 1992-09-23 18:05:03.000000000 -0400 +++ v15.6301-amd64/pop/src/closure_cons.p 2005-03-11 05:30:39.000000000 -0500 @@ -17,7 +17,8 @@ ;;; Macros for dropping code at -drop_ptr- lconstant macro ( - LONG = [_drop_ptr!(l)++ -> _drop_ptr], + QUAD = [_drop_ptr!(l)++ -> _drop_ptr], + LONG = [_drop_ptr!(i)++ -> _drop_ptr], SHORT = [_drop_ptr!(s)++ -> _drop_ptr], BYTE = [_drop_ptr!(b)++ -> _drop_ptr], ); @@ -31,11 +32,11 @@ ;;; Compute size of closure code if _zero(_nfroz) then - _5 + _6 elseif _nfroz _gr _16 then - _12 + _19 else - _nfroz _mult _6 _add _8 + _nfroz _mult _8 _add _10 endif -> _size; ##(w)[_size | b.r] -> _size; @@ -54,37 +55,46 @@ ;;; On entry, closure address should be in ARG_REG_0 (EAX) if _nfroz _gr _16 then ;;; Call via -Exec_closure- - ;;; subl $4, %USP - _16:EB83 -> SHORT, _4 -> BYTE; ;;; 3 bytes - ;;; movl %eax, (%USP) - _16:0389 -> SHORT; ;;; 2 bytes + ;;; subq $8, %USP + _16:48 -> BYTE, + _16:EB83 -> SHORT, _8 -> BYTE; ;;; 4 bytes + ;;; movq %eax, (%USP) + _16:48 -> BYTE, + _16:0389 -> SHORT; ;;; 3 bytes ;;; movl $[Exec_closure!PD_EXECUTE], %eax - _16:B8 -> BYTE, Exec_closure!PD_EXECUTE -> LONG; ;;; 5 bytes + _16:48 -> BYTE, + _16:B8 -> BYTE, + Exec_closure!PD_EXECUTE -> QUAD; ;;; 10 bytes ;;; jmp *%eax _16:E0FF -> SHORT; ;;; 2 bytes else ;;; Push the frozen arguments and chain the pdpart _0 -> _offs; until _zero(_nfroz) do - ;;; movl [@@PD_CLOS_FROZVALS{_offs}](%eax), %ecx + ;;; movq [@@PD_CLOS_FROZVALS{_offs}](%rax), %rcx ;;; (the offset should be byte-sized) - _16:488B -> SHORT, @@PD_CLOS_FROZVALS{_offs} -> BYTE; ;;; 3 bytes + _16:48 -> BYTE, + _16:488B -> SHORT, @@PD_CLOS_FROZVALS{_offs} -> BYTE; + ;;; 4 bytes @@(w){_offs}++ -> _offs; - ;;; movl %ecx, [-offs](%USP) - _16:4B89 -> SHORT, _negate(_offs) -> BYTE; ;;; 3 bytes + ;;; movq %rcx, [-offs](%USP) + _16:48 -> BYTE, + _16:4B89 -> SHORT, _negate(_offs) -> BYTE; ;;; 4 bytes _nfroz _sub _1 -> _nfroz; enduntil; if _nonzero(_offs) then ;;; adjust the userstack pointer - ;;; subl $[offs], %USP - _16:EB83 -> SHORT, _offs -> BYTE; ;;; 3 bytes + ;;; subq $[offs], %USP + _16:48 -> BYTE, + _16:EB83 -> SHORT, _offs -> BYTE; ;;; 4 bytes endif; ;;; now get PD_CLOS_PDPART address in ARG_REG_0 ;;; movl [@@PD_CLOS_PDPART](%eax), %eax - _16:408B -> SHORT, @@PD_CLOS_PDPART -> BYTE; ;;; 3 bytes + _16:48 -> BYTE, + _16:408B -> SHORT, @@PD_CLOS_PDPART -> BYTE; ;;; 4 bytes ;;; and jump straight to its execute address ;;; (assuming @@PD_EXECUTE == 0) - ;;; jmp *(%eax) + ;;; jmp *(%rax) _16:20FF -> SHORT; ;;; 2 bytes endif; enddefine; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/control.p v15.6301-amd64/pop/src/control.p --- v15.63/pop/src/control.p 1998-04-30 10:23:51.000000000 -0400 +++ v15.6301-amd64/pop/src/control.p 2005-03-11 05:30:39.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 1991. All rights reserved. ---------- +/* --- Copyright University of Sussex 1999. All rights reserved. ---------- > File: C.all/src/control.p > Purpose: Control procedures > Author: John Gibson (see revisions) @@ -266,10 +266,27 @@ enddefine; define Set_call_stack_lim(); - lvars _safe = _sp()@(csword)-[Nframe_cslen(_2:1e7)], + lvars _tmp, _safe = _sp()@(csword)-[Nframe_cslen(_2:1e7)], _plim = _call_stack_hi@(csword)-[_pop_callstack_lim]; + ;;; if _pop_callstack_lim is large, the offset calculation can wrap + ;;; round + if _plim >@(csword) _call_stack_hi then + ;;; choose some arbitrary limit close to the appropriate end of + ;;; memory + _0@(csword)[_1|vpage] -> _plim; + endif; +;;; _extern +;;; printf('Set_call_stack_lim, _plim = %ld\n _pop_callstack_lim = %ld\n', +;;; _plim, _pop_callstack_lim) -> _; +;;; _extern fflush(_0) -> _; if _safe <@(csword) _plim then _safe -> _plim endif; - Trim_callstack_lim(_plim, false) -> _call_stack_lim +;;; Trim_callstack_lim(_plim, false) -> _call_stack_lim; + Trim_callstack_lim(_plim, false) -> _tmp; +;;; _extern +;;; printf('Set_call_stack_lim, _plim = %ld\n _callstack_lim = %ld\n', +;;; _plim, _tmp) -> _; +;;; _extern fflush(_0) -> _; + _tmp -> _call_stack_lim; enddefine; /* Move the callstack area from _sp() to _limaddr up by _nwords @@ -300,6 +317,10 @@ /* --- Revision History --------------------------------------------------- +--- Robert Duncan, Jul 29 1999 + Added a check in Set_call_stack_lim that calculation of the limit + doesn't wrap round. This can happen if the stack grows down in low + memory or up in high memory. --- John Gibson, Jan 3 1991 Made -Callstack_reset- check more stack frames --- John Gibson, Nov 15 1990 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/declare.ph v15.6301-amd64/pop/src/declare.ph --- v15.63/pop/src/declare.ph 2003-11-01 16:15:27.000000000 -0500 +++ v15.6301-amd64/pop/src/declare.ph 2009-12-30 21:24:12.000000000 -0500 @@ -20,7 +20,8 @@ ;;; system variables weak vars _disable, _trap, _system_end, _userlim, _userhi, - _call_stack_hi, _call_stack_seg_hi, _plog_save_contn_sp + _call_stack_hi, _call_stack_seg_hi, _plog_save_contn_sp, + _user_base ; @@ -40,6 +41,8 @@ undef_key, prologvar_key, prologterm_key, intvec_key, shortvec_key, stackmark_key, external_ptr_key, exptr_mem_key, + bytevec_key, sbytevec_key, ushortvec_key, + uintvec_key, ulongvec_key, longvec_key, ; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/devio.p v15.6301-amd64/pop/src/devio.p --- v15.63/pop/src/devio.p 1999-03-19 19:36:14.000000000 -0500 +++ v15.6301-amd64/pop/src/devio.p 2005-03-11 05:30:39.000000000 -0500 @@ -146,13 +146,15 @@ lvars _fd; #_IF DEF USE_TERMIOS lstackmem struct TERMIOS _termios; - _nonneg(_extern tcgetattr(_fd, _termios)); + _extern tcgetattr(_fd, _termios) _lteq _2147483647; #_ELSEIF DEF USE_TERMIO lstackmem struct TERMIO _termio; - _nonneg(_extern[NI] ioctl(_fd, _TGETPARM, _termio)) +check this ; + _extern[NI] ioctl(_fd, _TGETPARM, _termio) _lteq _2147483647; #_ELSE lstackmem struct SGTTYB _sgttyb; - _nonneg(_extern[NI] ioctl(_fd, _TGETPARM, _sgttyb)) +check this ; + _extern[NI] ioctl(_fd, _TGETPARM, _sgttyb) _lteq _2147483647; #_ENDIF enddefine; @@ -219,7 +221,7 @@ define Fix_dev_params(dev, _writing) -> devparams; lvars tcb = dev!D_CTRL_BLK, unit, devparams, ttyparams, dev, _fd = dev!D_FILE_DESC, _writing; - +#_IF true #_IF DEF SIG_TTOU ;;; see if we are backgrounded (NB: we do this on all terminals, ;;; not just the controlling one - its easier and even non-controlling @@ -242,7 +244,7 @@ endprocedure() endunless; #_ENDIF - +#_ENDIF ;;; now in foreground -- test whether tty init params need (re)setting dev!D_UNIT_P -> unit; unit!UNT_INIT_TTPARAMS -> ttyparams; @@ -1141,9 +1143,9 @@ exitto( (unit, dev!D_UNIT_P), Set_dev_unit) endif enddefine; - - while _neg(_extern fstat(newdev!D_FILE_DESC, _statb)) - and _ERRNO == _:EINTR do + while (_extern fstat(newdev!D_FILE_DESC, _statb) + _gr _2147483647 + and _ERRNO == _:EINTR) do _CHECKINTERRUPT endwhile; DEV_T_TO_VARS(_statb, ST_DEV, _udev, _udev2); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/discin.p v15.6301-amd64/pop/src/discin.p --- v15.63/pop/src/discin.p 1996-03-15 11:17:41.000000000 -0500 +++ v15.6301-amd64/pop/src/discin.p 2005-03-11 05:30:39.000000000 -0500 @@ -23,6 +23,8 @@ define discin(file) -> file; lvars file, dev; +;;; _extern printf('entering discin(%p)\n', file) -> _ ; +;;; _extern fflush(_0) -> _ ; if isdevice(file) then file -> dev; Check_device(dev, true) ;;; checks it open @@ -32,6 +34,8 @@ endif; sysopen(file, 0, false, `N`) -> dev endif; +;;; _extern printf('discin(%p)\n', file) -> _ ; +;;; _extern fflush(_0) -> _ ; Consclos_protect(Io$-Get_char, dev, 1) -> file; device_full_name(dev) -> pdprops(file) enddefine; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/errors.p v15.6301-amd64/pop/src/errors.p --- v15.63/pop/src/errors.p 2004-12-31 07:02:13.000000000 -0500 +++ v15.6301-amd64/pop/src/errors.p 2005-03-11 05:30:39.000000000 -0500 @@ -112,6 +112,8 @@ define Exec_nonpd(item) with_props '(Sys$-Exec_nonpd)'; lvars item; +;;; _extern printf('Exec_nonpd %p\n', item) -> _; +;;; _extern fflush(_0) -> _; mishap(item, 1, 'enp: EXECUTING NON-PROCEDURE') enddefine; ;;; @@ -466,6 +468,8 @@ pop_message_min_detail -> detail endif; + 5 -> detail; + if not(_memory_is_corrupt) and severity /== `I` and testdef vedusewindows and weakref vedusewindows then weakref[vedusewindows] wved_mishap_reset() @@ -509,8 +513,9 @@ endif; /* PRINT DOING */ - if detail fi_>= 5 - and (not(pop_mishap_doing_lim) or pop_mishap_doing_lim fi_> 0) then + printf('PRINT DOING\n'); + if true /* detail fi_>= 5 + and (not(pop_mishap_doing_lim) or pop_mishap_doing_lim fi_> 0) */ then raise_exception_idstring -> re_idstring; false -> first; 0 ->> count -> _nprinted; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/extern_symbols.p v15.6301-amd64/pop/src/extern_symbols.p --- v15.63/pop/src/extern_symbols.p 2004-12-23 10:42:29.000000000 -0500 +++ v15.6301-amd64/pop/src/extern_symbols.p 2005-03-11 05:30:39.000000000 -0500 @@ -53,11 +53,8 @@ lconstant macro DLOPEN_FLAGS = 16:005; ;;; RTLD_LAZY|RTLD_GLOBAL #_ELSEIF DEF NCR lconstant macro DLOPEN_FLAGS = 16:003; ;;; RTLD_LAZY_GLOBAL -#_ELSEIF DEF OSF1 -;;; Should this be like linux and solaris?? A.S. 23 Dec 2004 +#_ELSEIF DEF OSF1 or DEF LINUX_ELF lconstant macro DLOPEN_FLAGS = 16:001; ;;; RTLD_LAZY -#_ELSEIF DEF LINUX_ELF -lconstant macro DLOPEN_FLAGS = 16:101; ;;; RTLD_LAZY|RTLD_GLOBAL #_ELSEIF DEFV IRIX >= 5.0 lconstant macro DLOPEN_FLAGS = 16:001; ;;; RTLD_LAZY #_ENDIF @@ -280,11 +277,6 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, 23 Dec 2004 - With help from Jeff Best. Changed - DLOPEN_FLAGS = 16:101; ;;; RTLD_LAZY|RTLD_GLOBAL - for linux as for SunOS, in accordance with comments in - /usr/include/bits/dlfcn.h --- Robert Duncan, Nov 27 1998 Fixed Shlib_findsym to use the proper flags value when calling dlopen() diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/fields.p v15.6301-amd64/pop/src/fields.p --- v15.63/pop/src/fields.p 2005-01-06 10:13:58.000000000 -0500 +++ v15.6301-amd64/pop/src/fields.p 2009-12-30 21:15:11.000000000 -0500 @@ -282,7 +282,7 @@ round_mult(bitoffs, bitalign) -> bitoffs elseif isinteger(spec) and spec /== 0 - and #_< -INT_BITS >_# fi_<= spec and spec fi_<= INT_BITS then + and #_< -WORD_BITS >_# fi_<= spec and spec fi_<= WORD_BITS then if spec fi_< 0 then 0 fi_- spec else spec endif -> bitsize; t_BIT -> type diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/gcmain.p v15.6301-amd64/pop/src/gcmain.p --- v15.63/pop/src/gcmain.p 1998-06-02 09:14:32.000000000 -0400 +++ v15.6301-amd64/pop/src/gcmain.p 2005-03-11 05:30:39.000000000 -0500 @@ -457,6 +457,8 @@ ;;; structure follows it _rec@(struct POPREC1)++ -> _rec else +;;; _extern printf('_rec!V_LENGTH = 0x%lx\n', _rec!V_LENGTH) -> _ ; +;;; _extern fflush(_0) -> _ ; ;;; V_LENGTH is a byte length -- get to next word after ;;; end of this struct _rec@V_WORDS[_rec!V_LENGTH | b.r]@~POPBASE -> _rec; @@ -464,6 +466,8 @@ ;;; next object module) repeat if _rec >=@(w) _lim then + _extern printf('RUN OFF at 0x%lx, _rec = 0x%lx\n', _lim, _rec) -> _ ; + _extern fflush(_0) -> _ ; mishap(0, 'App_struct_area: RUN OFF END OF AREA') endif; quitif(_rec!KEY == objmod_pad_key); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/getstore.p v15.6301-amd64/pop/src/getstore.p --- v15.63/pop/src/getstore.p 2003-11-01 16:21:25.000000000 -0500 +++ v15.6301-amd64/pop/src/getstore.p 2005-03-13 05:16:19.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2003. All rights reserved. ---------- +/* --- Copyright University of Sussex 2005. All rights reserved. ---------- > File: C.all/src/getstore.p > Purpose: > Author: John Gibson (see revisions) @@ -1024,11 +1024,17 @@ ;;; define updaterof active popmemlim n; lvars n; +;;; lconstant _MAX_MEM_MAX = _int(1<= 0 NEEDED', ':type-integral-nonneg') else - false -> n + if n > #_< 1<_# then + false -> n + else + _pint(Pint_->_uint(n, + #_< _int(1<_#)) -> n + endif endif endif; if n then @@ -1535,6 +1541,9 @@ /* --- Revision History --------------------------------------------------- +--- Aaron Sloman, Mar 13 2005 + Patch to updater of popmemlim provided by Waldek Hebisch + for AMD64 poplog --- Aaron Sloman, 1 Nov 2003 increased default max_mem_lim (popmemlim) from 3e5 tp 15e5 --- John Gibson, Jun 1 1998 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/initial.p v15.6301-amd64/pop/src/initial.p --- v15.63/pop/src/initial.p 2009-06-28 23:11:50.000000000 -0400 +++ v15.6301-amd64/pop/src/initial.p 2010-01-03 07:24:11.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2009. All rights reserved. ---------- +/* --- Copyright University of Sussex 2003. All rights reserved. ---------- > File: C.all/src/initial.p > Purpose: Global initialisation > Author: John Gibson (see revisions) @@ -21,9 +21,9 @@ ;;; Internal version number, for allowing library files etc to ;;; know about new versions. Used as the version number in the string - ;;; popversion. - ;;; (See declaration in declare.ph -- in AIX this is a vars.) - 156300 -> pop_internal_version; + ;;; popversion. + ;;; (See declaration in declare.ph -- in AIX this is a vars.) + 156301 -> pop_internal_version; ;;; Initialise variables @@ -44,10 +44,10 @@ constant - popcopyright = 'Copyright (c) 1982-2009 University of Sussex. All rights reserved.', + popcopyright = 'Copyright (c) 1982-1999 University of Sussex. All rights reserved.', ;;; version number string -- gets concatenated with Sys$-image_date set up - ;;; by "link" to produce pop_version. + ;;; by "link" to produce pop_version. Sys$-image_version = '(Version ' >< pop_internal_version/10000.0, ;;; dummy initialisations @@ -61,7 +61,7 @@ Sys$- _external_flags = _0, Sys$- _in_X_call = _0, - ;;; This is non-zero when in user external calls (set by _call_external), + ;;; This is non-zero when in user external calls (set by _call_external), ;;; and enables asynchronous callback by signals. ;;; It has the value -1 when completely outside of Pop. Sys$- _in_user_extern = _-1, @@ -85,107 +85,84 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, Jun 29 2009 - pop_internal_version = 156300 - To mark conversion of all documentation to remove special - graphics characters. - ---- Aaron Sloman, 2 Dec 2008 - pop_internal_version = 156200 - For changes by Waldek Hebisch to make use of 'setarch' unnecessary - (mainly change in amain.s to invoke linux_setper, defined in - $popexternlib/c_core.c) - ---- Aaron Sloman, Feb 4 2008 - pop_internal_version = 156102 - Only minor changes, including addition of a simple highlighting - extension to ved, and improvements to installation scripts ---- Aaron Sloman, Oct 1 2007 - pop_internal_version = 156101 (various changes, especially unix_dir.p) ---- Aaron Sloman, Apr 11 2007 - pop_internal_version = 156100 (various changes) - ---- Aaron Sloman, Jan 18 2005 - Chnaged version to - pop_internal_version = 156000 (various changes) --- Aaron Sloman, 1 Nov 2003 Added pop_translate_envvars syfileok will translate environment variables if it is true (default) --- John Gibson, Sep 29 1998 - pop_internal_version = 155210 (various changes) + pop_internal_version = 155210 (various changes) --- John Gibson, Dec 2 1997 - pop_internal_version = 155200 (various changes) + pop_internal_version = 155200 (various changes) --- John Gibson, Apr 30 1997 - pop_internal_version = 155101 (various changes) + pop_internal_version = 155101 (various changes) --- John Gibson, Feb 14 1997 - pop_internal_version = 155100 (16-bit chars) + pop_internal_version = 155100 (16-bit chars) --- John Gibson, Oct 17 1996 - pop_internal_version = 155001 (slight change to Popc interface) + pop_internal_version = 155001 (slight change to Popc interface) --- Robert Duncan, Oct 7 1996 - pop_internal_version = 155000 (general release) + pop_internal_version = 155000 (general release) --- John Williams, Sep 6 1996 - pop_internal_version = 154000 (installing in COGS). + pop_internal_version = 154000 (installing in COGS). --- John Gibson, Aug 15 1996 - pop_internal_version = 150301 (external names not translated for Popc) + pop_internal_version = 150301 (external names not translated for Popc) --- John Williams, May 30 1996 - pop_internal_version = 150300 (installing in Cogs) + pop_internal_version = 150300 (installing in Cogs) --- John Gibson, Apr 1 1996 - pop_internal_version = 150220 (slight change to Popc interface) + pop_internal_version = 150220 (slight change to Popc interface) --- John Gibson, Mar 26 1996 - pop_internal_version = 150210 (dlocal allowed at execute level) + pop_internal_version = 150210 (dlocal allowed at execute level) --- John Gibson, Mar 5 1996 - Changed default for pop_debugging to true. + Changed default for pop_debugging to true. --- Robert John Duncan, Jan 8 1996 Copyright extended to 1996. --- John Williams, Nov 30 1995 - pop_internal_version = 150200 (no warnings from vars in procedures). + pop_internal_version = 150200 (no warnings from vars in procedures). (Note 150100 used by ISL as version number for their re-release - of V15 with the vars change). + of V15 with the vars change). --- John Williams, Aug 7 1995 - pop_internal_version = 150001 + pop_internal_version = 150001 --- John Williams, Jul 31 1995 - pop_internal_version = 150000 + pop_internal_version = 150000 --- Robert John Duncan, Jul 12 1995 Updated and exported the copyright string. --- John Gibson, May 23 1995 - pop_internal_version = 145300 (new lvars default for procedure formals, etc) + pop_internal_version = 145300 (new lvars default for procedure formals, etc) --- John Gibson, May 20 1995 - pop_internal_version = 145200 (first Alpha OSF version) + pop_internal_version = 145200 (first Alpha OSF version) --- John Gibson, Apr 10 1995 - pop_internal_version = 145102 (procedure header and key layouts change) + pop_internal_version = 145102 (procedure header and key layouts change) --- John Williams, Feb 2 1995 - pop_internal_version = 145101 (fix to I_LBLOCK for Clisp/CLX) + pop_internal_version = 145101 (fix to I_LBLOCK for Clisp/CLX) --- John Gibson, Dec 8 1994 - pop_internal_version = 145100 (first Alpha VMS version) + pop_internal_version = 145100 (first Alpha VMS version) --- John Gibson, Nov 28 1994 Moved initialisation of pointer variable pop_external_flags to c_callback.c (pop must refer only to _pop_external_flags) --- John Gibson, Oct 24 1994 - Added new Popc define_extern_name construct for defining + Added new Popc define_extern_name construct for defining external names --- John Gibson, Jun 2 1994 Removed _d*ouble --- John Williams, Apr 26 1994 - Upped pop_internal_version to 145003 after copying 145002 + Upped pop_internal_version to 145003 after copying 145002 as COGS popversion "new". --- John Gibson, Feb 7 1994 - pop_internal_version = 145002 (various Ved changes) + pop_internal_version = 145002 (various Ved changes) --- Simon Nichols, Nov 29 1993 - pop_internal_version = 145001 (after copying 14.5) + pop_internal_version = 145001 (after copying 14.5) --- Simon Nichols, Nov 29 1993 - pop_internal_version = 145000 (prior to copying 14.5) + pop_internal_version = 145000 (prior to copying 14.5) --- John Gibson, Aug 16 1993 Replaced pop_p*as_mode with internal var vm_pas_mode --- John Williams, Jul 13 1993 - pop_internal_version upped to 142400, just after copying 14.2301 + pop_internal_version upped to 142400, just after copying 14.2301 --- John Gibson, May 21 1993 - Added init for pop_vm_flags + Added init for pop_vm_flags --- John Gibson, May 2 1993 pop_internal_version = 142301 (slight change in POPC interface) --- John Williams, Apr 23 1993 pop_internal_version upped to 142300, just after copying 14.2201 --- John Williams, Jan 8 1993 - pop_internal_version upped to 142201 (new vedsetup_actions) + pop_internal_version upped to 142201 (new vedsetup_actions) --- John Gibson, Dec 18 1992 Moved in initialisations of _external_flags and _in_X_call --- John Gibson, Oct 12 1992 Only in v15.63/pop/src: initial.p.2005 Only in v15.63/pop/src: initial.p.2008 Only in v15.63/pop/src: initial.p.2009 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/int_convert.p v15.6301-amd64/pop/src/int_convert.p --- v15.63/pop/src/int_convert.p 1995-09-19 11:53:14.000000000 -0400 +++ v15.6301-amd64/pop/src/int_convert.p 2009-12-24 15:49:43.000000000 -0500 @@ -36,8 +36,9 @@ SAVEWORKBGI(_work, _save1, _save2); BGWEAK Bigint_<< ( BGWEAK Pint_to_bigint( - _pint( _shift(_n, _negate(_ICVT_SHIFT)) _bimask _ICVT_HIMASK ), - _work), + _pint( _shift(_n, _negate(_ICVT_SHIFT)) + _bimask _ICVT_HIMASK), + _work), _ICVT_SHIFT) -> res; RESTWORKBGI(_work, _save1, _save2); _n _bimask _ICVT_LOMASK -> _n; @@ -79,7 +80,9 @@ define Pint_->_uint(n, _rangemask); lvars n, _hi, _lo, _rangemask; if isinteger(n) then - returnif(_nonneg(_int(n) ->> _hi)) (_hi) + _int(n) -> _hi; + returnif(_nonneg(_hi) and _hi _lteq _rangemask) (_hi); + elseif iscompound(n) and n!KEY == weakref biginteger_key then n!BGI_SLICES[_0] _bimask _ICVT_LOMASK -> _lo; BGWEAK Bigint_>>(n, _ICVT_SHIFT) -> _hi; @@ -89,7 +92,7 @@ _shift(_hi, _ICVT_SHIFT) _add _lo -> _hi; returnif(_hi _lteq _rangemask) (_hi) endif - endif + endif; endif; Err(n, _rangemask, false) enddefine; @@ -97,8 +100,12 @@ ;;; pop (big)integer -> signed int define Pint_->_sint(n, _rangemask); lvars n, _hi, _lo, _mask, _rangemask; - returnif(isinteger(n)) (_int(n)); - if iscompound(n) and n!KEY == weakref biginteger_key then + if(isinteger(n)) then + _int(n) -> _hi; + if _logcom(_rangemask) _slteq _hi and _hi _slteq _rangemask then + return (_hi); + endif + elseif iscompound(n) and n!KEY == weakref biginteger_key then n!BGI_SLICES[_0] _bimask _ICVT_LOMASK -> _lo; BGWEAK Bigint_>>(n, _ICVT_SHIFT) -> _hi; if isinteger(_hi) then diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/intvec.p v15.6301-amd64/pop/src/intvec.p --- v15.63/pop/src/intvec.p 1995-06-03 12:31:03.000000000 -0400 +++ v15.6301-amd64/pop/src/intvec.p 2009-12-30 22:05:52.000000000 -0500 @@ -13,6 +13,19 @@ defclass intvec :int; +defclass untvec :uint; + +defclass bytevec :byte; + +defclass sbytevec :sbyte; + +defclass shortvec :short; + +defclass ushortvec :ushort; + +defclass longvec :long; + +defclass ulongvec :ulong; /* --- Revision History --------------------------------------------------- --- John Gibson, Apr 5 1995 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/io.ph v15.6301-amd64/pop/src/io.ph --- v15.63/pop/src/io.ph 1997-04-04 08:25:56.000000000 -0500 +++ v15.6301-amd64/pop/src/io.ph 2005-03-11 05:30:39.000000000 -0500 @@ -9,8 +9,8 @@ #_TERMIN_IF DEF IO_INCLUDED struct DEVICE - { short D_FLAGS, - D_FILE_DESC; + { short D_FLAGS; + int D_FILE_DESC; full KEY, >-> D_CTRL_BLK, D_UNIT_N, diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/itemread.p v15.6301-amd64/pop/src/itemread.p --- v15.63/pop/src/itemread.p 1996-09-16 10:03:19.000000000 -0400 +++ v15.6301-amd64/pop/src/itemread.p 2005-03-11 05:30:39.000000000 -0500 @@ -123,6 +123,20 @@ endif enddefine; +constant _print_addr; +#_IF false +define nextitem_bb() -> item; +lvars item; + nextitem_true() -> item; + _extern printf('_next_code = %ld\nitem:', _next_code)-> _ ; + _extern fflush(_0); + _print_addr(item); +;;; $-Sys$-pretty$-pretty(item); + item => + _extern fflush(_0); +enddefine; +#_ENDIF + define Chop(); unless _next_code == _:M_ID_TERMIN then fast_front(proglist) -> poplastitem; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/lispcore.p v15.6301-amd64/pop/src/lispcore.p --- v15.63/pop/src/lispcore.p 1998-02-12 09:38:38.000000000 -0500 +++ v15.6301-amd64/pop/src/lispcore.p 2009-12-26 21:58:50.000000000 -0500 @@ -1400,7 +1400,7 @@ enddefine; -define lconstant App_package(pkg, procedure pdr, _do_internals); +define lconstant App_package(pkg, procedure pdr, _do_internals, check_access); lvars _sl, _offs, _lim, entry; stacklength() -> _sl; pkg!PKG_VECTOR -> pkg; @@ -1409,7 +1409,10 @@ while _offs _lt _lim do pkg!(w){_offs} -> entry; while iscompound(entry) do - if _do_internals or (entry!KEY == package_external_entry_key) then + if (_do_internals or + (entry!KEY == package_external_entry_key)) + and (not(check_access) + or check_access(entry!PGE_SYM)) then _CHECKUSER; lisp_apply(Return_symbol(entry!PGE_SYM), pdr, 1, 0) endif; @@ -1421,15 +1424,21 @@ define apppackage(pkg, pdr, do_internals, do_inherits); - lvars p; - Checkr_package(pkg) -> pkg; - $-Sys$-Check_procedure(pdr); - App_package(pkg, pdr, pop_true(do_internals)); - if pop_true(do_inherits) then - for p in pkg!PKG_USES do - App_package(p, pdr, false) - endfor - endif + lvars p; + Checkr_package(pkg) -> pkg; + $-Sys$-Check_procedure(pdr); + App_package(pkg, pdr, pop_true(do_internals), false); + if pop_true(do_inherits) then + for p in pkg!PKG_USES do + App_package(p, pdr, false, + procedure(sym); + lvars entry, name; + sym!SYM_NAME -> name; + Find_pkg_entry(name, pkg, pkg!PKG_USES) -> (entry, , ); + entry and (entry!PGE_SYM == sym); + endprocedure) + endfor + endif enddefine; @@ -1551,8 +1560,8 @@ endif -> (pkgs, do_inherits); fast_for pkg in pkgs do - apppackage( pkg, + apppackage( procedure(sym); if issubstring(string, symbol_string(sym)) then conspair(sym, list) -> list diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/mknewpop v15.6301-amd64/pop/src/mknewpop --- v15.63/pop/src/mknewpop 1993-07-14 09:37:02.000000000 -0400 +++ v15.6301-amd64/pop/src/mknewpop 2005-03-11 05:30:39.000000000 -0500 @@ -6,7 +6,12 @@ # Related Files: C.vms/src/mknewpop.com, LIB * NEWPOP IMAGE=$popsys/newpop.psv + corepop11 %nort $popliblib/mkimage.p -entrymain $IMAGE $popliblib/newpop.p +# cat << EOF > /tmp/mk$$ +# run %nort $popliblib/mkimage.p -entrymain $IMAGE $popliblib/newpop.p +# EOF +# gdb -e corepop11 -x /tmp/mk$$ rm -f $IMAGE- # --- Revision History --------------------------------------------------- diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/mksyscomp v15.6301-amd64/pop/src/mksyscomp --- v15.63/pop/src/mksyscomp 2008-11-06 04:28:40.000000000 -0500 +++ v15.6301-amd64/pop/src/mksyscomp 2009-12-24 13:00:41.000000000 -0500 @@ -1,5 +1,5 @@ #!/bin/sh -# --- Copyright University of Sussex 2008. All rights reserved. ---------- +# --- Copyright University of Sussex 1993. All rights reserved. ---------- # File: C.unix/src/mksyscomp # Purpose: Build saved images for POPC, POPLINK and POPLIBR # Author: John Gibson, Jun 24 1988 (see revisions) @@ -36,7 +36,6 @@ done # --- Revision History --------------------------------------------------- -# --- Aaron Sloman, Nov 6 2008 Changed corepop11 to corepop # --- John Gibson, Jul 10 1993 Image now built in popsys on corepop11 # --- Robert John Duncan, Jan 9 1992 # Rewritten to allow multiple arguments and always to use safepop11 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/newpop v15.6301-amd64/pop/src/newpop --- v15.63/pop/src/newpop 1993-07-09 23:55:48.000000000 -0400 +++ v15.6301-amd64/pop/src/newpop 2008-06-13 05:30:10.000000000 -0400 @@ -15,9 +15,13 @@ # Run the NEWPOP saved image based on corepop if [ $# -eq 0 ]; then - corepop +$popsys/newpop.psv +# echo corepop +$popsys/newpop.psv + corepop +$popsys/newpop.psv +# gdb /home/hebisch/poplog/v15.61-amd64/pop/pop/corepop else - corepop +$popsys/newpop.psv "$@" +# echo corepop +$popsys/newpop.psv "$@" + corepop +$popsys/newpop.psv "$@" +# gdb /home/hebisch/poplog/v15.61-amd64/pop/pop/corepop fi # --- Revision History --------------------------------------------------- diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/pdr_compose.p v15.6301-amd64/pop/src/pdr_compose.p --- v15.63/pop/src/pdr_compose.p 1990-06-26 14:30:44.000000000 -0400 +++ v15.6301-amd64/pop/src/pdr_compose.p 2005-03-11 05:30:39.000000000 -0500 @@ -13,7 +13,8 @@ ;;; Macros for dropping code at -_drop_ptr- lconstant macro ( - LONG = [_drop_ptr!(l)++ -> _drop_ptr], + QUAD = [_drop_ptr!(l)++ -> _drop_ptr], + LONG = [_drop_ptr!(i)++ -> _drop_ptr], SHORT = [_drop_ptr!(s)++ -> _drop_ptr], BYTE = [_drop_ptr!(b)++ -> _drop_ptr], ); @@ -27,7 +28,7 @@ lvars _drop_ptr, _comp, _size; ;;; Determine size of procedure - ##(w)[_21 | b.r] -> _size; ;;; code size in words + ##(w)[_26 | b.r] -> _size; ;;; code size in words @@PD_COMPOSITE_TABLE[_size] _sub @@POPBASE -> _size; ;;; plus header ;;; Allocate new procedure record @@ -45,32 +46,37 @@ _comp@PD_COMPOSITE_TABLE ->> _drop_ptr -> _comp!PD_EXECUTE; ;;; Set up the stack frame - ;;; movl %eax, %PB - _16:C589 -> SHORT; ;;; 2 bytes - ;;; pushl %PB - _16:55 -> BYTE; ;;; 1 byte + ;;; movq %rax, %PB + _16:48 -> BYTE, + _16:C589 -> SHORT; ;;; 3 bytes + ;;; pushq %PB + _16:55 -> BYTE; ;;; 1 byte ;;; Call PD_COMPOSITE_P1 and PD_COMPOSITE_P2 ;;; (assuming that @@PD_EXECUTE == 0) - ;;; movl [@@PD_COMPOSITE_P1](%PB), %eax - _16:458B -> SHORT, @@PD_COMPOSITE_P1 -> BYTE; ;;; 3 bytes - ;;; call *(%eax) - _16:10FF -> SHORT; ;;; 2 bytes - ;;; movl [@@PD_COMPOSITE_P2](%PB), %eax - _16:458B -> SHORT, @@PD_COMPOSITE_P2 -> BYTE; ;;; 3 bytes - ;;; call *(%eax) + ;;; movq [@@PD_COMPOSITE_P1](%PB), %rax + _16:48 -> BYTE, + _16:458B -> SHORT, @@PD_COMPOSITE_P1 -> BYTE; ;;; 4 bytes + ;;; call *(%rax) + _16:10FF -> SHORT; ;;; 2 bytes + ;;; movq [@@PD_COMPOSITE_P2](%PB), %rax + _16:48 -> BYTE, + _16:458B -> SHORT, @@PD_COMPOSITE_P2 -> BYTE; ;;; 4 bytes + ;;; call *(%rax) _16:10FF -> SHORT; ;;; 2 bytes ;;; Save pointer to exit code _drop_ptr -> _comp!PD_EXIT; ;;; Unwind the stack frame - ;;; addl $4, %esp - _16:C483 -> SHORT, _4 -> BYTE; ;;; 3 bytes - ;;; movl 4(%esp), %PB - _16:6C8B -> SHORT, _16:24 -> BYTE, _4 -> BYTE; ;;; 4 bytes + ;;; addq $8, %rsp + _16:48 -> BYTE, + _16:C483 -> SHORT, _8 -> BYTE; ;;; 4 bytes + ;;; movq 8(%rsp), %PB + _16:48 -> BYTE, + _16:6C8B -> SHORT, _16:24 -> BYTE, _8 -> BYTE; ;;; 5 bytes ;;; ret - _16:C3 -> BYTE; ;;; 1 bytes + _16:C3 -> BYTE; ;;; 1 bytes enddefine; endsection; /* $-Sys */ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/setpop.p v15.6301-amd64/pop/src/setpop.p --- v15.63/pop/src/setpop.p 2000-01-06 06:58:07.000000000 -0500 +++ v15.6301-amd64/pop/src/setpop.p 2009-12-27 11:03:55.000000000 -0500 @@ -43,6 +43,7 @@ Vms_jpi_string, Vms_jpi_int, Vms_get_image_name, Io$-Cons_device, Io$-Get_char, Io$-Rms_parse, Io$-Rms_search, Io$-Cons_stddev, Explode_substring, + dummy_procedure_callback_helper, ), image_version ; @@ -73,7 +74,8 @@ poppid, popusername, popdirectory, popheader, pop_runtime, pop_runtime_actions, pop_first_setpop, pop_nobanner, pop_noinit, popunderx, - setpop + setpop, + dummy_procedure_callback_helper ; constant @@ -892,6 +894,7 @@ enddefine; /* Setup_system */ define lvars Setpop_setup_system(); + Get_mem_break() -> _user_base; chain(_nextframe(_caller_sp_flush()), _0, Setup_system) enddefine; @@ -923,6 +926,11 @@ sysexit() enddefine; +define dummy_procedure_callback_helper(); + lvars _dummy1 = 666, _dummy2 = 42; + _extern printf('%d, %d\n', _dummy1, _dummy2); +enddefine; + endsection; /* $-Sys */ Only in v15.63/pop/src: setpop.p.2000 Only in v15.63/pop/src: shortvec.p diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sig_async.p v15.6301-amd64/pop/src/sig_async.p --- v15.63/pop/src/sig_async.p 1992-06-17 12:50:50.000000000 -0400 +++ v15.6301-amd64/pop/src/sig_async.p 2005-03-13 04:56:40.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 1992. All rights reserved. ---------- +/* --- Copyright University of Sussex 2005. All rights reserved. ---------- > File: C.all/src/sig_async.p > Purpose: routines to control asynchronous interrupts > Author: Roger Evans, Apr 18 1988 (see revisions) @@ -9,6 +9,7 @@ #_INCLUDE 'declare.ph'; #_INCLUDE 'signals.ph'; +lconstant _WORD_RANGE_MASK = _int(2**(WORD_BITS-1)-1); ;;; controlling asynchronous interrupts define active pop_enable_interrupts; @@ -29,7 +30,9 @@ define sys_send_signal(pid, signum); lvars pid, signum; Sys$-Check_integer(signum, 0); - _nonneg(_extern kill(Sys$-Pint_->_sint(pid, _-1), _int(signum))) +;;; (_extern kill(Sys$-Pint_->_sint(pid, _-1), _int(signum))) + (_extern kill(Sys$-Pint_->_sint(pid, _WORD_RANGE_MASK), _int(signum))) + _lteq _2147483647 enddefine; #_ENDIF @@ -37,6 +40,8 @@ /* --- Revision History --------------------------------------------------- +--- Aaron Sloman, Mar 13 2005 + Patch provided by Waldek Hebisch for AMD64 Poplog --- John Gibson, Jun 17 1992 Changed sys_send_signal to allow any signed (big)integer value for pid --- John Gibson, Jun 27 1988 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sr_sys.p v15.6301-amd64/pop/src/sr_sys.p --- v15.63/pop/src/sr_sys.p 1998-06-02 09:57:10.000000000 -0400 +++ v15.6301-amd64/pop/src/sr_sys.p 2005-03-11 05:30:39.000000000 -0500 @@ -316,7 +316,7 @@ endif _biset _MAP_FIXED, _sr_channel, _fileoffs) -> _res; - if _neg(_res) then + if _res _eq _-1 /* _gr _2147483647 */ then Syserr_mishap(_sr_device, 1, 'ERROR MAPPING SAVED IMAGE') elseif _res /== _baddr then mishap(_sr_device, 1, 'ERROR MAPPING SAVED IMAGE (mapped at wrong address)') @@ -570,13 +570,13 @@ _extern shmget(_shmem_key, ##(b){_size|w}, _0) -> _res; if isinstalled == undef then ;;; first try for shared memory, set isinstalled - _nonneg(_res) -> isinstalled - elseif _neg(_res) then + _res _lteq _2147483647 -> isinstalled + elseif _res _gr _2147483647 then ;;; previous sect was shared mem but not this one! Syserr_mishap(0, 'ERROR MAPPING INSTALLED SAVED IMAGE') endif endif; - if _nonneg(_res) then + if (_res) _lteq _2147483647 then ;;; _res is a shared memory identifier - now attach to it lvars _baddr = _base@(w->b); if _extern shmat(_res, _baddr, _SHM_RDONLY) /== _baddr then @@ -1272,8 +1272,8 @@ Read(_shrsp, @@(struct SHR_SECT)++); ;;; file offset and offs length ;;; deleting existing shared memory segments _extern shmget(_shmem_key, ##(b){_shrsp!SHRS_SIZE | w}, _0) -> _shmid; - if _neg(_shmid) - or _neg(_extern shmctl(_shmid, _IPC_RMID, _0)) then + if (_shmid) _gr _2147483647 + or (_extern shmctl(_shmid, _IPC_RMID, _0)) _gr _2147483647 then Warning(file, 'CAN\'T DE-INSTALL SAVED IMAGE'); return endif; @@ -1303,7 +1303,7 @@ ;;; create new shared memory segment from this area ;;; (644 mode is read/write by owner and read by all) _extern shmget(_shmem_key, _blen, _IPC_CREAT _biset _8:644) -> _shmid; - if _neg(_shmid) + if (_shmid) _gr _2147483647 or (_extern shmat(_shmid, _0, _0) ->> _baddr) == _-1 or _extern[NI] read(_sr_channel, _baddr, _blen) /== _blen then Only in v15.63/pop/src: sr_sys.p.1998 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sys_file_move.p v15.6301-amd64/pop/src/sys_file_move.p --- v15.63/pop/src/sys_file_move.p 1997-03-08 10:24:40.000000000 -0500 +++ v15.6301-amd64/pop/src/sys_file_move.p 2005-03-11 05:30:39.000000000 -0500 @@ -35,13 +35,23 @@ define lconstant unlink(f); lvars f; lstackmem stackbuff _fnbuf; - _extern unlink(Encode_sys(f,_fnbuf)) + lvars _pop_res = + _extern unlink(Encode_sys(f,_fnbuf)); + if _pop_res _lteq _2147483647 then _pop_res + else + _pop_res _sub _4294967296 + endif enddefine; define lconstant link(f, t, _fnbuf); lvars f, t, _fnbuf; lstackmem stackbuff _tnbuf; - _extern link(Encode_sys(f,_fnbuf), Encode_sys(t,_tnbuf)) + lvars _pop_res = + _extern link(Encode_sys(f,_fnbuf), Encode_sys(t,_tnbuf)); + if _pop_res _lteq _2147483647 then _pop_res + else + _pop_res _sub _4294967296 + endif enddefine; define lconstant Rename(f, t); @@ -51,7 +61,12 @@ define lconstant rename(f, t, _fnbuf); lvars f, t, _fnbuf; lstackmem stackbuff _tnbuf; - _extern rename(Encode_sys(f,_fnbuf), Encode_sys(t,_tnbuf)) + lvars _pop_res = + _extern rename(Encode_sys(f,_fnbuf), Encode_sys(t,_tnbuf)); + if _pop_res _lteq _2147483647 then _pop_res + else + _pop_res _sub _4294967296 + endif enddefine; while _neg(rename(f, t, _nbuf2) ->> _res) diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sys_file_stat.p v15.6301-amd64/pop/src/sys_file_stat.p --- v15.63/pop/src/sys_file_stat.p 1999-03-19 20:00:10.000000000 -0500 +++ v15.6301-amd64/pop/src/sys_file_stat.p 2009-12-24 15:34:16.000000000 -0500 @@ -47,12 +47,13 @@ Encode_sys(file, _nbuf) endif -> _arg; _extern[INDIR] _routine(_arg, _stbuf) -> _res; - quitunless(_neg(_res) and _ERRNO == _:EINTR); + quitunless(_res _gr _2147483647 and _ERRNO == _:EINTR); _CHECKINTERRUPT endrepeat; - returnif(_neg(_res)) (false -> statbuff); + returnif((_res) _gr _2147483647) (false -> statbuff); datalength(statbuff) -> len; +;;; printf(len, 'statbuff len: %p\n'); returnif(len == 0); go_on len to ONE TWO THREE FOUR FIVE SIX SEVEN EIGHT NINE else TEN; @@ -86,19 +87,24 @@ FOUR: ;;; user id - _pint(_stbuf!ST_UID) -> fast_subscrv(4,statbuff); +;;; _pint(_stbuf!ST_UID) -> fast_subscrv(4,statbuff); + Sint_->_pint(_stbuf!ST_UID) -> fast_subscrv(4,statbuff); THREE: ;;; group id - _pint(_stbuf!ST_GID) -> fast_subscrv(3,statbuff); +;;; _pint(_stbuf!ST_GID) -> fast_subscrv(3,statbuff); + Sint_->_pint(_stbuf!ST_GID) -> fast_subscrv(3,statbuff); TWO: ;;; last modified time - Sint_->_pint(_stbuf!ST_MTIME) -> fast_subscrv(2,statbuff); - +;;; Sint_->_pint(_stbuf!ST_MTIME) -> fast_subscrv(2,statbuff); + _pint(_stbuf!ST_MTIME) -> fast_subscrv(2,statbuff); +;;; printf(_pint(_stbuf!ST_MTIME), '_pint(_stbuf!ST_MTIME) = %p\n'); +;;; printf(fast_subscrv(2,statbuff), 'fast_subscrv(2,statbuff) = %p\n'); ONE: ;;; file size _pint(_stbuf!ST_SIZE) -> fast_subscrv(1,statbuff); +;;; printf(statbuff, 'statbuff = %p\n'); enddefine; endsection; /* $-Sys */ diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sys_host_name.p v15.6301-amd64/pop/src/sys_host_name.p --- v15.63/pop/src/sys_host_name.p 1997-03-10 09:07:49.000000000 -0500 +++ v15.6301-amd64/pop/src/sys_host_name.p 2005-03-11 05:30:39.000000000 -0500 @@ -22,7 +22,7 @@ lvars _offs; lstackmem stackbuff _obuf; lconstant _size = _:SIZEOF(stackbuff); - if _nonneg(_extern gethostname(_obuf, _size)) then + if (_extern gethostname(_obuf, _size)) _lteq _2147483647 then if (_locc(_obuf, @@(b)[_size], _0) ->> _offs) == _-1 then @@(b)[_size] -> _offs endif; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sys_input_waiting.p v15.6301-amd64/pop/src/sys_input_waiting.p --- v15.63/pop/src/sys_input_waiting.p 1997-02-18 10:39:18.000000000 -0500 +++ v15.6301-amd64/pop/src/sys_input_waiting.p 2005-03-11 05:30:39.000000000 -0500 @@ -102,7 +102,7 @@ repeat if wait and testdef $-Sys$-Xt$-Xpt_IO_wait and (weakref $-Sys$-Xt$-Xpt_IO_wait(_fdsets) ->> _nfds) then - quitunless(_neg(_int(_nfds) ->> _nfds)) + quitunless((_int(_nfds) ->> _nfds) _gr _2147483647) else lvars _n, _rdarg, _wrarg, _exarg; if _nonzero(_fdsets@WFDS_RD_SET!FDS_NFDS ->> _nfds) then @@ -125,7 +125,7 @@ _extern select(_nfds, _rdarg, _wrarg, _exarg, if wait then _NULL else _tvp0 endif) -> _nfds; - quitunless(_neg(_nfds) and _ERRNO == _:EINTR) + quitunless((_nfds) _gr _2147483647 and _ERRNO == _:EINTR) endif; _CHECKINTERRUPT; @@ -201,10 +201,13 @@ FD_ZERO(_fds); FD_SET(_fd, _fds); _0 ->> _tvp0!TIM_SEC -> _tvp0!TIM_USEC; - if _extern[NI] select(_fd _add _1, _fds, _NULL, _NULL, _tvp0) _sgr _0 then + lvars _selres + = _extern[NI] select(_fd _add _1, _fds, _NULL, _NULL, _tvp0); + if _selres _sgr 0 and _selres _lteq _2147483648 then ;;; return a true result if select says input waiting, but try ;;; to make it the number of chars - if _nonneg(_extern[NI] ioctl(_fd, _FIONREAD, _ip)) then + if (_extern[NI] ioctl(_fd, _FIONREAD, _ip)) + _lteq _2147483647 then _pint(_ip!(int)) else 0 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sys_io_control.p v15.6301-amd64/pop/src/sys_io_control.p --- v15.63/pop/src/sys_io_control.p 1994-07-08 12:23:40.000000000 -0400 +++ v15.6301-amd64/pop/src/sys_io_control.p 2005-03-11 05:30:39.000000000 -0500 @@ -25,7 +25,8 @@ define sys_io_control(dev, _mode) -> _res; lvars dev, devparams = false, argstruct = false, _mode, _res, _argbptr; - +;;; _extern printf('sys_io_control\n') -> _; +;;; _extern fflush(_0) -> _; unless isdevice(dev) then ;;; structure argument supplied ((), dev, _mode) -> (dev, _mode, argstruct); @@ -50,7 +51,8 @@ endif; endif; - _nonneg(_extern[NI] ioctl(dev!D_FILE_DESC, _mode, _argbptr)) -> _res; + (_extern[NI] ioctl(dev!D_FILE_DESC, _mode, _argbptr)) + _lteq _2147483647 -> _res; if devparams and _res then Get_tty_params(dev, devparams); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sys_real_time.p v15.6301-amd64/pop/src/sys_real_time.p --- v15.63/pop/src/sys_real_time.p 1995-06-30 12:19:46.000000000 -0400 +++ v15.6301-amd64/pop/src/sys_real_time.p 2009-12-29 23:55:34.000000000 -0500 @@ -14,7 +14,7 @@ ;;; ------------------------------------------------------------------- -section $-Sys => sys_real_time; +section $-Sys => sys_real_time, sys_microtime; /* Time in seconds since midnight 1 Jan 1970 GMT */ @@ -28,6 +28,16 @@ #_ENDIF enddefine; +define sys_microtime(); +#_IF DEFV BERKELEY >= 4.2 + lstackmem struct TIMEVAL _tvp; + _extern gettimeofday(_tvp, _NULL) -> ; + Sint_->_pint(_tvp!TIM_SEC)*1000000 + Sint_->_pint(_tvp!TIM_USEC) +#_ELSE + Sint_->_pint(_extern time(_NULL))*1000000 +#_ENDIF +enddefine; + endsection; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/asmout.p v15.6301-amd64/pop/src/syscomp/asmout.p --- v15.63/pop/src/syscomp/asmout.p 1999-02-26 09:03:21.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/asmout.p 2005-03-11 05:30:39.000000000 -0500 @@ -47,14 +47,18 @@ define nextlab(); dlocal pop_pr_radix = 36; - '.L' >< nextlabel; + '_L' >< nextlabel; nextlabel fi_+ 1 -> nextlabel; enddefine; ;;; Global labels constructed from word plus prefix char define lconstant asm_label(word, prefix_char); +#_IF false lconstant SEP_CHAR = `.`; +#_ELSE + lconstant SEP_CHAR = `_`; +#_ENDIF lvars n, len, string, q, r, prefix_char, word; if isstring(word) then word else fast_word_string(word) endif -> string; datalength(string) -> len; @@ -72,8 +76,9 @@ a a a a a a a a a a a a a a a a ;;; a -- p a a a a a a a a a a s s s s c c ;;; q -- \(128) else c; - - A: a: d: u : ;;; alpha, digit, underscore + u: ;;; underscore + `_` ; ;;; + A: a: d: ;;; alpha, digit, underscore nextloop; $ : @@ -82,7 +87,7 @@ then ;;; replace section separator $- with SEP_CHAR -> ; ;;; erase $ - unless n == 1 then SEP_CHAR endunless; + unless n == 1 then `_`, `S` endunless; n fi_+ 1 -> n; ;;; skip - nextloop ;;; else drop thru to "s" @@ -91,6 +96,7 @@ s: c: ;;; other sign, control etc ;;; represent as 3 decimal digits () fi_// 100 -> q -> r; + `_` ; q fi_+ `0`; r fi_// 10 -> q -> r; q fi_+ `0`, r fi_+ `0`; @@ -127,7 +133,8 @@ $- ASM_BYTE_STR = '\t.byte\t', $- ASM_SHORT_STR= '\t.value\t', $- ASM_INT_STR = '\t.long\t', - $- ASM_WORD_STR = ASM_INT_STR, + $- ASM_DOUBLE_STR = '\t.quad\t', + $- ASM_WORD_STR = ASM_DOUBLE_STR, ); ;;; Starting and ending an assembly code file @@ -156,14 +163,21 @@ global constant procedure ( asm_align_word = + #_IF true + outcode(% '.align\t8' %) + #_ELSE #_IF DEF LINUX and not(DEF LINUX_ELF) outcode(% '.align\t2' %) #_ELSE outcode(% '.align\t4' %) - #_ENDIF, - - asm_align_double = identfn, - + #_ENDIF + #_ENDIF, +asm_align_double = +#_IF false + identfn +#_ELSE + outcode(% '.align\t8' %) +#_ENDIF, ;;; asm_align_file -- end-of-file alignment ;;; (don't define if not needed) ;;; asm_align_file = identfn, @@ -212,11 +226,12 @@ asm_outshort = outdatum(% ASM_SHORT_STR %), asm_outint = outdatum(% ASM_INT_STR %), asm_outword = outdatum(% ASM_WORD_STR %), + asm_outdouble = outdatum(% ASM_DOUBLE_STR %), ); define asm_out_dfloat(hipart, lopart); lvars hipart, lopart; - asm_outword(lopart, hipart, 2); + asm_outint(lopart, hipart, 2); enddefine; /* -asm_addbits- is used to accumulate a sequence of bitfields into @@ -292,7 +307,7 @@ #_IF DEF SOLARIS explode(' \\/ 4'), #_ELSE - explode(' >> 2'), + explode(' >> 3'), #_ENDIF explode(ASM_RPAR), explode(' + '), dest_characters(hdr_size) @@ -309,17 +324,17 @@ ;;; Push nfroz frozvals (last nfroz longwords planted) ;;; EBX is the user stack pointer asm_outlab(nextlab() ->> l); - fast_for offs from nfroz*4 by -4 to 4 do - asmf_pr('\tsubl\t$4, %ebx\n'); - asmf_printf(asm_expr(l, "-", offs), '\tmovl\t%p, %%eax\n'); - asmf_pr('\tmovl\t%eax, (%ebx)\n'); + fast_for offs from nfroz*8 by -8 to 8 do + asmf_pr('\tsubq\t$8, %rbx\n'); + asmf_printf(asm_expr(l, "-", offs), '\tmovq\t%p, %%rax\n'); + asmf_pr('\tmovq\t%rax, (%rbx)\n'); endfast_for; ;;; Jump to -jmplab- - asmf_printf(jmplab, '\tmovl\t$%p, %%eax\n'); - asmf_pr('\tjmp\t*%eax\n'); + asmf_printf(jmplab, '\tmovq\t$%p, %%rax\n'); + asmf_pr('\tjmp\t*%rax\n'); ;;; Return the number of longwords planted asm_align_word(); - (nfroz*11+10)>>2; + (nfroz*18+15)>>3; enddefine; @@ -333,14 +348,14 @@ define asm_gen_exfunc_clos_code(action_lab); lvars action_lab; ;;; leal _exfunc_clos_action, %eax (= 6 bytes) - asmf_printf(action_lab, '\tleal\t%p, %%eax\n'); + asmf_printf(action_lab, '\tleaq\t%p, %%r10\n'); ;;; call *%eax (= 2 bytes) - asmf_printf('\tcall\t*%%eax\n'); + asmf_printf('\tcall\t*%%r10\n'); ;;; pad to 16 bytes -#_IF DEF SYSTEM_V +#_IF DEF SYSTEM_V or DEF LINUX asmf_printf('\t.align\t8\n'); #_ELSE - asmf_printf('\t.space\t8\n'); + asmf_printf('\t.space\t5\n'); #_ENDIF enddefine; @@ -366,7 +381,7 @@ ;;; Use C compiler to link constant - cc_link_command_header = '$POP__cc -Wl,-x,-export-dynamic -o $IM \\\n' + cc_link_command_header = '$POP__cc -Wl,-export-dynamic -o $IM \\\n' ; #_ELSE diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/genfloat.p v15.6301-amd64/pop/src/syscomp/genfloat.p --- v15.63/pop/src/syscomp/genfloat.p 1995-05-11 09:41:16.000000000 -0400 +++ v15.6301-amd64/pop/src/syscomp/genfloat.p 2005-03-11 05:30:39.000000000 -0500 @@ -68,7 +68,7 @@ lvars signif, expo; #_IF WORD_BITS==DOUBLE_BITS lvars (hi32, lo32) = d_float_ints(signif, expo); - (hi32 << 32) || lo32 &&~~ 2:111; + (hi32 << 32) || lo32 &&~~ 2:11; #_ELSE syspop\:_pint(s_float_val(signif, expo)) &&~~ 2:11; #_ENDIF diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/genproc.p v15.6301-amd64/pop/src/syscomp/genproc.p --- v15.63/pop/src/syscomp/genproc.p 1997-12-05 10:32:40.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/genproc.p 2010-01-03 07:29:42.000000000 -0500 @@ -59,9 +59,11 @@ M_MOVE M_MOVEb M_MOVEbit + M_MOVEi M_MOVEs M_MOVEsb M_MOVEsbit + M_MOVEsi M_MOVEss M_MULT M_NEG @@ -83,6 +85,7 @@ M_UNWIND_SF M_UPDb M_UPDbit + M_UPDi M_UPDs /* Registers */ @@ -129,18 +132,31 @@ ;;; === REGISTER USAGE ================================================ +/* + rax - work rcx - work + rdx - chain rbx - pop user stack + rsp - stack rbp - base + rsi - work rdi - work + r8 - non pop lvar r9 - helper for immediate constants + r10 - non pop lvar r11 - non pop lvar + r12 - non pop lvar r13 - pop lvar + r14 - pop lvar r15 - pop lvar + +*/ + lconstant ;;; 80x86 register names and their usage - EAX = "eax", ;;; WK_REG/principal work reg/arg_reg_0 - ECX = "ecx", ;;; secondary work reg/arg_reg_1 - EDX = "edx", ;;; CHAIN_REG/arg_reg_2 - EBX = "ebx", ;;; USP - ESP = "esp", ;;; SP - EBP = "ebp", ;;; PB (procedure base reg) - ESI = "esi", ;;; WK_ADDR_REG_1 - EDI = "edi", ;;; WK_ADDR_REG_2 + EAX = "rax", ;;; WK_REG/principal work reg/arg_reg_0 + ECX = "rcx", ;;; secondary work reg/arg_reg_1 + EDX = "rdx", ;;; CHAIN_REG/arg_reg_2 + EBX = "rbx", ;;; USP + ESP = "rsp", ;;; SP + EBP = "rbp", ;;; PB (procedure base reg) + ESI = "rsi", ;;; WK_ADDR_REG_1 + EDI = "rdi", ;;; WK_ADDR_REG_2 + R9 = "r9", ; constant @@ -190,8 +206,18 @@ ;;; Lists of pop/non-pop registers for register locals ;;; (none on this machine) - pop_registers = [[]], - nonpop_registers = [[]], +/* + pop_registers = [[] 13 14 15], + nonpop_registers = [[] 8 10 11 12], + + pop_registers = [[]], + + nonpop_registers = [[]], +*/ + pop_registers = [[]], + nonpop_registers = [[] 8 10 11 12], +/* nonpop_registers = [[] 8 12], */ + ; ;;; regnumber: @@ -227,6 +253,39 @@ ]) enddefine; +define int_reglabel = newassoc([]); enddefine; + +define word_reglabel = newassoc([]); enddefine; + +define byte_reglabel = newassoc([]); enddefine; + +procedure(); + lvars n, l, li, lw, lb; + for n from 0 to 7 do + reglabel(n) -> l; + consword(`e`, l(2), l(3), 3) -> li; + allbutfirst(1, l) -> lw; + if n < 4 then + consword(lw(1), `l`, 2) + else + consword(lw(1), lw(2), `l`, 3) + endif -> lb; + li -> int_reglabel(n); + lw -> word_reglabel(n); + lb -> byte_reglabel(n); + endfor; + for n from 8 to 15 do + consword('r' >< n) -> l; + consword('r' >< n >< 'd') -> li; + consword('r' >< n >< 'w') -> lw; + consword('r' >< n >< 'b') -> lb; + n -> regnumber(l); + l -> reglabel(n); + li -> int_reglabel(n); + lw -> word_reglabel(n); + lb -> byte_reglabel(n); + endfor +endprocedure(); ;;; Local register operands: @@ -377,39 +436,38 @@ mishap(opcode, 1, 'WORD NEEDED'); endunless; pop11_need_nextreaditem(")") -> ; -#_IF DEF MASM - ;;; map from Unix --> Intel opcodes - define lconstant to_intel = + ;;; map to amd64 opcodes + define lconstant to_amd64 = newproperty([ - [incl inc] - [decl dec] - [addl add] - [sall sal] - [sarl sar] - [testl test] - [cmpl cmp] - [xorl xor] - [movl mov] - [imull imul] - [movb mov] - [movw mov] - [movzbl movzx] - [movzwl movzx] - [movsbl movsx] - [movswl movsx] - [pushl push] - [popl pop] - [leal lea] - [addl add] - [subl sub] - [negl neg] - [andl and] - [orl or] - [notl not] + [incl incq] + [decl decq] + [addl addq] + [sall salq] + [sarl sarq] + [testl testq] + [cmpl cmpq] + [xorl xorq] + [movl movq] + [imull imulq] + [movb movb] + [movw movw] + [movd movl] + [movzbl movzbq] + [movzwl movzwq] + [movsbl movsbq] + [movswl movswq] + [pushl pushq] + [popl popq] + [leal leaq] + [addl addq] + [subl subq] + [negl negq] + [andl andq] + [orl orq] + [notl notq] ], 32, false, "perm"); enddefine; - to_intel(opcode) or opcode -> opcode; -#_ENDIF + to_amd64(opcode) or opcode -> opcode; """, opcode, """; enddefine; @@ -587,7 +645,7 @@ define lconstant long_opd(opd) -> opd; lvars opd; - adjust(opd, WORD_OFFS) -> opd; + adjust(opd, DOUBLE_OFFS) -> opd; #_IF DEF MASM if ismem(opd) then consTypedOperand("dword", opd) -> opd; @@ -595,12 +653,28 @@ #_ENDIF enddefine; +define lconstant int_opd(opd) -> opd; + lvars opd; + adjust(opd, INT_OFFS) -> opd; + if isreg(opd) then + ;;; replace with 32-bit register name + int_reglabel(regnumber(opd)) -> opd; + ;;; consword(`e`, opd(2), opd(3), 3) -> opd; +#_IF DEF MASM + elseif ismem(opd) then + consTypedOperand("dword", opd) -> opd; +#_ENDIF + endif; +enddefine; + + define lconstant word_opd(opd) -> opd; lvars opd; adjust(opd, SHORT_OFFS) -> opd; if isreg(opd) then ;;; replace with 16-bit register name - allbutfirst(1, opd) -> opd; + ;;; allbutfirst(1, opd) -> opd; + word_reglabel(regnumber(opd)) -> opd; #_IF DEF MASM elseif ismem(opd) then consTypedOperand("word", opd) -> opd; @@ -613,10 +687,13 @@ adjust(opd, BYTE_OFFS) -> opd; if isreg(opd) then ;;; replace with 8-bit register name (if allowed) +/* unless regnumber(opd) < 4 then mishap(opd, 1, 'ILLEGAL 8-BIT REGISTER NAME'); endunless; consword(opd(2), `l`, 2) -> opd; +*/ + byte_reglabel(regnumber(opd)) -> opd; #_IF DEF MASM elseif ismem(opd) then consTypedOperand("byte", opd) -> opd; @@ -719,6 +796,13 @@ endif; enddefine; +define lconstant asmMOVD(src, dst); + lvars src, dst; + int_opd(src) -> src; + int_opd(dst) -> dst; + asm_emit(OPCODE(movd), OPERANDS(src, dst), 3); +enddefine; + define lconstant asmMOVW(src, dst); lvars src, dst; word_opd(src) -> src; @@ -733,6 +817,21 @@ asm_emit(OPCODE(movb), OPERANDS(src, dst), 3); enddefine; +/* Valid only if dst is a register */ +define lconstant asmMOVZDL(src, dst); + lvars src, dst; + int_opd(src) -> src; + int_opd(dst) -> dst; + asm_emit(OPCODE(movd), OPERANDS(src, dst), 3); +enddefine; + +define lconstant asmMOVSDL(src, dst); + lvars src, dst; + int_opd(src) -> src; + long_opd(dst) -> dst; + asm_emit(OPCODE(movslq), OPERANDS(src, dst), 3); +enddefine; + define lconstant asmMOVZWL(src, dst); lvars src, dst; word_opd(src) -> src; @@ -901,6 +1000,18 @@ ]); enddefine; +define constant is_large_int(src); + lvars src; + if isinteger(src) or isbiginteger(src) then + if (src < -2147483648) or (src > 2147483647) then + true + else + false + endif + else + false + endif +enddefine; /* * Data Movement @@ -912,6 +1023,9 @@ if ismem(src) and ismem(dst) then asmMOVL(src, EAX ->> src); endif; + if is_large_int(src) then + asmMOVL(src, EAX ->> src); + endif; asmMOVL(src, dst); endunless; enddefine; @@ -940,7 +1054,7 @@ define lconstant gen_move_from_l(asm_op); lvars asm_op, (, src, dst) = explode(m_instr); if ismem(src) - or isreg(src) and asm_op == asmMOVB and regnumber(src) fi_>= 4 + ;;; or isreg(src) and asm_op == asmMOVB and regnumber(src) fi_>= 4 then asmMOVL(src, EAX ->> src); endif; @@ -951,8 +1065,11 @@ define M_MOVEsb = gen_move_to_l(% asmMOVSBL %) enddefine; define M_MOVEs = gen_move_to_l(% asmMOVZWL %) enddefine; define M_MOVEss = gen_move_to_l(% asmMOVSWL %) enddefine; +define M_MOVEi = gen_move_to_l(% asmMOVZDL %) enddefine; +define M_MOVEsi = gen_move_to_l(% asmMOVSDL %) enddefine; define M_UPDb = gen_move_from_l(% asmMOVB %) enddefine; define M_UPDs = gen_move_from_l(% asmMOVW %) enddefine; +define M_UPDi = gen_move_from_l(% asmMOVD %) enddefine; ;;; gen_bfield: ;;; extract a bitfield from a structure using assembly code routines @@ -1011,7 +1128,11 @@ lvars src1, src2, dst; if isreg(src1) then if isreg(src2) then ;;; base + index + if src2 /== ESP then {^src1 0 ^src2}; + else + {^src2 0 ^src1}; + endif else ;;; base + displacement {% src1, asm_uselab(immval(src2)) %}; endif; @@ -1071,11 +1192,31 @@ if ismem(src1) and ismem(dst) then asmMOVL(src1, EAX ->> src1); endif; + if is_large_int(src1) then + asmMOVL(src1, altwkreg(src2) ->> src1); + endif; asm_op(src1, dst); else + if is_large_int(src1) and is_large_int(src2) then + if isreg(dst) then + altwkreg(dst) -> tmp; + asmMOVL(src1, dst); + asmMOVL(src2, tmp); + asm_op(tmp, dst); + else + asmMOVL(src1, EAX); + asmMOVL(src2, ECX); + asm_op(ECX, EAX); + asmMOVL(EAX, dst); + endif; + else /* {____src1 __/= ___dst _& ____src2 __/= ___dst} */ if ismem(src1) then (src1, src2) -> (src2, src1) endif; /* {__________~mem(src1) _| _________mem(src2)} */ + if is_large_int(src1) then (src1, src2) -> (src2, src1) endif; + +#_IF false + if isreg(dst) and dst /== reg_in_operand(src1) then dst -> tmp; elseif wkreg(src2) then @@ -1086,11 +1227,18 @@ else altwkreg(src1) -> tmp; endif; +#_ELSE + R9 -> tmp; +#_ENDIF if asm_op == asmADDL and not(set_flags) - and not(ismem(src1)) and not(ismem(src2)) + and not(ismem(src1)) and not(ismem(src2)) + and not(is_large_int(src2)) then /* {__________~mem(src1) _& __________~mem(src2) _& ________reg(tmp)} */ /* optimise move+add to lea */ +/* + if src2 == ESP then (src1, src2) -> (src2, src1) endif; +*/ gen_lea(src1, src2, tmp); asmMOVL(tmp, dst); else @@ -1100,6 +1248,7 @@ asmMOVL(tmp, dst); endif; endif; + endif; enddefine; define lconstant gen_add = gen_op_2(% asmADDL %) enddefine; @@ -1112,39 +1261,71 @@ ;;; When _________set_flags is true, the code planted must leave the flags set ;;; correctly for a subsequent test. +;;; global constant _print_addr; define lconstant gen_sub(src1, src2, dst); lvars src1, src2, dst, tmp; +;;; printf(src1, 'src1 = %p, '); +;;; printf(src2, 'src2 = %p, '); +;;; printf(dst, 'dst = %p\n'); +;;; printf('Moja pulapka\n'); +;;; _print_addr(dst) -> _; if src2 = dst then - if ismem(src1) and ismem(dst) then +;;; printf('src2 = dst\n'); + if ismem(src1) and ismem(dst) or + is_large_int(src1) then +;;; printf('asmMOVL(src1, EAX ->> src1);\n'); asmMOVL(src1, EAX ->> src1); endif; +;;; printf('asmSUBL(src1, dst);\n'); asmSUBL(src1, dst); elseif isreg(dst) and src1 == dst then +;;; printf('isreg(dst) and src1 == dst\n'); + if is_large_int(src2) then +;;; printf('asmMOVL(src2, R9 ->> src2);\n'); + asmMOVL(src2, R9 ->> src2); + endif; +;;; printf('asmSUBL(src2, dst);\n'); asmSUBL(src2, dst); +;;; printf('asmNEGL(dst);\n'); asmNEGL(dst); else +;;; printf('else\n'); if isreg(dst) and dst /== reg_in_operand(src1) then +;;; printf('isreg(dst) and dst /== reg_in_operand(src1)\n'); dst -> tmp; elseif wkreg(src2) then +;;; printf('wkreg(src2)\n'); src2 -> tmp; else +;;; printf('else: altwkreg(src1) -> tmp;\n'); altwkreg(src1) -> tmp; endif; - if not(set_flags) and isintegral(src1) and not(ismem(src2)) then + if is_large_int(src1) then +;;; printf('asmMOVL(src1, R9 ->> src1);'); + asmMOVL(src1, R9 ->> src1); + endif; + if not(set_flags) and isintegral(src1) and + not(is_large_int(src2)) and not(ismem(src2)) then /* {________________isintegral(src1) _& __________~mem(src2) _& ________reg(tmp)} */ ;;; negate src1 and optimise to lea +;;; printf('gen_lea(src2, -src1, tmp);\n'); gen_lea(src2, -src1, tmp); else /* {____src2 _= ___tmp _| ___tmp __/= ____________________reg_in_operand(src1)} */ +;;; printf('asmMOVL(src2, tmp);\n'); asmMOVL(src2, tmp); +;;; printf('asmSUBL(src1, tmp);\n'); asmSUBL(src1, tmp); if src1 == USP_+ and src2 == USP_+ then ;;; the subtraction operation will have gone the wrong way +;;; printf('asmNEGL(tmp);\n'); asmNEGL(tmp); endif; endif; +;;; printf('asmMOVL(tmp, dst);\n'); asmMOVL(tmp, dst); endif; +;;; printf('end of gen_sub\n'); enddefine; ;;; gen_mult: @@ -1345,9 +1526,34 @@ define lconstant gen_test_or_cmp(src1, src2, test, lab, gen_p); lvars src1, src2, test, lab, gen_p; +;;; printf(src1, src2, 'gen_test_or_cmp:\n %p\n %p\n'); + if isimm(src1) and isimm(src2) then + if isinteger(src2) or isbiginteger(src2) then + if (src2 < -2147483648) or (src2 > 2147483647) then + asmMOVL(src2, EAX ->> src2); + else + asmMOVL(src1, EAX ->> src1); + endif; + else + asmMOVL(src1, EAX ->> src1); + endif; + endif; + if isinteger(src1) or isbiginteger(src1) then + if (src1 < -2147483648) or (src1 > 2147483647) then +;;; printf('loading big constant to register\n'); + asmMOVL(src1, altwkreg(src2) ->> src1); + endif; + endif; + if isinteger(src2) or isbiginteger(src2) then + if src2 < -2147483648 or src2 > 2147483647 then +;;; printf('loading big constant to register\n'); + asmMOVL(src2, altwkreg(src1) ->> src2); + endif; + endif; if ismem(src1) and ismem(src2) or isimm(src1) and isimm(src2) then asmMOVL(src1, altwkreg(src2) ->> src1); endif; + if isimm(src1) or ismem(src2) then ;;; ____src1 can't be an immediate operand; ;;; also, if there's a memory operand in the test it's better @@ -1457,9 +1663,11 @@ ;;; or if it's a POP integer we want (table_start + src - 3) lvars target; if sysint then - {% false, table_start, src, 4 %} + {% false, table_start, src, 8 %} else - {% src, asm_expr(table_start, "-", 3) %} +;;; {% src, asm_expr(table_start, "-", 3) %} +;;; printf('gen_switch on pop integer'); + {% false, asm_expr(table_start, "-", 6), src, 2 %} endif -> target; asmJMP(conspair(target, 0)); ;;; Plant the table; it begins with -else_lab- to account for the 0 case @@ -1493,11 +1701,11 @@ ;;; M_BRANCH_std: ;;; same as M_BRANCH, but guarantees to produce an instruction of a ;;; fixed size. That's not directly available from 386 assembler, so -;;; we simulate it by moving the label to a register (= 5 bytes) and +;;; we simulate it by moving the label to a register (= 7 bytes) and ;;; then jumping off that define M_BRANCH_std(); - asmMOVL(immrep(m_instr(2)), EAX); ;;; movl $L, %eax (5 bytes) + asmMOVL(immrep(m_instr(2)), EAX); ;;; movl $L, %eax (7 bytes) asmJMP(conspair(EAX, 0)); ;;; jmp *%eax (2 bytes) enddefine; @@ -1592,7 +1800,9 @@ dlocal_labs, ;;; Names of dynamic local variables + regmask, Nstkvars, + Nregs, ;;; Number of on-stack vars ; @@ -1602,17 +1812,32 @@ define M_CREATE_SF(); lconstant popint_zero = popint(0); - lvars reg_spec_id, Npopstkvars, reg_locals; + lvars reg_spec_id, Npopregs, Npopstkvars, reg_locals, n; explode(m_instr) -> reg_spec_id -> dlocal_labs -> Npopstkvars - -> Nstkvars -> /* Npopregs */ -> reg_locals -> ; + -> Nstkvars -> Npopregs -> reg_locals -> ; +/* ;;; Check there are no register locals and set the register spec to zero unless null(reg_locals) then mishap(reg_locals, 1, 'UNEXPECTED REGISTER LOCALS'); endunless; +*/ 0 -> idval(reg_spec_id); + listlength(reg_locals) -> Nregs; + + ;;; create register mask from reg locals + 0 -> regmask; + fast_for n in reg_locals do regmask || (1 << n) -> regmask endfast_for; + + ;;; Save registers + for n from 8 to 15 do + if regmask &&/=_0 (1 << n) then + asmPUSHL(reglabel(n)); + endif; + endfor; + ;;; Set the procedure base register asmMOVL(immrep(current_pdr_label), PB); ;;; Push dynamic locals @@ -1621,7 +1846,7 @@ repeat Npopstkvars times asmPUSHL(popint_zero) endrepeat; ;;; Allocate non-POP on-stack lvars (uninitialised) if Nstkvars /== Npopstkvars then - asmSUBL((Nstkvars - Npopstkvars) * 4, SP); + asmSUBL((Nstkvars - Npopstkvars) * 8, SP); endif; ;;; Push the owner address asmPUSHL(PB); @@ -1631,12 +1856,21 @@ ;;; plant code to unwind a procedure stack frame define M_UNWIND_SF(); + lvars n; ;;; Remove owner address and on-stack vars (POP and non-POP) - asmADDL((Nstkvars + 1) * 4, SP); + asmADDL((Nstkvars + 1) * 8, SP); ;;; Pop dynamic locals applist(rev(dlocal_labs), asmPOPL); + ;;; restore registers + + for n from 15 by -1 to 8 do + if regmask &&/=_0 (1 << n) then + asmPOPL(reglabel(n)); + endif; + endfor; + ;;; Restore procedure base register from previous owner address - asmMOVL({^SP 4}, PB); + asmMOVL({^SP 8}, PB); enddefine; endlblock; @@ -1666,10 +1900,10 @@ ;;; get closure address in EAX asmMOVL(immrep(current_pdr_label), EAX); ;;; push the frozvals - lconstant frozval_offset = field_##("PD_CLOS_FROZVALS").wof - 4; + lconstant frozval_offset = field_##("PD_CLOS_FROZVALS").wof - 8; lvars i; for i to nfroz do - asmMOVL({% EAX, frozval_offset + i*4 %}, ECX); + asmMOVL({% EAX, frozval_offset + i*8 %}, ECX); asmMOVL(ECX, -_USP); endfor; unless pdpart_opd then diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/m_optimise.p v15.6301-amd64/pop/src/syscomp/m_optimise.p --- v15.63/pop/src/syscomp/m_optimise.p 1998-04-29 11:12:54.000000000 -0400 +++ v15.6301-amd64/pop/src/syscomp/m_optimise.p 2005-03-11 05:30:40.000000000 -0500 @@ -232,8 +232,12 @@ [^T_SGN_BYTE {^M_MOVEsb ^M_UPDb} ] [^T_SHORT {^M_MOVEs ^M_UPDs} ] [^T_SGN_SHORT {^M_MOVEss ^M_UPDs} ] + [^T_INT {^M_MOVEi ^M_UPDi}] + [^T_SGN_INT {^M_MOVEsi ^M_UPDi}] [^T_WORD {^M_MOVE ^M_MOVE} ] + [^T_INT_DOUBLE {^M_MOVE ^M_MOVE} ] ]); +;;; printf(acctype, 'typed_move_instr: acctype = %p\n'); type_m_opcode(acctype) -> op; if upd then f_subv(2,op) else f_subv(1,op) endif -> op; #_ENDIF @@ -270,6 +274,7 @@ f_hd(m_codelist) -> inst; f_subv(1, inst) -> opcode; +;;; printf(opcode, inst, 'get_moves if: \n inst = %p\n opcode = %p\n'); if isstring(pdprops(opcode) ->> x) and f_subs(1, x) == `%` then ;;; pseudo-op opcode(m_codelist, mustconvert) -> m_codelist; @@ -279,6 +284,7 @@ returnif(opcode == x); ;;; didn't convert true -> got_one endif; +;;; printf('get_moves endif\n'); if (arithop1(opcode) ->> l) and isintegral(inst(2)) then l(inst(2)) -> y, inst(3) -> z @@ -471,8 +477,11 @@ lvars mustconvert, push_precedes; dlocal m_codelist; repeat +;;; printf('premove\n'); premove(m_codelist, push_precedes); +;;; printf('postmove\n'); postmove(m_codelist, false); +;;; printf('get_moves\n'); quitunless(get_moves(m_codelist, mustconvert) -> m_codelist) endrepeat; if mustconvert then postmove(m_codelist, true) endif @@ -570,6 +579,7 @@ lvars i; m_codelist -> org_m_codelist; until m_codelist == [] do +;;; printf(hd(m_codelist), 'm_optimise: %p\n'); if f_subv(1, f_hd(m_codelist)) /== M_LABEL then do_premove(m_codelist, true, false) -> m_codelist; if finalimprove(f_hd(m_codelist)) ->> i then @@ -680,6 +690,7 @@ %] . replace_current else ;;; non bitfield +;;; printf('OP_!\n'); get_access_type(type_code) -> acctype; if offs_index /== 0 then if indexscale /== 1 then diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/m_trans.p v15.6301-amd64/pop/src/syscomp/m_trans.p --- v15.63/pop/src/syscomp/m_trans.p 1998-03-25 09:22:57.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/m_trans.p 2009-12-24 15:33:20.000000000 -0500 @@ -2094,7 +2094,7 @@ endunless; #_ENDIF - if pd_frame_len > 16:FF then + if pd_frame_len > MAX_STACK_FRAME_SIZE then mishap(p, 1, 'PROCEDURE STACK FRAME TOO LARGE (too many lvars)') endif; @@ -2181,8 +2181,19 @@ 2); asm_outshort(reg_spec, 1); ;;; PD_REGMASK - - asm_outbyte( +#_IF DEF FRAME_LEN_16BIT + asm_outshort(0, 1); + asm_outshort +#_ELSE +#_IF DEF FRAME_LEN_32BIT + asm_outshort(0, 1); + asm_outint(0, 1); + asm_outint +#_ELSE + asm_outbyte +#_ENDIF +#_ENDIF + ( ;;; stack frame length in words pd_frame_len, ;;; PD_FRAME_LEN ;;; see above diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/mcdata.p v15.6301-amd64/pop/src/syscomp/mcdata.p --- v15.63/pop/src/syscomp/mcdata.p 1995-08-24 13:17:32.000000000 -0400 +++ v15.6301-amd64/pop/src/syscomp/mcdata.p 2009-12-24 15:32:59.000000000 -0500 @@ -107,6 +107,15 @@ endsection; /* $- */ +constant macro MAX_STACK_FRAME_SIZE = + #_IF DEF FRAME_LEN_16BIT + 16:FFFF + #_ELSEIF DEF FRAME_LEN_32BIT + 16:FFFFFFFF + #_ELSE + 16:FF + #_ENDIF; + section $-Popas; constant macro ( Only in v15.6301-amd64/pop/src/syscomp: new diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/os_comms.p v15.6301-amd64/pop/src/syscomp/os_comms.p --- v15.63/pop/src/syscomp/os_comms.p 2007-09-10 15:50:14.000000000 -0400 +++ v15.6301-amd64/pop/src/syscomp/os_comms.p 2009-12-24 15:48:52.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2007. All rights reserved. ---------- +/* --- Copyright University of Sussex 1999. All rights reserved. ---------- > File: C.unix/src/syscomp/os_comms.p > Purpose: > Author: John Gibson (see revisions) @@ -120,23 +120,12 @@ if exlink then out_obj_files(wobj_files) else - - ;;; Altered by A.S. to produce a 'sh' file. 4 Jan 2005 - ;;; Altered by A.S. to produce a 'bash' file. 10 Sep 2007 - ;;; asmf_pr('#!/bin/csh -f\n'); - ;;; asmf_pr('#!/bin/sh\n'); - asmf_pr('#!/bin/bash\n'); - - ;;; asmf_printf(image_name, 'set IM=$1; if $IM == "" set IM=%p\n'); - asmf_printf(image_name, 'IM=$1\n if [ ! ${IM} ]; then IM=%p ; fi\n'); + asmf_pr('#!/bin/sh\n'); + asmf_printf(image_name, 'IM=$1\nIM=${IM:-%p}\n'); #_IF DEF cc_link_command_header ;;; Using C compiler to link (uses $POP__cc as command) - ;;; asmf_pr('if ! $?POP__cc set POP__cc=cc\n'); - asmf_pr('if [ ! ${POP__cc} ]; then POP__cc=cc; fi\n'); - - ;;; shell-neutral bits follow. - + asmf_pr('POP__cc=${POP__cc:-cc}\n'); asmf_pr(cc_link_command_header); for f in link_flags do asmf_printf(f, '-Wl,%p \\\n') endfor; out_obj_files(wobj_files); @@ -167,13 +156,6 @@ ;;; any X libraries) nl_printf('-lpop'); - ;;; A.S. 1 Nov 2003 - ;;; If motif included make it come before other X stuff, so that - ;;; correct version can be linked to popxternlib/libXm.so - if member('-lXm', link_other) then - nl_printf('-lXm'); - delete('-lXm', link_other) -> link_other; - endif; out_obj_files(link_other); ;;; standard libraries @@ -197,13 +179,11 @@ endif); unless exlink then - ;;; asmf_pr('set ST = $status\n'); - asmf_pr('ST=$status\n'); + asmf_pr('ST=$?\n'); if cleanup_command then asmf_printf(cleanup_command, '%p\n') endif; if makebase then - ;;; asmf_pr('if ($ST == 0) rm -f $IM.stb\n') - asmf_pr('if [[ $ST == 0 ]]; then rm -f $IM.stb ; fi\n') + asmf_pr('if [ $ST == 0 ] ; then rm -f $IM.stb ; fi\n') endif; asmf_pr('exit $ST\n') endunless; @@ -329,110 +309,97 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, Sep 10 2007 - Altered to create a bash script header instead of sh for $popsys/poplink_cmnd ---- Aaron Sloman, Jan 4 2005 - Changed gen_link_command to produce a version of $popsys/poplink_cmnd - that uses 'sh' syntax rather than 'csh', because not all linux systems - now come with csh or tcsh installed, which prevents re-linking. ---- Aaron Sloman, Dec 31 2004 - Altered gen_link_command so that if motif is included it uses a link to - the appropriate file is made in - $popexternlib/libXm.so - e.g. in case there is not a libXm.so link in /usr/X11R6/lib - This requires the installation scripts to insert the link in - $popexternlib --- John Gibson, Apr 9 1999 - Made out_obj_files convert -R to appropriate -rpath args - for Linux + Made out_obj_files convert -R to appropriate -rpath args + for Linux --- Julian Clinton, Aug 7 1998 - Add '-lmw' for NCR. + Add '-lmw' for NCR. --- Robert Duncan, Jul 2 1998 - Allowed for extra libraries in HP-UX link command + Allowed for extra libraries in HP-UX link command --- Robert Duncan, Jun 05 1998 - Added libgen to link command for DG/UX (used at least by libXm) + Added libgen to link command for DG/UX (used at least by libXm) --- Robert Duncan, Aug 13 1996 - Added libgen to link command for NCR (used at least by libXm) + Added libgen to link command for NCR (used at least by libXm) --- John Gibson, Dec 7 1995 - Now allows env vars POP__as, POP__ar and POP__crt0 (if set) to - override AS_CMD, AR_CMD and unix_ld_crt_objects + Now allows env vars POP__as, POP__ar and POP__crt0 (if set) to + override AS_CMD, AR_CMD and unix_ld_crt_objects --- John Gibson, Mar 10 1995 - OSF changes + OSF changes --- Poplog System, Jan 18 1995 (Julian Clinton) - Set options for Linux and SCO Open Desktop 3.0. + Set options for Linux and SCO Open Desktop 3.0. --- Robert John Duncan, Mar 21 1994 - Changes for SG IRIX 5+ + Changes for SG IRIX 5+ --- John Gibson, Nov 19 1993 - Changed gen_link_command to take ______exlink arg to say just produce - file containing object/library args + Changed gen_link_command to take ______exlink arg to say just produce + file containing object/library args --- John Gibson, Nov 13 1993 - -lpop now the only pop library in link command + -lpop now the only pop library in link command --- John Gibson, Aug 30 1993 - Replaced run*_poplink with run_comp_util + Replaced run*_poplink with run_comp_util --- John Gibson, Jul 10 1993 - Added ________makebase argument to gen_link_command and assemble_and_link + Added ________makebase argument to gen_link_command and assemble_and_link --- Robert John Duncan, Jun 11 1993 - Changed gen_link_command to write out explicit references to the pop - external libraries using the '-L' and '-l' options to ld and made it - take an additional argument -- _____________extern_libdir -- which is the - directory containing the libraries as determined by poplink. This is - necessary when the libraries are shared, because they may not be in - the same directory when the image is run. - Also tidied up references to the crt*.o files -- their location can - now be specified by defining unix_ld_crt_objects in "asmout.p". + Changed gen_link_command to write out explicit references to the pop + external libraries using the '-L' and '-l' options to ld and made it + take an additional argument -- _____________extern_libdir -- which is the + directory containing the libraries as determined by poplink. This is + necessary when the libraries are shared, because they may not be in + the same directory when the image is run. + Also tidied up references to the crt*.o files -- their location can + now be specified by defining unix_ld_crt_objects in "asmout.p". --- Simon Nichols, Jun 2 1993 - Removed addition of -ldl/-ldld to link command -- now done with - a dummy exload in src/unixextern.p. + Removed addition of -ldl/-ldld to link command -- now done with + a dummy exload in src/unixextern.p. --- Robert John Duncan, Jun 2 1993 - Changes for SVR4 + Changes for SVR4 --- John Gibson, May 23 1993 - Removed addition of -lt*ermcap to link command -- now done with - a dummy exload in src/termcap.p. + Removed addition of -lt*ermcap to link command -- now done with + a dummy exload in src/termcap.p. --- John Gibson, May 14 1993 - Added _______________cleanup_command arg to gen_link_command + Added _______________cleanup_command arg to gen_link_command --- John Gibson, May 6 1993 - Removed addition of c_c*ore.obj from gen_link_command -- this is - now part of $popexternlib/libpop.olb. + Removed addition of c_c*ore.obj from gen_link_command -- this is + now part of $popexternlib/libpop.olb. --- Simon Nichols, Mar 2 1993 - Changed location of crt?.o in Solaris 2.1 + Changed location of crt?.o in Solaris 2.1 --- Simon Nichols, Jan 29 1993 - Changed name of conditional compilation flag SU*NOS_DYNAMIC to - SHARED_LIBRARIES, as it's more descriptive and not SunOS specific. - Added support for shared libraries on HP-UX. + Changed name of conditional compilation flag SU*NOS_DYNAMIC to + SHARED_LIBRARIES, as it's more descriptive and not SunOS specific. + Added support for shared libraries on HP-UX. --- John Gibson, Oct 20 1992 - Changed os_library_command to hash-encode module names longer - than 14 chars + Changed os_library_command to hash-encode module names longer + than 14 chars --- Robert John Duncan, Jul 24 1992 - Changed location of commands for SunOS 5.0 and the list of - libraries to be given to ld + Changed location of commands for SunOS 5.0 and the list of + libraries to be given to ld --- Robert John Duncan, Jul 21 1992 - Added SYSTEM_V to list of systems which don't need ranlib + Added SYSTEM_V to list of systems which don't need ranlib --- Simon Nichols, Mar 3 1992 - Changes to support SunOS dynamic linking (temporarily flagged by - SU*NOS_DYNAMIC). + Changes to support SunOS dynamic linking (temporarily flagged by + SU*NOS_DYNAMIC). --- Robert John Duncan, Jun 24 1991 - Added code for SG IRIX + Added code for SG IRIX --- John Gibson, Jan 21 1991 - Added -share- arg to -gen_link_command- + Added -share- arg to -gen_link_command- --- John Gibson, Nov 22 1990 - Changed malloc.o to c_c*ore.obj + Changed malloc.o to c_c*ore.obj --- John Gibson, Nov 22 1990 --- John Gibson, Sep 27 1990 - Replaced calls of -interrupt- with mishaps + Replaced calls of -interrupt- with mishaps --- Rob Duncan, May 31 1990 - Added non-standard run-time library for DECSTATION + Added non-standard run-time library for DECSTATION --- John Gibson, May 10 1990 - Made $popsrc/malloc.o be systranslated (so it gets current - value of $popsrc). + Made $popsrc/malloc.o be systranslated (so it gets current + value of $popsrc). --- Rob Duncan, May 8 1990 - Added patch for MIPS and funny runtime libraries for MIPS/RISCOS + Added patch for MIPS and funny runtime libraries for MIPS/RISCOS --- Rob Duncan, Nov 7 1989 - Added t*ermcap library ('-lt*ermcap') to end of link command + Added t*ermcap library ('-lt*ermcap') to end of link command --- John Gibson, Aug 4 1989 - Version 13.66+ + Version 13.66+ --- John Gibson, Jul 24 1989 - -os_library_command- moved here from poplibr_main.p + -os_library_command- moved here from poplibr_main.p --- John Gibson, Jul 17 1989 - Extracted from Unix versions of asmout.p - Added -run*_poplink- + Extracted from Unix versions of asmout.p + Added -run*_poplink- */ Only in v15.6301-amd64/pop/src/syscomp: os_comms.p.adm64.orig Only in v15.6301-amd64/pop/src/syscomp: os_comms.p.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/poplink_main.p v15.6301-amd64/pop/src/syscomp/poplink_main.p --- v15.63/pop/src/syscomp/poplink_main.p 2005-01-04 09:45:04.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/poplink_main.p 2005-03-11 05:30:40.000000000 -0500 @@ -191,7 +191,7 @@ define lconstant gen_clos(lab_list, nargs, upd, pdpt, frozl); lvars f, lab_list, nargs, upd, len_lab, pdpt, frozl, - nfroz = listlength(frozl), len = 7+nfroz; + nfroz = listlength(frozl), len = 5+nfroz; asm_outword(props, ;;; PD_PROPS asm_symlabel('procedure_key'), ;;; KEY @@ -1308,6 +1308,8 @@ DATA -> asmf_charout_seg; out_objmod_pad(-1); asm_outglab(asm_symlabel('Sys$-\^_data_seg_end')); + ;;; Make sure the label does not jump to the next file + asm_outword(0, 1); endfile(fileout_4, true); Only in v15.6301-amd64/pop/src/syscomp: poplink_main.p.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/symdefs.p v15.6301-amd64/pop/src/syscomp/symdefs.p --- v15.63/pop/src/syscomp/symdefs.p 1997-03-05 10:35:08.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/symdefs.p 2009-12-24 15:32:15.000000000 -0500 @@ -131,6 +131,26 @@ word K_END_V[0]; ;;; dummy field to get word length of key }; +#_IF DEF FRAME_LEN_16BIT +deftype + stk_off_t = short; +constant macro PD_FRAME_SPARE = [ short PD_FRAME_SPARE_S ; ] ; +#_ELSE +#_IF DEF FRAME_LEN_32BIT +deftype + stk_off_t = int; +constant macro PD_FRAME_SPARE = [ + short PD_FRAME_SPARE_S ; + int PD_FRAME_SPARE_I; +] ; +#_ELSE +deftype + stk_off_t = byte; +constant macro PD_FRAME_SPARE = [] ; +#_ENDIF +#_ENDIF + + constant macro ( ;;; start of all procedures @@ -150,7 +170,8 @@ byte PD_FLAGS2, ;;; second flags byte PD_SPARE; ;;; currently unused short PD_REGMASK; ;;; mask for register locals - byte PD_FRAME_LEN, ;;; total size of stack frame in words + PD_FRAME_SPARE + stk_off_t PD_FRAME_LEN, ;;; total size of stack frame in words PD_GC_OFFSET_LEN, ;;; word index from frame pointer to lowest addr lword for gc scan PD_GC_SCAN_LEN, ;;; no of stack frame words for gc scan PD_NUM_STK_VARS, ;;; no of stack allocated locals diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/sysdefs.p v15.6301-amd64/pop/src/syscomp/sysdefs.p --- v15.63/pop/src/syscomp/sysdefs.p 2005-01-06 11:43:11.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/sysdefs.p 2009-12-26 11:41:20.000000000 -0500 @@ -29,17 +29,24 @@ ;;; Values for machine and C data types are defined in mcdata.p, ;;; and can be overidden here if necessary + WORD_BITS = 64, + +;;; POPINT_BITS = 62, + POPINT_BITS = 61, + SHORT_ALIGN_BITS = 8, ;;; alignment in bits for short access INT_ALIGN_BITS = 8, ;;; alignment in bits for int access DOUBLE_ALIGN_BITS = 8, ;;; alignment in bits for double access STRUCT_SHORT_ALIGN_BITS = 16, ;;; bit alignment for short STRUCT_INT_ALIGN_BITS = 32, ;;; bit alignment for int - STRUCT_DOUBLE_ALIGN_BITS = 32, ;;; bit alignment for double + STRUCT_DOUBLE_ALIGN_BITS = 64, ;;; bit alignment for double CODE_POINTER_TYPE = "byte", ;;; type of pointer to machine code BIT_POINTER_TYPE = "byte", ;;; type of pointer for bitfield access + ;;; FRAME_LEN_32BIT = true, + ;;; === OPERATING SYSTEM (UNIX BSD) ================================== @@ -53,6 +60,9 @@ SHARED_LIBRARIES = true, + BSD_MMAP = true, ;;; has -mmap- and -mprotect- facilities + BSD_MPROTECT = true, + VPAGE_OFFS = 4096, ;;; word address offset of a virtual page ;;; LOWEST_ADDRESS: @@ -61,7 +71,7 @@ ;;; UNIX_USRSTACK: ;;; ???? - UNIX_USRSTACK = 16:FC000000, + UNIX_USRSTACK = 16:FC0000000, ;;; Procedures to get and set the memory break and return the REAL end of ;;; memory. (We always need the real end to ensure that the end of the @@ -104,7 +114,7 @@ ;;; Include M-code listing in assembly language files - M_DEBUG = false, + M_DEBUG = true, ); @@ -113,6 +123,8 @@ /* --- Revision History --------------------------------------------------- +--- Aaron Sloman, Mar 13 2005 + Patch for AMD64 poplog provided by Waldek Hebisch --- Aaron Sloman, Jan 6 2005 Changed to set C_FLOAT_RESULT_SINGLE = false, to fix bug in invocations of external programs returning single Only in v15.6301-amd64/pop/src/syscomp: sysdefs.p.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/sysdefs_linux_elf.p v15.6301-amd64/pop/src/syscomp/sysdefs_linux_elf.p --- v15.63/pop/src/syscomp/sysdefs_linux_elf.p 2005-01-06 11:43:11.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/sysdefs_linux_elf.p 2005-03-11 05:30:40.000000000 -0500 @@ -29,13 +29,17 @@ ;;; Values for machine and C data types are defined in mcdata.p, ;;; and can be overidden here if necessary + WORD_BITS = 64, + + POPINT_BITS = 62, + SHORT_ALIGN_BITS = 8, ;;; alignment in bits for short access INT_ALIGN_BITS = 8, ;;; alignment in bits for int access DOUBLE_ALIGN_BITS = 8, ;;; alignment in bits for double access STRUCT_SHORT_ALIGN_BITS = 16, ;;; bit alignment for short STRUCT_INT_ALIGN_BITS = 32, ;;; bit alignment for int - STRUCT_DOUBLE_ALIGN_BITS = 32, ;;; bit alignment for double + STRUCT_DOUBLE_ALIGN_BITS = 64, ;;; bit alignment for double CODE_POINTER_TYPE = "byte", ;;; type of pointer to machine code BIT_POINTER_TYPE = "byte", ;;; type of pointer for bitfield access @@ -53,6 +57,9 @@ SHARED_LIBRARIES = true, + BSD_MMAP = true, ;;; has -mmap- and -mprotect- facilities + BSD_MPROTECT = true, + VPAGE_OFFS = 4096, ;;; word address offset of a virtual page ;;; LOWEST_ADDRESS: @@ -61,7 +68,7 @@ ;;; UNIX_USRSTACK: ;;; ???? - UNIX_USRSTACK = 16:FC000000, + UNIX_USRSTACK = 16:FC0000000, ;;; Procedures to get and set the memory break and return the REAL end of ;;; memory. (We always need the real end to ensure that the end of the @@ -104,7 +111,7 @@ ;;; Include M-code listing in assembly language files - M_DEBUG = false, + M_DEBUG = true, ); Only in v15.6301-amd64/pop/src/syscomp: sysdefs_linux_elf.p.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/syspop.p v15.6301-amd64/pop/src/syscomp/syspop.p --- v15.63/pop/src/syscomp/syspop.p 1997-03-08 12:35:35.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/syspop.p 2005-03-11 05:30:40.000000000 -0500 @@ -1353,7 +1353,7 @@ match_struct_init(init, type_spec, base_p, false, false, false) + offset -> offset else - struct_err(init, 1, 'illegal initialisation for field') + struct_err(type_spec, init, 2, 'illegal initialisation for field') endif enddefine; /* match_spec_init */ @@ -1457,7 +1457,7 @@ false endif; unless () then - struct_err(init, 1, 'illegal initialisation for field') + struct_err(type_code, init, 2, 'illegal initialisation for field') endunless; ;;; result is a pair -- see :GEN free_struct diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscomp/w_util.p v15.6301-amd64/pop/src/syscomp/w_util.p --- v15.63/pop/src/syscomp/w_util.p 1995-11-10 09:15:14.000000000 -0500 +++ v15.6301-amd64/pop/src/syscomp/w_util.p 2009-12-30 14:27:21.000000000 -0500 @@ -179,7 +179,7 @@ */ define word_dict_cell(word); lvars string = fast_word_string(word), len = datalength(string), word; - +#_IF false if len fi_> 2 then ;;; use first, middle and last chars and length f_subs(1,string) fi_+ len @@ -195,7 +195,29 @@ else 0 endif -> len; - (len fi_&& 16:3FF) fi_+ 1 +#_ELSE + lvars res = len, i = 1; + while len fi_> 3 do + (f_subs(i, string) fi_+ (f_subs(i fi_+ 1, string) fi_<< 8) + fi_+ (f_subs(i fi_+ 2, string) fi_<< 16)) + + (f_subs(i fi_+ 3, string) << 24) + res -> res; + len fi_- 4 -> len; + i fi_+ 4 -> i; + endwhile; + if len == 3 then + (f_subs(i, string) fi_+ (f_subs(i fi_+ 1, string) fi_<< 8) + fi_+ (f_subs(i fi_+ 2, string) fi_<< 16)) + + res -> res; + elseif len == 2 then + (f_subs(i, string) fi_+ (f_subs(i fi_+ 1, string) fi_<< 8)) + + res -> res; + elseif len == 1 then + f_subs(i, string) + res -> res; + endif; + ;;; Mix bits + ((res && 16:FFFE0000) >> 17) ||/& res -> res; +#_ENDIF + (res && 16:3FF) fi_+ 1 enddefine; define path_index_cell(pathstr, word); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syscreate.p v15.6301-amd64/pop/src/syscreate.p --- v15.63/pop/src/syscreate.p 1997-03-08 08:26:31.000000000 -0500 +++ v15.6301-amd64/pop/src/syscreate.p 2005-03-11 05:30:39.000000000 -0500 @@ -51,7 +51,7 @@ endif -> ; _statb!ST_MODE -> _mode; - if _neg(_extern[NI] access(_file, _2)) then + if ((_extern[NI] access(_file, _2)) _gr _2147483647) then Set_enotdir(file); if _ERRNO == _:ENOENT then 0 ;;; doesn't exist diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sysdate.p v15.6301-amd64/pop/src/sysdate.p --- v15.63/pop/src/sysdate.p 1998-03-26 09:42:57.000000000 -0500 +++ v15.6301-amd64/pop/src/sysdate.p 2005-03-11 05:30:39.000000000 -0500 @@ -21,6 +21,9 @@ #_IF DEFV SUNOS < 5.0 or DEF OSF1 or DEFV ULTRIX >= 4.0 lconstant macro USE_TM_ZONE = true; #_ELSEIF DEF SYSTEM_V or DEF HPUX or DEF LINUX or DEF AIX +#_IF DEF LINUX +lconstant macro USE_TM_ZONE = true; +#_ENDIF lconstant macro TZNAME = [tzname:data]; ;;; Timezone name for System V systems #_ELSEIF DEF IRIX lconstant macro TZNAME = [_tzname:data]; ;;; Timezone name for System V systems @@ -53,6 +56,8 @@ lvars seconds, local_time, _tzlen, _tzone, _date_addr, _timep; lstackmem time_t _secs, byte _buf[128]; +;;; _extern printf('before Check_integral') -> _; +;;; _extern fflush(_0) -> _; Check_integral(seconds); #_IF EXCEEDS_POPINT_SIGNED(time_t) Pint_->_sint @@ -61,11 +66,18 @@ #_ENDIF (seconds, _MOST_POSITIVE_SIGNED(time_t)) -> _secs!(time_t); if local_time then +;;; _extern printf('before localtime') -> _; +;;; _extern fflush(_0) -> _; _extern localtime(_secs) else +;;; _extern printf('before gmtime') -> _; +;;; _extern fflush(_0) -> _; _extern gmtime(_secs) endif -> _timep; +;;; _extern printf('before asctime') -> _; +;;; _extern fflush(_0) -> _; + _extern asctime(_timep) -> _date_addr; ;;; get timezone name @@ -75,13 +87,21 @@ #_ELSEIF DEF TZNAME ;;; get it from tzname -- 1st word is timezone, 2nd is dst timezone if _zero(_timep!TM_ISDST) then +;;; _extern printf('before TZNAME!((b))[_0]') -> _; +;;; _extern fflush(_0) -> _; + _extern TZNAME!((b))[_0] else +;;; _extern printf('before TZNAME!((b))[_1]') -> _; +;;; _extern fflush(_0) -> _; _extern TZNAME!((b))[_1] endif -> _tzone; #_ELSEIF DEF BERKELEY lstackmem struct TIMEVAL _tvp; +;;; _extern printf('before gettimeofday') -> _; +;;; _extern fflush(_0) -> _; + _extern gettimeofday(_tvp, _buf) -> ; _extern timezone(_buf!TZN_MINUTESWEST, _timep!TM_ISDST) -> _tzone; @@ -89,6 +109,9 @@ #_ENDIF ;;; move timezone name into date -- 24 chars ignores the newline etc +;;; _extern printf('before _bmove') -> _; +;;; _extern fflush(_0) -> _; + _bmove(@@(b)[_24], _date_addr, _buf) -> ; ;;; insert timezone string ##(b){_locc(_tzone, @@(b)[_128], _0)} -> _tzlen; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sysfork.p v15.6301-amd64/pop/src/sysfork.p --- v15.63/pop/src/sysfork.p 1995-08-26 11:08:59.000000000 -0400 +++ v15.6301-amd64/pop/src/sysfork.p 2005-03-11 05:30:39.000000000 -0500 @@ -82,7 +82,7 @@ _extern pop_fork() -> _child_id; - if _neg(_child_id) then + if (_child_id) _gr 2147483647 then Syserr_mishap(0, 'UNABLE TO FORK') elseif _zero(_child_id) then ;;; the child @@ -188,7 +188,7 @@ ##(csword){_call_stack_hi, _vf_tmp} -> _vf_stk@(struct VFRET)[_vf_n]!CSTKLEN; - if _neg(_do_vfork()) then + if (_do_vfork()) _gr _2147483647 then unless _vfork_child then _extern _pop_sigmask(_0) -> endunless; Syserr_mishap(0, 'UNABLE TO VFORK') endif; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sysio.p v15.6301-amd64/pop/src/sysio.p --- v15.63/pop/src/sysio.p 1995-11-29 08:06:31.000000000 -0500 +++ v15.6301-amd64/pop/src/sysio.p 2005-03-11 05:30:39.000000000 -0500 @@ -40,7 +40,7 @@ _extern[NI] pop_close(_stdfd) -> else ;;; try to keep old standard file open under another descriptor - if _nonneg(_extern[NI] fcntl(_stdfd, _F_DUPFD, _3) ->> _tmp) then + if (_extern[NI] fcntl(_stdfd, _F_DUPFD, _3) ->> _tmp) _lteq _2147483647 then _tmp -> std_dev!D_FILE_DESC; _extern[NI] fcntl(_tmp, _F_SETFD, _1) -> ; ;;; set close-on-exec _extern[NI] pop_close(_stdfd) -> diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sysisdirectory.p v15.6301-amd64/pop/src/sysisdirectory.p --- v15.63/pop/src/sysisdirectory.p 1997-03-08 09:15:01.000000000 -0500 +++ v15.6301-amd64/pop/src/sysisdirectory.p 2005-03-11 05:30:39.000000000 -0500 @@ -20,7 +20,7 @@ _CLAWBACK_SAVE; sysfileok(path, false) -> path; if datalength(path) == 0 then '.' -> path endif; - _nonneg(_extern[NI] stat(Encode_sys(path,_nbuf), _statb)) + _extern[NI] stat(Encode_sys(path,_nbuf), _statb) _lteq _2147483647 and _statb!ST_MODE _bimask _STM_IFMT == _STM_IFDIR; Clawback(0) -> enddefine; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syslink.p v15.6301-amd64/pop/src/syslink.p --- v15.63/pop/src/syslink.p 1997-03-08 09:33:33.000000000 -0500 +++ v15.6301-amd64/pop/src/syslink.p 2005-03-11 05:30:39.000000000 -0500 @@ -26,7 +26,7 @@ define sysunlink() with_nargs 1; lvars file = Symlink_target(); lstackmem stackbuff _nbuf; - while _neg(_extern unlink(Encode_sys(file,_nbuf))) do + while (_extern unlink(Encode_sys(file,_nbuf))) _gr _2147483647 do if _ERRNO == _:EINTR then _CHECKINTERRUPT; nextloop endif; Set_enotdir(file); returnif(_ERRNO == _:ENOENT) (false); @@ -59,7 +59,7 @@ Symlink_target(file1, _flags _bitst _2:01) -> file1; Symlink_target(file2, _flags _bitst _2:10) -> file2; - while _neg(try_link(file1, Encode_sys(file2,_nbuf2))) do + while (try_link(file1, Encode_sys(file2,_nbuf2))) _gr _2147483647 do if _ERRNO == _:EINTR then _CHECKINTERRUPT; nextloop endif; Set_enotdir(file1); Set_enotdir(file2); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sysopen.p v15.6301-amd64/pop/src/sysopen.p --- v15.63/pop/src/sysopen.p 1997-03-10 09:06:52.000000000 -0500 +++ v15.6301-amd64/pop/src/sysopen.p 2005-03-11 05:30:39.000000000 -0500 @@ -51,7 +51,7 @@ if _ERRNO == _:ENOENT then ;;; check whether it's because the directory doesn't exist Fname_path(file, true) -> file; - if _neg(_extern[NI] access(Encode_sys(file,_nbuf), _0)) then + if (_extern[NI] access(Encode_sys(file,_nbuf), _0)) _gr _2147483647 then _:ENOTDIR -> _ERRNO endif endif @@ -75,7 +75,8 @@ procedure; lstackmem stackbuff _obuf; lvars _len = _extern readlink((), _obuf, _:SIZEOF(stackbuff)); - _nonneg(_len) and Consstring_bptr(_obuf, _len, CSB_LSTACKMEM) + /* _nonneg(_len) */ (_len _lteq _2147483647) + and Consstring_bptr(_obuf, _len, CSB_LSTACKMEM) endprocedure( Encode_sys(target,_nbuf) ) -> linkval; ;;; if not a symbolic link return target returnunless(linkval); @@ -94,7 +95,7 @@ define Sys_open(file, accmode, arg3, open_p, _iscreate); lvars file, accmode, arg3, procedure open_p, fullname, - _iscreate, _errc, _fd; + _iscreate, _errc, _fd, ress; if isinteger(arg3) then ;;; optional character arg specifying error action @@ -119,8 +120,16 @@ endif endif; - returnif(_nonneg( open_p(file, fullname, accmode, 0) ->> _fd )) - ( Sys_cons_device(file, fullname, accmode, arg3, _pint(_fd), false) ); + if(( open_p(file, fullname, accmode, 0) ->> _fd ) _lteq _2147483647) + then +;;; _extern printf('doing Sys_cons_device\n') -> _ ; +;;; _extern fflush(_0) -> _ ; + Sys_cons_device(file, fullname, accmode, arg3, _pint(_fd), false) + -> ress; +;;; _extern printf('after Sys_cons_device\n') -> _ ; +;;; _extern fflush(_0) -> _ ; + return (ress); + endif; ;;; can't open/create file Set_enotdir(fullname); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syspipe.p v15.6301-amd64/pop/src/syspipe.p --- v15.63/pop/src/syspipe.p 1994-06-01 12:15:39.000000000 -0400 +++ v15.6301-amd64/pop/src/syspipe.p 2005-03-11 05:30:39.000000000 -0500 @@ -26,7 +26,7 @@ quitif((Sys_fd_open_check(_pint(_res), false, _retry) ->> _retry) fi_< 0) endrepeat; - if _neg(_res) then Syserr_mishap(0, 'CAN\'T CREATE PIPE') endif; + if (_res) _gr _2147483647 then Syserr_mishap(0, 'CAN\'T CREATE PIPE') endif; _fdp!(int)[_0] -> _fd_in; _fdp!(int)[_1] -> _fd_out; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/syspop.ph v15.6301-amd64/pop/src/syspop.ph --- v15.63/pop/src/syspop.ph 1998-04-30 10:34:06.000000000 -0400 +++ v15.6301-amd64/pop/src/syspop.ph 2005-03-11 05:30:39.000000000 -0500 @@ -109,7 +109,7 @@ s_stackbuff = short[460]; struct TIMEVAL - { -int TIM_SEC, TIM_USEC; }; + { -long TIM_SEC, TIM_USEC; }; struct CODING_FUNCS { (code) CDFN_ENCODE, ;;; UNICODE -> something diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/sysutil.p v15.6301-amd64/pop/src/sysutil.p --- v15.63/pop/src/sysutil.p 2000-01-06 11:13:22.000000000 -0500 +++ v15.6301-amd64/pop/src/sysutil.p 2005-03-11 05:30:39.000000000 -0500 @@ -39,8 +39,8 @@ _n _sub _1 -> _n enduntil; ;;; do the call and loop if EINTR - unless _neg(_call_sys((), _nargs, _routine) ->> _res) - and _ERRNO == _:EINTR then + unless (_call_sys((), _nargs, _routine) ->> _res) + _gr _2147483647 and _ERRNO == _:EINTR then _useras(@@(w)[_nargs]); ;;; remove args return endunless @@ -53,7 +53,8 @@ define Set_mem_prot(_base, _lim, _prot); lvars _base, _lim, _prot; #_IF DEF BSD_MPROTECT - _nonneg(_extern mprotect(_base@(w->b), ##(b){_lim, _base | w}, _prot)) + (_extern mprotect(_base@(w->b), ##(b){_lim, _base | w}, _prot)) + _lteq _2147483647 #_ELSE "undef" #_ENDIF diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/termcap.p v15.6301-amd64/pop/src/termcap.p --- v15.63/pop/src/termcap.p 2004-03-15 05:05:14.000000000 -0500 +++ v15.6301-amd64/pop/src/termcap.p 2009-12-24 15:31:23.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2004. All rights reserved. ---------- +/* --- Copyright University of Sussex 1998. All rights reserved. ---------- > File: C.unix/src/termcap.p > Purpose: Simple interface to C termcap library > Author: Rob Duncan, Apr 11 1989 (see revisions) @@ -11,9 +11,7 @@ */ #_TERMIN_IF DEF NCR -/* Too many problems with termcap on linux systems. */ -#_TERMIN_IF DEF LINUX - +#_TERMIN_IF false #_INCLUDE 'declare.ph' #_INCLUDE 'io.ph' @@ -58,7 +56,8 @@ ;;; problem ['-B static -lcurses -B dynamic'] #_ELSE - ['-ltermcap'] +;;; ['-ltermcap'] + ['-lncurses'] #_ENDIF lconstant exload_dummy; ;;; anything will do endexload; @@ -524,7 +523,7 @@ lvars id, _res; Check_termcap_id(id) -> id; returnunless(termcap_entry_name)(false); - if _nonneg(_extern tgetnum(id@V_BYTES) ->> _res) then + if (_extern tgetnum(id@V_BYTES) ->> _res) _lteq _2147483647 then _pint(_res); else false; @@ -599,8 +598,6 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, 15 Mar 2004 - Ignore termcap if DEF LINUX. See comp.lang.pop discussions --- John Gibson, Mar 26 1998 Set -lcurses for AIX --- Robert Duncan, Aug 14 1997 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/unix_dir.p v15.6301-amd64/pop/src/unix_dir.p --- v15.63/pop/src/unix_dir.p 2007-10-01 09:26:05.000000000 -0400 +++ v15.6301-amd64/pop/src/unix_dir.p 2008-06-05 09:22:05.000000000 -0400 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2007. All rights reserved. ---------- +/* --- Copyright University of Sussex 1997. All rights reserved. ---------- > File: C.unix/src/unix_dir.p > Purpose: > Author: John Gibson et al (see revisions) @@ -66,8 +66,8 @@ define Open_stream(dirname) -> _fd; lvars dirname, _fd; - if _neg($-Sys$-Io$-Opencreate(dirname, dirname, O_RDONLY, 0) ->> _fd) - then + if ($-Sys$-Io$-Opencreate(dirname, dirname, O_RDONLY, 0) ->> _fd) + _gr _2147483647 then _NULL -> _fd endif enddefine; @@ -84,7 +84,7 @@ _extern[NI] read(_fd, _dir_entry@(w->b), ##DIR_END_BYTE) -> _n; unless _n == ##DIR_END_BYTE then if _nonzero(_n) then - if _neg(_n) then + if (_n) _gr _2147483647 then Syserr_mishap(0, 'ERROR READING ..') else mishap(0, 'ERROR READING .. (premature end of file)') @@ -188,8 +188,6 @@ #_ELSE ;;; not for linux -/* old version, replaced by new version above for linux */ - define lconstant Get_curr_dir(); lvars path, _dir_entry, _dotdev, _dotdev2, _dotino, _rootdev, _rootdev2, _rootino, _dirp; @@ -219,8 +217,10 @@ if (Open_stream('..') ->> _dirp) == _NULL then mishap(0, 'CAN\'T OPEN DIRECTORY ..') endif; +;;; _extern printf('_dirp = %ld\n', _dirp) -> _; +;;; _extern fflush(_0) -> _; _extern[NI] stat(_dotdotdir, _statb) -> ; - if _neg(_extern[NI] chdir(_dotdotdir)) then + if (_extern[NI] chdir(_dotdotdir)) _gr _2147483647 then mishap(0, 'CAN\'T CHANGE DIRECTORY TO ..'); endif; @@ -230,6 +230,8 @@ if (Read_entry(_dirp) ->> _dir_entry) == _NULL then mishap(0, PEOF_ms) endif; +;;; _extern printf('_dirp = %ld\n', _dirp) -> _; +;;; _extern fflush(_0) -> _; quitif(_dir_entry!DIR_INO == _dotino) endrepeat else @@ -237,6 +239,8 @@ if (Read_entry(_dirp) ->> _dir_entry) == _NULL then mishap(0, PEOF_ms) endif; +;;; _extern printf('_dirp = %ld\n', _dirp) -> _; +;;; _extern fflush(_0) -> _; _extern[NI] stat(_dir_entry@DIR_NAME, _statb) ->; quitif( DEV_T_==_VARS(_statb, ST_DEV, _dotdev, _dotdev2) and _statb!ST_INO == _dotino) @@ -251,12 +255,16 @@ endprocedure(_dir_entry), deststring(path) -> |#) -> path; +;;; _extern printf('3 _dirp = %ld\n', _dirp) -> _; +;;; _extern fflush(_0) -> _; Close_stream(_dirp) endrepeat; ;;; change back to current directory!!! _extern[NI] chdir(Encode_sys(path,_nbuf)) -> ; +;;; _extern printf('chdir(%s)\n', Encode_sys(path,_nbuf))-> _; +;;; _extern fflush(_0) -> _; Clawback(path) enddefine; @@ -275,7 +283,7 @@ lstackmem stackbuff _nbuf; returnif((sysfileok(new_dir) ->> new_dir) = current); if new_dir = nullstring then systranslate('HOME') -> new_dir endif; - if _neg(_extern[NI] chdir(Encode_sys(new_dir,_nbuf))) then + if (_extern[NI] chdir(Encode_sys(new_dir,_nbuf))) _gr _2147483647 then Syserr_mishap(new_dir, 1, 'CAN\'T CHANGE DIRECTORY') endif; false -> current Only in v15.63/pop/src: unix_dir.p-1999-05-20 Only in v15.6301-amd64/pop/src: unix_dir.p.adm64.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/unixdefs.ph v15.6301-amd64/pop/src/unixdefs.ph --- v15.63/pop/src/unixdefs.ph 2004-12-31 07:01:25.000000000 -0500 +++ v15.6301-amd64/pop/src/unixdefs.ph 2009-12-24 15:31:05.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2004. All rights reserved. ---------- +/* --- Copyright University of Sussex 1999. All rights reserved. ---------- > File: C.unix/src/unixdefs.ph > Purpose: > Author: John Gibson (see revisions) @@ -50,9 +50,9 @@ deftype dev_t = double, - ino_t = int, + ino_t = long, mode_t = int, - nlink_t = int, + nlink_t = long, time_t = -long, uid_t = int, gid_t = uid_t; @@ -175,14 +175,13 @@ struct STATB { dev_t ST_DEV; - short ST_PAD1; /* reserved for network id */ ino_t ST_INO; - mode_t ST_MODE; nlink_t ST_NLINK; + mode_t ST_MODE; uid_t ST_UID; gid_t ST_GID; + int ST_PAD2; dev_t ST_RDEV; - short ST_PAD2; off_t ST_SIZE; long ST_BLKSIZE; blkcnt_t ST_BLOCKS; @@ -192,7 +191,7 @@ long ST_MTIME_X; time_t ST_CTIME; long ST_CTIME_X; - long ST_PAD4[2]; /* expansion area */ + long ST_PAD4[3]; /* expansion area */ }; #_ELSEIF DEF BERKELEY and not(DEF IRIX) @@ -494,7 +493,7 @@ ;;; --- TIMES/TIMERS ------------------------------------------------------- struct TMS - { int TMS_UTIME, + { long TMS_UTIME, TMS_STIME, TMS_CUTIME, TMS_CSTIME; @@ -549,7 +548,7 @@ ;;; -- MISCELLANEOUS ------------------------------------------------------ -#_IF DEF HPUX or DEF IRIX or DEF SYSTEM_V +#_IF true /* DEF HPUX or DEF IRIX or DEF SYSTEM_V */ ;;; strings returned by tgetstr() have terminfo-style escapes lconstant macro USE_TERMINFO = true; @@ -640,28 +639,6 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, Dec 31 2004 - Added the documentation below for changes to errno. - ---- Aaron Sloman and Waldek Hebisch 29 Jun 2003 - The use of 'errno' which has been deprecated for some time is no longer - supported. So the old use is simulated using these two procedures defined - in $popexternlib/c_core.c (thanks to Waldek Hebisch): - int get_libc_errno(void) - int set_libc_errno(int x) - The are accessed via an active variable defined in $popsrc/errors.p - - define active DO_ERRNO_VAL(); - - define updaterof active DO_ERRNO_VAL(_x); - - This macro definition is no longer used - lconstant macro _ERRNO = [_extern errno:data!(int)]; - - Instead it is defined thus to invoke the active variable or its updater - - lconstant macro _ERRNO = [DO_ERRNO_VAL]; - --- John Gibson, Apr 9 1999 Replaced test ALPHA_LINUX or (X86_LINUX and LIN*UX_GLI*BC) with DEFV LINUX >= 2.0 diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/vec_generic.p v15.6301-amd64/pop/src/vec_generic.p --- v15.63/pop/src/vec_generic.p 1997-02-12 12:29:00.000000000 -0500 +++ v15.6301-amd64/pop/src/vec_generic.p 2009-12-30 14:59:15.000000000 -0500 @@ -44,8 +44,26 @@ enddefine; define Byte_hash(_cptr, _len); +#_IF false lvars _len, _cptr; CHAR_HASH(b) +#_ELSE + lvars _res = _len; + while _len _sgr _3 do + _cptr!(i) _add _res -> _res; + _len _add _-4 -> _len; + _cptr _add _4 -> _cptr; + endwhile; + if _len == _3 then + (_cptr!(i) _bimask _16:FFFFFF) _add _res -> _res; + elseif _len == _2 then + _cptr!(s) _add _res -> _res; + elseif _len == _1 then + _cptr!(b)[_0] _add _res -> _res; + endif; + ;;; Mix bits + _shift(_res _bimask _16:FFFE0000, _-17) _bixor _res +#_ENDIF enddefine; define Short_hash(_cptr, _len); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/src/vm_conspdr.p v15.6301-amd64/pop/src/vm_conspdr.p --- v15.63/pop/src/vm_conspdr.p 2005-02-12 15:05:49.000000000 -0500 +++ v15.6301-amd64/pop/src/vm_conspdr.p 2009-12-27 00:36:41.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2005. All rights reserved. ---------- +/* --- Copyright University of Sussex 2003. All rights reserved. ---------- > File: C.all/src/vm_conspdr.p > Purpose: > Author: John Gibson, Mar 11 1988 (see revisions) @@ -387,6 +387,9 @@ enduntil; instr!INST_OP -> _op; if _op == I_NOT then + ;;; Check for double negation, we could do better but + ;;; this is very rare. + returnif(is_not)(false); Optimise_clist_tl(next_clist, true) else if IS_UNOPT_JUMP(_op) ->> _op then @@ -1176,11 +1179,10 @@ endif; Incr_lab_refcount(asm_exit_lab); - ;;; check proposed by Waldek Hebisch - if _Nframewords _gr _16:FF then - mishap(0, 'PROCEDURE STACK FRAME TOO LARGE (too many lvars?)'); - endif; + if _Nframewords _gr _:MAX_STACK_FRAME_SIZE then + mishap(0, 'PROCEDURE STACK FRAME TOO LARGE (too many lvars?)'); + endif; ;;; first instruction creates stack frame on entry Cons_inst(I_CREATE_SF, 1) :: codelist -> codelist; @@ -1235,8 +1237,6 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, Feb 12 2005 - Check for stack frame limit exceeded suggested by Waldek Hebisch --- David Young, Oct 8 2003 Fixed bug in Optimise_conditions which caused a sequence of I_NOTs followed by an I_GOTO to be incorrectly ignored. This was diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/x/Xpm/xpmP.h v15.6301-amd64/pop/x/Xpm/xpmP.h --- v15.63/pop/x/Xpm/xpmP.h 1996-03-04 06:07:41.000000000 -0500 +++ v15.6301-amd64/pop/x/Xpm/xpmP.h 2005-03-11 05:30:40.000000000 -0500 @@ -15,6 +15,7 @@ #include "sys$library:stdio.h" #else #include +#include /* stdio.h doesn't declare popen on a Sequent DYNIX OS */ #ifdef sequent extern FILE *popen(); diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/x/src/xt_error.p v15.6301-amd64/pop/x/src/xt_error.p --- v15.63/pop/x/src/xt_error.p 2007-01-06 18:22:53.000000000 -0500 +++ v15.6301-amd64/pop/x/src/xt_error.p 1996-02-06 09:52:14.000000000 -0500 @@ -1,4 +1,4 @@ -/* --- Copyright University of Sussex 2007. All rights reserved. ---------- +/* --- Copyright University of Sussex 1996. All rights reserved. ---------- > File: C.x/x/src/xt_error.p > Purpose: X Toolkit - error handlers > Author: Roger Evans, Jul 5 1990 (see revisions) @@ -66,33 +66,13 @@ error stream. Not for public use -- called from XtPoplog.c */ -;;; Modified this to cope with lesstif warning messages. define Xpt_sys_pr_message(exptr); lvars exptr, string; exacc_ntstring(exptr) -> string; if string == termin then cucharerr(`\n`) else - ;;; Inserted by A.S. because of Lesstif problem - if issubstring('XtRemoveGrab asked', string) - then - ;;; A.S. 6 Jan 2007 Print warnings ONLY if pop_debugging - ;;; has value 'lesstif'. Even then print shortened message. - if pop_debugging = 'lesstif' then - 'Lesstif removegrab warning' -> string; - sys_pr_message(0, {^string ^nullstring 16:01}, nullstring, `W`); - ;;; sysobey('echo Lesstif removegrab warning'); - endif; - else - ;;; Not sure what to do with blank strings. They have - ;;; caused problems in already closed windows. Should there be a test here? - - ;;; Print the warning. It's not the Lesstif one. - ;;; AS. 6 Jan 2007. Fixed incorrect arg: was false now nullstring. - ;;; sys_pr_message(0, {^string ^nullstring 16:01}, false, `W`); - sys_pr_message(0, {^string ^nullstring 16:01}, nullstring, `W`); - - endif; + sys_pr_message(0, {^string ^nullstring 16:01}, false, `W`) endif enddefine; @@ -103,17 +83,6 @@ /* --- Revision History --------------------------------------------------- ---- Aaron Sloman, Jan 6 2007 - Altered Xpt_sys_pr_message(exptr); because of spurious warnings from - Lesstif when quitting windows. - ;;; WARNING - xtw: X TOOLKIT WARNING (xtRemoveGrab: grabError -- XtRemoveGrab asked to remove a widget not on the list) - - If pop_debugging = 'lesstif' then a shortened warning is printed. - If pop_debugging has any other value no warning is printed. - Other strings are printed as normal. For details see - http://www.cs.bham.ac.uk/research/projects/poplog/bugfixes/BUGREPORTS - (Search for Lesstif). - --- John Gibson, Feb 6 1996 Uses sys_pr_message instead of sys*prmessage --- Robert John Duncan, Feb 1 1995 Only in v15.6301-amd64/pop/x/src: xt_error.p-32-bit-poplog Only in v15.63/pop/x/src: xt_error.p.orig diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/x/ui/lib/pop_ui_logo.p v15.6301-amd64/pop/x/ui/lib/pop_ui_logo.p --- v15.63/pop/x/ui/lib/pop_ui_logo.p 1996-07-18 04:36:09.000000000 -0400 +++ v15.6301-amd64/pop/x/ui/lib/pop_ui_logo.p 2009-12-24 15:29:59.000000000 -0500 @@ -58,7 +58,7 @@ POPUIBITMAPS dir_>< 'poplog_64.xbm', ;;; filename of xbm sprintf(pop_internal_version / 10000.0, 'Sussex Poplog Version %p'), - ' Copyright \(169) 1982-1996, The University of Sussex ', + ' Copyright \(169) 1982-2005, The University of Sussex ', 'All Rights Reserved.', '', popmemused div 256 sys_>< ' Kilobytes used, ' sys_>< @@ -66,7 +66,12 @@ ' (editing ' sys_>< len sys_>< ' file', if len == 1 then sys_>< ') ' else sys_>< 's) ' endif, '', - 'Marketed under licence by:', 'Integral Solutions Ltd.', + 'Poplog is free sftware, see:', + 'http://www.cs.bham.ac.uk/research/poplog/freepoplog.html', + 'and ftp://ftp.cs.bham.ac.uk/pub/dist/poplog/', + '', + 'Previously marketed by:', + 'Integral Solutions Ltd.', 'Berk House, Basing View', 'Basingstoke, Hants.', 'RG21 4RG, UK', @@ -74,8 +79,6 @@ 'Tel: +44 (0)1256 55899', 'Fax: +44 (0)1256 63467', '', - 'Email: isl@isl.co.uk', - 'URL: http://www.isl.co.uk', '' %] enddefine; diff -ru --exclude=CVS --exclude='*index' --exclude=basepop11.map --exclude=ref --exclude=help --exclude=teach v15.63/pop/x/ved/src/xvedkey.p v15.6301-amd64/pop/x/ved/src/xvedkey.p --- v15.63/pop/x/ved/src/xvedkey.p 1999-01-30 19:33:40.000000000 -0500 +++ v15.6301-amd64/pop/x/ved/src/xvedkey.p 2005-03-11 05:30:40.000000000 -0500 @@ -69,7 +69,8 @@ ;;; DEFAULT - process the key and see if we can make some sense from it. ;;; ignore modifier keys and KeyRelease events. - returnif(keysym fi_< 0 or IsModifierKey(keysym)); +;;; printf(keysym, 'keysym = %p\n') ; + returnif((keysym fi_< 0) or (536870911 < keysym) or IsModifierKey(keysym)); ;;; test for keypad state if xvedkeypadon then