>From b99bd6041570cfb4aaf2e9ee1f16f0f1816177ff Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio
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 [
+
+
+ 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 [
+
+
+ | 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)"
+
+
+ | 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."
-
-
- super postCopy.
- descriptor := descriptor copy
- "literals := literals deepCopy.
- self makeLiteralsReadOnly"
- ]
-
makeLiteralsReadOnly [
literals isNil ifTrue: [^self].
@@ -781,5 +799,44 @@ instances.'>
^ self descriptor temporariesFor: anObject
]
+
+ fixBlockInformation [
+
+
+ 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 [
+
+
+ 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."
+
+
+
+ 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 [
+
+
+ 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 [
+
+ ^ debugInfo
+ ]
+
setDebugInformation: aDebugInfo [
debugInfo := aDebugInfo
@@ -157,5 +162,34 @@ code of the method.'>
^ (debugInfo at: anObject) temporaries: anObject numArgs
]
+
+ postCopy [
+
+
+ super postCopy.
+ debugInfo := debugInfo copy
+ ]
+
+ fixDebugInformation: anOldCompiledMethod replaceWith: aNewCompiledMethod [
+
+
+ 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 [
+
+
+ | 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
+
+ * 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 [
+
+
+ Object subclass: #Bar.
+ Object subclass: #Foo.
+ Foo compile: '
+ fakeDeepCopy [
+
+ | 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 [ ]'.
+
+ ]
+
+ testCopy [
+
+
+ | 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 [
+
+
+ | 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 [
+
+
+ | 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 [
+
+
+ | method |
+ method := Foo>>#optimized_1.
+ self assert: method primitive = 0.
+
+ method := Foo>>#primitive_1.
+ self assert: method primitive = VMpr_Object_shallowCopy.
+ ]
+
+ testSyntax [
+
+
+ | 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 @@
+
+ Tests
+
+
+ TestCompiledMethod
+ kernel/CompiledMethodTests.st
+
+
+ ChangeLog
+
--
1.8.1.2