'From Squeak3.8alpha of ''17 July 2004'' [latest update: #6229] on 23 September 2004 at 6:24:25 pm'! "Change Set: Kernel-Contexts Date: 23 September 2004 Author: Anthony Hannan/ .cs by md This is the Kernel-Contexts Systemcategory, it is part of the new Closure implementation. This changeset just puts some classes into Kernel-Contexts, they are not yet used. For that, insall the ClosureCompiler from SqueakMap"! Object subclass: #BlockClosure instanceVariableNames: 'method environment' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Contexts'! !BlockClosure commentStamp: 'ajh 7/19/2004 14:57' prior: 0! A BlockClosure is a block of Smalltalk code (enclosed within []) that may be executed later by sending #valueWithArguments: (or one of its variants) to it. A block can take arguments by specifying the names of the arguments in the beginning of the block, as in "[:arg1 :arg2 | ...]", and can have its own local temps, as in "[:arg1 | | temp1 temp2 | ...]". The block may reference variables outside its scope directly by name. It also may return from its home context by using ^, otherwise, the value of the last statement is returned to the sender of valueWithArguments:. Structure: method CompiledMethod2 Contains the block's code. It has its own method separate from its home method. environment ClosureEnvironment | Object The lexical environment the block was created in. The environment only contains variables that were captured/reference by this block or other sister blocks. If only self and/or its instance variables are captured then the environment is simply the receiver object. Each non-inlined blocks has its own CompiledMethod. These block methods are held in the literals of the home method and sent the #createBlock: message at runtime to create BlockClosures. Home method temps captured by inner blocks are placed inside a ClosureEnvironment when the home method is started. This environment is supplied as the argument to each #createBlock:. When #value... is sent to a block closure, its method is executed in a new MethodContext with its closure environment as the receiver. The block method accesses its free variables (captured home temps) via this environment. Closure environments are nested mirroring the nesting of blocks. Each environment points to its parent environment (the top method environment has no parent). However, for efficiency, environments that have no captured temps are skipped (never created). For example, an environment's parent may actually be its grand-parent. There is no special parent variable in ClosureEnvironment, it is just another named variable such as 'self' or 'parent env' (special var with space so it can't be referenced by user code), or it may not be their at all. A block closure that returns to its home context does so by finding the thisContext sender that owns the top environment. A return inside a block forces the home environment to be created even if it has no captured temps. Each context holds its local environment (which holds its captured temps) in its #myEnv instance variable (previously the unused #receiverMap variable). Code that references captured temps goes through the #myEnv context variable. Block closures are totally separate from their home context. They are reentrant and each activation has its own block-local temps. So except for the thisContext psuedo-variable, contexts are now LIFO (assuming we get rid of old block contexts and recompile the whole image). ! Object variableSubclass: #ClosureEnvironment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Contexts'! !ClosureEnvironment commentStamp: 'ajh 6/24/2004 03:33' prior: 0! An environment is a collection of temporary variable values that have escaped the original method context and placed in this environment because blocks existed in the method that reference these variables (and blocks may out live their creating context). Nested blocks create nested environments when temp vars are introduced at multiple levels and referenced at lower levels. So each environment has a parent environment in its first slot. The top environment has the original receiver in it first slot (if referenced by an inner block). A block consists of its outer environment and a method to execute while the outer environment is in the receiver position. A block that remote returns from its home context holds the home environment in its outer environment. The remote return unwinds the call stack to the context that created the home context. ! ProtoObject subclass: #MessageCatcher instanceVariableNames: 'echoToTranscript accumulator ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Contexts'! !MessageCatcher commentStamp: '' prior: 0! Any message sent to me is returned as a Message object. "Message catcher" creates an instance of me. ! Object subclass: #PseudoPoolVariable instanceVariableNames: 'name getterBlock setterBlock' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Contexts'! !PseudoPoolVariable commentStamp: '' prior: 0! The values of pool and global variables (traditionally Associations) are fetched by sending #poolValue and set by sending #setInPool: which send #poolValue:. These sends are automatically added in by the Compiler (see PoolVarNode {code generation}). So any object can act like a pool variable. This class allows getter and setter blocks for poolValue and poolValue:.! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 6/24/2004 03:50'! env: aClosureEnvironment "the outer environment" environment _ aClosureEnvironment! ! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 5/28/2001 18:37'! method: compiledMethod "compiledMethod will be the code I execute when I'm evaluated" method _ compiledMethod! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'! copyForSaving "obsolete"! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'! fixTemps "obsolete"! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/31/2003 12:53'! reentrant! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 7/15/2001 16:13'! valueError self error: 'Incompatible number of args'! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 7/26/2002 11:47'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess _ Processor activeProcess. oldPriority _ activeProcess priority. activeProcess priority: Processor highestPriority. result _ self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 6/24/2004 03:34'! veryDeepInner: deepCopier "Do not copy my method (which can be shared because CompiledMethod2 are basically treated as immutables) or my home context (MethodContexts are treated as immutables too)" super veryDeepInner: deepCopier. method _ method. environment _ environment. ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:04'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 15:57'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'! value "Evaluate the block with no args. Fail if the block expects other than 0 arguments." ^ environment executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'! value: arg1 "Evaluate the block with the given args. Fail if the block expects other than 1 arguments." ^ environment with: arg1 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'! value: arg1 value: arg2 "Evaluate the block with the given args. Fail if the block expects other than 2 arguments." ^ environment with: arg1 with: arg2 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'! value: arg1 value: arg2 value: arg3 "Evaluate the block with the given args. Fail if the block expects other than 3 arguments." ^ environment with: arg1 with: arg2 with: arg3 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'! value: arg1 value: arg2 value: arg3 value: arg4 "Evaluate the block with the given args. Fail if the block expects other than 4 arguments." ^ environment with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'! valueWithArguments: anArray "Evaluate the block with given args. Fail if the block expects other than the given number of arguments." ^ environment withArgs: anArray executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 14:44'! valueWithPossibleArgs: anArray | n | (n _ self numArgs) = 0 ifTrue: [^ self value]. n = anArray size ifTrue: [^ self valueWithArguments: anArray]. ^ self valueWithArguments: (n > anArray size ifTrue: [anArray, (Array new: n - anArray size)] ifFalse: [anArray copyFrom: 1 to: n])! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 6/24/2004 03:40'! env ^ environment! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 2/6/2003 13:24'! hasLiteralSuchThat: testBlock (testBlock value: method) ifTrue: [^ true]. ^ method hasLiteralSuchThat: testBlock! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/31/2003 16:59'! hasLiteralThorough: literal "Answer true if literal is identical to any literal imbedded in my method" method == literal ifTrue: [^ true]. ^ method hasLiteralThorough: literal! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 2/6/2003 13:27'! hasMethodReturn "Answer whether the receiver has a return ('^') in its code." ^ self method remoteReturns! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/21/2001 14:01'! method ^ method! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/28/2001 14:37'! numArgs ^ method numArgs! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! repeat "Evaluate the receiver repeatedly, ending only if the block explicitly returns." [self value. true] whileTrue! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! repeatWithGCIf: testBlock | ans | "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" ans _ self value. (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans _ self value ]. ^ans! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/15/2001 16:14'! assert self assert: self! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 5/20/2004 17:37'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b _ aBlock. thisContext tempAt: 1 put: nil. "aBlock _ nil" b value. ]. ^ returnValue! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/21/2003 17:50'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action." ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/1/2003 00:30'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | "just a marker, fail and execute the following" handlerActive _ true. ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/31/2003 20:41'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/26/2002 11:49'! valueUninterruptably "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." ^ self ifCurtailed: [^ self]! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 6/24/2004 03:43'! asContext "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" ^ MethodContext sender: nil receiver: environment method: method arguments: #()! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 1/27/2003 18:51'! callCC "Call with current continuation, ala Scheme. Evaluate self against a copy of the sender's call stack, which can be resumed later" ^ self value: thisContext sender asContinuation! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process while self runs" | semaphore | semaphore _ Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." ^ self newProcess priority: priority; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:23'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^ Process forContext: [self value. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/27/2002 12:26'! simulate "Like run except interpret self using Smalltalk instead of VM. It is much slower." ^ self newProcess simulate! ! !BlockClosure methodsFor: 'printing' stamp: 'ajh 9/10/2002 16:53'! printOn: aStream super printOn: aStream. aStream space; nextPutAll: self identityHashPrintString! ! !BlockClosure methodsFor: 'Camp Smalltalk' stamp: 'rw 1/23/2002 00:27'! sunitEnsure: aBlock ^self ensure: aBlock! ! !BlockClosure methodsFor: 'Camp Smalltalk' stamp: 'rw 1/23/2002 00:28'! sunitOn: anException do: aHandlerBlock ^self on: anException do: aHandlerBlock! ! !BlockClosure methodsFor: 'comparing' stamp: 'ajh 6/24/2004 03:56'! = other self class == other class ifFalse: [^ false]. self env = other env ifFalse: [^ false]. ^ self method = other method! ! !BlockClosure methodsFor: 'comparing' stamp: 'ajh 10/4/2002 17:12'! hash ^ method hash! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/24/2004 03:54'! = other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. 1 to: self size do: [:i | (self at: i) = (other at: i) ifFalse: [^ false]. ]. ^ true! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/24/2004 03:56'! hash "Answer an integer hash value for the receiver such that, -- the hash value of an unchanged object is constant over time, and -- two equal objects have equal hash values" | hash | hash _ self species hash. self size <= 10 ifTrue: [self do: [:elem | hash _ hash bitXor: elem hash]]. ^hash bitXor: self size hash! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 16:53'! inspectorClass ^ ClosureEnvInspector! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/29/2004 14:33'! return: value "Find thisContext sender that is owner of self and return from it" | home | home _ thisContext findContextSuchThat: [:ctxt | ctxt myEnv == self]. home return: value! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! doesNotUnderstand: aMessage accumulator ifNotNil: [accumulator add: aMessage]. ^ aMessage! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! privAccumulator ^ accumulator! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! privAccumulator: collection accumulator _ collection! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 12:08'! canAssign ^ setterBlock notNil! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:01'! getter: block getterBlock _ block! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 14:15'! name ^ name! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:00'! name: string name _ string! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:01'! setter: block setterBlock _ block! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 14:02'! value ^ getterBlock value! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 13:58'! value: obj setterBlock value: obj! ! ProtoObject subclass: #MessageCatcher instanceVariableNames: 'accumulator' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Contexts'!