From 68815e0edb16bcfec5aece3e9001171d531c89b1 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 22 Feb 2015 12:54:08 -0700 Subject: [PATCH] smp: without-interrupts: global.scm --- README.txt | 20 +++++++ src/microcode/intern.c | 130 ++++++++++++++++++++++++++++++++-------- src/runtime/global.scm | 15 ++++- src/runtime/runtime.pkg | 2 + 4 files changed, 140 insertions(+), 27 deletions(-) diff --git a/README.txt b/README.txt index d37659256..c987ab4ed 100644 --- a/README.txt +++ b/README.txt @@ -1146,9 +1146,29 @@ The hits with accompanying analysis: is now provided via a thread-mutex. global.scm:36: get-interrupt-enables set-interrupt-enables! with-interrupt-mask + Definitions. global.scm:129: (set-interrupt-enables! (fix:and limit-mask (get-interrupt-enables)))) + Caller: limit-interrupts! + No callers, but exported to (). global.scm:234: (with-absolutely-no-interrupts (ucode-primitive halt)) + Caller: %quit global.scm:346: (without-interrupts + Caller: clean-obarray + + OK. Callers of limit-interrupts! should be warned in the + Release Notes? Why does %quit use with-absolutely-no- + interrupts? + + The big problem was clean-obarray. It runs as a + secondary-gc-daemon (running in parallel with other + processors), and was using without-interrupts to ensure sole + access to the obarray. + + A number of primitives and compiler utilities modify the + obarray so a pthread mutex was introduced to serialize access + to it (conservatively, without much study of its modifier + procedures). Clean-obarray serializes with these C functions + using the new smp-lock-obarray primitive. hash.scm:168: (with-absolutely-no-interrupts hash.scm:213: (with-absolutely-no-interrupts diff --git a/src/microcode/intern.c b/src/microcode/intern.c index af6760715..e1c7b3545 100644 --- a/src/microcode/intern.c +++ b/src/microcode/intern.c @@ -26,9 +26,16 @@ USA. /* String hash functions and interning of symbols. */ -#include "scheme.h" #include "prims.h" +#include "ossmp.h" #include "trap.h" + +#ifdef ENABLE_SMP +static pthread_mutex_t mutex = MUTEX_INITIALIZER; +# ifdef ENABLE_DEBUGGING_TOOLS +static bool locked_p = false; +# endif +#endif /* The FNV hash, short for Fowler/Noll/Vo in honor of its creators. */ @@ -123,17 +130,21 @@ replace_symbol_bucket_type (SCHEME_OBJECT symbol, unsigned int type) void strengthen_symbol (SCHEME_OBJECT symbol) { + LOCK(); replace_symbol_bucket_type (symbol, TC_LIST); + UNLOCK(); } void weaken_symbol (SCHEME_OBJECT symbol) { + LOCK(); replace_symbol_bucket_type (symbol, TC_WEAK_CONS); + UNLOCK(); } static SCHEME_OBJECT -make_symbol (SCHEME_OBJECT string, SCHEME_OBJECT * cell) +make_symbol_entry (SCHEME_OBJECT string) { Primitive_GC_If_Needed (4); { @@ -141,26 +152,47 @@ make_symbol (SCHEME_OBJECT string, SCHEME_OBJECT * cell) Free += 2; MEMORY_SET (symbol, SYMBOL_NAME, string); MEMORY_SET (symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT); - (*cell) = (system_pair_cons (TC_WEAK_CONS, symbol, EMPTY_LIST)); - return (symbol); + return (system_pair_cons (TC_WEAK_CONS, symbol, EMPTY_LIST)); } } SCHEME_OBJECT find_symbol (unsigned long length, const char * string) { - SCHEME_OBJECT * cell = (find_symbol_internal (length, string)); - return ((INTERNED_SYMBOL_P (*cell)) ? (*cell) : SHARP_F); + SCHEME_OBJECT * cell, result; + LOCK(); + cell = (find_symbol_internal (length, string)); + result = ((INTERNED_SYMBOL_P (*cell)) ? (*cell) : SHARP_F); + UNLOCK(); + return (result); } SCHEME_OBJECT memory_to_symbol (unsigned long length, const void * string) { - SCHEME_OBJECT * cell = (find_symbol_internal (length, string)); - return - ((INTERNED_SYMBOL_P (*cell)) - ? (*cell) - : (make_symbol ((memory_to_string (length, string)), cell))); + SCHEME_OBJECT * cell, result; + LOCK(); + cell = (find_symbol_internal (length, string)); + if (INTERNED_SYMBOL_P (*cell)) + result = (*cell); + else + { + SCHEME_OBJECT entry; + UNLOCK(); + /* May abort for GC. */ + entry = (make_symbol_entry (memory_to_string (length, string))); + LOCK(); + cell = (find_symbol_internal (length, string)); + if (INTERNED_SYMBOL_P (*cell)) + result = (*cell); + else + { + (*cell) = entry; + result = PAIR_CAR (entry); + } + } + UNLOCK(); + return (result); } SCHEME_OBJECT @@ -172,29 +204,60 @@ char_pointer_to_symbol (const char * string) SCHEME_OBJECT string_to_symbol (SCHEME_OBJECT string) { - SCHEME_OBJECT * cell - = (find_symbol_internal ((STRING_LENGTH (string)), - (STRING_POINTER (string)))); - return ((INTERNED_SYMBOL_P (*cell)) - ? (*cell) - : (make_symbol (string, cell))); + unsigned long length = (STRING_LENGTH (string)); + const char * chars = (STRING_POINTER (string)); + SCHEME_OBJECT * cell, result; + LOCK(); + cell = (find_symbol_internal (length, chars)); + if (INTERNED_SYMBOL_P (*cell)) + result = (*cell); + else + { + SCHEME_OBJECT entry; + UNLOCK(); + /* May abort for GC. */ + entry = (make_symbol_entry (string)); + LOCK(); + cell = (find_symbol_internal (length, chars)); + if (INTERNED_SYMBOL_P (*cell)) + result = (*cell); + else + { + (*cell) = entry; + result = PAIR_CAR (entry); + } + } + UNLOCK(); + return (result); } SCHEME_OBJECT intern_symbol (SCHEME_OBJECT symbol) { - SCHEME_OBJECT name = (MEMORY_REF (symbol, SYMBOL_NAME)); - SCHEME_OBJECT * cell - = (find_symbol_internal ((STRING_LENGTH (name)), - (STRING_POINTER (name)))); + SCHEME_OBJECT string = (MEMORY_REF (symbol, SYMBOL_NAME)); + unsigned long length = (STRING_LENGTH (string)); + const char * chars = (STRING_POINTER (string)); + SCHEME_OBJECT * cell, result; + LOCK(); + cell = (find_symbol_internal (length, chars)); if (INTERNED_SYMBOL_P (*cell)) - return (*cell); + result = (*cell); else { - SCHEME_OBJECT result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol)); - (*cell) = (system_pair_cons (TC_WEAK_CONS, result, EMPTY_LIST)); - return (result); + SCHEME_OBJECT entry; + UNLOCK(); + /* May abort for GC. */ + result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol)); + entry = (system_pair_cons (TC_WEAK_CONS, result, EMPTY_LIST)); + LOCK(); + cell = (find_symbol_internal (length, chars)); + if (INTERNED_SYMBOL_P (*cell)) + result = (*cell); + else + (*cell) = entry; } + UNLOCK(); + return (result); } const char * @@ -265,3 +328,20 @@ Equivalent to (MODULO (STRING-HASH STRING) DENOMINATOR).") % (arg_ulong_integer (2)))); } } + +DEFINE_PRIMITIVE ("SMP-LOCK-OBARRAY", Prim_smp_lock_obarray, 1, 1, + "(SMP-LOCK-OBARRAY LOCK?)\n\ +When LOCK? is #F/non-#F, unlock/lock the pthread mutex serializing\n\ +accesses to the obarray.") +{ + PRIMITIVE_HEADER (1); + { +#ifdef ENABLE_SMP + if (ARG_REF (1) != SHARP_F) + LOCK(); + else + UNLOCK(); +#endif + } + PRIMITIVE_RETURN (UNSPECIFIC); +} diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 5a4823df8..23b3588c5 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -313,8 +313,19 @@ USA. (define unspecific (object-new-type (ucode-type constant) 1)) +(define-integrable (with-system-obarray-locked thunk) + (if enable-smp? + (begin + ((ucode-primitive smp-lock-obarray 1) #t) + (let ((value (thunk))) + ((ucode-primitive smp-lock-obarray 1) #f) + value)) + (thunk))) + (define (for-each-interned-symbol procedure) - (for-each-symbol-in-obarray (fixed-objects-item 'OBARRAY) procedure)) + (with-system-obarray-locked + (lambda () + (for-each-symbol-in-obarray (fixed-objects-item 'OBARRAY) procedure)))) (define (for-each-symbol-in-obarray obarray procedure) (let per-bucket ((index (vector-length obarray))) @@ -343,7 +354,7 @@ USA. list)) (define (clean-obarray) - (without-interrupts + (with-system-obarray-locked (lambda () (let ((obarray (fixed-objects-item 'OBARRAY))) (let loop ((index (vector-length obarray))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index d94c1683f..252f7eb2f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -412,6 +412,8 @@ USA. (define-package (runtime miscellaneous-global) (files "global") (parent (runtime)) + (import (runtime thread) + enable-smp?) (export () %exit %quit -- 2.25.1