The Trunk: Kernel-ul.1098.mcz

Levente Uzonyi uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-ul.1098.mcz

==================== 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].
 
  newClass
  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].
 
  ^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.
  newMeta
  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') -----
  copyTwoLevel
  "one more level than a shallowCopy"
 
  | newObject class index |
  class := self class.
+ newObject := self shallowCopy.
- newObject := self clone.
  newObject == self ifTrue: [^ self].
  class isVariable
  ifTrue:
  [index := self basicSize.
  [index > 0]
  whileTrue:
  [newObject basicAt: index put: (self basicAt: index) shallowCopy.
  index := index - 1]].
  index := class instSize.
  [index > 0]
  whileTrue:
  [newObject instVarAt: index put: (self instVarAt: index) shallowCopy.
  index := index - 1].
  ^newObject!

Item was changed:
  ----- Method: Object>>shallowCopy (in category 'copying') -----
  shallowCopy
  "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
  !