>From 4bdadcea7b09d4d6c5edcf5f3e3d199ffe4d72d8 Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio
Date: Thu, 27 Jun 2013 17:36:14 +0200
Subject: [PATCH] Add a new Kernel-Tests package and a better support for
method copying.
When a compiled method is copied some literals (block and closures)
need to be updated: they have references to the old method. The debug
information also need to be updated to point to the new literals array.
---
ChangeLog | 9 ++
configure.ac | 1 +
kernel/BlkClosure.st | 6 ++
kernel/CompildMeth.st | 79 +++++++++++---
kernel/CompiledBlk.st | 6 ++
kernel/MethodInfo.st | 34 +++++++
packages/kernel-tests/ChangeLog | 4 +
.../kernel-tests/kernel/CompiledMethodTests.st | 113 +++++++++++++++++++++
packages/kernel-tests/package.xml | 10 ++
tests/testsuite.at | 1 +
10 files changed, 251 insertions(+), 12 deletions(-)
create mode 100644 packages/kernel-tests/ChangeLog
create mode 100644 packages/kernel-tests/kernel/CompiledMethodTests.st
create mode 100644 packages/kernel-tests/package.xml
diff --git a/ChangeLog b/ChangeLog
index e4d94e6..7239658 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,14 @@
2013-06-27 Gwenael Casaccio
+ * kernel/BlkClosure.st: Add accessor.
+ * kernel/CompildMeth.st: DeepCopy fixes references in method information, block closure and compiled block.
+ * kernel/CompiledBlk.st: Add accessor.
+ * kernel/MethodInfo.st: Add method that change debug references to the new compiled method, block or block closure.
+ * configure.ac: Introduce the Kernel-Tests package.
+ * tests/testsuite.at: Add the Kernel-Tests package.
+
+2013-06-27 Gwenael Casaccio
+
* kernel/CompildMeth.st: Don't change the method class if it's the same.
* kernel/MethodInfo.st: Add a debug information setter.
* packages/stinst/parser/DebugInformationTests.st: Add a debug information test case.
diff --git a/configure.ac b/configure.ac
index 56c09cb..e53b6c2 100644
--- a/configure.ac
+++ b/configure.ac
@@ -517,6 +517,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([Kernel-Tests], [kernel-tests])
GST_PACKAGE_ENABLE([NCurses],
[ncurses],
diff --git a/kernel/BlkClosure.st b/kernel/BlkClosure.st
index ec17d2b..af85fbc 100644
--- a/kernel/BlkClosure.st
+++ b/kernel/BlkClosure.st
@@ -622,6 +622,12 @@ creation of Processes from blocks.'>
SystemExceptions.WrongArgumentCount signal
]
+ method: aCompiledCode [
+
+
+ block method: aCompiledCode
+ ]
+
valueAndResumeOnUnwind [
"Private - For use by #ensure:"
diff --git a/kernel/CompildMeth.st b/kernel/CompildMeth.st
index 4d551d5..e0be59d 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,42 @@ instances.'>
^ self descriptor temporariesFor: anObject
]
+
+ fixBlockInformation [
+
+
+ 1 to: literals size do: [ :i |
+ (literals at: i) class == CompiledBlock ifTrue: [
+ | newBlock |
+ newBlock := (literals at: i) copy.
+ newBlock method: self.
+ literals at: i put: newBlock ].
+ (literals at: i) class == BlockClosure ifTrue: [
+ | newBlock |
+ newBlock := (literals at: i) deepCopy.
+ newBlock block: newBlock block copy.
+ newBlock method: self.
+ literals at: i put: newBlock ]. ]
+ ]
+
+ 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.
+ ]
]
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/kernel-tests/ChangeLog b/packages/kernel-tests/ChangeLog
new file mode 100644
index 0000000..6820768
--- /dev/null
+++ b/packages/kernel-tests/ChangeLog
@@ -0,0 +1,4 @@
+2013-06-11 Gwenael Casaccio
+
+ * kernel/CompiledMethodTests.st: Test compiled methods
+
diff --git a/packages/kernel-tests/kernel/CompiledMethodTests.st b/packages/kernel-tests/kernel/CompiledMethodTests.st
new file mode 100644
index 0000000..d2a8af8
--- /dev/null
+++ b/packages/kernel-tests/kernel/CompiledMethodTests.st
@@ -0,0 +1,113 @@
+TestCase subclass: TestCompiledMethod [
+
+ | barClass fooClass |
+
+ setUp [
+
+
+ barClass := Behavior new.
+ fooClass := Behavior new.
+ fooClass 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
+ ]'.
+ fooClass compile:
+'optimized_1 [ ^ #(1 2 3) ]'.
+ fooClass compile:
+'primitive_1 [ ]'.
+
+ ]
+
+ check: old_method with: new_method [
+
+
+ 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 basicSize == new_method basicSize.
+ 1 to: old_method basicSize do: [ :i |
+ self assert: (old_method at: i) == (new_method at: i) ].
+
+ 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) ].
+ ]
+
+ testCopy [
+
+
+ | old_method new_method |
+ old_method := fooClass>>#fakeDeepCopy.
+ new_method := old_method deepCopy.
+
+ self check: old_method with: new_method.
+ ]
+
+ testDeepCopy [
+
+
+ | old_method new_method |
+ old_method := fooClass>>#fakeDeepCopy.
+ new_method := old_method deepCopy.
+
+ self check: old_method with: new_method.
+ ]
+
+ testWithNewMethodClass [
+
+
+ | old_method new_method |
+ old_method := fooClass>>#fakeDeepCopy.
+ new_method := old_method withNewMethodClass: fooClass.
+
+ self assert: new_method == old_method.
+
+ old_method := fooClass>>#fakeDeepCopy.
+ new_method := old_method withNewMethodClass: barClass.
+
+ self check: old_method with: new_method.
+ ]
+
+ testPrimitive [
+
+
+ | method |
+ method := fooClass>>#optimized_1.
+ self assert: method primitive = 0.
+
+ method := fooClass>>#primitive_1.
+ self assert: method primitive = VMpr_Object_shallowCopy.
+ ]
+
+ testSyntax [
+
+
+ | method |
+ method := fooClass>>#optimized_1.
+ self assert: method isOldSyntax not.
+
+ method := fooClass>>#primitive_1.
+ self assert: method isOldSyntax not.
+ ]
+]
+
diff --git a/packages/kernel-tests/package.xml b/packages/kernel-tests/package.xml
new file mode 100644
index 0000000..4dc8484
--- /dev/null
+++ b/packages/kernel-tests/package.xml
@@ -0,0 +1,10 @@
+
+ Kernel-Tests
+
+
+ TestCompiledMethod
+ kernel/CompiledMethodTests.st
+
+
+ ChangeLog
+
diff --git a/tests/testsuite.at b/tests/testsuite.at
index 8cd2b1c..b95e1bf 100644
--- a/tests/testsuite.at
+++ b/tests/testsuite.at
@@ -156,6 +156,7 @@ AT_PACKAGE_TEST([DhbNumericalMethods])
AT_PACKAGE_TEST([Digest])
AT_OPTIONAL_PACKAGE_TEST([GDBM])
AT_OPTIONAL_PACKAGE_TEST([Iconv])
+AT_PACKAGE_TEST([Kernel-Tests])
AT_PACKAGE_TEST([Magritte])
AT_OPTIONAL_PACKAGE_TEST([ROE])
AT_PACKAGE_TEST([ObjectDumper])
--
1.8.1.2