cmucl-cvs December 2010

cmucl-cvs@common-lisp.net

2 participants
72 discussions

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (x86-arch.c)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Tuesday, December 14, 2010 @ 16:27:14 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: x86-arch.c Sun C miscompiles the inline assembly for the cpuid instruction, so on Solaris, use the /dev/cpu/self/cpuid device to get the cpuid data that we need. ------------+ x86-arch.c | 47 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) Index: src/lisp/x86-arch.c diff -u src/lisp/x86-arch.c:1.39 src/lisp/x86-arch.c:1.39.24.1 --- src/lisp/x86-arch.c:1.39 Tue Jan 6 13:18:43 2009 +++ src/lisp/x86-arch.c Tue Dec 14 16:27:13 2010 @@ -1,6 +1,6 @@ /* x86-arch.c -*- Mode: C; comment-column: 40 -*- * - * $Header: /project/cmucl/cvsroot/src/lisp/x86-arch.c,v 1.39 2009-01-06 18:18:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/x86-arch.c,v 1.39.24.1 2010-12-14 21:27:13 rtoy Exp $ * */ @@ -24,6 +24,50 @@ unsigned long fast_random_state = 1; +#if defined(SOLARIS) +/* + * Use the /dev/cpu/self/cpuid interface on Solaris. We could use the + * same method below, but the Sun C compiler miscompiles the inline + * assembly. + */ + +#include <sys/types.h> +#include <sys/stat.h> +#include <fcntl.h> +#include <unistd.h> +#include <string.h> +#include <errno.h> + +void cpuid(int level, unsigned int* a, unsigned int* b, + unsigned int* c, unsigned int* d) +{ + int device; + uint32_t regs[4]; + static const char devname[] = "/dev/cpu/self/cpuid"; + + *a = *b = *c = *d = 0; + if ((device = open(devname, O_RDONLY)) == -1) { + perror(devname); + goto exit; + } + + if (pread(device, regs, sizeof(regs), 1) != sizeof(regs)) { + perror(devname); + goto exit; + } + + *a = regs[0]; + *b = regs[1]; + *c = regs[2]; + *d = regs[3]; + + exit: + (void) close(device); + + return; +} + +#else #define __cpuid(level, a, b, c, d) \ __asm__ ("xchgl\t%%ebx, %1\n\t" \ "cpuid\n\t" \ @@ -43,6 +87,7 @@ *c = ecx; *d = edx; } +#endif int arch_support_sse2(void)

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/lisp (Config.sparc_common)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Tuesday, December 14, 2010 @ 16:26:02 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sol-x86-branch Modified: Config.sparc_common Add -DFEATURE_SSE2 if we're compiling on x86 and have either FEATURE_X87 or FEATURE_SSE2 defined. ---------------------+ Config.sparc_common | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) Index: src/lisp/Config.sparc_common diff -u src/lisp/Config.sparc_common:1.3.6.1 src/lisp/Config.sparc_common:1.3.6.2 --- src/lisp/Config.sparc_common:1.3.6.1 Mon Dec 13 23:25:11 2010 +++ src/lisp/Config.sparc_common Tue Dec 14 16:26:02 2010 @@ -27,12 +27,24 @@ GC_SRC = gencgc.c endif +# Enable support for SSE2. If FEATURE_X87 is set, we want SSE2 +# support in the C code too so that the same binary is built in both +# cases. If neither is set, then we don't want any SSE2 support at +# all. +ifdef FEATURE_X87 +SSE2 = -DFEATURE_SSE2 +else +ifdef FEATURE_SSE2 +SSE2 = -DFEATURE_SSE2 +endif +endif + # Enable support for Unicode ifdef FEATURE_UNICODE UNICODE = -DUNICODE endif -CPPFLAGS = -I. -I$(PATH1) -DSOLARIS -DSVR4 $(CC_V8PLUS) $(LINKAGE) $(GENCGC) $(UNICODE) +CPPFLAGS = -I. -I$(PATH1) -DSOLARIS -DSVR4 $(CC_V8PLUS) $(LINKAGE) $(GENCGC) $(UNICODE) $(SSE2) CFLAGS = -g $(CC_V8PLUS)

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src/code (signal.lisp)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Tuesday, December 14, 2010 @ 16:24:09 Author: rtoy Path: /project/cmucl/cvsroot/src/code Tag: cross-sol-x86-branch Modified: signal.lisp Fix up calls to with-textdomain which was missing the second arg when compiled on solaris/x86. -------------+ signal.lisp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) Index: src/code/signal.lisp diff -u src/code/signal.lisp:1.41 src/code/signal.lisp:1.41.8.1 --- src/code/signal.lisp:1.41 Tue Jul 13 23:13:20 2010 +++ src/code/signal.lisp Tue Dec 14 16:24:09 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/signal.lisp,v 1.41 2010-07-14 03:13:20 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/signal.lisp,v 1.41.8.1 2010-12-14 21:24:09 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -104,7 +104,7 @@ (def-unix-signal :SIGIOT 6 "Iot instruction") ; Compatibility (def-unix-signal :SIGABRT 6 "C abort()") (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os" - #+sparc "cmucl-sparc-svr4" + #+(or sparc solaris) "cmucl-sparc-svr4" #+bsd "cmucl-bsd-os") #-linux (def-unix-signal :SIGEMT 7 "Emt instruction")) @@ -115,7 +115,7 @@ (def-unix-signal :SIGBUS #-linux 10 #+linux 7 "Bus error") (def-unix-signal :SIGSEGV 11 "Segmentation violation") (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os" - #+sparc "cmucl-sparc-svr4" + #+(or sparc solaris) "cmucl-sparc-svr4" #+bsd "cmucl-bsd-os") #-linux (def-unix-signal :SIGSYS 12 "Bad argument to system call")) @@ -124,7 +124,7 @@ (def-unix-signal :SIGALRM 14 "Alarm clock") (def-unix-signal :SIGTERM 15 "Software termination signal") (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os" - #+sparc "cmucl-sparc-svr4" + #+(or sparc solaris) "cmucl-sparc-svr4" #+bsd "cmucl-bsd-os") #+linux (def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor")) @@ -163,7 +163,7 @@ ;;; SVR4 (or Solaris?) specific signals (intl::with-textdomain ("cmucl" #+linux "cmucl-linux-os" - #+sparc "cmucl-sparc-svr4" + #+(or sparc solaris) "cmucl-sparc-svr4" #+bsd "cmucl-bsd-os") #+svr4 (def-unix-signal :SIGWAITING 32 "Process's lwps are blocked"))

1 0

[cmucl-cvs] CMUCL commit: src/pcl (cmucl-documentation.lisp)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Tuesday, December 14, 2010 @ 16:22:28 Author: rtoy Path: /project/cmucl/cvsroot/src/pcl Modified: cmucl-documentation.lisp Don't call dgettext if there's no documentation string. This used to work, but doesn't anymore because the domain won't normally be NIL anymore. --------------------------+ cmucl-documentation.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/pcl/cmucl-documentation.lisp diff -u src/pcl/cmucl-documentation.lisp:1.17 src/pcl/cmucl-documentation.lisp:1.18 --- src/pcl/cmucl-documentation.lisp:1.17 Fri Mar 19 11:19:03 2010 +++ src/pcl/cmucl-documentation.lisp Tue Dec 14 16:22:27 2010 @@ -4,7 +4,7 @@ ;;; the public domain, and is provided 'as is'. (file-comment - "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.17 2010-03-19 15:19:03 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.18 2010-12-14 21:22:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -222,7 +222,7 @@ `(defmethod documentation :around ((x t) (doc-type (eql ',dt))) (let ((doc (call-next-method)) (domain (info ,dt :textdomain x))) - (or (intl:dgettext domain doc) + (or (and doc (intl:dgettext domain doc)) doc))))) (frob function) (frob setf)

1 0

[cmucl-cvs] CMUCL commit: cross-sol-x86-branch src (10 files)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Monday, December 13, 2010 @ 23:25:11 Author: rtoy Path: /project/cmucl/cvsroot/src Tag: cross-sol-x86-branch Added: lisp/Config.x86_solaris_sunc tools/cross-scripts/cross-x86-osx-solaris.lisp Modified: compiler/x86/parms.lisp lisp/Config.sparc_common lisp/Config.sparc_sunc lisp/interrupt.c lisp/solaris-os.c lisp/sunos-os.h lisp/x86-assem.S lisp/x86-validate.h First cut at a build for Solaris/x86. Result doesn't work; it gets as far as TYPE-INIT, but then crashes. These changes still allow solaris/sparc and darwin/x86 to build, so we haven't broken both sparc and x86 while doing this. tools/cross-scripts/cross-x86-osx-solaris.lisp: o New cross-compile script to use darwin/x86 to cross-compile to solaris/x86. compiler/x86/parms.lisp: o For now, put thel linkage space start at 0xc0000000 on Solaris/x86. lisp/Config.sparc_common: o Separate out the common parts between Solaris sparc and x86. Move the different parts into the appropriate file. lisp/Config.sparc_sunc: o Add ASSEM_SRC and ARCH_SRC here, with the appropriate OS_SRC, OS_LINK_FLAGS, and OS_LIBS> lisp/Config.x86_solaris_sunc: o New file for building solaris/x86 using Sun C (aka Sun Studio aka Solaris Studio) lisp/interrupt.c: o Use a static array for the altstack. Should eventually do what other x86 platforms do. lisp/solaris-os.c: o Don't need os_flush_icache on x86 (?), so make the body empty for x86. o Add x86 version of os_sigcontext_reg and os_sigcontext_pc. lisp/sunos-os.h: o The pagesize is 4096 on x86 instead of 8192. o Don't need (?) SAVE_CONTEXT. lisp/x86-assem.S: o Update to support Sun C assembler: - Add appropriate GNAME, FUNCDEF and ENDFUNC macros. - Sun assembler doesn't have int3 instruction, so add INT3 macro to do the appropriate things. - Sun assembler doesn't like control L characters in the file so remove them. lisp/x86-validate.h: o Add entry for Solaris. This needs work, but it looks like these values will work. ------------------------------------------------+ compiler/x86/parms.lisp | 5 lisp/Config.sparc_common | 8 lisp/Config.sparc_sunc | 7 lisp/Config.x86_solaris_sunc | 14 + lisp/interrupt.c | 6 lisp/solaris-os.c | 37 +++ lisp/sunos-os.h | 8 lisp/x86-assem.S | 61 +++-- lisp/x86-validate.h | 31 ++- tools/cross-scripts/cross-x86-osx-solaris.lisp | 236 +++++++++++++++++++++++ 10 files changed, 378 insertions(+), 35 deletions(-) Index: src/compiler/x86/parms.lisp diff -u src/compiler/x86/parms.lisp:1.41 src/compiler/x86/parms.lisp:1.41.2.1 --- src/compiler/x86/parms.lisp:1.41 Sat Dec 4 12:32:34 2010 +++ src/compiler/x86/parms.lisp Mon Dec 13 23:25:11 2010 @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.41 2010-12-04 17:32:34 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.41.2.1 2010-12-14 04:25:11 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -65,7 +65,8 @@ (setf (c::backend-foreign-linkage-space-start *target-backend*) #+linux #x58000000 - #-linux #xB0000000 + #+solaris #xC0000000 + #-(or linux solaris) #xB0000000 (c::backend-foreign-linkage-entry-size *target-backend*) 8) ); eval-when Index: src/lisp/Config.sparc_common diff -u src/lisp/Config.sparc_common:1.3 src/lisp/Config.sparc_common:1.3.6.1 --- src/lisp/Config.sparc_common:1.3 Wed Jul 28 21:51:12 2010 +++ src/lisp/Config.sparc_common Mon Dec 13 23:25:11 2010 @@ -38,11 +38,11 @@ CFLAGS = -g $(CC_V8PLUS) NM = $(PATH1)/solaris-nm -ASSEM_SRC = sparc-assem.S -ARCH_SRC = sparc-arch.c +#ASSEM_SRC = sparc-assem.S +#ARCH_SRC = sparc-arch.c DEPEND=$(CC) -OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c +#OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c OS_LINK_FLAGS= -OS_LIBS= -lsocket -lnsl -ldl +#OS_LIBS= -lsocket -lnsl -ldl EXEC_FINAL_OBJ = exec-final.o Index: src/lisp/Config.sparc_sunc diff -u src/lisp/Config.sparc_sunc:1.2 src/lisp/Config.sparc_sunc:1.2.12.1 --- src/lisp/Config.sparc_sunc:1.2 Mon Feb 1 11:41:39 2010 +++ src/lisp/Config.sparc_sunc Mon Dec 13 23:25:11 2010 @@ -20,6 +20,13 @@ AS_V8PLUS = -m32 -xarch=sparc endif +ASSEM_SRC = sparc-assem.S +ARCH_SRC = sparc-arch.c + +OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c +OS_LINK_FLAGS= +OS_LIBS= -lsocket -lnsl -ldl + CC = cc -xlibmieee -O CPP = cc -E DEPEND_FLAGS = -xM Index: src/lisp/Config.x86_solaris_sunc diff -u /dev/null src/lisp/Config.x86_solaris_sunc:1.1.2.1 --- /dev/null Mon Dec 13 23:25:11 2010 +++ src/lisp/Config.x86_solaris_sunc Mon Dec 13 23:25:11 2010 @@ -0,0 +1,14 @@ +# -*- Mode: makefile -*- +include Config.sparc_common + +CC = cc -xlibmieee -g +CFLAGS += -Di386 +CPP = cc -E +DEPEND_FLAGS = -xM + +ASSEM_SRC = x86-assem.S +ARCH_SRC = x86-arch.c + +OS_SRC = solaris-os.c os-common.c undefineds.c elf.c e_rem_pio2.c k_rem_pio2.c +OS_LINK_FLAGS= +OS_LIBS= -lsocket -lnsl -ldl Index: src/lisp/interrupt.c diff -u src/lisp/interrupt.c:1.60 src/lisp/interrupt.c:1.60.12.1 --- src/lisp/interrupt.c:1.60 Mon Nov 2 10:05:07 2009 +++ src/lisp/interrupt.c Mon Dec 13 23:25:11 2010 @@ -1,4 +1,4 @@ -/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.60 2009-11-02 15:05:07 rtoy Rel $ */ +/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.60.12.1 2010-12-14 04:25:11 rtoy Exp $ */ /* Interrupt handling magic. */ @@ -396,7 +396,7 @@ * Noise to install handlers. * \****************************************************************/ -#if !(defined(i386) || defined(__x86_64)) +#if defined(SOLARIS) || !(defined(i386) || defined(__x86_64)) #define SIGNAL_STACK_SIZE SIGSTKSZ static char altstack[SIGNAL_STACK_SIZE]; #endif @@ -422,7 +422,7 @@ if (signal == PROTECTION_VIOLATION_SIGNAL) { stack_t sigstack; -#if (defined( i386 ) || defined(__x86_64)) +#if !defined(SOLARIS) && (defined( i386 ) || defined(__x86_64)) sigstack.ss_sp = (void *) SIGNAL_STACK_START; #else sigstack.ss_sp = (void *) altstack; Index: src/lisp/solaris-os.c diff -u src/lisp/solaris-os.c:1.26 src/lisp/solaris-os.c:1.26.4.1 --- src/lisp/solaris-os.c:1.26 Fri Nov 12 07:57:32 2010 +++ src/lisp/solaris-os.c Mon Dec 13 23:25:11 2010 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26 2010-11-12 12:57:32 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26.4.1 2010-12-14 04:25:11 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -138,6 +138,7 @@ void os_flush_icache(os_vm_address_t address, os_vm_size_t length) { +#ifndef i386 static int flushit = -1; /* @@ -158,6 +159,7 @@ fprintf(stderr, ";;;iflush %p - %lx\n", (void *) address, length); flush_icache((unsigned int *) address, length); } +#endif } void @@ -492,3 +494,36 @@ return sym_addr; } + +#ifdef i386 +unsigned long * +os_sigcontext_reg(ucontext_t *scp, int index) +{ + switch (index) { + case 0: + return (unsigned long *) &scp->uc_mcontext.gregs[EAX]; + case 2: + return (unsigned long *) &scp->uc_mcontext.gregs[ECX]; + case 4: + return (unsigned long *) &scp->uc_mcontext.gregs[EDX]; + case 6: + return (unsigned long *) &scp->uc_mcontext.gregs[EBX]; + case 8: + return (unsigned long *) &scp->uc_mcontext.gregs[ESP]; + case 10: + return (unsigned long *) &scp->uc_mcontext.gregs[EBP]; + case 12: + return (unsigned long *) &scp->uc_mcontext.gregs[ESI]; + case 14: + return (unsigned long *) &scp->uc_mcontext.gregs[EDI]; + } + return NULL; +} + +unsigned long * +os_sigcontext_pc(ucontext_t *scp) +{ + return (unsigned long *) &scp->uc_mcontext.gregs[EIP]; +} + +#endif Index: src/lisp/sunos-os.h diff -u src/lisp/sunos-os.h:1.13 src/lisp/sunos-os.h:1.13.32.1 --- src/lisp/sunos-os.h:1.13 Mon Mar 17 23:58:45 2008 +++ src/lisp/sunos-os.h Mon Dec 13 23:25:11 2010 @@ -1,6 +1,6 @@ /* - $Header: /project/cmucl/cvsroot/src/lisp/sunos-os.h,v 1.13 2008-03-18 03:58:45 cshapiro Rel $ + $Header: /project/cmucl/cvsroot/src/lisp/sunos-os.h,v 1.13.32.1 2010-12-14 04:25:11 rtoy Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -42,13 +42,19 @@ #define OS_VM_PROT_WRITE PROT_WRITE #define OS_VM_PROT_EXECUTE PROT_EXEC +#ifdef i386 +#define OS_VM_DEFAULT_PAGESIZE 4096 +#else #define OS_VM_DEFAULT_PAGESIZE 8192 +#endif #ifdef SOLARIS #include <ucontext.h> #define HANDLER_ARGS int signal, siginfo_t *code, struct ucontext *context #define CODE(code) ((code) ? code->si_code : 0) +#ifndef i386 #define SAVE_CONTEXT() save_context() +#endif #ifdef NULL #undef NULL Index: src/lisp/x86-assem.S diff -u src/lisp/x86-assem.S:1.34 src/lisp/x86-assem.S:1.34.6.1 --- src/lisp/x86-assem.S:1.34 Mon Jul 19 19:08:37 2010 +++ src/lisp/x86-assem.S Mon Dec 13 23:25:11 2010 @@ -1,6 +1,6 @@ -### x86-assem.S -*- Mode: Asm; -*- +/* ### x86-assem.S -*- Mode: Asm; -*- */ /** - * $Header: /project/cmucl/cvsroot/src/lisp/x86-assem.S,v 1.34 2010-07-19 23:08:37 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/x86-assem.S,v 1.34.6.1 2010-12-14 04:25:11 rtoy Exp $ * * Authors: Paul F. Werkowski <pw(a)snoopy.mv.com> * Douglas T. Crosher @@ -11,7 +11,7 @@ * */ - + #include "x86-validate.h" #define LANGUAGE_ASSEMBLY @@ -19,26 +19,43 @@ #include "lispregs.h" /* Minimize conditionalization for different OS naming schemes */ -#ifndef DARWIN +#ifdef DARWIN +#define GNAME(var) _##var +#define FUNCDEF(x) \ + .text ; \ + .align 2,0x90 ; \ + .globl GNAME(x) ; \ +GNAME(x): ; +#define ENDFUNC(x) +#elif defined(SOLARIS) #define GNAME(var) var #define FUNCDEF(x) \ .text ; \ - .balign 4,0x90 ; \ + .align 16,0x90 ; \ .globl GNAME(x) ; \ .type x,@function ; \ GNAME(x): ; #define ENDFUNC(x) \ .size GNAME(x),.-GNAME(x) #else -#define GNAME(var) _##var +#define GNAME(var) var #define FUNCDEF(x) \ .text ; \ - .align 2,0x90 ; \ + .balign 4,0x90 ; \ .globl GNAME(x) ; \ + .type x,@function ; \ GNAME(x): ; -#define ENDFUNC(x) +#define ENDFUNC(x) \ + .size GNAME(x),.-GNAME(x) #endif +#ifdef SOLARIS +#define INT3 int $3 + +#else +#define INT3 int3 +#endif + /* Get the right type of alignment. Linux wants alignment in bytes. */ #if defined (__linux__) || defined (__FreeBSD__) #define align_16byte 16 @@ -49,7 +66,7 @@ .text .globl GNAME(foreign_function_call_active) - + /* * The C function will preserve ebx, esi, edi, and ebp across its * function call - ebx is used to save the return lisp address. @@ -122,7 +139,7 @@ jmp *%ebx ENDFUNC(call_into_c) - + /* The C conventions require that ebx, esi, edi, and ebp be preserved across function calls. */ @@ -255,7 +272,7 @@ movl %edx,%eax # c-val ret ENDFUNC(call_into_lisp) - + /* Support for saving and restoring the NPX state from C. */ FUNCDEF(fpu_save) movl 4(%esp),%eax @@ -284,7 +301,7 @@ fxrstor (%eax) ret ENDFUNC(sse_restore) - + #if 0 /* @@ -297,7 +314,7 @@ * The undefined-function trampoline. */ FUNCDEF(undefined_tramp) - int3 + INT3 .byte trap_Error /* Number of argument bytes */ .byte 2 @@ -339,23 +356,23 @@ .globl GNAME(function_end_breakpoint_trap) GNAME(function_end_breakpoint_trap): - int3 + INT3 .byte trap_FunctionEndBreakpoint hlt # Should never return here. .globl GNAME(function_end_breakpoint_end) GNAME(function_end_breakpoint_end): - + FUNCDEF(do_pending_interrupt) - int3 + INT3 .byte trap_PendingInterrupt ret ENDFUNC(do_pending_interrupt) #ifdef trap_DynamicSpaceOverflowError FUNCDEF(do_dynamic_space_overflow_error) - int3 + INT3 .byte trap_DynamicSpaceOverflowError ret ENDFUNC(do_dynamic_space_overflow_error) @@ -363,13 +380,13 @@ #ifdef trap_DynamicSpaceOverflowWarning FUNCDEF(do_dynamic_space_overflow_warning) - int3 + INT3 .byte trap_DynamicSpaceOverflowWarning ret ENDFUNC(do_dynamic_space_overflow_warning) #endif - + #ifdef WANT_CGC /* A copy function optimized for the Pentium and works ok on * 486 as well. This assumes (does not check) that the input @@ -423,7 +440,7 @@ ret ENDFUNC(fastcopy16) #endif - + /* Allocate bytes and return the start of the allocated space @@ -666,7 +683,7 @@ ret ENDFUNC(alloc_16_to_edi) - + #ifdef GENCGC /* Called from lisp when an inline allocation overflows. @@ -832,7 +849,7 @@ movl 8(%ebp),%eax /* Now trap to Lisp */ - int3 + INT3 .byte trap_Error /* Number of argument bytes */ .byte 2 Index: src/lisp/x86-validate.h diff -u src/lisp/x86-validate.h:1.31 src/lisp/x86-validate.h:1.31.8.1 --- src/lisp/x86-validate.h:1.31 Fri May 21 15:26:53 2010 +++ src/lisp/x86-validate.h Mon Dec 13 23:25:11 2010 @@ -3,7 +3,7 @@ * This code was written as part of the CMU Common Lisp project at * Carnegie Mellon University, and has been placed in the public domain. * - * $Header: /project/cmucl/cvsroot/src/lisp/x86-validate.h,v 1.31 2010-05-21 19:26:53 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/x86-validate.h,v 1.31.8.1 2010-12-14 04:25:11 rtoy Exp $ * */ @@ -172,7 +172,7 @@ #define CONTROL_STACK_START 0x38000000 #define CONTROL_STACK_SIZE (0x07fff000 - 8192) #define SIGNAL_STACK_START CONTROL_STACK_END -#define SIGNAL_STACK_SIZE 8192 +#define SIGNAL_STACK_SIZE SIGSTKSZ #define DYNAMIC_0_SPACE_START (SpaceStart_TargetDynamic) @@ -188,6 +188,33 @@ #endif #endif +#ifdef SOLARIS +#define READ_ONLY_SPACE_START (SpaceStart_TargetReadOnly) +#define READ_ONLY_SPACE_SIZE (0x0ffff000) /* 256MB - 1 page */ + +#define STATIC_SPACE_START (SpaceStart_TargetStatic) +#define STATIC_SPACE_SIZE (0x0ffff000) /* 256MB - 1 page */ + +#define BINDING_STACK_START (0x20000000) +#define BINDING_STACK_SIZE (0x07fff000) /* 128MB - 1 page */ + +#define CONTROL_STACK_START 0x38000000 +#define CONTROL_STACK_SIZE (0x07fff000 - 8192) +#define SIGNAL_STACK_SIZE SIGSTKSZ + +#define DYNAMIC_0_SPACE_START (SpaceStart_TargetDynamic) + +#ifdef GENCGC +#define DYNAMIC_SPACE_SIZE (0x66000000) /* 1.632GB */ +#else +#define DYNAMIC_SPACE_SIZE (0x04000000) /* 64MB */ +#endif +#define DEFAULT_DYNAMIC_SPACE_SIZE (0x20000000) /* 512MB */ +#ifdef LINKAGE_TABLE +#define FOREIGN_LINKAGE_SPACE_START (LinkageSpaceStart) +#define FOREIGN_LINKAGE_SPACE_SIZE (0x100000) /* 1MB */ +#endif +#endif #define CONTROL_STACK_END (CONTROL_STACK_START + CONTROL_STACK_SIZE) Index: src/tools/cross-scripts/cross-x86-osx-solaris.lisp diff -u /dev/null src/tools/cross-scripts/cross-x86-osx-solaris.lisp:1.1.2.1 --- /dev/null Mon Dec 13 23:25:11 2010 +++ src/tools/cross-scripts/cross-x86-osx-solaris.lisp Mon Dec 13 23:25:11 2010 @@ -0,0 +1,236 @@ +;; Basic cross-compile script for cross-compiling from x86 on darwin +;; (Mac OS X) to x86 on Solaris. This is a basic x86-to-x86 +;; cross-compile, except we tweek the features and misfeatures +;; for Solaris/x86. + +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "X86" "OLD-X86" '("OLD-VM")) +(setf (c:backend-name c:*native-backend*) "OLD-X86") + +(c::new-backend "X86" + ;; Features to add here. These are just examples. You may not + ;; need to list anything here. We list them here anyway as a + ;; record of typical features for all x86 ports. + '(:x86 + :i486 + :pentium + :stack-checking ; Catches stack overflow + :heap-overflow-check ; Catches heap overflows + :relative-package-names ; relative package names + :mp ; multiprocessing + :gencgc ; Generational GC + :conservative-float-type + :complex-fp-vops + :hash-new + :random-mt19937 + :cmu :cmu20 :cmu20b ; Version features + :double-double ; double-double float support + :linkage-table + + :solaris :svr4 + ;; The :sse2 and :x87 features will get set by the compiling + ;; lisp, so don't set it here! + ) + ;; Features to remove from current *features* here. Normally don't + ;; need to list anything here unless you are trying to remove a + ;; feature. + '(:x86-bootstrap + ;; :alpha :osf1 :mips + :propagate-fun-type :propagate-float-type :constrain-float-type + ;; :openbsd :freebsd :glibc2 :linux + :mach-o :darwin + :long-float :new-random :small)) +;;; +(setf *features* (remove :bsd *features*)) +;; Set up the linkage space stuff appropriately for sparc. +(setf (c::backend-foreign-linkage-space-start c::*target-backend*) + #xC0000000 + (c::backend-foreign-linkage-entry-size c::*target-backend*) + 8) + +;;; +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) + +;; Make fixup-code-object and sanctify-for-execution in the VM package +;; be the same as the original. Needed to get rid of a compiler error +;; in generic/core.lisp. (This halts cross-compilations if the +;; compiling lisp uses the -batch flag. +(import 'old-vm::fixup-code-object "VM") +(import 'old-vm::sanctify-for-execution "VM") +(export 'vm::fixup-code-object "VM") +(export 'vm::sanctify-for-execution "VM") + +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:x86/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/x86/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(when (target-featurep :sse2) + (load "vm:sse2-sap")) +(load "vm:system") +(load "vm:char") +(if (target-featurep :sse2) + (load "vm:float-sse2") + (load "vm:float")) + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(if (target-featurep :sse2) + (load "vm:sse2-c-call") + (load "vm:x87-c-call")) + +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +;; These need to be loaded before array because array wants to use +;; some vops as templates. +(load (if (target-featurep :sse2) + "vm:sse2-array" + "vm:x87-array")) +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm)))) + syms)))) + (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS + OLD-VM:CHAR-BITS + #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-BIT-VECTOR-TYPE + OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE + OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET + OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE + OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE + ) + #+double-double + (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE)) + +;; Modular arith hacks +(setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32) +(setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32) +;; End arith hacks + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + name) +(export 'extern-alien-name) +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-vm::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-vm::any-reg +;; to the hash table with the same value as x86::any-reg. +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-vm::any-reg ht) + (gethash 'vm::any-reg ht)))

1 0

[cmucl-cvs] CMUCL commit: src (2 files)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Monday, December 13, 2010 @ 19:26:43 Author: rtoy Path: /project/cmucl/cvsroot/src Added: bootfiles/20b/boot-2010-12.lisp Modified: compiler/generic/new-genesis.lisp compiler/generic/new-genesis.lisp: o More cleanups. Basically back to rev 1.93 with a couple more cleanups, but this works on sparc. bootfiles/20b/boot-2010-12.lisp: o Use this to bootstrap the necessary values in the compiler backend for the foreign-linkage-space. -----------------------------------+ bootfiles/20b/boot-2010-12.lisp | 23 +++++++++++ compiler/generic/new-genesis.lisp | 71 ++++++------------------------------ 2 files changed, 36 insertions(+), 58 deletions(-) Index: src/bootfiles/20b/boot-2010-12.lisp diff -u /dev/null src/bootfiles/20b/boot-2010-12.lisp:1.1 --- /dev/null Mon Dec 13 19:26:43 2010 +++ src/bootfiles/20b/boot-2010-12.lisp Mon Dec 13 19:26:42 2010 @@ -0,0 +1,23 @@ +;; Setup backend-foreign-linkage-space-start/entry-size for each +;; architecture. + +#+x86 +(setf (c::backend-foreign-linkage-space-start c:*target-backend*) + #+linux #x58000000 + #-linux #xB0000000 + (c::backend-foreign-linkage-entry-size c:*target-backend*) + 8) + +#+sparc +(setf (c::backend-foreign-linkage-space-start c:*target-backend*) + ;; This better match the value in sparc-validate.h! + #x0f800000 + (c::backend-foreign-linkage-entry-size c:*target-backend*) + ;; This better agree with what sparc-arch.c thinks it is! Right now, + ;; it's 4 instructions, so 16 bytes. + 16) +#+ppc +(setf (c::backend-foreign-linkage-space-start c:*target-backend*) + #x17000000 + (c::backend-foreign-linkage-entry-size c:*target-backend*) + 32) \ No newline at end of file Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.94 src/compiler/generic/new-genesis.lisp:1.95 --- src/compiler/generic/new-genesis.lisp:1.94 Sat Dec 11 10:07:08 2010 +++ src/compiler/generic/new-genesis.lisp Mon Dec 13 19:26:43 2010 @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.94 2010-12-11 15:07:08 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.95 2010-12-14 00:26:43 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1321,42 +1321,24 @@ ;; Destructively byte swap a string, if the backend and the native ;; backend have different endianness. (declaim (inline maybe-byte-swap-string)) -#+unicode (defun maybe-byte-swap-string (s &optional (len (length s))) + #-unicode + (declare (ignore len)) + #+unicode (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) (dotimes (k len) (let ((code (char-code (aref s k)))) (setf (aref s k) (code-char (swap-16 code)))))) s) -#-unicode -(defun maybe-byte-swap-string (s &optional len) - (declare (ignore s len)) - s) ;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns ;;; that symbol in the given Package. ;;; -#-unicode -(defun cold-load-symbol (size package) - (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 size) - (cold-intern (intern string package) package))) - -#+unicode -(defmacro load-char-code () - (ecase (c::backend-byte-order c::*native-backend*) - (:little-endian - `(code-char (+ (read-arg 1) - (ash (read-arg 1) 8)))) - (:big-endian - `(code-char (+ (ash (read-arg 1) 8) - (read-arg 1)))))) -#+unicode (defun cold-load-symbol (size package) (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* 2 size)) + (read-n-bytes *fasl-file* string 0 (* vm:char-bytes size)) (maybe-byte-swap-string string) (cold-intern (intern string package) package))) @@ -1383,21 +1365,11 @@ (fop-keyword-small-symbol-save) (push-table (cold-load-symbol (clone-arg) *keyword-package*))) -#-unicode (clone-cold-fop (fop-uninterned-symbol-save) (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-n-bytes *fasl-file* name 0 size) - (let ((symbol (allocate-symbol name))) - (push-table symbol)))) - -#+unicode -(clone-cold-fop (fop-uninterned-symbol-save) - (fop-uninterned-small-symbol-save) - (let* ((size (clone-arg)) - (name (make-string size))) - (read-n-bytes *fasl-file* name 0 (* 2 size)) + (read-n-bytes *fasl-file* name 0 (* vm:char-bytes size)) (maybe-byte-swap-string name) (let ((symbol (allocate-symbol name))) (push-table symbol)))) @@ -1452,20 +1424,11 @@ ;;; Loading vectors... -#-unicode (clone-cold-fop (fop-string) (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-n-bytes *fasl-file* string 0 len) - (string-to-core string))) - -#+unicode -(clone-cold-fop (fop-string) - (fop-small-string) - (let* ((len (clone-arg)) - (string (make-string len))) - (read-n-bytes *fasl-file* string 0 (* 2 len)) + (read-n-bytes *fasl-file* string 0 (* vm:char-bytes len)) (maybe-byte-swap-string string) (string-to-core string))) @@ -1989,12 +1952,8 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - #-unicode - (read-n-bytes *fasl-file* sym 0 len) - #+unicode - (progn - (read-n-bytes *fasl-file* sym 0 (* 2 len)) - (maybe-byte-swap-string sym)) + (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) + (maybe-byte-swap-string sym) (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) @@ -2010,12 +1969,8 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - #-unicode - (read-n-bytes *fasl-file* sym 0 len) - #+unicode - (progn - (read-n-bytes *fasl-file* sym 0 (* 2 len)) - (maybe-byte-swap-string sym)) + (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) + (maybe-byte-swap-string sym) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind)) @@ -2218,8 +2173,8 @@ type *cold-linkage-table* *cold-foreign-hash*))) - (+ vm:target-foreign-linkage-space-start - (* entry-num vm:target-foreign-linkage-entry-size)))) + (+ (c:backend-foreign-linkage-space-start c:*backend*) + (* entry-num (c:backend-foreign-linkage-entry-size c:*backend*))))) #+linkage-table (defun init-foreign-linkage ()

1 0

[cmucl-cvs] CMUCL commit: src/code (intl.lisp)
by Raymond Toy 13 Dec '10

13 Dec '10

Date: Sunday, December 12, 2010 @ 19:19:38 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: intl.lisp Revert previous change. Instead of caching probe-file, have LOAD-DOMAIN return an appropriate entry instead of returning NIL. This still gets rid of all the stats. Solution from Paul Foley. -----------+ intl.lisp | 77 ++++++++++++++++++++++++------------------------------------ 1 file changed, 31 insertions(+), 46 deletions(-) Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.9 src/code/intl.lisp:1.10 --- src/code/intl.lisp:1.9 Sat Dec 11 17:39:46 2010 +++ src/code/intl.lisp Sun Dec 12 19:19:38 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- -;;; $Revision: 1.9 $ +;;; $Revision: 1.10 $ ;;; Copyright 1999-2010 Paul Foley (mycroft(a)actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.9 2010-12-11 22:39:46 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.10 2010-12-13 00:19:38 rtoy Exp $") (in-package "INTL") @@ -79,49 +79,29 @@ (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream)))) -;; If the domain file doesn't exist because the locale isn't -;; supported, we end up doing a huge number of stats looking for a -;; non-existent file everytime a translation is needed. This is -;; really expensive. So create a cache to hold the results. -(let ((domain-file-cache (make-hash-table :test 'equal))) - (defun get-domain-file-cache () - ;; Mostly for debugging to let the user get at the cache. - domain-file-cache) - (defun clear-domain-file-cache () - ;; Mostly for debugging. But also useful if we now have installed - ;; some new translations. - (clrhash domain-file-cache)) - (defun locate-domain-file (domain locale locale-dir) - ;; The default locale-dir includes search lists. If we get called - ;; before the search lists are initialized, we lose. The search - ;; lists are initialized in environment-init, which sets - ;; *environment-list-initialized*. This way, we return NIL to - ;; indicate there's no domain file to use. - (when lisp::*environment-list-initialized* - (flet ((path (locale base) - (merge-pathnames (make-pathname :directory (list :relative locale - "LC_MESSAGES") - :name domain :type "mo") - base)) - (memoized-probe-file (p) - ;; Cache the results of probe-file and return the - ;; cached value when possible. - (multiple-value-bind (value foundp) - (gethash p domain-file-cache) - (if foundp - value - (setf (gethash p domain-file-cache) (probe-file p)))))) - (let ((locale (or (gethash locale *locale-aliases*) locale))) - (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) - (let ((probe - (or (memoized-probe-file (path locale base)) - (let ((dot (position #\. locale))) - (and dot (memoized-probe-file (path (subseq locale 0 dot) base)))) - (let ((at (position #\@ locale))) - (and at (memoized-probe-file (path (subseq locale 0 at) base)))) - (let ((us (position #\_ locale))) - (and us (memoized-probe-file (path (subseq locale 0 us) base))))))) - (when probe (return probe))))))))) +(defun locate-domain-file (domain locale locale-dir) + ;; The default locale-dir includes search lists. If we get called + ;; before the search lists are initialized, we lose. The search + ;; lists are initialized in environment-init, which sets + ;; *environment-list-initialized*. This way, we return NIL to + ;; indicate there's no domain file to use. + (when lisp::*environment-list-initialized* + (flet ((path (locale base) + (merge-pathnames (make-pathname :directory (list :relative locale + "LC_MESSAGES") + :name domain :type "mo") + base))) + (let ((locale (or (gethash locale *locale-aliases*) locale))) + (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) + (let ((probe + (or (probe-file (path locale base)) + (let ((dot (position #\. locale))) + (and dot (probe-file (path (subseq locale 0 dot) base)))) + (let ((at (position #\@ locale))) + (and at (probe-file (path (subseq locale 0 at) base)))) + (let ((us (position #\_ locale))) + (and us (probe-file (path (subseq locale 0 us) base))))))) + (when probe (return probe)))))))) (defun find-encoding (domain) (when (null (domain-entry-encoding domain)) @@ -341,7 +321,12 @@ (defun load-domain (domain locale &optional (locale-dir *locale-directories*)) (let ((file (locate-domain-file domain locale locale-dir)) (read #'read-lelong)) - (unless file (return-from load-domain nil)) + (unless file + (let ((entry (make-domain-entry :domain domain :locale locale + :hash (make-hash-table :size 0 + :test 'equal)))) + (setf (gethash domain *loaded-domains*) entry) + (return-from load-domain entry))) (with-open-file (stream file :direction :input :if-does-not-exist nil :element-type '(unsigned-byte 8)) (unless stream (return-from load-domain nil))

1 0

[cmucl-cvs] CMUCL commit: src/code (intl.lisp)
by Raymond Toy 11 Dec '10

11 Dec '10

Date: Saturday, December 11, 2010 @ 17:39:46 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: intl.lisp Speed up building on sparc. Time taken is now almost half! This was caused by all the calls to stat in PROBE-FILE in LOCATE-DOMAIN-FILE for files that did not exist. The default locale was C, so every message lookup was causing many stat's to non-exist files. (There were over 1000 calls/sec on a 750 MHz sparc!) So we cache all the calls to PROBE-FILE in LOCATE-DOMAIN-FILE. But just in case, we also allow the user to get at the hash table to examine it (GET-DOMAIN-FILE-CACHE) and also allow the user to clear it (CLEAR-DOMAIN-FILE-CACHE) in case new translations are added without restarting lisp. -----------+ intl.lisp | 70 ++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 25 deletions(-) Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.8 src/code/intl.lisp:1.9 --- src/code/intl.lisp:1.8 Tue Jul 13 23:13:20 2010 +++ src/code/intl.lisp Sat Dec 11 17:39:46 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- -;;; $Revision: 1.8 $ +;;; $Revision: 1.9 $ ;;; Copyright 1999-2010 Paul Foley (mycroft(a)actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.8 2010-07-14 03:13:20 rtoy Rel $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.9 2010-12-11 22:39:46 rtoy Exp $") (in-package "INTL") @@ -79,29 +79,49 @@ (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream)))) -(defun locate-domain-file (domain locale locale-dir) - ;; The default locale-dir includes search lists. If we get called - ;; before the search lists are initialized, we lose. The search - ;; lists are initialized in environment-init, which sets - ;; *environment-list-initialized*. This way, we return NIL to - ;; indicate there's no domain file to use. - (when lisp::*environment-list-initialized* - (flet ((path (locale base) - (merge-pathnames (make-pathname :directory (list :relative locale - "LC_MESSAGES") - :name domain :type "mo") - base))) - (let ((locale (or (gethash locale *locale-aliases*) locale))) - (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) - (let ((probe - (or (probe-file (path locale base)) - (let ((dot (position #\. locale))) - (and dot (probe-file (path (subseq locale 0 dot) base)))) - (let ((at (position #\@ locale))) - (and at (probe-file (path (subseq locale 0 at) base)))) - (let ((us (position #\_ locale))) - (and us (probe-file (path (subseq locale 0 us) base))))))) - (when probe (return probe)))))))) +;; If the domain file doesn't exist because the locale isn't +;; supported, we end up doing a huge number of stats looking for a +;; non-existent file everytime a translation is needed. This is +;; really expensive. So create a cache to hold the results. +(let ((domain-file-cache (make-hash-table :test 'equal))) + (defun get-domain-file-cache () + ;; Mostly for debugging to let the user get at the cache. + domain-file-cache) + (defun clear-domain-file-cache () + ;; Mostly for debugging. But also useful if we now have installed + ;; some new translations. + (clrhash domain-file-cache)) + (defun locate-domain-file (domain locale locale-dir) + ;; The default locale-dir includes search lists. If we get called + ;; before the search lists are initialized, we lose. The search + ;; lists are initialized in environment-init, which sets + ;; *environment-list-initialized*. This way, we return NIL to + ;; indicate there's no domain file to use. + (when lisp::*environment-list-initialized* + (flet ((path (locale base) + (merge-pathnames (make-pathname :directory (list :relative locale + "LC_MESSAGES") + :name domain :type "mo") + base)) + (memoized-probe-file (p) + ;; Cache the results of probe-file and return the + ;; cached value when possible. + (multiple-value-bind (value foundp) + (gethash p domain-file-cache) + (if foundp + value + (setf (gethash p domain-file-cache) (probe-file p)))))) + (let ((locale (or (gethash locale *locale-aliases*) locale))) + (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) + (let ((probe + (or (memoized-probe-file (path locale base)) + (let ((dot (position #\. locale))) + (and dot (memoized-probe-file (path (subseq locale 0 dot) base)))) + (let ((at (position #\@ locale))) + (and at (memoized-probe-file (path (subseq locale 0 at) base)))) + (let ((us (position #\_ locale))) + (and us (memoized-probe-file (path (subseq locale 0 us) base))))))) + (when probe (return probe))))))))) (defun find-encoding (domain) (when (null (domain-entry-encoding domain))

1 0

[cmucl-cvs] CMUCL commit: src/compiler/generic (new-genesis.lisp)
by Raymond Toy 11 Dec '10

11 Dec '10

Date: Saturday, December 11, 2010 @ 10:07:08 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/generic Modified: new-genesis.lisp Revert some of the previous cleanups. They were preventing building on sparc for some reason. We keep the unicode and non-unicode fops separate for now. ------------------+ new-genesis.lisp | 85 ++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 59 insertions(+), 26 deletions(-) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.93 src/compiler/generic/new-genesis.lisp:1.94 --- src/compiler/generic/new-genesis.lisp:1.93 Sat Dec 4 18:17:06 2010 +++ src/compiler/generic/new-genesis.lisp Sat Dec 11 10:07:08 2010 @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.93 2010-12-04 23:17:06 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.94 2010-12-11 15:07:08 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -431,22 +431,15 @@ vm:simple-string-type)) (bytes (make-array (1+ len) :element-type '(unsigned-byte 16)))) (write-indexed des vm:vector-length-slot (make-fixnum-descriptor len)) - (dotimes (k len) (setf (aref bytes k) (logand #xffff (char-code (aref string k))))) (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) - ;; Swap byte order of unicode strings if the backend and - ;; native-backend have different endianness. - #+(or) - (progn - (format t "s-t-c: len = ~d, ~S~%" len string) - (format t " codes = ~{~X~^ ~}~%" (map 'list #'char-code string))) + ;; Swap byte order of unicode strings. (dotimes (k len) (let ((x (aref bytes k))) - (setf (aref bytes k) (maybe-byte-swap-short x)))) - #+(or) - (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list))) + (setf (aref bytes k) (+ (ldb (byte 8 8) x) + (ash (ldb (byte 8 0) x) 8)))))) (copy-to-system-area bytes (* vm:vector-data-offset ;; the word size of the native backend which ;; may be different from the target backend @@ -1340,15 +1333,30 @@ (defun maybe-byte-swap-string (s &optional len) (declare (ignore s len)) s) - + ;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns ;;; that symbol in the given Package. ;;; +#-unicode +(defun cold-load-symbol (size package) + (let ((string (make-string size))) + (read-n-bytes *fasl-file* string 0 size) + (cold-intern (intern string package) package))) + +#+unicode +(defmacro load-char-code () + (ecase (c::backend-byte-order c::*native-backend*) + (:little-endian + `(code-char (+ (read-arg 1) + (ash (read-arg 1) 8)))) + (:big-endian + `(code-char (+ (ash (read-arg 1) 8) + (read-arg 1)))))) + +#+unicode (defun cold-load-symbol (size package) (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* vm:char-bytes size)) - ;; Make the string have the correct byte order for the native - ;; backend. + (read-n-bytes *fasl-file* string 0 (* 2 size)) (maybe-byte-swap-string string) (cold-intern (intern string package) package))) @@ -1375,11 +1383,21 @@ (fop-keyword-small-symbol-save) (push-table (cold-load-symbol (clone-arg) *keyword-package*))) +#-unicode +(clone-cold-fop (fop-uninterned-symbol-save) + (fop-uninterned-small-symbol-save) + (let* ((size (clone-arg)) + (name (make-string size))) + (read-n-bytes *fasl-file* name 0 size) + (let ((symbol (allocate-symbol name))) + (push-table symbol)))) + +#+unicode (clone-cold-fop (fop-uninterned-symbol-save) (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-n-bytes *fasl-file* name 0 (* vm:char-bytes size)) + (read-n-bytes *fasl-file* name 0 (* 2 size)) (maybe-byte-swap-string name) (let ((symbol (allocate-symbol name))) (push-table symbol)))) @@ -1434,14 +1452,20 @@ ;;; Loading vectors... +#-unicode +(clone-cold-fop (fop-string) + (fop-small-string) + (let* ((len (clone-arg)) + (string (make-string len))) + (read-n-bytes *fasl-file* string 0 len) + (string-to-core string))) + +#+unicode (clone-cold-fop (fop-string) (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-n-bytes *fasl-file* string 0 (* vm:char-bytes len)) - ;; Make the string have the correct byte order for the native - ;; backend. (This wouldn't be needed if string-to-core had an - ;; option not to swap bytes. + (read-n-bytes *fasl-file* string 0 (* 2 len)) (maybe-byte-swap-string string) (string-to-core string))) @@ -1965,8 +1989,13 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) - (maybe-byte-swap-string sym) + #-unicode + (read-n-bytes *fasl-file* sym 0 len) + #+unicode + (progn + (read-n-bytes *fasl-file* sym 0 (* 2 len)) + (maybe-byte-swap-string sym)) + (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) #-linkage-table (lookup-foreign-symbol sym))) @@ -1981,8 +2010,12 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) - (maybe-byte-swap-string sym) + #-unicode + (read-n-bytes *fasl-file* sym 0 len) + #+unicode + (progn + (read-n-bytes *fasl-file* sym 0 (* 2 len)) + (maybe-byte-swap-string sym)) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind)) @@ -2185,8 +2218,8 @@ type *cold-linkage-table* *cold-foreign-hash*))) - (+ (c:backend-foreign-linkage-space-start c:*backend*) - (* entry-num (c:backend-foreign-linkage-entry-size c:*backend*))))) + (+ vm:target-foreign-linkage-space-start + (* entry-num vm:target-foreign-linkage-entry-size)))) #+linkage-table (defun init-foreign-linkage ()

1 0

[cmucl-cvs] CMUCL commit: src/code (exports.lisp)
by Raymond Toy 09 Dec '10

09 Dec '10

Date: Thursday, December 9, 2010 @ 09:01:01 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: exports.lisp Export some UNIX symbols for FreeBSD to get rid of a build warning. --------------+ exports.lisp | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) Index: src/code/exports.lisp diff -u src/code/exports.lisp:1.302 src/code/exports.lisp:1.303 --- src/code/exports.lisp:1.302 Wed Nov 10 14:51:23 2010 +++ src/code/exports.lisp Thu Dec 9 09:01:01 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.302 2010-11-10 19:51:23 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.303 2010-12-09 14:01:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -338,6 +338,23 @@ "USER-INFO" "USER-INFO-NAME" "USER-INFO-PASSWORD" "USER-INFO-UID" "USER-INFO-GID" "USER-INFO-GECOS" "USER-INFO-DIR" "USER-INFO-SHELL" "GROUP-INFO" "GROUP-INFO-NAME" "GROUP-INFO-GID" "GROUP-INFO-MEMBERS") + #+freebsd + (:export "GROUP-INFO" + "GROUP-INFO-GID" + "GROUP-INFO-MEMBERS" + "GROUP-INFO-NAME" + "UNIX-GETGRGID" + "UNIX-GETGRNAM" + "UNIX-GETPWNAM" + "UNIX-GETPWUID" + "USER-INFO" + "USER-INFO-DIR" + "USER-INFO-GECOS" + "USER-INFO-GID" + "USER-INFO-NAME" + "USER-INFO-PASSWORD" + "USER-INFO-SHELL" + "USER-INFO-UID") #+ppc (:export "UNIX-GETPWUID" "USER-INFO"

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs December 2010