[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] [PATCH] Rewrite object mutation
From: |
Paolo Bonzini |
Subject: |
[Help-smalltalk] [PATCH] Rewrite object mutation |
Date: |
Tue, 20 Nov 2007 11:20:51 +0100 |
User-agent: |
Thunderbird 2.0.0.9 (Macintosh/20071031) |
This patch rewrites object mutation, simplifying it greatly (and fixing
bugs) by telling the mutation methods about what the new superclass will
be. This is a really really old part of GNU Smalltalk, even predating
my maintainership; apparently it was mostly untested (it was part of the
Blox GUI in 1.1.5) and it is being exercised more because of the new
syntax and because of less common features being used---in this case,
class instance variables.
Anyway, when I modified it to fix mutate.st's XFAIL I broke it in new
interesting ways. The changes to mutate.st are regression tests for
class mutation, so you can see what the bugs were about.
Paolo
2007-11-20 Paolo Bonzini <address@hidden>
* kernel/Behavior.st: Partially undo change from
#updateInstanceVars:shape: to
#updateInstanceVars:numInherited:shape:.
Add back #updateInstanceVars:shape: and add new
#updateInstanceVars:superclass:shape:. Return true from
#inheritsFrom: if passed nil. Use new keyword argument to
include superclass variables in instVarMap. Reverse direction of
instVarMap. Simplify creation of subclasses' instance variable
array. Add here #mutate:via: (taken from kernel/Object.st)
and use it instead of #mutate:startingAt:newClass:.
* kernel/Object.st: Remove #mutate:startingAt:newClass:.
* kernel/Metaclass.st: Rename "superclass" argument to
"theSuperclass" or "newSuperclass". Call
#updateInstanceVars:superclass:shape:.
* tests/mutate.st: Add minimal testcase for GTK+ loading failure.
Test that class-instance variables are copied around correctly.
Test that moving up the hierarchy preserves instance variables.
--- orig/kernel/Behavior.st
+++ mod/kernel/Behavior.st
@@ -54,10 +54,7 @@ method dictionary, and iterating over th
ifTrue: [{symbol}]
ifFalse: [instanceVariables copyWith: symbol].
duplicated := self superclass allInstVarNames includes: symbol.
- self
- updateInstanceVars: newInstanceVariables
- numInherited: self superclass instSize
- shape: self shape.
+ self updateInstanceVars: newInstanceVariables shape: self shape.
duplicated ifTrue: [self compileAll].
self compileAllSubclasses
]
@@ -77,10 +74,7 @@ method dictionary, and iterating over th
to: index
with: #().
self
- updateInstanceVars: newInstanceVariables
- numInherited: self superclass instSize
- shape: self shape.
- self
+ updateInstanceVars: newInstanceVariables shape: self shape;
compileAll;
compileAllSubclasses
]
@@ -98,10 +92,7 @@ method dictionary, and iterating over th
"If instance variables change, update instance variables and
instance spec of the class and all its subclasses"
variableArray = oldInstVarNames ifTrue: [^self].
- self
- updateInstanceVars: variableArray
- numInherited: self superclass instSize
- shape: self shape.
+ self updateInstanceVars: variableArray shape: self shape.
"If no variable has been removed, no need to recompile"
(oldInstVarNames allSatisfy: [:each | variableArray includes: each])
@@ -976,8 +967,9 @@ method dictionary, and iterating over th
<category: 'testing the class hierarchy'>
| sc |
+ aClass isNil ifTrue: [^true].
+
sc := self.
-
[sc := sc superclass.
sc isNil] whileFalse: [sc == aClass ifTrue: [^true]].
^false
@@ -1015,10 +1007,7 @@ method dictionary, and iterating over th
shape = #inherit ifTrue: [realShape := self superclass shape].
self shape == realShape ifTrue: [^false].
realShape isNil ifTrue: [
- self
- updateInstanceVars: self allInstVarNames
- numInherited: self superclass instSize
- shape: nil ].
+ self updateInstanceVars: self allInstVarNames shape: nil ].
self isVariable
ifTrue:
[SystemExceptions.MutationError
@@ -1340,24 +1329,44 @@ method dictionary, and iterating over th
^true
]
- updateInstanceVars: variableArray numInherited: numInherited shape: shape [
+ updateInstanceVars: variableArray shape: shape [
"Update instance variables and instance spec of the class and all
- its subclasses"
+ its subclasses. variableArray lists the new variables, including
+ inherited ones."
+ ^self
+ updateInstanceVars: variableArray
+ superclass: self superclass
+ shape: shape
+ ]
+
+ updateInstanceVars: variableArray superclass: newSuper shape: shape [
+ "Update instance variables and instance spec of the class and all
+ its subclasses. variableArray lists the new variables, including
+ those inherited from newSuper."
<category: 'private'>
- | instVarMap startOfInstanceVars endOfInstanceVars newInstanceVars
oldInstVars oldClass instances |
- startOfInstanceVars := numInherited + 1.
- endOfInstanceVars := self instSize.
- newInstanceVars := variableArray copyFrom: startOfInstanceVars
- to: variableArray size.
+ | instVarMap newInstVars oldInstVars oldClass instances oldSuper |
+
+ "Find a common superclass."
+ oldSuper := self superclass.
+ newSuper == oldSuper ifFalse: [
+ [ newSuper includesBehavior: oldSuper ] whileFalse: [
+ oldSuper := oldSuper superclass ] ].
+
+ "Make map for inherited instance variables."
oldInstVars := self allInstVarNames.
- instVarMap := Array new: newInstanceVars size.
- startOfInstanceVars to: endOfInstanceVars
- do:
- [:i |
- | map |
- map := newInstanceVars findLast: [:each | each = (oldInstVars
at: i)].
- map > 0 ifTrue: [instVarMap at: map put: i]].
+ instVarMap := Array new: oldInstVars size.
+ 1 to: oldSuper instSize do: [ :i |
+ instVarMap at: i put: i ].
+
+ "Make map for this class's instance variables."
+ newInstVars := variableArray copyFrom: newSuper instSize + 1.
+ oldInstVars
+ from: oldSuper instSize + 1 to: oldInstVars size
+ keysAndValuesDo: [ :index :var |
+ | map |
+ map := newInstVars findLast: [:each | each = var].
+ map > 0 ifTrue: [instVarMap at: index put: map + newSuper
instSize]].
"Fix up all subclasses."
self allSubclassesDo:
@@ -1367,21 +1376,16 @@ method dictionary, and iterating over th
oldClass superclass: sc.
instances := sc allInstances.
instances do: [:each | each changeClassTo: oldClass].
- iv := sc allInstVarNames
- copyReplaceFrom: startOfInstanceVars
- to: endOfInstanceVars
- with: newInstanceVars.
+ iv := variableArray, (sc allInstVarNames
+ copyFrom: oldInstVars size + 1
+ to: sc allInstVarNames size).
sc setInstanceVariables: iv.
sc setInstanceSpec: sc shape instVars: sc allInstVarNames size.
"Mutate all instances of the class to conform to new memory
model
of the class."
- instances do:
- [:each |
- each
- mutate: instVarMap
- startAt: startOfInstanceVars
- newClass: sc]].
+ instances do: [:each |
+ sc mutate: each via: instVarMap]].
"Now update this class' instance vars"
oldClass := Behavior new.
@@ -1390,12 +1394,36 @@ method dictionary, and iterating over th
instances do: [:each | each changeClassTo: oldClass].
self setInstanceVariables: variableArray.
self setInstanceSpec: shape instVars: variableArray size.
- instances do:
- [:each |
- each
- mutate: instVarMap
- startAt: startOfInstanceVars
- newClass: self]
+ instances do: [:each |
+ self mutate: each via: instVarMap]
+ ]
+
+ mutate: object via: instVarMap [
+ "Private - Mutate object to a new class representation. instVarMap
+ maps from old instVarAt: indices to new instVarAt:put: indices.
+ start is the first instance variable to change."
+
+ <category: 'private'>
+ | aCopy mappedValue end adjustment |
+ aCopy := object class isVariable
+ ifTrue: [self basicNew: object basicSize]
+ ifFalse: [self basicNew].
+
+ "Copy old instance variables to their new positions using instVarMap."
+ 1 to: instVarMap size do: [:i |
+ mappedValue := instVarMap at: i.
+ mappedValue notNil
+ ifTrue: [aCopy instVarAt: mappedValue put: (object instVarAt:
i)]].
+
+ "If mutating a subclass, instVarMap is smaller than `object class
instSize';
+ in this case, everything after it must be copied."
+ adjustment := self instSize - object class instSize.
+ instVarMap size + 1 to: object class instSize
+ do: [:i | aCopy instVarAt: i + adjustment put: (object instVarAt:
i)].
+
+ "Copy the indexed variables, if any."
+ 1 to: object basicSize do: [:i | aCopy basicAt: i put: (object
basicAt: i)].
+ ^object become: aCopy
]
isBehavior [
--- orig/kernel/Metaclass.st
+++ mod/kernel/Metaclass.st
@@ -161,15 +161,15 @@ it should be...the Smalltalk metaclass s
^self instanceClass pragmaHandlerFor: aSymbol
]
- name: className environment: aNamespace subclassOf: superclass [
+ name: className environment: aNamespace subclassOf: theSuperclass [
"Private - create a full featured class and install it, or change the
superclass or shape of an existing one; instance variable names,
class variable names and pool dictionaries are left untouched."
<category: 'basic'>
| aClass variableArray |
- variableArray := superclass notNil
- ifTrue: [superclass allInstVarNames]
+ variableArray := theSuperclass notNil
+ ifTrue: [theSuperclass allInstVarNames]
ifFalse: [#()].
"Look for an existing metaclass"
@@ -179,7 +179,7 @@ it should be...the Smalltalk metaclass s
[^self
newMeta: className
environment: aNamespace
- subclassOf: superclass
+ subclassOf: theSuperclass
instanceVariableArray: variableArray
shape: nil
classPool: BindingDictionary new
@@ -189,7 +189,7 @@ it should be...the Smalltalk metaclass s
^self
name: className
environment: aNamespace
- subclassOf: superclass
+ subclassOf: theSuperclass
instanceVariableArray: variableArray
shape: aClass shape
classPool: aClass classPool
@@ -197,7 +197,7 @@ it should be...the Smalltalk metaclass s
category: aClass category
]
- name: newName environment: aNamespace subclassOf: superclass
instanceVariableNames: stringOfInstVarNames shape: shape classVariableNames:
stringOfClassVarNames poolDictionaries: stringOfPoolNames category:
categoryName [
+ name: newName environment: aNamespace subclassOf: theSuperclass
instanceVariableNames: stringOfInstVarNames shape: shape classVariableNames:
stringOfClassVarNames poolDictionaries: stringOfPoolNames category:
categoryName [
"Private - parse the instance and class variables, and the pool
dictionaries, then create the class."
@@ -206,8 +206,8 @@ it should be...the Smalltalk metaclass s
| variableArray classVarDict sharedPoolNames |
variableArray := self parseInstanceVariableString: stringOfInstVarNames.
- variableArray := superclass notNil
- ifTrue: [superclass allInstVarNames , variableArray]
+ variableArray := theSuperclass notNil
+ ifTrue: [theSuperclass allInstVarNames , variableArray]
ifFalse: [variableArray].
classVarDict := self parse: stringOfClassVarNames
toDictionary: BindingDictionary new.
@@ -215,7 +215,7 @@ it should be...the Smalltalk metaclass s
^self
name: newName asSymbol
environment: aNamespace
- subclassOf: superclass
+ subclassOf: theSuperclass
instanceVariableArray: variableArray
shape: shape
classPool: classVarDict
@@ -223,7 +223,7 @@ it should be...the Smalltalk metaclass s
category: categoryName
]
- name: className environment: aNamespace subclassOf: superclass
instanceVariableArray: variableArray shape: shape classPool: classVarDict
poolDictionaries: sharedPoolNames category: categoryName [
+ name: className environment: aNamespace subclassOf: newSuperclass
instanceVariableArray: variableArray shape: shape classPool: classVarDict
poolDictionaries: sharedPoolNames category: categoryName [
"Private - create a full featured class and install it, or change an
existing one"
@@ -240,7 +240,7 @@ it should be...the Smalltalk metaclass s
[^self
newMeta: className
environment: aNamespace
- subclassOf: superclass
+ subclassOf: newSuperclass
instanceVariableArray: variableArray
shape: realShape
classPool: classVarDict
@@ -252,7 +252,7 @@ it should be...the Smalltalk metaclass s
ifFalse:
[SystemExceptions.MutationError
signal: 'Cannot change shape of variable class']].
- superclass isUntrusted & self class isUntrusted not
+ newSuperclass isUntrusted & self class isUntrusted not
ifTrue:
[SystemExceptions.MutationError
signal: 'Cannot move trusted class below untrusted
superclass'].
@@ -278,7 +278,7 @@ it should be...the Smalltalk metaclass s
[aClass instanceCount > 0 ifTrue: [ObjectMemory
globalGarbageCollect].
aClass
updateInstanceVars: variableArray
- numInherited: superclass instSize
+ superclass: newSuperclass
shape: realShape].
"Now add/remove pool dictionaries. FIXME: They may affect name binding,
@@ -296,29 +296,29 @@ it should be...the Smalltalk metaclass s
ifFalse:
[aClass removeSharedPool: dict.
needToRecompileMetaclasses := true]]].
- aClass superclass ~~ superclass
+ aClass superclass ~~ newSuperclass
ifTrue:
["Mutate the class if the set of class-instance variables
changes."
- self superclass allInstVarNames ~= superclass class
allInstVarNames
+ self superclass allInstVarNames ~= newSuperclass class
allInstVarNames
ifTrue:
[aClass class
updateInstanceVars:
- superclass class allInstVarNames,
+ newSuperclass class allInstVarNames,
aClass class instVarNames
- numInherited: superclass class instSize
+ superclass: newSuperclass class
shape: aClass class shape].
"Fix references between classes..."
aClass superclass removeSubclass: aClass.
- superclass addSubclass: aClass.
- aClass superclass: superclass.
+ newSuperclass addSubclass: aClass.
+ aClass superclass: newSuperclass.
needToRecompileClasses := true.
"...and between metaclasses..."
self superclass removeSubclass: self.
- superclass class addSubclass: self.
- self superclass: superclass class.
+ newSuperclass class addSubclass: self.
+ self superclass: newSuperclass class.
needToRecompileMetaclasses := true].
aClass category: categoryName.
@@ -340,7 +340,7 @@ it should be...the Smalltalk metaclass s
^aClass
]
- newMeta: className environment: aNamespace subclassOf: superclass
instanceVariableArray: arrayOfInstVarNames shape: shape classPool: classVarDict
poolDictionaries: sharedPoolNames category: categoryName [
+ newMeta: className environment: aNamespace subclassOf: theSuperclass
instanceVariableArray: arrayOfInstVarNames shape: shape classPool: classVarDict
poolDictionaries: sharedPoolNames category: categoryName [
"Private - create a full featured class and install it"
<category: 'basic'>
@@ -349,17 +349,17 @@ it should be...the Smalltalk metaclass s
classVarDict environment: aClass.
instanceClass := aClass.
aNamespace at: className put: aClass.
- superclass isNil ifFalse: [superclass addSubclass: aClass].
+ theSuperclass isNil ifFalse: [theSuperclass addSubclass: aClass].
Behavior flushCache.
^aClass
- superclass: superclass;
+ superclass: theSuperclass;
setName: className;
setEnvironment: aNamespace;
setInstanceVariables: arrayOfInstVarNames;
setInstanceSpec: shape instVars: arrayOfInstVarNames size;
setClassVariables: classVarDict;
setSharedPools: sharedPoolNames;
- makeUntrusted: superclass isUntrusted;
+ makeUntrusted: theSuperclass isUntrusted;
category: categoryName;
yourself
]
@@ -417,10 +417,10 @@ it should be...the Smalltalk metaclass s
aStream nextPutAll: ' class'
]
- initMetaclass: superclass [
+ initMetaclass: theSuperclass [
<category: 'private'>
- instanceVariables := superclass allInstVarNames.
- instanceSpec := superclass instanceSpec
+ instanceVariables := theSuperclass allInstVarNames.
+ instanceSpec := theSuperclass instanceSpec
]
parsePools: aString in: aNamespace [
--- orig/kernel/Object.st
+++ mod/kernel/Object.st
@@ -744,37 +744,6 @@ All classes in the system are subclasses
^name
]
- mutate: instVarMap startAt: start newClass: class [
- "Private - Mutate object to a new class representation. instVarMap
- maps between old instVarAt: indices and new instVarAt:put: indices.
- start is the first instance variable to change."
-
- <category: 'private'>
- | aCopy mappedValue end adjustment |
- adjustment := self class instSize - class instSize.
- aCopy := self class isVariable
- ifTrue: [class basicNew: self basicSize]
- ifFalse: [class basicNew].
- end := instVarMap size + start - 1.
-
- "Copy the instance variables, if any"
- 1 to: start - 1 do: [:i | aCopy instVarAt: i put: (self instVarAt: i)].
-
- "Copy old instance variables to their new positions using instVarMap"
- start to: end
- do:
- [:i |
- mappedValue := instVarMap at: i - start + 1.
- mappedValue notNil
- ifTrue: [aCopy instVarAt: i put: (self instVarAt:
mappedValue)]].
- end + 1 to: class instSize
- do: [:i | aCopy instVarAt: i put: (self instVarAt: i + adjustment)].
-
- "Copy the indexed variables, if any."
- 1 to: self basicSize do: [:i | aCopy basicAt: i put: (self basicAt: i)].
- ^self become: aCopy
- ]
-
allOwners [
"Return an Array of Objects that point to the receiver."
--- orig/tests/mutate.ok
+++ mod/tests/mutate.ok
@@ -99,6 +99,11 @@ returned value is true
Recompiling classes...
Execution begins...
+Smalltalk
+returned value is SystemDictionary new: 512 "<0>"
+Recompiling classes...
+
+Execution begins...
(#a #b #c )
returned value is Array new: 3 "<0>"
@@ -109,3 +114,7 @@ returned value is Array new: 4 "<0>"
Execution begins...
(#a #d )
returned value is Array new: 2 "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is 'abc'
--- orig/tests/mutate.st
+++ mod/tests/mutate.st
@@ -124,6 +124,13 @@ Eval [ (C shape -> C classPool keys asAr
Eval [ C class compile: 'foo [ ^MutationError ]' ]
Eval [ C foo == SystemExceptions.MutationError ]
+"Test mutating the class when the new superclass has additional class-instance
+ variables"
+CObject subclass: CFoo [ ]
+CStruct subclass: CFoo [ ]
+Eval [ CFoo environment printNl ]
+
+"Test adding variables with multiple |...| blocks or with extend."
Object subclass: Foo [ | a | ]
Foo subclass: Bar [ | xyz | ]
Foo subclass: Bar [ | b | | c | ]
@@ -131,3 +138,20 @@ Eval [ Bar allInstVarNames printNl ]
Foo extend [ | d | ]
Eval [ Bar allInstVarNames printNl ]
Eval [ Foo allInstVarNames printNl ]
+
+"Test moving to an upper superclass, but preserving instance variables
+ because they are specified in the instanceVariableNames: keyword."
+Association subclass: Blah [ ]
+Eval [
+ | blah |
+ blah := Blah new.
+ blah value: 'abc'.
+ Object
+ subclass: #Blah
+ instanceVariableNames: 'key value'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: ''.
+
+ blah instVarAt: 2
+]
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Help-smalltalk] [PATCH] Rewrite object mutation,
Paolo Bonzini <=