'From Cuis 1.0 of 28 November 2009 [latest update: #337] on 8 December 2009 at 9:21:10 pm'!

!Object methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'!
printWithClosureAnalysisOn: aStream
	"Append to the argument, aStream, a sequence of characters that  
	identifies the receiver."

	| title |
	title := self class name.
	aStream
		nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']);
		nextPutAll: title! !

!Object methodsFor: 'testing' stamp: 'eem 5/23/2008 13:47'!
isClosure
	^false! !


!Behavior methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'!
printWithClosureAnalysisOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'a descendent of '.
	superclass printWithClosureAnalysisOn: aStream! !


!ClassDescription methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'!
printWithClosureAnalysisOn: aStream 

	aStream nextPutAll: self name! !


!CompiledMethod methodsFor: 'literals' stamp: 'eem 7/29/2008 17:23'!
headerDescription
	"Answer a description containing the information about the form of the 
	receiver and the form of the context needed to run the receiver."

	| s |
	s := '' writeStream.
	self header printOn: s.
	s cr; nextPutAll: '"primitive: '.
	self primitive printOn: s.
	s cr; nextPutAll: ' numArgs: '.
	self numArgs printOn: s.
	s cr; nextPutAll: ' numTemps: '.
	self numTemps printOn: s.
	s cr; nextPutAll: ' numLiterals: '.
	self numLiterals printOn: s.
	s cr; nextPutAll: ' frameSize: '.
	self frameSize printOn: s.
	s cr; nextPutAll: ' isClosureCompiled: '.
	self isBlueBookCompiled not printOn: s.
	s nextPut: $"; cr.
	^ s contents! !

!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/24/2008 14:27'!
qCompress: string firstTry: firstTry
	"A very simple text compression routine designed for method temp names.
	Most common 12 chars get values 0-11 packed in one 4-bit nibble;
	others get values 12-15 (2 bits) * 16 plus next nibble.
	Last char of str must be a space so it may be dropped without
	consequence if output ends on odd nibble.
	Normal call is with firstTry == true."
	| charTable odd ix oddNibble names shorterStr maybe str temps |
	 str := string isOctetString
				ifTrue: [string]
				ifFalse: [temps := string findTokens: ' '.
					String
						streamContents: [:stream | 1
								to: temps size
								do: [:index | 
									stream nextPut: $t.
									stream nextPutAll: index asString.
									stream space]]].
	charTable :=  "Character encoding table must match qDecompress:"
	' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
	^ ByteArray streamContents:
		[:strm | odd := true.  "Flag for odd or even nibble out"
		oddNibble := nil.
		str do:
			[:char | ix := (charTable indexOf: char) - 1.
			(ix <= 12 ifTrue: [Array with: ix]
				ifFalse: [Array with: ix//16+12 with: ix\\16])
				do:
				[:nibble | (odd := odd not)
					ifTrue: [strm nextPut: oddNibble*16 + nibble]
					ifFalse: [oddNibble := nibble]]].
		strm position > 251 ifTrue:
			["Only values 1...251 are available for the flag byte
			that signals compressed temps. See the logic in endPC."
			"Before giving up completely, we attempt to encode most of
			the temps, but with the last few shortened to tNN-style names."
			firstTry ifFalse: [^ nil "already tried --give up now"].
			names := str findTokens: ' '.
			names size < 8 ifTrue: [^ nil  "weird case -- give up now"].
			4 to: names size//2 by: 4 do:
				[:i | shorterStr := String streamContents:
					[:s |
					1 to: names size - i do: [:j | s nextPutAll: (names at: j); space].
					1 to: i do: [:j | s nextPutAll: 't' , j printString; space]].
				(maybe := self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]].
			^ nil].
		strm nextPut: strm position]
"
  | m s |  m := CompiledMethod new.
s := 'charTable odd ix oddNibble '.
^ Array with: s size with: (m qCompress: s) size
	with: (m qDecompress: (m qCompress: s))
"
! !

!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/24/2008 14:30'!
qDecompress: byteArray
	"Decompress strings compressed by qCompress:.
	Most common 12 chars get values 0-11 packed in one 4-bit nibble;
	others get values 12-15 (2 bits) * 16 plus next nibble"
	|  charTable extended ext |
	charTable :=  "Character encoding table must match qCompress:"
	' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
	^ String streamContents:
		[:strm | extended := false.  "Flag for 2-nibble characters"
		byteArray do:
			[:byte | 
			(Array with: byte//16 with: byte\\16) do:
				[:nibble |
				extended
					ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended := false]
					ifFalse: [nibble < 12
								ifTrue: [strm nextPut: (charTable at: nibble + 1)]
								ifFalse: [ext := nibble-12.  extended := true]]]]]! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'eem 7/29/2008 17:15'!
methodNode
	"Return the parse tree that represents self"
	| aClass source |
	aClass := self methodClass.
	^ (source := self getSourceFromFile)
		ifNil: [self decompile]
		ifNotNil: [aClass parserClass new
					encoderClass: (self isBlueBookCompiled
									ifTrue: [EncoderForV3]
									ifFalse: [EncoderForV3PlusClosures]);
					parse: source class: aClass]! !


!CompiledMethod class methodsFor: 'class initialization' stamp: 'eem 6/5/2008 09:05'!
initialize    "CompiledMethod initialize"
	"Initialize class variables specifying the size of the temporary frame
	needed to run instances of me."

	SmallFrame := 16.	"Context range for temps+stack"
	LargeFrame := 56! !


!Debugger methodsFor: 'context stack (message list)' stamp: 'eem 9/5/2008 13:57'!
selectedMessageName
	"Answer the message selector of the currently selected context.
	 If the method is unbound we can still usefully answer its old selector."

	| selector |
	selector := self selectedContext methodSelector.
	^(selector ~~ self selectedContext method selector
	    and: [selector beginsWith: 'DoIt'])
		ifTrue: [self selectedContext method selector]
		ifFalse: [selector]! !


!InstructionStream methodsFor: 'testing' stamp: 'eem 6/4/2008 15:58'!
willStore
	"Answer whether the next bytecode is a store or store-pop"

	| byte |
	byte := self method at: pc.
	^(byte between: 96 and: 142)
		and: [byte <= 111			"96 103		storeAndPopReceiverVariableBytecode"
									"104 111	storeAndPopTemporaryVariableBytecode"
			or: [byte >= 129		"129		extendedStoreBytecode"
				and: [byte <= 130	"130		extendedStoreAndPopBytecode"
					or: [(byte = 132	"132		doubleExtendedDoAnythingBytecode"
						and: [(self method at: pc+1) >= 160])
					or: [byte = 141	"141		storeRemoteTempLongBytecode"
					or: [byte = 142	"142		storeAndPopRemoteTempLongBytecode"]]]]]]! !

!InstructionStream methodsFor: 'testing' stamp: 'eem 6/4/2008 15:56'!
willStorePop
	"Answer whether the next bytecode is a store-pop."

	| byte |
	byte := self method at: pc.
	^byte = 130					"130		extendedStoreAndPopBytecode"
	  or: [byte = 142				"142		storeAndPopRemoteTempLongBytecode"
	  or: [byte between: 96 and: 111	"96 103		storeAndPopReceiverVariableBytecode"
									"104 111	storeAndPopTemporaryVariableBytecode"]]! !

!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/4/2008 10:58'!
addSelectorTo: set 
	"If this instruction is a send, add its selector to set."

	| selectorOrSelf |
	(selectorOrSelf := self selectorToSendOrSelf) == self ifFalse:
		[set add: selectorOrSelf]! !

!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:51'!
scanFor: scanBlock
	"Answer the index of the first bytecode for which scanBlock answer true
	 when supplied with that bytecode."

	| method end byte type |
	method := self method.
	end := method endPC.
	[pc <= end] whileTrue: 
		[(scanBlock value: (byte := method at: pc)) ifTrue:
			[^true].
		 type := byte // 16.
		 pc :=	type = 8 "extensions"
					ifTrue: [pc + (#(2 2 2 2 3 2 2 1 1 1 2 1 3 3 3 4) at: byte \\ 16 + 1)]
					ifFalse: [type = 10 "long jumps"
								ifTrue: [pc + 2]
								ifFalse: [pc + 1]]].
	^false! !


!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'!
methodReturnConstant: value
	"Simulate the action of a 'return constant' bytecode whose value is the
	 argument, value. This corresponds to a source expression like '^0'."

	^self return: value from: self methodReturnContext! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'!
methodReturnReceiver
	"Simulate the action of a 'return receiver' bytecode. This corresponds to
	 the source expression '^self'."

	^self return: self receiver from: self methodReturnContext! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'!
methodReturnTop
	"Simulate the action of a 'return top of stack' bytecode. This corresponds
	 to source expressions like '^something'."

	^self return: self pop from: self methodReturnContext! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:34'!
popIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into one of my temporary variables."

	self contextForLocalVariables at: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:34'!
pushTemporaryVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the 
	temporary variable whose index is the argument, index, on the top of 
	the stack."

	self push: (self contextForLocalVariables at: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:34'!
storeIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into one 
	of my temporary variables."

	self contextForLocalVariables at: offset + 1 put: self top! !

!ContextPart methodsFor: 'debugger access' stamp: 'eem 6/1/2008 09:43'!
stackOfSize: limit 
	"Answer an OrderedCollection of the top 'limit' contexts
	 on the receiver's sender chain."

	| stack ctxt |
	stack := OrderedCollection new.
	stack addLast: (ctxt := self).
	[(ctxt := ctxt sender) ~~ nil
	 and: [stack size < limit]] whileTrue:
		[stack addLast: ctxt].
	^stack! !

!ContextPart methodsFor: 'debugger access'!
swapSender: coroutine 
	"Replace the receiver's sender with coroutine and answer the receiver's 
	previous sender. For use in coroutining."

	| oldSender |
	oldSender := sender.
	sender := coroutine.
	^oldSender! !

!ContextPart methodsFor: 'controlling' stamp: 'eem 6/14/2008 19:17'!
blockCopy: numArgs 
	"Primitive. Distinguish a block of code from its enclosing method by 
	creating a new BlockContext for that block. The compiler inserts into all 
	methods that contain blocks the bytecodes to send the message 
	blockCopy:. Do not use blockCopy: in code that you write!! Only the 
	compiler can decide to send the message blockCopy:. Fail if numArgs is 
	not a SmallInteger. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 80>
	^ (BlockContext newForMethod: self method)
		home: self home
		startpc: pc + 2
		nargs: numArgs! !

!ContextPart methodsFor: 'controlling' stamp: 'ar 3/6/2001 14:26'!
terminateTo: previousContext
	"Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender."

	| currentContext sendingContext |
	<primitive: 196>
	(self hasSender: previousContext) ifTrue: [
		currentContext := sender.
		[currentContext == previousContext] whileFalse: [
			sendingContext := currentContext sender.
			currentContext terminate.
			currentContext := sendingContext]].
	sender := previousContext! !


!MethodContext methodsFor: 'initialize-release' stamp: 'eem 8/22/2008 09:57'!
privRefreshWith: aCompiledMethod 
	"Reinitialize the receiver as though it had been for a different method. 
	 Used by a Debugger when one of the methods to which it refers is 
	 recompiled."

	aCompiledMethod isCompiledMethod ifFalse:
		[self error: 'method can only be set to aCompiledMethod'].
	method := aCompiledMethod.
	self assert: closureOrNil == nil.
	"was: receiverMap := nil."
	self privRefresh! !

!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'!
home 
	"Answer the context in which the receiver was defined."

	closureOrNil == nil ifTrue:
		[^self].
	^closureOrNil outerContext home! !

!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'!
isExecutingBlock
	"Is this executing a block versus a method?  In the new closure
	 implemetation this is true if closureOrNil is not nil, in which case
	 it should be holding a BlockClosure."

	^closureOrNil isClosure! !

!MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 11:59'!
setSender: s receiver: r method: m arguments: args 
	"Create the receiver's initial state."

	sender := s.
	receiver := r.
	method := m.
	closureOrNil := nil.
	pc := method initialPC.
	self stackp: method numTemps.
	1 to: args size do: [:i | self at: i put: (args at: i)]! !

!MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 12:00'!
startpc
	^closureOrNil
		ifNil:	[self method initialPC]
		ifNotNil: [closureOrNil startpc]! !

!MethodContext methodsFor: 'printing' stamp: 'eem 5/27/2008 17:23'!
printOn: aStream

	self outerContext
		ifNil: [super printOn: aStream]
		ifNotNil:
			[:outerContext|
			 aStream nextPutAll: '[] in '.
			 outerContext printOn: aStream]! !

!MethodContext methodsFor: 'nil' stamp: 'jmv 12/8/2009 21:04'!
cannotReturn: result
	closureOrNil notNil ifTrue:
		[^self cannotReturn: result to: sender].
	Debugger
		openContext: thisContext
		label: 'computation has been terminated'
		contents: nil! !


!Parser methodsFor: 'public access' stamp: 'eem 6/19/2008 09:38'!
encoder
	encoder isNil ifTrue:
		[encoder := Encoder new].
	^encoder! !


!String methodsFor: 'testing' stamp: 'jmv 12/8/2009 21:03'!
isOctetString
	^true! !


!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'eem 9/23/2008 14:23'!
errorMessage
	^errorMessage! !

!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'eem 9/23/2008 14:23'!
location
	^location! !


!SystemDictionary methodsFor: 'special objects' stamp: 'eem 7/22/2008 18:37'!
recreateSpecialObjectsArray
	"Smalltalk recreateSpecialObjectsArray"
	"The Special Objects Array is an array of object pointers used
	by the
	Squeak virtual machine. Its contents are critical and
	unchecked, so don't even think of playing here unless you
	know what you are doing."
	| newArray |
	newArray := Array new: 50.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray at: 4 put: (self associationAt: #Processor).
	"Numerous classes below used for type checking and instantiation"
	newArray at: 5 put: Bitmap.
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: String.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk.
	newArray at: 10 put: Float.
	newArray at: 11 put: MethodContext.
	newArray at: 12 put: BlockContext.
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: Display.
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray at: 18 put: (self specialObjectsArray at: 18).
	"(low space Semaphore)"
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	newArray at: 23 put: nil.
	"An array of the 32 selectors that are compiled as special bytecodes,
	 paired alternately with the number of arguments each takes."
	newArray at: 24 put: #(	#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
							#* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
							#at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
							#blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
	"An array of the 255 Characters in ascii order."
	newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have compact headers"
	newArray at: 29 put: self compactClassesArray.
	newArray at: 30 put: (self specialObjectsArray at: 30).
	"(delay Semaphore)"
	newArray at: 31 put: (self specialObjectsArray at: 31).
	"(user interrupt Semaphore)"
	"Prototype instances that can be copied for fast initialization"
	newArray at: 32 put: (Float new: 2).
	newArray at: 33 put: (LargePositiveInteger new: 4).
	newArray at: 34 put: Point new.
	newArray at: 35 put: #cannotInterpret:.
	"Note: This must be fixed once we start using context prototypes (yeah, right)"
	"(MethodContext new: CompiledMethod fullFrameSize)."
	newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)"
	newArray at: 37 put: BlockClosure.
	"(BlockContext new: CompiledMethod fullFrameSize)."
	newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)"
	newArray at: 39 put: (self specialObjectsArray at: 39).	"preserve external semaphores"
	"array of objects referred to by external code"
	newArray at: 40 put: PseudoContext.
	newArray at: 41 put: TranslatedMethod.
	"finalization Semaphore"
	newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]).
	newArray at: 43 put: LargeNegativeInteger.
	"External objects for callout.
	 Note: Written so that one can actually completely remove the FFI."
	newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
	newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
	newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
	newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []).
	newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []).
	newArray at: 49 put: #aboutToReturn:through:.
	newArray at: 50 put: #run:with:in:.
	"Now replace the interpreter's reference in one atomic operation"
	self specialObjectsArray become: newArray! !

MethodContext removeSelector: #blockHome!
MethodContext removeSelector: #cachesStack!
MethodContext removeSelector: #finalBlockHome!
MethodContext removeSelector: #hideFromDebugger!
MethodContext removeSelector: #isMethodContext!
BlockContext removeSelector: #blockHome!
BlockContext removeSelector: #finalBlockHome!
BlockContext removeSelector: #hideFromDebugger!
BlockContext removeSelector: #ifProperUnwindSupportedElseSignalAboutToReturn!
BlockContext removeSelector: #isMethodContext!
ContextPart removeSelector: #blockHome!
ContextPart removeSelector: #cachesStack!
CompiledMethod initialize!
Object removeSelector: #isBlockClosure!
"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
CompiledMethod initialize.
ByteArray variableByteSubclass: #CompiledMethod
	instanceVariableNames: ''
	classVariableNames: 'LargeFrame SmallFrame'
	poolDictionaries: ''
	category: 'Kernel-Methods'.
"Postscript:
Remove unused class vars from CompiledMethod since we can't redefine its class definition directly.
 Add the new BlockClosure to the specialObjectsArray"
(#(#BlockNodeCache #SpecialConstants) intersection: CompiledMethod classPool keys) do:
	[:classVarName|
	CompiledMethod removeClassVarName: classVarName].
Smalltalk recreateSpecialObjectsArray!

