Hi, Add new Tests package and better support for method copying.
When a compiled method is copied some literals (block and closures) need to be fixed: they are pointing to the bad method. Also the debug information need to be patched to point to the new literals array. And a new test package is added with compiled method testing. Cheers, Gwen
>From b99bd6041570cfb4aaf2e9ee1f16f0f1816177ff Mon Sep 17 00:00:00 2001 From: Gwenael Casaccio <[email protected]> Date: Tue, 11 Jun 2013 23:27:27 +0200 Subject: [PATCH] Add new Tests package and better support for method copying. When a compiled method is copied some literals (block and closures) need to be fixed: they are pointing to the bad method. Also the debug information need to be patched to point to the new literals array. --- configure.ac | 1 + kernel/BlkClosure.st | 6 ++ kernel/CompildMeth.st | 81 +++++++++++++++--- kernel/CompiledBlk.st | 6 ++ kernel/MethodInfo.st | 34 ++++++++ packages/tests/ChangeLog | 4 + packages/tests/kernel/CompiledMethodTests.st | 123 +++++++++++++++++++++++++++ packages/tests/package.xml | 10 +++ 8 files changed, 253 insertions(+), 12 deletions(-) create mode 100644 packages/tests/ChangeLog create mode 100644 packages/tests/kernel/CompiledMethodTests.st create mode 100644 packages/tests/package.xml diff --git a/configure.ac b/configure.ac index df552c7..0f62805 100644 --- a/configure.ac +++ b/configure.ac @@ -510,6 +510,7 @@ GST_PACKAGE_ENABLE([Digest], [digest], [], [], [Makefile], [digest.la]) GST_PACKAGE_ENABLE([GNUPlot], [gnuplot]) GST_PACKAGE_ENABLE([Magritte], [magritte]) GST_PACKAGE_ENABLE([Magritte-Seaside], [seaside/magritte]) +GST_PACKAGE_ENABLE([Tests], [tests]) GST_PACKAGE_ENABLE([NCurses], [ncurses], diff --git a/kernel/BlkClosure.st b/kernel/BlkClosure.st index ec17d2b..75dc436 100644 --- a/kernel/BlkClosure.st +++ b/kernel/BlkClosure.st @@ -522,6 +522,12 @@ creation of Processes from blocks.'> ^block method ] + method: aCompiledCode [ + <category: 'accessing'> + + block method: aCompiledCode + ] + receiver [ "Answer the object that is used as `self' when executing the receiver (if nil, it might mean that the receiver is not valid though...)" diff --git a/kernel/CompildMeth.st b/kernel/CompildMeth.st index 4d551d5..826fe73 100644 --- a/kernel/CompildMeth.st +++ b/kernel/CompildMeth.st @@ -143,6 +143,36 @@ instances.'> self allInstancesDo: [:each | each stripSourceCode] ] + copy [ + <category: 'copying'> + + | copy | + copy := super copy. + copy fixDebugInformation: self. + ^ copy + ] + + deepCopy [ + "Returns a deep copy of the receiver (the instance variables are + copies of the receiver's instance variables)" + + <category: 'copying'> + | class aCopy num | + class := self class. + aCopy := self shallowCopy. + class isPointers + ifTrue: [num := class instSize + self basicSize] + ifFalse: [num := class instSize]. + + "copy the instance variables (if any)" + 1 to: num do: [:i | aCopy instVarAt: i put: (self instVarAt: i) copy]. + aCopy + fixBlockInformation; + fixDebugInformation: self; + makeLiteralsReadOnly. + ^aCopy + ] + sourceCodeLinesDelta [ "Answer the delta from the numbers in LINE_NUMBER bytecodes to source code line numbers." @@ -591,18 +621,6 @@ instances.'> nextPutAll: self selector ] - postCopy [ - "Private - Make a deep copy of the descriptor and literals. - Don't need to replace the method header and bytecodes, since they - are integers." - - <category: 'private'> - super postCopy. - descriptor := descriptor copy - "literals := literals deepCopy. - self makeLiteralsReadOnly" - ] - makeLiteralsReadOnly [ <category: 'private'> literals isNil ifTrue: [^self]. @@ -781,5 +799,44 @@ instances.'> ^ self descriptor temporariesFor: anObject ] + + fixBlockInformation [ + <category: 'private-copying'> + + 1 to: literals size do: [ :i | + (literals at: i) class == CompiledBlock ifTrue: [ + | new_block | + new_block := (literals at: i) copy. + new_block method: self. + literals at: i put: new_block ]. + (literals at: i) class == BlockClosure ifTrue: [ + | new_block | + new_block := (literals at: i) deepCopy. + new_block block: new_block block copy. + new_block method: self. + literals at: i put: new_block ]. ] + ] + + fixDebugInformation: aCompiledMethod [ + <category: 'private-copying'> + + descriptor fixDebugInformation: aCompiledMethod replaceWith: self + ] + + postCopy [ + "Private - Make a deep copy of the descriptor and literals. + Don't need to replace the method header and bytecodes, since they + are integers." + + <category: 'private-copying'> + + super postCopy. + descriptor := descriptor copy. + literals := literals copy. + self fixBlockInformation. + self makeLiteralsReadOnly. + "literals := literals deepCopy. + self makeLiteralsReadOnly" + ] ] diff --git a/kernel/CompiledBlk.st b/kernel/CompiledBlk.st index d5ca707..08c98cf 100644 --- a/kernel/CompiledBlk.st +++ b/kernel/CompiledBlk.st @@ -138,6 +138,12 @@ CompiledCode subclass: CompiledBlock [ ^super = aMethod and: [method = aMethod method] ] + method: aCompiledMethod [ + <category: 'accessing'> + + method := aCompiledMethod + ] + method [ "Answer the CompiledMethod in which the receiver lies" diff --git a/kernel/MethodInfo.st b/kernel/MethodInfo.st index c3569de..a6dbe63 100644 --- a/kernel/MethodInfo.st +++ b/kernel/MethodInfo.st @@ -141,6 +141,11 @@ code of the method.'> sourceCode := source ] + debugInformation [ + <category: 'private'> + ^ debugInfo + ] + setDebugInformation: aDebugInfo [ <category: 'private'> debugInfo := aDebugInfo @@ -157,5 +162,34 @@ code of the method.'> ^ (debugInfo at: anObject) temporaries: anObject numArgs ] + + postCopy [ + <category: 'private-copying'> + + super postCopy. + debugInfo := debugInfo copy + ] + + fixDebugInformation: anOldCompiledMethod replaceWith: aNewCompiledMethod [ + <category: 'private-copying'> + + self debugInfoReplace: anOldCompiledMethod with: aNewCompiledMethod. + 1 to: anOldCompiledMethod literals size do: [ :i | + (anOldCompiledMethod literals at: i) class == CompiledBlock ifTrue: [ + self debugInfoReplace: (anOldCompiledMethod literals at: i) with: (aNewCompiledMethod literals at: i) ]. + (anOldCompiledMethod literals at: i) class == BlockClosure ifTrue: [ + self debugInfoReplace: (anOldCompiledMethod literals at: i) block with: (aNewCompiledMethod literals at: i) block ] ] + ] + + debugInfoReplace: aKey with: aNewKey [ + <category: 'private-copying'> + + | assoc | + assoc := debugInfo associationAt: aKey. + debugInfo remove: assoc. + assoc key: aNewKey. + debugInfo add: assoc. + ] + ] diff --git a/packages/tests/ChangeLog b/packages/tests/ChangeLog new file mode 100644 index 0000000..6820768 --- /dev/null +++ b/packages/tests/ChangeLog @@ -0,0 +1,4 @@ +2013-06-11 Gwenael Casaccio <[email protected]> + + * kernel/CompiledMethodTests.st: Test compiled methods + diff --git a/packages/tests/kernel/CompiledMethodTests.st b/packages/tests/kernel/CompiledMethodTests.st new file mode 100644 index 0000000..fe10f68 --- /dev/null +++ b/packages/tests/kernel/CompiledMethodTests.st @@ -0,0 +1,123 @@ +TestCase subclass: TestCompiledMethod [ + + setUp [ + <category: 'setup'> + + Object subclass: #Bar. + Object subclass: #Foo. + Foo compile: ' + fakeDeepCopy [ + <category: ''copying''> + | class aCopy num | + class := self class. + aCopy := self shallowCopy. + class isPointers + ifTrue: [num := class instSize + self basicSize] + ifFalse: [num := class instSize]. + + "copy the instance variables (if any)" + 1 to: num do: [:i | aCopy instVarAt: i put: (self instVarAt: i) copy]. + [ :aCopy | aCopy + fixBlockInformation; + fixDebugInformation: self. + ^aCopy ] value: aCopy. + [ :bla | bla value ] value: 123 + ]'. + Foo compile: +'optimized_1 [ ^ #(1 2 3) ]'. + Foo compile: +'primitive_1 [ <primitive: VMpr_Object_shallowCopy> ]'. + + ] + + testCopy [ + <category: 'testing'> + + | old_method new_method | + old_method := Foo>>#fakeDeepCopy. + new_method := old_method deepCopy. + + self assert: old_method ~~ new_method. + self assert: old_method literals ~~ new_method literals. + self assert: old_method getHeader == new_method getHeader. + self assert: old_method descriptor ~~ new_method descriptor. + self assert: old_method descriptor debugInformation ~~ new_method descriptor debugInformation. + + self assert: old_method descriptor debugInformation size = new_method descriptor debugInformation size. + old_method descriptor debugInformation keysAndValuesDo: [ :key :value | + self should: [ new_method descriptor debugInformation at: key ] raise: SystemExceptions.NotFound ]. " should fail because the method and all the blocks are copied " + + self assert: (new_method temporaries) = #(#class #aCopy #num). + new_method allBlocksDo: [ :each | self assert: (each method == new_method) ]. + ] + + testDeepCopy [ + <category: 'testing'> + + | old_method new_method | + old_method := Foo>>#fakeDeepCopy. + new_method := old_method deepCopy. + + self assert: old_method ~~ new_method. + self assert: old_method literals ~~ new_method literals. + self assert: old_method getHeader == new_method getHeader. + self assert: old_method descriptor ~~ new_method descriptor. + self assert: old_method descriptor debugInformation ~~ new_method descriptor debugInformation. + + self assert: old_method descriptor debugInformation size = new_method descriptor debugInformation size. + old_method descriptor debugInformation keysAndValuesDo: [ :key :value | + self should: [ new_method descriptor debugInformation at: key ] raise: SystemExceptions.NotFound ]. " should fail because the method and all the blocks are copied " + + self assert: (new_method temporaries) = #(#class #aCopy #num). + new_method allBlocksDo: [ :each | self assert: (each method == new_method) ]. + ] + + testWithNewMethodClass [ + <category: 'testing'> + + | old_method new_method | + old_method := Foo>>#fakeDeepCopy. + new_method := old_method withNewMethodClass: Foo. + + self assert: new_method == old_method. + + old_method := Foo>>#fakeDeepCopy. + new_method := old_method withNewMethodClass: Bar. + + self assert: old_method ~~ new_method. + self assert: old_method literals ~~ new_method literals. + self assert: old_method getHeader == new_method getHeader. + self assert: old_method descriptor ~~ new_method descriptor. + self assert: old_method descriptor debugInformation ~~ new_method descriptor debugInformation. + + self assert: old_method descriptor debugInformation size = new_method descriptor debugInformation size. + old_method descriptor debugInformation keysAndValuesDo: [ :key :value | + self should: [ new_method descriptor debugInformation at: key ] raise: SystemExceptions.NotFound ]. " should fail because the method and all the blocks are copied " + + self assert: (new_method temporaries) = #(#class #aCopy #num). + new_method allBlocksDo: [ :each | self assert: (each method == new_method) ]. + ] + + testPrimitive [ + <category: 'testing'> + + | method | + method := Foo>>#optimized_1. + self assert: method primitive = 0. + + method := Foo>>#primitive_1. + self assert: method primitive = VMpr_Object_shallowCopy. + ] + + testSyntax [ + <category: 'testing'> + + | method | + method := Foo>>#optimized_1. + self assert: method isOldSyntax not. + + method := Foo>>#primitive_1. + self assert: method isOldSyntax not. + ] +] + diff --git a/packages/tests/package.xml b/packages/tests/package.xml new file mode 100644 index 0000000..d54996a --- /dev/null +++ b/packages/tests/package.xml @@ -0,0 +1,10 @@ +<package> + <name>Tests</name> + + <test> + <sunit>TestCompiledMethod</sunit> + <filein>kernel/CompiledMethodTests.st</filein> + </test> + + <file>ChangeLog</file> +</package> -- 1.8.1.2
_______________________________________________ help-smalltalk mailing list [email protected] https://lists.gnu.org/mailman/listinfo/help-smalltalk
