[Pkg] The Trunk: Kernel-ul.1098.mcz

commits at source.squeak.org commits at source.squeak.org
Mon Apr 24 12:20:25 UTC 2017

Levente Uzonyi uploaded a new version of Kernel to project The Trunk:

==================== Summary ====================

Name: Kernel-ul.1098
Author: ul
Time: 24 April 2017, 12:59:49.967288 pm
UUID: f803e743-6f80-4bd8-9d1b-192f56d70de6
Ancestors: Kernel-eem.1097

- rewrote senders of #clone to use #shallowCopy
- Object >> #shallowCopy uses the fallback code of #clone, because that one is  simpler (copying is done by #copyFrom:) and can copy CompiledMethods too.

=============== Diff against Kernel-eem.1097 ===============

Item was changed:
  ----- Method: ClassBuilder>>newSubclassOf:type:instanceVariables:from: (in category 'class definition') -----
  newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass
  	"Create a new subclass of the given superclass with the given specification."
  	| newFormat newClass |
  	"Compute the format of the new class"
  	newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper.
  	newFormat ifNil: [^nil].
  	(oldClass == nil or:[oldClass isMeta not]) 
  		ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass]
+ 		ifFalse:[newClass := oldClass shallowCopy].
- 		ifFalse:[newClass := oldClass clone].
  		superclass: newSuper
  		methodDictionary: (oldClass ifNil: [MethodDictionary new] ifNotNil: [oldClass methodDict copy])
  		format: newFormat;
  		setInstVarNames: instVars.
  	oldClass ifNotNil:[
  		newClass organization: oldClass organization.
  		"Recompile the new class"
  		oldClass hasMethods 
  			ifTrue:[newClass compileAllFrom: oldClass].
  		oldClass hasTraitComposition ifTrue: [
  			newClass setTraitComposition: oldClass traitComposition copyTraitExpression ].
  		oldClass class hasTraitComposition ifTrue: [
  			newClass class setTraitComposition: oldClass class traitComposition copyTraitExpression ].
  		self recordClass: oldClass replacedBy: newClass.
  	(oldClass == nil or:[oldClass isObsolete not]) 
  		ifTrue:[newSuper addSubclass: newClass]
  		ifFalse:[newSuper addObsoleteSubclass: newClass].

Item was changed:
  ----- Method: ClassBuilder>>privateNewSubclassOf:from: (in category 'private') -----
  privateNewSubclassOf: newSuper from: oldClass
  	"Create a new meta and non-meta subclass of newSuper using oldClass as template"
  	"WARNING: This method does not preserve the superclass/subclass invariant!!"
  	| newSuperMeta oldMeta newMeta |
  	oldClass ifNil:[^self privateNewSubclassOf: newSuper].
  	newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class].
  	oldMeta := oldClass class.
+ 	newMeta := oldMeta shallowCopy.
- 	newMeta := oldMeta clone.
  		superclass: newSuperMeta
  		methodDictionary: oldMeta methodDict copy
  		format: (self computeFormat: oldMeta typeOfClass 
  					instSize: oldMeta instVarNames size 
  					forSuper: newSuperMeta);
  		setInstVarNames: oldMeta instVarNames;
  		organization: oldMeta organization.
  	"Recompile the meta class"
  	oldMeta hasMethods 
  		ifTrue:[newMeta compileAllFrom: oldMeta].
  	"Record the meta class change"
  	self recordClass: oldMeta replacedBy: newMeta.
  	"And create a new instance"
  	^newMeta adoptInstance: oldClass from: oldMeta!

Item was changed:
  ----- Method: EventSensor>>queueEvent: (in category 'private-I/O') -----
  queueEvent: evt
  	"Queue the given event in the event queue (if any).
  	Note that the event buffer must be copied since it
  	will be reused later on."
  	self eventQueue ifNotNil: [:queue |
+ 		queue nextPut: evt shallowCopy].!
- 		queue nextPut: evt clone].!

Item was changed:
  ----- Method: Float>>veryDeepCopyWith: (in category 'copying') -----
  veryDeepCopyWith: deepCopier
  	"Return self.  Do not record me."
+ 	^self shallowCopy!
- 	^ self clone!

Item was changed:
  ----- Method: Object>>copyTwoLevel (in category 'copying') -----
  	"one more level than a shallowCopy"
  	| newObject class index |
  	class := self class.
+ 	newObject := self shallowCopy.
- 	newObject := self clone.
  	newObject == self ifTrue: [^ self].
  	class isVariable
  			[index := self basicSize.
  			[index > 0]
  					[newObject basicAt: index put: (self basicAt: index) shallowCopy.
  					index := index - 1]].
  	index := class instSize.
  	[index > 0]
  			[newObject instVarAt: index put: (self instVarAt: index) shallowCopy.
  			index := index - 1].

Item was changed:
  ----- Method: Object>>shallowCopy (in category 'copying') -----
  	"Answer a copy of the receiver which shares the receiver's instance variables."
- 	| class newObject index |
  	<primitive: 148 error: ec>
+ 	| class newObject |
  	ec == #'insufficient object memory' ifFalse:
  		[^self primitiveFailed].
+ 	"If the primitive fails due to insufficient memory, instantiate via basicNew: to invoke
+ 	 the garbage collector before retrying, and use copyFrom: to copy state."
+ 	newObject := (class := self class) isVariable
+ 					ifTrue: 
+ 						[class isCompiledMethodClass
+ 							ifTrue:
+ 								[class newMethod: self basicSize - self initialPC + 1 header: self header]
+ 							ifFalse:
+ 								[class basicNew: self basicSize]]
+ 					ifFalse:
+ 						[class basicNew].
+ 	^newObject copyFrom: self!
- 	class := self class.
- 	class isVariable
- 		ifTrue: 
- 			[index := self basicSize.
- 			 newObject := class basicNew: index.
- 			 [index > 0] whileTrue: 
- 				[newObject basicAt: index put: (self basicAt: index).
- 				 index := index - 1]]
- 		ifFalse: [newObject := class basicNew].
- 	index := class instSize.
- 	[index > 0] whileTrue: 
- 		[newObject instVarAt: index put: (self instVarAt: index).
- 		 index := index - 1].
- 	^newObject!

Item was changed:
  ----- Method: Object>>veryDeepCopyWith: (in category 'copying') -----
  veryDeepCopyWith: deepCopier
  	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
  	| class index sub subAss new uc sup has mine |
  	deepCopier references at: self ifPresent: [:newer | ^ newer]. 	"already did him"
  	class := self class.
  	class isMeta ifTrue: [^ self].		"a class"
+ 	new := self shallowCopy.
- 	new := self clone.
  	(class isSystemDefined not and: [deepCopier newUniClasses "allowed"]) ifTrue: [
  		uc := deepCopier uniClasses at: class ifAbsent: [nil].
  		uc ifNil: [
  			deepCopier uniClasses at: class put: (uc := self copyUniClassWith: deepCopier).
  			deepCopier references at: class put: uc].	"remember"
  		new := uc new.
  		new copyFrom: self].	"copy inst vars in case any are weak"
  	deepCopier references at: self put: new.	"remember"
  	(class isVariable and: [class isPointers]) ifTrue: 
  		[index := self basicSize.
  		[index > 0] whileTrue: 
  			[sub := self basicAt: index.
  			(subAss := deepCopier references associationAt: sub ifAbsent: [nil])
  				ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)]
  				ifNotNil: [new basicAt: index put: subAss value].
  			index := index - 1]].
  	"Ask each superclass if it wants to share (weak copy) any inst vars"
  	new veryDeepInner: deepCopier.		"does super a lot"
  	"other superclasses want all inst vars deep copied"
  	sup := class.  index := class instSize.
  	[has := sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil].
  	has := has ifNil: [class isSystemDefined not "is a uniClass"] ifNotNil: [true].
  	mine := sup instVarNames.
  	has ifTrue: [index := index - mine size]	"skip inst vars"
  		ifFalse: [1 to: mine size do: [:xx |
  				sub := self instVarAt: index.
  				(subAss := deepCopier references associationAt: sub ifAbsent: [nil])
  						"use association, not value, so nil is an exceptional value"
  					ifNil: [new instVarAt: index put: 
  								(sub veryDeepCopyWith: deepCopier)]
  					ifNotNil: [new instVarAt: index put: subAss value].
  				index := index - 1]].
  	(sup := sup superclass) == nil] whileFalse.
  	new rehash.	"force Sets and Dictionaries to rehash"
  	^ new

More information about the Packages mailing list