[PATCH] Thread-local storage for gst

This patch implements thread-local storage.  In order to avoid expensive
locks, each process can only access its own environment.  To enforce
this all the access is proxied by a ProcessEnvironment singleton object,
returned by ProcessorScheduler>>#environment.

I'm sending this also to the seaside-dev mailing list to tell them that
this particular patch is released under MIT license and they can take
any pieces they care about (if they do).  The same patch will be
committed with ProcEnv.st under LGPL to the GNU Smalltalk repository.

Paolo

2008-04-01  Paolo Bonzini  <[hidden email]>

        * kernel/Process.st: Rename unwindPoints variable to environment.
        * kernel/ProcSched.st: Add #processEnvironment.
        * kernel/ProcEnv.st: New.

        * tests/processes.st: Test ProcessEnvironment.
        * tests/processes.ok: New.

        * libgst/dict.c: Rename unwindPoints variable of Process to environment.
        * libgst/files.c: Load ProcEnv.st.

diff --git a/NEWS b/NEWS
index cc10c77..5ef1438 100644
--- a/NEWS
+++ b/NEWS
@@ -41,6 +41,9 @@ o   The semantics of #on:do: were changed: executing off the end of an
 o   New tool gst-remote allows remote control of a GNU Smalltalk VM
     via a TCP socket.
 
+o   Processes support thread-local variables, which are accessed through
+    a special dictionary returned by ProcessorScheduler>>#processEnvironment.
+
 o   Packages can specify start/stop scripts.  Start scripts can be activated
     with gst-load, while both start and stop scripts are supported by
     gst-remote.
diff --git a/kernel/ProcEnv.st b/kernel/ProcEnv.st
new file mode 100644
index 0000000..490c4a4
--- /dev/null
+++ b/kernel/ProcEnv.st
@@ -0,0 +1,170 @@
+"======================================================================
+|
+|   ProcessEnvironment Method Definitions
+|
+|
+ ======================================================================"
+
+
+LookupKey subclass: ProcessVariable [
+    <category: 'Language-Processes'>
+    <comment: 'I represent a proxy for a thread-local variable defined
+for a process.  Requesting the value will return the thread-local
+setting for the current process.'>
+
+    environment [
+ ^Processor activeProcess
+    ]
+
+    value [
+ ^Processor activeProcess environment at: self key ifAbsent: [ nil ]
+    ]
+
+    value: anObject [
+ Processor activeProcess environment at: self key put: anObject
+    ]
+]
+
+]
+
+Object subclass: ProcessEnvironment [
+    <category: 'Language-Processes'>
+    <comment: 'I represent a proxy for thread-local variables defined for
+Smalltalk processes.  Associations requested to me retrieve the thread-local
+value for the current process.  For now, I don''t provide the full protocol of
+a Dictionary; in particular the iteration protocol is absent.'>
+
+    ProcessEnvironment class [
+ | uniqueInstance |
+
+ uniqueInstance [
+    "Return the singleton instance of ProcessEnvironment."
+    uniqueInstance isNil ifTrue: [ uniqueInstance := self basicNew ].
+    ^uniqueInstance
+ ]
+
+ new [
+    self shouldNotImplement
+ ]
+    ]
+
+    add: newObject [
+        "Add the newObject association to the receiver"
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment add: newObject
+    ]
+
+    at: key put: value [
+        "Store value as associated to the given key"
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment at: key put: value
+    ]
+
+    at: key [
+        "Answer the value associated to the given key. Return nil if the key
+         is not found"
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment at: key ifAbsent: [nil]
+    ]
+
+    at: key ifAbsent: aBlock [
+        "Answer the value associated to the given key, or the result of evaluating
+         aBlock if the key is not found"
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment at: key ifAbsent: aBlock
+    ]
+
+    at: key ifAbsentPut: aBlock [
+        "Answer the value associated to the given key, setting it to
+ the result of evaluating aBlock if the key is not found."
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment at: key ifAbsentPut: aBlock
+    ]
+
+    at: key ifPresent: aBlock [
+        "Answer the value associated to the given key, or the result of evaluating
+         aBlock if the key is not found"
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment at: key ifPresent: aBlock
+    ]
+
+    associationAt: key ifAbsent: aBlock [
+        "Answer the value associated to the given key, or the result of evaluating
+         aBlock if the key is not found"
+
+        <category: 'accessing'>
+        ^Kernel.ProcessVariable key: key
+    ]
+
+    associationAt: key [
+        "Answer the value associated to the given key, or the result of evaluating
+         aBlock if the key is not found"
+
+        <category: 'accessing'>
+        ^Kernel.ProcessVariable key: key
+    ]
+
+    keys [
+        "Answer a kind of Set containing the keys of the receiver"
+
+        <category: 'accessing'>
+        ^Processor activeProcess environment keys
+    ]
+
+    includesKey: key [
+        "Answer whether the receiver contains the given key"
+
+        <category: 'dictionary testing'>
+        ^Processor activeProcess environment includesKey: key
+    ]
+    removeAllKeys: keys [
+        "Remove all the keys in keys, without raising any errors"
+
+        <category: 'dictionary removing'>
+        keys do: [:key | self removeKey: key ifAbsent: []]
+    ]
+
+    removeAllKeys: keys ifAbsent: aBlock [
+        "Remove all the keys in keys, passing the missing keys as parameters
+         to aBlock as they're encountered"
+
+        <category: 'dictionary removing'>
+        keys do: [:key | self removeKey: key ifAbsent: [aBlock value: key]]
+    ]
+
+    remove: anAssociation [
+        "Remove anAssociation's key from the dictionary"
+
+        <category: 'dictionary removing'>
+ ^Processor activeProcess environment removeKey: anAssociation key
+    ifAbsent: []
+    ]
+
+    remove: anAssociation ifAbsent: aBlock [
+        "Remove anAssociation's key from the dictionary"
+
+        <category: 'dictionary removing'>
+ ^Processor activeProcess environment removeKey: anAssociation key
+    ifAbsent: aBlock
+    ]
+
+    removeKey: aSymbol [
+        "Remove the aSymbol key from the dictionary"
+
+        <category: 'dictionary removing'>
+ ^Processor activeProcess environment removeKey: aSymbol ifAbsent: []
+    ]
+
+    removeKey: aSymbol ifAbsent: aBlock [
+        "Remove the aSymbol key from the dictionary"
+
+        <category: 'dictionary removing'>
+ ^Processor activeProcess environment removeKey: aSymbol ifAbsent: aBlock
+    ]
+]
diff --git a/kernel/ProcSched.st b/kernel/ProcSched.st
index e5172ce..c3d6068 100644
--- a/kernel/ProcSched.st
+++ b/kernel/ProcSched.st
@@ -45,6 +45,18 @@ Object subclass: ProcessorScheduler [
  self shouldNotImplement
     ]
 
+    processEnvironment [
+ "Answer another singleton object hosting thread-local variables
+ for the Smalltalk processes.  This acts like a normal Dictionary
+ with a couple of differences: a) using #associationAt: will
+ return special associations that retrieve a thread-local value;
+ b) requesting missing keys will return nil, and removing them
+ will be a nop."
+
+ <category: 'basic'>
+ ^ProcessEnvironment uniqueInstance
+    ]
+
     activeProcess [
  "Answer the active process"
 
diff --git a/kernel/Process.st b/kernel/Process.st
index d5029e5..2109e47 100644
--- a/kernel/Process.st
+++ b/kernel/Process.st
@@ -33,7 +33,7 @@
 
 
 Link subclass: Process [
-    | suspendedContext priority myList name unwindPoints interruptLock interrupts |
+    | suspendedContext priority myList name environment interruptLock interrupts |
     
     <category: 'Language-Processes'>
     <comment: 'I represent a unit of computation.  My instances are independantly
@@ -319,10 +319,16 @@ can suspend themselves and resume themselves however they wish.'>
  ensure: [terminated ifFalse: [unwindBlock value]]
     ]
 
-    unwindPoints [
+    environment [
+ "This is private because it is not thread-safe.  Access via
+ ProcessorScheduler>>#environment only touches the environment
+ of the current process, so expensive semaphores are unnecessary.
+ We may want to revisit this in the future, but it won't be
+ backwards-incompatible."
+
  <category: 'private'>
- unwindPoints isNil ifTrue: [unwindPoints := OrderedCollection new].
- ^unwindPoints
+ environment isNil ifTrue: [environment := LookupTable new].
+ ^environment
     ]
 
     interruptLock [
diff --git a/libgst/dict.c b/libgst/dict.c
index 690439f..6600b1b 100644
--- a/libgst/dict.c
+++ b/libgst/dict.c
@@ -419,7 +419,7 @@ static const class_definition class_info[] = {
   {&_gst_process_class, &_gst_link_class,
    ISP_FIXED, true, 7,
    "Process",
-   "suspendedContext priority myList name unwindPoints interrupts interruptLock",
+   "suspendedContext priority myList name environment interrupts interruptLock",
    NULL, NULL },
 
   {&_gst_callin_process_class, &_gst_process_class,
diff --git a/libgst/files.c b/libgst/files.c
index e59bdf0..8b985c8 100644
--- a/libgst/files.c
+++ b/libgst/files.c
@@ -264,7 +264,8 @@ static const char standard_files[] = {
   "CFuncs.st\0"
   "CStruct.st\0"
 
-  /* Exception handling */
+  /* Exception handling and ProcessEnvironment */
+  "ProcEnv.st\0"
   "ExcHandling.st\0"
   "AnsiExcept.st\0"
 
diff --git a/packages.xml b/packages.xml
index e8f90af..dc0b527 100644
--- a/packages.xml
+++ b/packages.xml
@@ -149,6 +149,7 @@
   <file>CType.st</file>
   <file>IdentitySet.st</file>
   <file>ProcSched.st</file>
+  <file>ProcEnv.st</file>
   <file>ValueAdapt.st</file>
   <file>CharArray.st</file>
   <file>Integer.st</file>
diff --git a/tests/processes.ok b/tests/processes.ok
index ca571e4..86e7378 100644
--- a/tests/processes.ok
+++ b/tests/processes.ok
@@ -61,3 +61,13 @@ returned value is true
 
 Execution begins...
 returned value is nil
+
+Execution begins...
+nil
+1
+2
+nil
+3
+2
+2
+returned value is 2
diff --git a/tests/processes.st b/tests/processes.st
index 2285717..a61e419 100644
--- a/tests/processes.st
+++ b/tests/processes.st
@@ -237,3 +237,36 @@ Eval [
     [ stop ] whileFalse: [ queue nextPut: false. Processor yield ].
 ]
 
+
+"Test ProcessEnvironment and ProcessVariable"
+Eval [
+    "Value defaults to nil"
+    b := Processor processEnvironment associationAt: #a.
+    b value printNl.
+
+    "#at:put: affects #value"
+    Processor processEnvironment at: #a put: 1.
+    b value printNl.
+
+    "and #value: affects #at:"
+    b value: 2.
+    (Processor processEnvironment at: #a) printNl.
+    s := Semaphore new.
+    [
+ "Value defaults to nil here too."
+        b value printNl.
+
+ "Requesting value has not created the variable."
+        Processor processEnvironment at: #a ifAbsentPut: [3].
+        b value printNl.
+        s signal
+    ] fork.
+    s wait.
+
+    "The variable exists here..."
+    Processor processEnvironment at: #a ifAbsentPut: [4].
+
+    "... and its value is still 2."
+    (Processor processEnvironment at: #a) printNl.
+    b value printNl
+]
--
1.5.3.4.910.gc5122-dirty


_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk