--- a/compiler/PPCCodeGenerator.st Fri Jul 24 15:06:54 2015 +0100
+++ b/compiler/PPCCodeGenerator.st Mon Aug 17 12:13:16 2015 +0100
@@ -131,7 +131,7 @@
compiler addOnLine: '].'.
]."
- guard id: (compiler idFor: guard prefixed: #guard).
+ guard id: (compiler idFor: guard defaultName: #guard).
guard compileGuard: compiler.
trueBlock isNil ifFalse: [
@@ -191,6 +191,61 @@
!PPCCodeGenerator methodsFor:'private'!
+checkBlockIsInlinable: block
+ "Check whether the given block could be inlined. If not,
+ throw an error. If yes, this method is noop.
+
+ A block is inlineable if and only if it's a purely functional
+ (see PPCASTUtilities>>checkBlockIsPurelyFunctional:inClass: for
+ details)
+
+ As a side-effect, copy all self-sent methods from the block
+ to the target class.
+ "
+ | blockNode |
+
+ blockNode := block sourceNode.
+ "In Smalltalk implementation which use cheap-block optimization (Smalltalk/X) it may
+ happen that home context of the block is nil (in case of cheap blocks)"
+ block home notNil ifTrue:[
+ | blockClass |
+
+ blockClass := block home receiver class.
+ PPCASTUtilities new checkNodeIsFunctional: blockNode inClass: blockClass.
+ "The above code should raise an error when block is not functional (i.e., when not
+ inlineable, so if the control flow reach this point, block is OK and we can safely
+ copy self-sent methods."
+ self copySelfSentMethodsOf: blockNode inClass: blockClass
+ ].
+
+ "Created: / 27-07-2015 / 14:40:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 27-07-2015 / 15:52:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+copySelfSentMethodsOf: anRBProgramNode inClass: aClass
+ PPCASTUtilities new withAllMessageNodesOf: anRBProgramNode sentToSelfDo: [ :node|
+ | method source |
+
+ method := aClass lookupSelector: node selector.
+ method isNil ifTrue:[
+ PPCCompilationError new signalWith: 'oops, no method found (internal error)!!'.
+ ].
+ source := method source.
+ source isNil ifTrue:[
+ PPCCompilationError new signalWith: 'unavailable source for method ', method printString ,'!!'.
+ ].
+ "Following actually copies the method to the target class,
+ though the APU is not nice. This has to be cleaned up"
+ (compiler cachedValue: node selector) isNil ifTrue:[
+ compiler cache: node selector as: (PPCMethod new id: node selector; source: source; yourself).
+ "Now compile self-sends of the just copied method"
+ self copySelfSentMethodsOf: method parseTree inClass: aClass
+ ].
+ ]
+
+ "Created: / 27-07-2015 / 14:50:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
withAllVariableNodesOf: anRBProgramNode do: aBlock
"Enumerate all chilren of `anRBProgramNode` (including itself)
and evaluate `aBlock` for each variable node.
@@ -225,7 +280,7 @@
| classificationId classification |
self error: 'deprecated.'.
classification := node extendClassification: node predicate classification.
- classificationId := (compiler idFor: classification prefixed: #classification).
+ classificationId := (compiler idFor: classification defaultName: #classification).
compiler addConstant: classification as: classificationId.
compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
@@ -266,11 +321,11 @@
startMethodForNode:node
node isMarkedForInline ifTrue:[
compiler startInline: (compiler idFor: node).
- compiler addComment: 'BEGIN inlined code of ' , node printString.
+ compiler codeComment: 'BEGIN inlined code of ' , node printString.
compiler indent.
] ifFalse:[
compiler startMethod: (compiler idFor: node).
- compiler addComment: 'GENERATED by ' , node printString.
+ compiler codeComment: 'GENERATED by ' , node printString.
compiler allocateReturnVariable.
].
@@ -311,6 +366,7 @@
visitActionNode: node
| blockNode blockBody blockNodesVar blockNeedsCollection blockMatches childValueVars |
+ self checkBlockIsInlinable: node block.
blockNode := node block sourceNode copy.
self assert: blockNode arguments size == 1.
blockNodesVar := blockNode arguments first .
@@ -335,7 +391,7 @@
blockNeedsCollection := false.
blockMatches := IdentityDictionary new."Must use IDENTITY dict as nodes have overwritten their #=!!!!!!"
childValueVars := node child preferredChildrenVariableNames.
- self withAllVariableNodesOf: blockBody do:[:variableNode|
+ PPCASTUtilities new withAllVariableNodesOf: blockBody do:[:variableNode|
variableNode name = blockNodesVar name ifTrue:[
"Check if variable node matches..."
variableNode parent isMessage ifTrue:[
@@ -366,7 +422,7 @@
blockNeedsCollection ifTrue:[
"Bad, we have to use the collection.
Replace all references to blockNodeVar to retvalVar..."
- self withAllVariableNodesOf: blockBody do:[:variableNode|
+ PPCASTUtilities new withAllVariableNodesOf: blockBody do:[:variableNode|
variableNode name = blockNodesVar name ifTrue:[
variableNode name: self retvalVar.
].
@@ -404,7 +460,7 @@
compiler code: blockBody.
]
- "Modified: / 19-06-2015 / 07:05:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 27-07-2015 / 15:49:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitAndNode: node
@@ -434,7 +490,7 @@
| classification classificationId |
classification := node extendClassification: node predicate classification.
- classificationId := compiler idFor: classification prefixed: #classification.
+ classificationId := compiler idFor: classification defaultName: #classification.
compiler addConstant: classification as: classificationId.
compiler add: '(', classificationId, ' at: context peek asInteger)'.
@@ -452,7 +508,7 @@
node character ppcPrintable ifTrue: [
chid := node character storeString
] ifFalse: [
- chid := compiler idFor: node character prefixed: #char.
+ chid := compiler idFor: node character defaultName: #char.
compiler addConstant: (Character value: node character asInteger) as: chid .
].
@@ -536,6 +592,7 @@
visitMappedActionNode: node
| child blockNode blockBody |
+ self checkBlockIsInlinable: node block.
child := node child.
blockNode := node block sourceNode copy.
blockBody := blockNode body.
@@ -569,7 +626,7 @@
| blockArg |
blockArg := blockNode arguments first.
- self withAllVariableNodesOf: blockBody do:[:variableNode|
+ PPCASTUtilities new withAllVariableNodesOf: blockBody do:[:variableNode|
variableNode name = blockArg name ifTrue:[
variableNode name: self retvalVar.
].
@@ -595,7 +652,7 @@
]
"Created: / 02-06-2015 / 17:28:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 19-06-2015 / 07:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 27-07-2015 / 15:49:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitMessagePredicateNode: node
@@ -616,7 +673,7 @@
visitNotCharSetPredicateNode: node
| classificationId classification |
classification := node extendClassification: node predicate classification.
- classificationId := (compiler idFor: classification prefixed: #classification).
+ classificationId := (compiler idFor: classification defaultName: #classification).
compiler addConstant: classification as: classificationId.
compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
@@ -634,7 +691,7 @@
node character ppcPrintable ifTrue: [
chid := node character storeString
] ifFalse: [
- chid := compiler idFor: node character prefixed: #char.
+ chid := compiler idFor: node character defaultName: #char.
compiler addConstant: (Character value: node character asInteger) as: chid .
].
@@ -707,7 +764,7 @@
visitPluggableNode: node
| blockId |
- blockId := compiler idFor: node block prefixed: #block.
+ blockId := compiler idFor: node block defaultName: #pluggableBlock.
compiler addConstant: node block as: blockId.
compiler codeReturn: blockId, ' value: context.'.
@@ -753,7 +810,7 @@
visitPredicateNode: node
| pid |
- pid := (compiler idFor: node predicate prefixed: #predicate).
+ pid := (compiler idFor: node predicate defaultName: #predicate).
compiler addConstant: node predicate as: pid.
@@ -844,7 +901,7 @@
classification := node extendClassification: node predicate classification.
- classificationId := compiler idFor: classification prefixed: #classification.
+ classificationId := compiler idFor: classification defaultName: #classification.
compiler addConstant: classification as: classificationId.
compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
@@ -876,8 +933,15 @@
self addGuard: node child ifTrue: nil ifFalse: [ compiler codeReturn: '#()' ].
- compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
+ compiler codeIf: 'error'
+ then: [
+ compiler codeClearError.
+ compiler codeReturn: '#()'.
+ ] else: [
+ compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
+ ].
+
compiler add: '[ error ] whileFalse: ['.
compiler indent.
compiler add: self retvalVar, ' add: ', elementVar, '.'.