help-smalltalk
[Top][All Lists]
Advanced

[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
+]





reply via email to

[Prev in Thread] Current Thread [Next in Thread]