From c76fe581db4767a6975d8444d3b056a74c4d4536 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 14:23:04 +0200 Subject: [PATCH 01/75] Removed unused variables --- smalltalksrc/VMMaker/StackInterpreter.class.st | 2 -- 1 file changed, 2 deletions(-) diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index bbae2da07b..fa48f86c5f 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -327,8 +327,6 @@ Class { 'stackPointer', 'framePointer', 'localReturnValue', - 'localAbsentReceiver', - 'localAbsentReceiverOrZero', 'extA', 'extB', 'numExtB', From bef15af981318fed92b39e3b7c031e7b8e193d92 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 15:25:56 +0200 Subject: [PATCH 02/75] Forbid variable localization in the intepreter loop if it creates conflicts --- .../Melchor/MLVMCCodeGenerator.class.st | 4 +- .../MockLocalizationInterpreterMock.class.st | 54 +++++++++++++++++++ .../SlangLocalizationTestCase.class.st | 22 ++++++++ smalltalksrc/Slang/CCodeGenerator.class.st | 49 ++++++++++------- .../VMMaker/AbstractInterpreter.class.st | 33 ++++++++++++ 5 files changed, 141 insertions(+), 21 deletions(-) create mode 100644 smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st create mode 100644 smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st create mode 100644 smalltalksrc/VMMaker/AbstractInterpreter.class.st diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index 3a711f74da..e166b00087 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -137,8 +137,8 @@ MLVMCCodeGenerator >> doInlining: inlineFlagOrSymbol [ self inlineDispatchesInMethodNamed: #interpret localizingVars: self vmClass namesOfVariablesToLocalize. bar value: 1. - removed := self removeMethodsReferingToGlobals: self vmClass namesOfVariablesToLocalize - except: #interpret. + removed := self validateLocalizationOfGlobals: self vmClass namesOfVariablesToLocalize + exceptMethod: #interpret. bar value: 2]. "only prune when generating the interpreter itself" diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st new file mode 100644 index 0000000000..0ef0dc2bb4 --- /dev/null +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -0,0 +1,54 @@ +Class { + #name : #MockLocalizationInterpreterMock, + #superclass : #AbstractInterpreter, + #instVars : [ + 'variableToLocalize', + 'sharedVariableToLocalize' + ], + #classVars : [ + 'BytecodeTable' + ], + #category : #'Slang-Tests' +} + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initialize [ + + BytecodeTable := Array new: 3. + self table: BytecodeTable from: + #( + ( 0 bytecodeToInline) + ( 1 bytecodeUsingLocalizedVariable) + ( 2 bytecodeUsingSharedLocalizedVariable) + ) +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeToInline [ + + "Do nothing" +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ + + variableToLocalize := 42 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariable [ + + sharedVariableToLocalize := 42 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> interpret [ + + self dispatchOn: 1 in: BytecodeTable +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ + + sharedVariableToLocalize := 17 +] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st new file mode 100644 index 0000000000..7325dc0e1f --- /dev/null +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -0,0 +1,22 @@ +Class { + #name : #SlangLocalizationTestCase, + #superclass : #SlangAbstractTestCase, + #category : #'Slang-Tests' +} + +{ #category : #tests } +SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ + + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + + [ + ccg inlineDispatchesInMethodNamed: #interpret localizingVars: #( sharedVariableToLocalize ). + + "This should not arrive here" + self fail + ] on: Error do: [ :error | + self assert: error messageText equals: 'Cannot localize Shared Variables in the interpreter loop: sharedVariableToLocalize' ]. +] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 1f19f7414a..1d975ea7b9 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3354,6 +3354,11 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector localizingVars: varsLi "Inline dispatches (case statements) in the method with the given name." | m | + + self + validateLocalizationOfGlobals: varsList + exceptMethod: selector. + m := self methodNamed: selector. m = nil ifFalse: [ m inlineCaseStatementBranchesIn: self localizingVars: varsList. @@ -4433,25 +4438,6 @@ CCodeGenerator >> removeMethodForSelector: aSelector [ methods removeKey: aSelector ifAbsent: [] ] -{ #category : #inlining } -CCodeGenerator >> removeMethodsReferingToGlobals: varList except: methodName [ - "Remove any methods (presumably inlined) that still contain references to the given - global variables. Answer a Dictionary of the removed methods for later reporting." - - | varListAsStrings removed | - varListAsStrings := varList collect: [ :sym | sym asString ]. - removed := Dictionary new: methods size / 2. - methods copy keysAndValuesDo: - [ :sel :meth| | mVars | - sel ~= methodName ifTrue: - [mVars := meth freeVariableReferences asSet. - (varListAsStrings anySatisfy: [ :v | mVars includes: v]) ifTrue: - [removed at: sel put: meth. - self removeMethodForSelector: sel]]]. - - ^removed -] - { #category : #utilities } CCodeGenerator >> removeVariable: aName [ "Remove the given (instance) variable from the code base." @@ -5183,6 +5169,31 @@ CCodeGenerator >> validateCppIf: nodeOrNil withValue: value [ ] +{ #category : #inlining } +CCodeGenerator >> validateLocalizationOfGlobals: varList exceptMethod: methodName [ + + | localizationCandidates variablesInConflict | + localizationCandidates := varList collect: [ :sym | sym asString ]. + variablesInConflict := Set new. + + methods copy keysAndValuesDo: [ :sel :meth| | methodFreeVariables | + sel ~= methodName ifTrue: [ + methodFreeVariables := meth freeVariableReferences asSet. + localizationCandidates do: [ :candidate | + (methodFreeVariables includes: candidate) + ifTrue: [ variablesInConflict add: candidate ] ] ] ]. + + variablesInConflict ifNotEmpty: [ | errorMessage | + errorMessage := String streamContents: [ :stream | + stream nextPutAll: 'Cannot localize Shared Variables in the interpreter loop: '. + variablesInConflict + do: [ :e | stream nextPutAll: e ] + separatedBy: [ stream nextPutAll: ', ' ] + ]. + self error: errorMessage + ] +] + { #category : #'C code generator' } CCodeGenerator >> valueForContant: node ifAbsent: default [ ^ default diff --git a/smalltalksrc/VMMaker/AbstractInterpreter.class.st b/smalltalksrc/VMMaker/AbstractInterpreter.class.st new file mode 100644 index 0000000000..cd1cb5463d --- /dev/null +++ b/smalltalksrc/VMMaker/AbstractInterpreter.class.st @@ -0,0 +1,33 @@ +Class { + #name : #AbstractInterpreter, + #superclass : #VMClass, + #category : #'VMMaker-Interpreter' +} + +{ #category : #initialization } +AbstractInterpreter class >> table: anArray from: specArray [ + "SpecArray is an array of one of (index selector) or (index1 + index2 selector) or (index nil) or (index1 index2 nil). If selector + then the entry is the selector, but if nil the entry is the index." + | contiguous | + contiguous := 0. + specArray do: + [:spec | + (spec at: 1) = contiguous ifFalse: + [self error: 'Non-contiguous table entry']. + spec size = 2 + ifTrue: + [anArray + at: (spec at: 1) + 1 + put: ((spec at: 2) ifNil: [spec at: 1] ifNotNil: [:sym| sym]). + contiguous := contiguous + 1] + ifFalse: + [(spec at: 1) to: (spec at: 2) do: + [:i | anArray at: i + 1 put: ((spec at: 3) ifNil: [i] ifNotNil: [:sym| sym])]. + contiguous := contiguous + ((spec at: 2) - (spec at: 1)) + 1]]. + anArray doWithIndex: + [:entry :index| + entry isSymbol ifTrue: + [(self shouldIncludeMethodForSelector: entry) ifFalse: + [anArray at: index put: 0]]] +] From 1749752b9dd314b73db68e92ddb0679493c6c5b4 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 16:20:53 +0200 Subject: [PATCH 03/75] Cleanups in localization --- .../Melchor/MLVMCCodeGenerator.class.st | 48 ----------------- .../SlangLocalizationTestCase.class.st | 3 +- smalltalksrc/Slang/CCodeGenerator.class.st | 52 ++++++++++++------- smalltalksrc/Slang/TMethod.class.st | 25 +++++---- .../VMMaker/CogMethodSurrogate32.class.st | 12 ++--- .../CogSistaMethodSurrogate32.class.st | 4 +- .../CogSistaMethodSurrogate64.class.st | 4 +- .../VMMaker/CogStackPageSurrogate32.class.st | 14 ++--- smalltalksrc/VMMaker/Cogit.class.st | 49 ----------------- .../VMMaker/InterpreterPrimitives.class.st | 2 +- .../VMMaker/StackInterpreter.class.st | 35 +++---------- 11 files changed, 71 insertions(+), 177 deletions(-) diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index e166b00087..da62d72b91 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -496,54 +496,6 @@ MLVMCCodeGenerator >> removeVariable: aName [ newLine]] ] -{ #category : #'C translation support' } -MLVMCCodeGenerator >> reportShouldNotBeRemoved: removed varList: varList [ - "Report whether any of the removed methods are still used." - | varListAsStrings shouldNotBeRemoved | - varListAsStrings := varList collect: [ :sym | sym asString ]. - shouldNotBeRemoved := Set new. - removed do: - [:m| - m isAPIMethod ifTrue: - [shouldNotBeRemoved add: m selector]]. - methods do: - [:m| - (m selector = #interpret - or: [removed includes: m selector]) ifFalse: - [m allCalls do: - [:sel| - (removed includesKey: sel) ifTrue: - [shouldNotBeRemoved add: sel]]]]. - self vmClass additionalSelectorTables do: - [:selectorTable| - selectorTable do: - [:selOrInteger| - selOrInteger isInteger ifFalse: - [(removed includesKey: selOrInteger) ifTrue: - [shouldNotBeRemoved add: selOrInteger]]]]. - shouldNotBeRemoved do: - [:sel| | str | - str := String streamContents: - [:strm| | them | - strm - nextPutAll: 'Removed '; - nextPutAll: sel; - nextPutAll: ' because it refers to the local variable'. - them := (removed at: sel) freeVariableReferences asSet intersection: varListAsStrings. - them size > 1 ifTrue: - [strm nextPut: $s. - them := self sortStrings: them]. - them do: [:var| strm space; nextPutAll: var]. - - strm - nextPutAll: ' of interpret.'; - newLine; - nextPutAll: 'But it is either used outside of interpret or exported!!'; - newLine]. - logger newLine; show: str. - self inform: str] -] - { #category : #'C code generator' } MLVMCCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMethod typeIfNil: typeIfNil [ "Answer the return type for a send. Unbound sends default to typeIfNil. diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 7325dc0e1f..6c73328a36 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -12,8 +12,7 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - [ - ccg inlineDispatchesInMethodNamed: #interpret localizingVars: #( sharedVariableToLocalize ). + [ ccg localizeVariables: #( sharedVariableToLocalize ) inMethod: (ccg methodNamed: #interpret). "This should not arrive here" self fail diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 1d975ea7b9..e4e21a7f86 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -717,11 +717,6 @@ CCodeGenerator >> checkClassForNameConflicts: aClass [ cr]]] ] -{ #category : #utilities } -CCodeGenerator >> checkDeleteVariable: aName [ - "Hook for debugging variable deletion." -] - { #category : #utilities } CCodeGenerator >> checkForGlobalUsage: vars in: aTMethod [ vars do: @@ -3349,6 +3344,24 @@ CCodeGenerator >> initializerForInstVar: varName inStartClass: aClass [ ^nil ] +{ #category : #inlining } +CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ + + "Inline dispatches (case statements) in the method with the given name. + Then localize variables" + + | m | + m := self methodNamed: selector. + m = nil ifFalse: [ + m inlineCaseStatementBranchesIn: self. + m parseTree nodesDo: [ :n | + n isCaseStmt ifTrue: [ + n + customizeShortCasesForDispatchVar: 'currentBytecode' + in: self + method: m ] ] ] +] + { #category : #inlining } CCodeGenerator >> inlineDispatchesInMethodNamed: selector localizingVars: varsList [ "Inline dispatches (case statements) in the method with the given name." @@ -3652,10 +3665,25 @@ CCodeGenerator >> localizeGlobalVariables [ (localized at: name) do: [:var| logger newLine; show: var, ' localised to ', name; cr]]]. - elected do: [:ea| (variables includes: ea) ifTrue: [self checkDeleteVariable: ea]]. variables removeAllFoundIn: elected ] +{ #category : #inlining } +CCodeGenerator >> localizeVariables: varsList inMethod: m [ + + self validateLocalizationOfGlobals: varsList exceptMethod: m selector. + m localizeVariables: varsList. + varsList do: [ :v | + | varString | + varString := v asString. + variables remove: varString ifAbsent: [ ]. + (variableDeclarations includesKey: varString) ifTrue: [ + m + declarationAt: v asString + put: (variableDeclarations at: varString). + variableDeclarations removeKey: varString ] ] +] + { #category : #utilities } CCodeGenerator >> logger [ ^logger @@ -4326,12 +4354,6 @@ CCodeGenerator >> promoteIntegerArithmeticTypes: firstType and: secondType [ ^firstType ] -{ #category : #inlining } -CCodeGenerator >> pruneMethods: selectorList [ - "Explicitly prune some methods" - selectorList do: [:sel| self removeMethodForSelector: sel] -] - { #category : #inlining } CCodeGenerator >> pruneUnreachableMethods [ "Remove any methods that are not reachable. Retain methods needed by the translated classes - see implementors of requiredMethodNames" @@ -4450,7 +4472,6 @@ CCodeGenerator >> removeVariable: aName [ { #category : #utilities } CCodeGenerator >> removeVariable: aName ifAbsent: ifAbsentBlock [ "Remove the given (instance) variable from the code base." - self checkDeleteVariable: aName. variableDeclarations removeKey: aName ifAbsent: []. ^variables remove: aName ifAbsent: ifAbsentBlock ] @@ -4481,11 +4502,6 @@ CCodeGenerator >> reportRecursiveMethods [ ]. ] -{ #category : #inlining } -CCodeGenerator >> reportShouldNotBeRemoved: removed varList: varList [ - "Report whether any of the removed methods are still used." -] - { #category : #'C translation support' } CCodeGenerator >> reservedWords [ ^#( 'auto' diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 5194267711..429edbcdb5 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -1229,9 +1229,8 @@ TMethod >> inlineBuiltin: aSendNode in: aCodeGen [ ] { #category : #inlining } -TMethod >> inlineCaseStatementBranchesIn: aCodeGen localizingVars: varsList [ - | maxTemp usedVars v exitLabel | - maxTemp := 0. +TMethod >> inlineCaseStatementBranchesIn: aCodeGen [ + | exitLabel | parseTree nodesDo: [:n | n isCaseStmt ifTrue: @@ -1258,16 +1257,7 @@ TMethod >> inlineCaseStatementBranchesIn: aCodeGen localizingVars: varsList [ newStatements addFirst: meth asInlineNode; addFirst: (TLabeledCommentNode new setComment: meth selector). - stmtNode setStatements: newStatements]]]]]]. - usedVars := (locals , args) asSet. - 1 to: maxTemp do: - [:i | - v := 't' , i printString. - (usedVars includes: v) ifTrue: - [self error: 'temp variable name conflicts with an existing local or arg']. - locals addLast: v]. - "make local versions of the given globals" - locals addAll: (varsList reject: [:var | usedVars includes: var]) + stmtNode setStatements: newStatements]]]]]] ] { #category : #inlining } @@ -1863,6 +1853,15 @@ TMethod >> labels: aCollection [ labels := aCollection asSet ] +{ #category : #inlining } +TMethod >> localizeVariables: localizationCandidates [ + + | definedVariables | + definedVariables := (locals , args) asSet. + "make local versions of the given globals" + locals addAll: (localizationCandidates reject: [ :var | definedVariables includes: var ]) +] + { #category : #accessing } TMethod >> locals [ "The local variables of this method." diff --git a/smalltalksrc/VMMaker/CogMethodSurrogate32.class.st b/smalltalksrc/VMMaker/CogMethodSurrogate32.class.st index 2553fe05b5..aea16be868 100644 --- a/smalltalksrc/VMMaker/CogMethodSurrogate32.class.st +++ b/smalltalksrc/VMMaker/CogMethodSurrogate32.class.st @@ -59,25 +59,25 @@ CogMethodSurrogate32 >> blockSize: aValue [ { #category : #accessing } CogMethodSurrogate32 >> methodHeader [ - ^memory unsignedLongAt: address + 12 + baseHeaderSize + ^memory unsignedLong32At: address + 12 + baseHeaderSize ] { #category : #accessing } CogMethodSurrogate32 >> methodHeader: aValue [ ^memory - unsignedLongAt: address + baseHeaderSize + 12 + unsignedLong32At: address + baseHeaderSize + 12 put: aValue ] { #category : #accessing } CogMethodSurrogate32 >> methodObject [ - ^memory unsignedLongAt: address + 8 + baseHeaderSize + ^memory unsignedLong32At: address + 8 + baseHeaderSize ] { #category : #accessing } CogMethodSurrogate32 >> methodObject: aValue [ ^memory - unsignedLongAt: address + baseHeaderSize + 8 + unsignedLong32At: address + baseHeaderSize + 8 put: aValue ] @@ -95,12 +95,12 @@ CogMethodSurrogate32 >> picUsage: aValue [ { #category : #accessing } CogMethodSurrogate32 >> selector [ - ^memory unsignedLongAt: address + 16 + baseHeaderSize + ^memory unsignedLong32At: address + 16 + baseHeaderSize ] { #category : #accessing } CogMethodSurrogate32 >> selector: aValue [ ^memory - unsignedLongAt: address + baseHeaderSize + 16 + unsignedLong32At: address + baseHeaderSize + 16 put: aValue ] diff --git a/smalltalksrc/VMMaker/CogSistaMethodSurrogate32.class.st b/smalltalksrc/VMMaker/CogSistaMethodSurrogate32.class.st index a15eb90edc..4d227db4c4 100644 --- a/smalltalksrc/VMMaker/CogSistaMethodSurrogate32.class.st +++ b/smalltalksrc/VMMaker/CogSistaMethodSurrogate32.class.st @@ -19,12 +19,12 @@ CogSistaMethodSurrogate32 class >> offsetOf: aByteSymbol [ { #category : #accessing } CogSistaMethodSurrogate32 >> counters [ - ^memory unsignedLongAt: address + 21 + baseHeaderSize + ^memory unsignedLong32At: address + 20 + baseHeaderSize ] { #category : #accessing } CogSistaMethodSurrogate32 >> counters: aValue [ ^memory - unsignedLongAt: address + baseHeaderSize + 21 + unsignedLong32At: address + baseHeaderSize + 20 put: aValue ] diff --git a/smalltalksrc/VMMaker/CogSistaMethodSurrogate64.class.st b/smalltalksrc/VMMaker/CogSistaMethodSurrogate64.class.st index bda28d8f2a..4ce4f99870 100644 --- a/smalltalksrc/VMMaker/CogSistaMethodSurrogate64.class.st +++ b/smalltalksrc/VMMaker/CogSistaMethodSurrogate64.class.st @@ -19,12 +19,12 @@ CogSistaMethodSurrogate64 class >> offsetOf: aByteSymbol [ { #category : #accessing } CogSistaMethodSurrogate64 >> counters [ - ^memory unsignedLong64At: address + 33 + baseHeaderSize + ^memory unsignedLong64At: address + 32 + baseHeaderSize ] { #category : #accessing } CogSistaMethodSurrogate64 >> counters: aValue [ ^memory - unsignedLong64At: address + baseHeaderSize + 33 + unsignedLong64At: address + baseHeaderSize + 32 put: aValue ] diff --git a/smalltalksrc/VMMaker/CogStackPageSurrogate32.class.st b/smalltalksrc/VMMaker/CogStackPageSurrogate32.class.st index 554dc1b4ee..df2dca66b8 100644 --- a/smalltalksrc/VMMaker/CogStackPageSurrogate32.class.st +++ b/smalltalksrc/VMMaker/CogStackPageSurrogate32.class.st @@ -25,7 +25,7 @@ Class { { #category : #accessing } CogStackPageSurrogate32 class >> alignedByteSize [ - ^44 + ^40 ] { #category : #accessing } @@ -85,13 +85,13 @@ CogStackPageSurrogate32 >> lastAddress: aValue [ { #category : #accessing } CogStackPageSurrogate32 >> nextPage [ - ^stackPages surrogateAtAddress: (memory unsignedLong32At: address + 36) + ^stackPages surrogateAtAddress: (memory unsignedLong32At: address + 32) ] { #category : #accessing } CogStackPageSurrogate32 >> nextPage: aValue [ - self assert: (address + 36 >= zoneBase and: [address + 39 < zoneLimit]). - memory unsignedLong32At: address + 36 put: aValue asInteger. + self assert: (address + 32 >= zoneBase and: [address + 35 < zoneLimit]). + memory unsignedLong32At: address + 32 put: aValue asInteger. ^aValue ] @@ -108,13 +108,13 @@ CogStackPageSurrogate32 >> padToWord: aValue [ { #category : #accessing } CogStackPageSurrogate32 >> prevPage [ - ^stackPages surrogateAtAddress: (memory unsignedLong32At: address + 40) + ^stackPages surrogateAtAddress: (memory unsignedLong32At: address + 36) ] { #category : #accessing } CogStackPageSurrogate32 >> prevPage: aValue [ - self assert: (address + 40 >= zoneBase and: [address + 43 < zoneLimit]). - memory unsignedLong32At: address + 40 put: aValue asInteger. + self assert: (address + 36 >= zoneBase and: [address + 39 < zoneLimit]). + memory unsignedLong32At: address + 36 put: aValue asInteger. ^aValue ] diff --git a/smalltalksrc/VMMaker/Cogit.class.st b/smalltalksrc/VMMaker/Cogit.class.st index edffd83240..46aa5a4652 100644 --- a/smalltalksrc/VMMaker/Cogit.class.st +++ b/smalltalksrc/VMMaker/Cogit.class.st @@ -11592,55 +11592,6 @@ Cogit >> setCStackPointer: aStackPointer [ put: aStackPointer) asVoidPointer] ] -{ #category : #'simulation only' } -Cogit >> setClickStepBreakBlock [ - "Set the break block to present a confirmer, breaking if true, and restoring the previous break block. - If an open debugger on the receiver can be found, proceed it." - - | previousBreakBlock previousAtEachStepBlock previousBreakPC previousSingleStep previousClickConfirm | - (breakBlock isNil or: [breakBlock method ~~ thisContext method]) ifTrue: - [previousBreakBlock := breakBlock. - previousAtEachStepBlock := coInterpreter atEachStepBlock. - previousBreakPC := breakPC. - previousSingleStep := singleStep. - previousClickConfirm := clickConfirm. - breakBlock := [:ign| - (processor pc ~= previousBreakPC - and: [UIManager confirm: 'step?']) - ifTrue: [false] - ifFalse: [breakBlock := previousBreakBlock. - coInterpreter atEachStepBlock: previousAtEachStepBlock. - breakPC := previousBreakPC. - singleStep := previousSingleStep. - clickConfirm := previousClickConfirm. - true]]. - coInterpreter atEachStepBlock: - [previousAtEachStepBlock value. - (coInterpreter localIP ~= previousBreakPC - and: [UIManager confirm: 'step?']) ifFalse: - [breakBlock := previousBreakBlock. - coInterpreter atEachStepBlock: previousAtEachStepBlock. - breakPC := previousBreakPC. - singleStep := previousSingleStep. - clickConfirm := previousClickConfirm. - self halt]]. - singleStep := breakPC := clickConfirm := true]. - (World submorphs - detect: - [:m| - m model class == Debugger - and: [(m model interruptedProcess suspendedContext findContextSuchThat: - [:ctxt| - (ctxt receiver == self - and: [ctxt selector == #simulateCogCodeAt:]) - or: [ctxt receiver == coInterpreter - and: [ctxt selector == #interpret]]]) notNil]] - ifNone: []) ifNotNil: - [:debuggerWindow| - WorldState addDeferredUIMessage: - [debuggerWindow model proceed]] -] - { #category : #initialization } Cogit >> setInterpreter: aCoInterpreter [ "Initialization of the code generator in the simulator. diff --git a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st index cb8ddf5b16..e1e26221ec 100644 --- a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st +++ b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st @@ -62,7 +62,7 @@ secHasEnvironmentAccess " Class { #name : #InterpreterPrimitives, - #superclass : #VMClass, + #superclass : #AbstractInterpreter, #instVars : [ 'objectMemory', 'messageSelector', diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index fa48f86c5f..92724b99be 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -1715,34 +1715,6 @@ StackInterpreter class >> sourceFileName [ ^'interp.c' ] -{ #category : #initialization } -StackInterpreter class >> table: anArray from: specArray [ - "SpecArray is an array of one of (index selector) or (index1 - index2 selector) or (index nil) or (index1 index2 nil). If selector - then the entry is the selector, but if nil the entry is the index." - | contiguous | - contiguous := 0. - specArray do: - [:spec | - (spec at: 1) = contiguous ifFalse: - [self error: 'Non-contiguous table entry']. - spec size = 2 - ifTrue: - [anArray - at: (spec at: 1) + 1 - put: ((spec at: 2) ifNil: [spec at: 1] ifNotNil: [:sym| sym]). - contiguous := contiguous + 1] - ifFalse: - [(spec at: 1) to: (spec at: 2) do: - [:i | anArray at: i + 1 put: ((spec at: 3) ifNil: [i] ifNotNil: [:sym| sym])]. - contiguous := contiguous + ((spec at: 2) - (spec at: 1)) + 1]]. - anArray doWithIndex: - [:entry :index| - entry isSymbol ifTrue: - [(self shouldIncludeMethodForSelector: entry) ifFalse: - [anArray at: index put: 0]]] -] - { #category : #translation } StackInterpreter class >> translationClass [ "Return te class to use as the interpreterCLass when translating. For the all-in-one @@ -11974,7 +11946,12 @@ StackInterpreter >> printFramesOnStackPageListInUse [ { #category : #'debug printing' } StackInterpreter >> printHeadFrame [ - + + "Prints the head frame from within the interpreter. + Simulation only. + + Do not generate this function as there is no way to properly translate it to C. + Translating this function requires access to localFP and localSP which are local variables in the interpreter loop function, thus, they are not accessible from within this function." self printFrame: localFP WithSP: localSP ] From 3b812398d5d935199c6127705dd0cf319f895c59 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 16:23:31 +0200 Subject: [PATCH 04/75] Remove reporting --- .../Melchor/MLVMCCodeGenerator.class.st | 23 +++++++------- smalltalksrc/Slang/CCodeGenerator.class.st | 30 ------------------- 2 files changed, 10 insertions(+), 43 deletions(-) diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index da62d72b91..ed20ebd1fe 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -114,15 +114,15 @@ MLVMCCodeGenerator >> doInlining: inlineFlagOrSymbol [ "Inline the bodies of all methods that are suitable for inlining." "Modified slightly for the core VM translator, since the first level of inlining for the interpret loop must be performed in order that the instruction implementations can easily discover their addresses. Remember to inline the bytecode routines as well" - | removed | + | interpretMethod | inlineFlagOrSymbol isSymbol ifTrue: - [self inlineDispatchesInMethodNamed: #interpret localizingVars: #(). + [self inlineDispatchesInMethodNamed: #interpret. self doBasicInlining: inlineFlagOrSymbol. self pruneUnreachableMethods. ^self]. inlineFlagOrSymbol ifFalse: - [self inlineDispatchesInMethodNamed: #interpret localizingVars: #(). + [self inlineDispatchesInMethodNamed: #interpret. self pruneUnreachableMethods. ^self]. @@ -134,17 +134,14 @@ MLVMCCodeGenerator >> doInlining: inlineFlagOrSymbol [ displayProgress: 'Inlining bytecodes' from: 1 to: 2 during: [:bar | - self inlineDispatchesInMethodNamed: #interpret - localizingVars: self vmClass namesOfVariablesToLocalize. - bar value: 1. - removed := self validateLocalizationOfGlobals: self vmClass namesOfVariablesToLocalize - exceptMethod: #interpret. - bar value: 2]. - - "only prune when generating the interpreter itself" - self pruneUnreachableMethods. + self inlineDispatchesInMethodNamed: #interpret. + bar value: 1 ]. - self reportShouldNotBeRemoved: removed varList: self vmClass namesOfVariablesToLocalize + self pruneUnreachableMethods. + interpretMethod := self methodNamed: #interpret. + self + localizeVariables: self vmClass namesOfVariablesToLocalize + inMethod: interpretMethod ] { #category : #'C code generator' } diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index e4e21a7f86..0dbebda299 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3362,36 +3362,6 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ method: m ] ] ] ] -{ #category : #inlining } -CCodeGenerator >> inlineDispatchesInMethodNamed: selector localizingVars: varsList [ - "Inline dispatches (case statements) in the method with the given name." - - | m | - - self - validateLocalizationOfGlobals: varsList - exceptMethod: selector. - - m := self methodNamed: selector. - m = nil ifFalse: [ - m inlineCaseStatementBranchesIn: self localizingVars: varsList. - m parseTree nodesDo: [ :n | - n isCaseStmt ifTrue: [ - n customizeShortCasesForDispatchVar: 'currentBytecode' in: self method: m. - ]. - ]. - ]. - varsList do: [ :v | | varString | - varString := v asString. - self checkDeleteVariable: varString. - variables remove: varString ifAbsent: []. - (variableDeclarations includesKey: varString) ifTrue: [ - m declarationAt: v asString put: (variableDeclarations at: varString). - variableDeclarations removeKey: varString. - ]. - ] -] - { #category : #utilities } CCodeGenerator >> instVarNamesForClass: aClass [ ^ aClass instVarNames From 22a8dc8dcb889ac8aa475e99e06084eec4b4f532 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 16:57:55 +0200 Subject: [PATCH 05/75] Adding case of localizing after and before inlining --- .../MockLocalizationInterpreterMock.class.st | 19 +- .../SlangLocalizationTestCase.class.st | 34 ++ smalltalksrc/Slang/TMethod.class.st | 57 ++-- .../SimulatorEventTransformer.class.st | 158 --------- .../SimulatorMorphicEventTests.class.st | 63 ---- .../SimulatorMorphicModel.class.st | 320 ------------------ 6 files changed, 81 insertions(+), 570 deletions(-) delete mode 100644 smalltalksrc/VMMaker-Tools/SimulatorEventTransformer.class.st delete mode 100644 smalltalksrc/VMMaker-Tools/SimulatorMorphicEventTests.class.st delete mode 100644 smalltalksrc/VMMaker-Tools/SimulatorMorphicModel.class.st diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 0ef0dc2bb4..9fccaf53c3 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -3,7 +3,8 @@ Class { #superclass : #AbstractInterpreter, #instVars : [ 'variableToLocalize', - 'sharedVariableToLocalize' + 'sharedVariableToLocalize', + 'sharedVariableToLocalizeBeforeInlining' ], #classVars : [ 'BytecodeTable' @@ -14,12 +15,13 @@ Class { { #category : #initialization } MockLocalizationInterpreterMock class >> initialize [ - BytecodeTable := Array new: 3. + BytecodeTable := Array new: 4. self table: BytecodeTable from: #( ( 0 bytecodeToInline) ( 1 bytecodeUsingLocalizedVariable) ( 2 bytecodeUsingSharedLocalizedVariable) + ( 3 bytecodeUsingSharedLocalizedVariableBeforeInlining) ) ] @@ -41,12 +43,25 @@ MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariable [ sharedVariableToLocalize := 42 ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariableBeforeInlining [ + + sharedVariableToLocalizeBeforeInlining := 42. + self methodAlsoSharedLocalizedVariableBeforeInlining +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> interpret [ self dispatchOn: 1 in: BytecodeTable ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> methodAlsoSharedLocalizedVariableBeforeInlining [ + + sharedVariableToLocalizeBeforeInlining := 17 +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 6c73328a36..7918333d5d 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -19,3 +19,37 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ ] on: Error do: [ :error | self assert: error messageText equals: 'Cannot localize Shared Variables in the interpreter loop: sharedVariableToLocalize' ]. ] + +{ #category : #tests } +SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUsesAreNotInlined [ + + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg retainMethods: #( interpret ). + ccg prepareMethods. + ccg pruneUnreachableMethods. + + "This should not fail" + [ ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret). + + "This should not arrive here" + self fail + ] on: Error do: [ :error | + self assert: error messageText equals: 'Cannot localize Shared Variables in the interpreter loop: sharedVariableToLocalizeBeforeInlining' ] +] + +{ #category : #tests } +SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAreInlined [ + + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg retainMethods: #( interpret ). + ccg prepareMethods. + ccg doBasicInlining: true. + ccg pruneUnreachableMethods. + + "This should not fail" + ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret) +] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 429edbcdb5..a1d128bded 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -1230,34 +1230,37 @@ TMethod >> inlineBuiltin: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineCaseStatementBranchesIn: aCodeGen [ + | exitLabel | - parseTree nodesDo: - [:n | - n isCaseStmt ifTrue: - [n cases do: - [:stmtNode | | newStatements stmt meth | - (stmt := stmtNode statements first) isSend ifTrue: - [(meth := (aCodeGen methodNamed: stmt selector)) isNil ifFalse: - [(meth hasUnrenamableCCode - or: [meth args notEmpty]) ifFalse: - [meth := meth copy. - meth hasReturn - ifTrue: - [exitLabel := meth unusedLabelForInliningInto: self. - meth exitVar: nil label: exitLabel. - labels add: exitLabel] - ifFalse: [exitLabel := nil]. - meth renameLabelsForInliningInto: self. - labels addAll: meth labels. - newStatements := stmtNode statements asOrderedCollection allButFirst. - exitLabel ifNotNil: - [newStatements addFirst: (TLabeledCommentNode new - setLabel: exitLabel - comment: 'end case')]. - newStatements - addFirst: meth asInlineNode; - addFirst: (TLabeledCommentNode new setComment: meth selector). - stmtNode setStatements: newStatements]]]]]] + parseTree nodesDo: [ :n | + n isCaseStmt ifTrue: [ + n cases do: [ :stmtNode | + | newStatements stmt meth | + (stmt := stmtNode statements first) isSend ifTrue: [ + (meth := aCodeGen methodNamed: stmt selector) ifNotNil: [ + (meth hasUnrenamableCCode not and: [ meth args isEmpty ]) + ifTrue: [ + "We can inline!" + meth := meth copy. + meth hasReturn + ifTrue: [ + exitLabel := meth unusedLabelForInliningInto: self. + meth exitVar: nil label: exitLabel. + labels add: exitLabel ] + ifFalse: [ exitLabel := nil ]. + meth renameLabelsForInliningInto: self. + labels addAll: meth labels. + newStatements := stmtNode statements asOrderedCollection + allButFirst. + exitLabel ifNotNil: [ + newStatements addFirst: + (TLabeledCommentNode new + setLabel: exitLabel + comment: 'end case') ]. + newStatements + addFirst: meth asInlineNode; + addFirst: (TLabeledCommentNode new setComment: meth selector). + stmtNode setStatements: newStatements ] ] ] ] ] ] ] { #category : #inlining } diff --git a/smalltalksrc/VMMaker-Tools/SimulatorEventTransformer.class.st b/smalltalksrc/VMMaker-Tools/SimulatorEventTransformer.class.st deleted file mode 100644 index a14064949b..0000000000 --- a/smalltalksrc/VMMaker-Tools/SimulatorEventTransformer.class.st +++ /dev/null @@ -1,158 +0,0 @@ -" -A SimulatorEventTransformer takes events as wrapped by HandMorph and converts them to a form a StackInterpreterSimulator can deal with. - -See HandMorph >> handleEvent to see what the wrapping entails. -See HandMorph >> ProcessEvents or EventSensor >> fetchMoreEvents for examples of what an unwrapped event looks like when given to the system for pre-wrapping. - -Instance Variables - -" -Class { - #name : #SimulatorEventTransformer, - #superclass : #Object, - #instVars : [ - 'buttons', - 'modifiers' - ], - #classVars : [ - 'Default' - ], - #pools : [ - 'EventSensorConstants' - ], - #category : #'VMMaker-Tools-Old' -} - -{ #category : #'initialize-release' } -SimulatorEventTransformer class >> default [ - ^Default ifNil:[Default := self new] -] - -{ #category : #accessing } -SimulatorEventTransformer class >> eventTypeMouse [ - ^EventTypeMouse -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> degenerateEvent: aMorphicEvent [ - "tty. Bert had mentioned a distinction between events and polling events and that Morphic could handle both. - I don't know what he is talking about." - aMorphicEvent isMouse ifTrue: - [^self degenerateMouseEvent: aMorphicEvent]. - aMorphicEvent isKeyboard ifTrue: - [^self degenerateKeyboardEvent: aMorphicEvent]. -" type = EventTypeDragDropFiles ifTrue: [evt := self generateDropFilesEvent: evtBuf]. - type = EventTypeWindow ifTrue:[evt := self generateWindowEvent: evtBuf]." - - ^nil -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> degenerateEvent: aMorphicEvent for: client [ - "Handle ''degenerating'' events for aClient. This interface gets the client - to queue the event via queueForwardedEvent:, and may generate more - than one event for the input event (i.e. a fake mouse move before a - button down), in addition to filtering-out excessive mouse moves." - aMorphicEvent isMouse ifTrue: - [^self degenerateMouseEvent: aMorphicEvent for: client]. - aMorphicEvent isKeyboard ifTrue: - [^self degenerateKeyboardEvent: aMorphicEvent for: client]. - ^self degenerateUnknownEvent: aMorphicEvent for: client -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> degenerateKeyboardEvent: aMorphicEvent [ - "see HandMorph>>generateKeyboardEvent and EventSensor class comment" - ^{ 2. - aMorphicEvent timeStamp. - aMorphicEvent keyValue. "<--this is wrong. See Sensor FirstEvt: for what needs to happen. hooo boy" - aMorphicEvent type caseOf: { - [#keyDown] -> [EventKeyDown]. - [#keyUp] -> [EventKeyUp]. - [#keystroke] -> [EventKeyChar] }. - modifiers. - aMorphicEvent keyValue. - 0. - 0 } -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> degenerateKeyboardEvent: aMorphicEvent for: aClient [ - "Convert the keyboard event into a low-level event for the VM simulator (aClient). - See HandMorph>>generateKeyboardEvent and EventSensor class comment" - aClient queueForwardedEvent: - { 2. - aMorphicEvent timeStamp. - aMorphicEvent keyValue. "<--this is wrong. See Sensor FirstEvt: for what needs to happen. hooo boy" - aMorphicEvent type caseOf: { - [#keyDown] -> [EventKeyDown]. - [#keyUp] -> [EventKeyUp]. - [#keystroke] -> [EventKeyChar] }. - modifiers. - aMorphicEvent keyValue. - 0. - self windowIndex } -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> degenerateMouseEvent: aMorphicEvent [ - "see HandMorph>>generateMouseEvent" - - modifiers := aMorphicEvent buttons >> 3. "Sad, but modifiers come in on mouse move events..." - aMorphicEvent type == #mouseMove - ifTrue: [buttons = 0 ifTrue: [^nil]] "filter-out mouse moves unless buttons are pressed, so simulation doersn't get window leave events when we leave its window" - ifFalse: [buttons := aMorphicEvent buttons]. - ^{ 1. - aMorphicEvent timeStamp. - aMorphicEvent position x. - aMorphicEvent position y. - buttons bitAnd: 7. "thanks Ron T." - buttons >> 3. "Thanks dtl" - 0. - 0 } -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> degenerateMouseEvent: aMorphicEvent for: aClient [ - "Convert the mouse event into low-level events for the VM simulator (aClient). Filter-out mouse moves, - and generate a fake mouse move before each button press. - See HandMorph>>generateMouseEvent" - | translated | - translated := aMorphicEvent position - aClient displayView bounds origin. - modifiers := aMorphicEvent buttons >> 3. "Sad, but modifiers come in on mouse move events..." - - aMorphicEvent type == #mouseMove - ifTrue: "filter-out mouse moves unless buttons are pressed, so simulation doesn't get window leave events when we leave its window" - [buttons = 0 ifTrue: [^nil]] - ifFalse:"If the buttons are going down, make sure to add a mouse move event to the current position before the buttons are pressed." - [((buttons bitAnd: 7) = 0 and: [(aMorphicEvent buttons bitAnd: 7) ~= 0]) ifTrue: - [aClient queueForwardedEvent: - { 1. - aMorphicEvent timeStamp. - translated x. - translated y. - 0. - buttons >> 3. "Thanks dtl" - 0. - self windowIndex }]. - buttons := aMorphicEvent buttons]. - aClient queueForwardedEvent: - { 1. - aMorphicEvent timeStamp. - translated x. - translated y. - buttons bitAnd: 7. "thanks Ron T." - buttons >> 3. "Thanks dtl" - 0. - self windowIndex } -] - -{ #category : #'initialize-release' } -SimulatorEventTransformer >> initialize [ - buttons := modifiers := 0 -] - -{ #category : #'event transformation' } -SimulatorEventTransformer >> windowIndex [ - ^1 -] diff --git a/smalltalksrc/VMMaker-Tools/SimulatorMorphicEventTests.class.st b/smalltalksrc/VMMaker-Tools/SimulatorMorphicEventTests.class.st deleted file mode 100644 index 70931ec162..0000000000 --- a/smalltalksrc/VMMaker-Tools/SimulatorMorphicEventTests.class.st +++ /dev/null @@ -1,63 +0,0 @@ -Class { - #name : #SimulatorMorphicEventTests, - #superclass : #TestCase, - #pools : [ - 'EventSensorConstants' - ], - #category : #'VMMaker-Tools-Old' -} - -{ #category : #'test event' } -SimulatorMorphicEventTests >> testKeyEventDegeneration [ - |aMorphicEvent evtBuf type| - aMorphicEvent := HandMorph new generateKeyboardEvent: {2 . 0. 0. 0. 0. 0. 0. 0}. - evtBuf := SimulatorEventTransformer default degenerateEvent: aMorphicEvent. - type := evtBuf at:1. - self assert:(type = EventTypeKeyboard). - -] - -{ #category : #'test event' } -SimulatorMorphicEventTests >> testMouseEventDegeneration [ - |aMorphicEvent evtBuf type| - "see class comment in EventSensor browse" - aMorphicEvent := HandMorph new generateMouseEvent: {1 . 0. 0. 0. 0. 0. 0. 0}. - evtBuf := SimulatorEventTransformer default degenerateEvent: aMorphicEvent. - type := evtBuf at:1. - self assert:(type = EventTypeMouse). - -] - -{ #category : #'test event' } -SimulatorMorphicEventTests >> testNullEventDegeneration [ - |aMorphicEvent evtBuf type| - "Test a bad morphic event returns a null event" "see class comment in EventSensor browse" - aMorphicEvent := UserInputEvent new. - evtBuf := SimulatorEventTransformer default degenerateEvent: aMorphicEvent. - type := evtBuf at:1. - self assert:(type = EventTypeNone). - - -] - -{ #category : #'test tight coupling' } -SimulatorMorphicEventTests >> testSimulatorDisplayViewAccess [ - "There is tight coupling between the morph,model and vm simulator on the simulators displayView variable - this test makes sure it is accesible and is an ImageMorph." - -self assert: ((SystemNavigation allImplementorsOf: #displayView localTo: StackInterpreterSimulator) size = 1). -self assert: ((SystemNavigation allImplementorsOf: #displayView: localTo: StackInterpreterSimulator)size = 1). - - -] - -{ #category : #'test tight coupling' } -SimulatorMorphicEventTests >> testStackInterpreterSimulatorDisplayViewAccess [ - "There is tight coupling between the morph,model and vm simulator on the simulators displayView variable - this test makes sure it is accesible and is an ImageMorph." - -self assert: ((SystemNavigation allImplementorsOf: #displayView localTo: StackInterpreterSimulator) size = 1). -self assert: ((SystemNavigation allImplementorsOf: #displayView: localTo: StackInterpreterSimulator)size = 1). - - -] diff --git a/smalltalksrc/VMMaker-Tools/SimulatorMorphicModel.class.st b/smalltalksrc/VMMaker-Tools/SimulatorMorphicModel.class.st deleted file mode 100644 index 5a5ecd048d..0000000000 --- a/smalltalksrc/VMMaker-Tools/SimulatorMorphicModel.class.st +++ /dev/null @@ -1,320 +0,0 @@ -" -A SimulatorMorphicModel handles Morphic callbacks and UI for (some parts of ) the simulator. - -I handle event forwarding management.. - -Currently, I am a listener to HandMorphs>>addPrimitiveEventListener. -I am added as a listener by SimulatorMorph>>displayView (which probably needs to change. tty) -" -Class { - #name : #SimulatorMorphicModel, - #superclass : #Model, - #instVars : [ - 'vm', - 'title', - 'stepping', - 'morph' - ], - #pools : [ - 'EventSensorConstants' - ], - #category : #'VMMaker-Tools-Old' -} - -{ #category : #'class initialization' } -SimulatorMorphicModel class >> initialize [ - "I want to keep it launchable by script only for now. - Eliot has a bunch of options that aren't really feasible for a Morphic first approach. - " - "self - registerWindowColor; - registerInOpenMenu; - registerInFlaps" -] - -{ #category : #'instance creation' } -SimulatorMorphicModel class >> on: aStackInterpreterSimulator title: aString transcript: aTranscriptStream [ - | simmodel | - simmodel := self new. - simmodel - vm: aStackInterpreterSimulator; - title: aString; - transcript: aTranscriptStream. - ^simmodel. -] - -{ #category : #'class initialization' } -SimulatorMorphicModel class >> registerInFlaps [ -" Flaps - registerQuad: - { #StackInterpreterSimulator. - #prototypicalToolWindow. - 'StackInterpreter Simulator' translated. - 'A Morphic Wrapper for VM Simulations' translated } - forFlapNamed: 'Tools' translated. - Flaps replaceToolsFlap" -] - -{ #category : #'class initialization' } -SimulatorMorphicModel class >> registerInOpenMenu [ - (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ - TheWorldMenu unregisterOpenCommand: 'StackInterpreter Simulator'. - TheWorldMenu registerOpenCommand: {'StackInterpreter Simulator'. {self. #open}}]. - -] - -{ #category : #'class initialization' } -SimulatorMorphicModel class >> unload [ - self - unregisterFromOpenMenu; - unregisterFromFlaps. -] - -{ #category : #'class initialization' } -SimulatorMorphicModel class >> unregisterFromFlaps [ - "Flaps - unregisterQuadsWithReceiver: self; - replaceToolsFlap" -] - -{ #category : #'class initialization' } -SimulatorMorphicModel class >> unregisterFromOpenMenu [ - (TheWorldMenu respondsTo: #registerOpenCommand:) - ifTrue: [TheWorldMenu unregisterOpenCommand: 'StackInterpreter Simulator']. - -] - -{ #category : #accessing } -SimulatorMorphicModel >> bounds [ - ^morph bounds. -] - -{ #category : #'user interface' } -SimulatorMorphicModel >> byteCountText [ - ^vm byteCountText -] - -{ #category : #'user interface - squeakJS' } -SimulatorMorphicModel >> currentContextStack [ - self flag: 'tty'. - ^ 'Current Context Stack' printString asText -] - -{ #category : #'user interface' } -SimulatorMorphicModel >> defaultWindowColor [ - ^ (Color r: 0.645 g: 1.0 b: 1.0) -] - -{ #category : #accessing } -SimulatorMorphicModel >> displayForm [ - ^ vm displayForm -] - -{ #category : #accessing } -SimulatorMorphicModel >> displayView [ - ^ vm displayView -] - -{ #category : #accessing } -SimulatorMorphicModel >> displayView: anImageMorph [ - vm displayView: anImageMorph -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> forceInterruptCheck [ - vm forceInterruptCheck -"^UserDialogBoxMorph inform: 'Toggle Transcript' title: 'TODO:'" -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> hack [ - UserDialogBoxMorph inform: (morph bounds printString) title: 'Hack:' -] - -{ #category : #'event-forwarding' } -SimulatorMorphicModel >> handleListenEvent: aMorphicEvent [ -"The SimulatorImageMorph regsitered me (a SimulatorMorphicModel ) with HandMorph>>addEventListener -HandMorph then broadcasts events to all registered listeners at this method. See HandMorph>>sendListenPrimitiveEvent -" - morph ifNotNil: - [(SimulatorEventTransformer default degenerateEvent: aMorphicEvent) ifNotNil: - [:evtBuf| - ((evtBuf at: 1) = EventTypeMouse and: [morph bounds containsPoint: aMorphicEvent position]) ifTrue: - [| xtranslated ytranslated | - xtranslated := (evtBuf at:3) - (morph bounds left) - 2 . "<--heh" - ytranslated := (evtBuf at:4) - (morph bounds top). - evtBuf at: 3 put: xtranslated. - evtBuf at: 4 put: ytranslated]. - vm queueForwardedEvent: evtBuf]] -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> help [ - "Open up a workspace with explanatory info in it about the StackInterpreterSimulator" - Workspace new - contents: self helpText; - openLabel: self windowTitle, ' Help'. -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> helpText [ - ^(String streamContents: [:str | - str nextPutAll: -'Stack Intepreter Simulator Help Contents Go Here.']) translated -] - -{ #category : #'user interface' } -SimulatorMorphicModel >> initialExtent [ - ^ 1286@938 -] - -{ #category : #'initialize-release' } -SimulatorMorphicModel >> initialize [ - - title := 'StackInterpreter Simulator (Beta))'. -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> ioExit [ - vm ioExit - displayView activeHand removeEventListener: self model. "This is a bug as the user in vm ioExit may have cancelled the confirm t.m." -"^UserDialogBoxMorph inform: 'Toggle Transcript' title: 'TODO:'" -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> loadImage [ - ^UserDialogBoxMorph inform: 'load image' title: 'TODO:' -] - -{ #category : #accessing } -SimulatorMorphicModel >> morph [ - "I need the bounds of my morph for filtering mouse events. - If there is a canned way of doing this besides this tight binding to my SimulatorMorph, - then please refactor me. - - see my protocol event-forwarding for the gory details" - self flag:'tty'. - ^morph. -] - -{ #category : #accessing } -SimulatorMorphicModel >> morph: aMorph [ - "I need the bounds of my morph for filtering mouse events. - If there is a canned way of doing this besides this tight binding to my SimulatorMorph, - then please refactor me. - - see my protocol event-forwarding for the gory details" - self flag:'tty'. - morph := aMorph. -] - -{ #category : #'user interface - squeakJS' } -SimulatorMorphicModel >> onItemClicked: anItem [ - "I am an item in the current context display on the SqueakJS tree view". -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> options [ -^UserDialogBoxMorph inform: 'Options Popup--need checkboxes?' title: 'TODO:' -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> over [ - stepping:=true. -^UserDialogBoxMorph inform: 'Step Over' title: 'TODO:' -] - -{ #category : #'user interface - squeakJS' } -SimulatorMorphicModel >> processesAndContextStack [ - "just a stub. see top right panel at http://lively-web.org/users/bert/squeak.html for what I intend to present" - self flag: 'tty'. - ^ 'Processes and ContextStack' printString asText - -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> reset [ - ^UserDialogBoxMorph inform: 'Reset' title: 'TODO:' -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> return [ -^UserDialogBoxMorph inform: 'Return' title: 'TODO:' -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> run [ - stepping:=false. - vm run -"^UserDialogBoxMorph inform: 'Run' title: 'TODO:'" -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> send [ -^UserDialogBoxMorph inform: 'Send' title: 'TODO:' -] - -{ #category : #'user interface - squeakJS' } -SimulatorMorphicModel >> specialObjectsAndActiveContext [ - "just a stub. see top left panel at http://lively-web.org/users/bert/squeak.html for what I intend to present" - self flag: 'tty'. - ^ 'Special Objects and Active Context' printString asText - -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> step [ - stepping:=true. -^UserDialogBoxMorph inform: 'Step' title: 'TODO:' -] - -{ #category : #accessing } -SimulatorMorphicModel >> stepping [ - ^stepping -] - -{ #category : #accessing } -SimulatorMorphicModel >> stepping: aBoolean [ - stepping := aBoolean -] - -{ #category : #accessing } -SimulatorMorphicModel >> title: aString [ - title := aString -] - -{ #category : #'buttons callbacks' } -SimulatorMorphicModel >> toggleTranscript [ - vm toggleTranscriptForSimulatorMorph: self transcript. -"^UserDialogBoxMorph inform: 'Toggle Transcript' title: 'TODO:'" -] - -{ #category : #accessing } -SimulatorMorphicModel >> transcript [ - ^vm transcript -] - -{ #category : #accessing } -SimulatorMorphicModel >> transcript: aTranscriptStream [ - vm transcript: aTranscriptStream. -] - -{ #category : #'user interface' } -SimulatorMorphicModel >> utilitiesMenu: aMenuMorph [ - ^vm utilitiesMenu: aMenuMorph -] - -{ #category : #accessing } -SimulatorMorphicModel >> vm [ - ^vm -] - -{ #category : #accessing } -SimulatorMorphicModel >> vm: aVMSimulator [ - vm := aVMSimulator -] - -{ #category : #'user interface' } -SimulatorMorphicModel >> windowTitle [ - ^ title translated -] From 751363d04715bd553325215b357042be76d26152 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 18:07:14 +0200 Subject: [PATCH 06/75] Adding first iteration on automatic localization of variables: - define a local variable for the localized one - internalize it at the beginning of the function - externalize it at the exits of the function - If we inline a method, replace the localizable variables by their localized versions --- .../MockLocalizationInterpreterMock.class.st | 23 +- .../SlangLocalizationTestCase.class.st | 82 +++++- smalltalksrc/Slang/CCodeGenerator.class.st | 40 ++- smalltalksrc/Slang/TAssignmentNode.class.st | 31 +++ smalltalksrc/Slang/TInlineNode.class.st | 7 + smalltalksrc/Slang/TMethod.class.st | 235 ++++++++++-------- smalltalksrc/Slang/TParseNode.class.st | 14 ++ smalltalksrc/Slang/TSendNode.class.st | 10 + smalltalksrc/Slang/TVariableNode.class.st | 15 ++ smalltalksrc/VMMaker/CogVMSimulator.class.st | 139 ----------- .../VMMaker/StackInterpreter.class.st | 40 +-- .../StackInterpreterSimulator.class.st | 139 ----------- .../StackMTInterpreterSimulator.class.st | 139 ----------- 13 files changed, 361 insertions(+), 553 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 9fccaf53c3..95f55f1b25 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -4,7 +4,8 @@ Class { #instVars : [ 'variableToLocalize', 'sharedVariableToLocalize', - 'sharedVariableToLocalizeBeforeInlining' + 'sharedVariableToLocalizeBeforeInlining', + 'autoLocalizedVariable' ], #classVars : [ 'BytecodeTable' @@ -15,13 +16,24 @@ Class { { #category : #initialization } MockLocalizationInterpreterMock class >> initialize [ - BytecodeTable := Array new: 4. + BytecodeTable := Array new: 5. self table: BytecodeTable from: #( ( 0 bytecodeToInline) ( 1 bytecodeUsingLocalizedVariable) ( 2 bytecodeUsingSharedLocalizedVariable) ( 3 bytecodeUsingSharedLocalizedVariableBeforeInlining) + ( 4 bytecodeUsingAutoLocalizedVariable) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithAutoLocalizedVariableOnly [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingAutoLocalizedVariable) ) ] @@ -31,6 +43,12 @@ MockLocalizationInterpreterMock >> bytecodeToInline [ "Do nothing" ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingAutoLocalizedVariable [ + + autoLocalizedVariable := 17 +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ @@ -52,6 +70,7 @@ MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariableBeforeInl { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> interpret [ + self dispatchOn: 1 in: BytecodeTable ] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 7918333d5d..387b8af5b1 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -5,11 +5,85 @@ Class { } { #category : #tests } -SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ +SlangLocalizationTestCase >> setUp [ + + super setUp. + MockLocalizationInterpreterMock initialize. +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + self assert: ((ccg methodNamed: #interpret) locals includes: #local_autoLocalizedVariable) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ + + | internalizationStatement | + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + internalizationStatement := (ccg methodNamed: #interpret) statements last. + + self + assert: internalizationStatement + equals: (TAssignmentNode + variableNamed: #autoLocalizedVariable + expression: (TVariableNode named: #local_autoLocalizedVariable)) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning [ + + | internalizationStatement | + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + internalizationStatement := (ccg methodNamed: #interpret) statements first. + + self + assert: internalizationStatement + equals: (TAssignmentNode + variableNamed: #local_autoLocalizedVariable + expression: (TVariableNode named: #autoLocalizedVariable)) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + | interpretMethod | + MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Fail if we find some node inside the case that uses the localized variable" + interpretMethod := ccg methodNamed: #interpret. + interpretMethod statements second cases do: [ :e | + e nodesDo: [ :node | + (node isVariable and: [ node name = #autoLocalizedVariable ]) + ifTrue: [ self fail ] ] + ]. +] + +{ #category : #tests } +SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. [ ccg localizeVariables: #( sharedVariableToLocalize ) inMethod: (ccg methodNamed: #interpret). @@ -22,10 +96,9 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ { #category : #tests } SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUsesAreNotInlined [ - - ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. ccg retainMethods: #( interpret ). ccg prepareMethods. ccg pruneUnreachableMethods. @@ -41,10 +114,9 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUse { #category : #tests } SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAreInlined [ - - ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. ccg retainMethods: #( interpret ). ccg prepareMethods. ccg doBasicInlining: true. diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 0dbebda299..10953f7b3c 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3350,16 +3350,36 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ "Inline dispatches (case statements) in the method with the given name. Then localize variables" - | m | - m := self methodNamed: selector. - m = nil ifFalse: [ - m inlineCaseStatementBranchesIn: self. - m parseTree nodesDo: [ :n | - n isCaseStmt ifTrue: [ - n - customizeShortCasesForDispatchVar: 'currentBytecode' - in: self - method: m ] ] ] + | m variablesToLocalize | + (m := self methodNamed: selector) ifNil: [ ^ self ]. + + variablesToLocalize := Set new. + m + extractDirective: #localizedVariable: + valueBlock: [:sendNode| variablesToLocalize add: sendNode arguments first value ] + default: nil. + m localizeVariables: (variablesToLocalize collect: [ :e | 'local_', e ]). + variablesToLocalize do: [ :e | + m statements addFirst: (TAssignmentNode + variableNamed: #local_, e + expression: (TVariableNode named: e)). + self haltIf: (m statements last isReturn and: [m statements last expression name ~= 'self']). + m statements addLast: (TAssignmentNode + variableNamed: e + expression: (TVariableNode named: #local_, e)). + ]. + + + m + inlineCaseStatementBranchesIn: self + withReplacementDictionary: (variablesToLocalize collect: [ :v | + v -> (TVariableNode named: #local_, v) ]) asDictionary. + m parseTree nodesDo: [ :n | + n isCaseStmt ifTrue: [ + n + customizeShortCasesForDispatchVar: 'currentBytecode' + in: self + method: m ] ] ] { #category : #utilities } diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index 78e76540b4..ea05fb677e 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -8,6 +8,31 @@ Class { #category : #'Slang-AST' } +{ #category : #'instance creation' } +TAssignmentNode class >> variable: aVariable expression: anExpression [ + + ^ self new + setVariable: aVariable expression: anExpression; + yourself +] + +{ #category : #'instance creation' } +TAssignmentNode class >> variableNamed: aVariableName expression: anExpression [ + + ^ self new + setVariable: (TVariableNode named: aVariableName) expression: anExpression; + yourself +] + +{ #category : #comparing } +TAssignmentNode >> = anotherNode [ + + super = anotherNode ifFalse: [ ^ false ]. + variable = anotherNode variable ifFalse: [ ^ false ]. + expression = anotherNode expression ifFalse: [ ^ false ]. + ^ true +] + { #category : #transformations } TAssignmentNode >> bindVariableUsesIn: aDictionary [ "Do NOT bind the variable on the left-hand-side of an assignment statement." @@ -141,6 +166,12 @@ TAssignmentNode >> expression [ ^expression ] +{ #category : #comparing } +TAssignmentNode >> hash [ + + ^ variable hash + expression hash +] + { #category : #testing } TAssignmentNode >> isAssignment [ diff --git a/smalltalksrc/Slang/TInlineNode.class.st b/smalltalksrc/Slang/TInlineNode.class.st index 66ade7edb0..2a738ceff2 100644 --- a/smalltalksrc/Slang/TInlineNode.class.st +++ b/smalltalksrc/Slang/TInlineNode.class.st @@ -25,6 +25,13 @@ TInlineNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold i yourself] ] +{ #category : #transformations } +TInlineNode >> bindVariablesIn: aDictionary [ + + method := method bindVariablesIn: aDictionary. + +] + { #category : #'C code generation' } TInlineNode >> emitCCodeOn: aStream level: level generator: aCodeGen [ method emitInlineOn: aStream level: level generator: aCodeGen. diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index a1d128bded..0e8be8e3f5 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -160,41 +160,45 @@ TMethod >> allReferencedVariablesUsing: aCodeGen [ { #category : #inlining } TMethod >> argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeGen [ + "Return a collection of assignment nodes that assign the given argument expressions to the formal parameter variables of the given method." + "Optimization: If the actual parameters are either constants or local variables in the target method (the receiver), substitute them directly into the body of meth. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals." | stmtList substitutionDict argList | - meth args size > (argList := aSendNode args) size ifTrue: - [self assert: (meth args first beginsWith: 'self_in_'). - argList := {aSendNode receiver}, aSendNode args]. - + meth args size > (argList := aSendNode arguments) size ifTrue: [ + self assert: (meth args first beginsWith: 'self_in_'). + argList := { aSendNode receiver } , aSendNode args ]. + stmtList := OrderedCollection new: argList size. substitutionDict := Dictionary new: argList size. - meth args with: argList do: - [:argName :exprNode | - (self isNode: exprNode substitutableFor: argName inMethod: meth in: aCodeGen) - ifTrue: - [substitutionDict - at: argName - put: (aCodeGen - node: exprNode - typeCompatibleWith: argName - inliningInto: meth - in: self). - locals remove: argName ifAbsent: [self assert: (argName beginsWith: 'self_in_')]. - declarations removeKey: argName ifAbsent: nil] - ifFalse: "Add an assignment for anything except an unused self_in_foo argument" - [(elidedArgs includes: argName) ifFalse: - [stmtList addLast: - (TAssignmentNode new - setVariable: (TVariableNode new setName: argName) - expression: (aCodeGen - node: exprNode copy - typeCompatibleWith: argName - inliningInto: meth - in: self))]]]. + meth args with: argList do: [ :argName :exprNode | + (self + isNode: exprNode + substitutableFor: argName + inMethod: meth + in: aCodeGen) + ifTrue: [ + substitutionDict at: argName put: (aCodeGen + node: exprNode + typeCompatibleWith: argName + inliningInto: meth + in: self). + locals + remove: argName + ifAbsent: [ self assert: (argName beginsWith: 'self_in_') ]. + declarations removeKey: argName ifAbsent: nil ] + ifFalse: [ "Add an assignment for anything except an unused self_in_foo argument" + (elidedArgs includes: argName) ifFalse: [ + stmtList addLast: (TAssignmentNode new + setVariable: (TVariableNode new setName: argName) + expression: (aCodeGen + node: exprNode copy + typeCompatibleWith: argName + inliningInto: meth + in: self)) ] ] ]. meth parseTree: (meth parseTree bindVariablesIn: substitutionDict). - ^stmtList + ^ stmtList ] { #category : #'primitive compilation' } @@ -263,30 +267,49 @@ TMethod >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: c yourself] ] +{ #category : #transformations } +TMethod >> bindVariablesIn: constantDictionary [ + "Class variables are used as constants. This method replaces all references to class variables in the body of this method with the corresponding constant looked up in the class pool dictionary of the source class. The source class class variables should be initialized before this method is called." + + parseTree := parseTree bindVariablesIn: constantDictionary. +] + { #category : #transformations } TMethod >> buildCaseStmt: aSendNode in: aCodeGen [ + "Build a case statement node for the given send of dispatchOn:in:." + "Note: the first argument is the variable to be dispatched on. The second argument is a constant node holding an array of unary selectors, which will be turned into sends to self." | unimplemented errorMessage | - (aSendNode args size >= 2 - and: [aSendNode args second isConstant - and: [aSendNode args second value isArray]]) ifFalse: - [self error: 'wrong node structure for a case statement']. - - unimplemented := aSendNode args second value select: [:s| (aCodeGen methodNamed: s) isNil]. - unimplemented isEmpty ifFalse: - [errorMessage := 'The following selectors in case statement "', (aSendNode printString copyUpTo: $#), '..." are unimplemented: ', - (String streamContents: [:s| unimplemented do: [:sel| s crtab; store: sel]]). - aCodeGen logger nextPutAll: errorMessage; cr; flush. - (self confirm: errorMessage - orCancel: aCodeGen abortBlock) ifFalse: - [self halt]]. - - ^TCaseStmtNode new - setExpression: aSendNode args first - selectors: aSendNode args second value - arguments: (aSendNode args copyFrom: 3 to: aSendNode args size) + (aSendNode arguments size >= 2 and: [ + aSendNode arguments second isConstant and: [ + aSendNode arguments second value isArray ] ]) ifFalse: [ + self error: 'wrong node structure for a case statement' ]. + + unimplemented := aSendNode arguments second value select: [ :s | + (aCodeGen methodNamed: s) isNil ]. + unimplemented isEmpty ifFalse: [ + errorMessage := 'The following selectors in case statement "' + , (aSendNode printString copyUpTo: $#) + , '..." are unimplemented: ' + , (String streamContents: [ :s | + unimplemented do: [ :sel | + s + crtab; + store: sel ] ]). + aCodeGen logger + nextPutAll: errorMessage; + cr; + flush. + (self confirm: errorMessage orCancel: aCodeGen abortBlock) ifFalse: [ + self halt ] ]. + + ^ TCaseStmtNode new + setExpression: aSendNode arguments first + selectors: aSendNode arguments second value + arguments: + (aSendNode arguments copyFrom: 3 to: aSendNode arguments size) ] { #category : #transformations } @@ -1229,7 +1252,7 @@ TMethod >> inlineBuiltin: aSendNode in: aCodeGen [ ] { #category : #inlining } -TMethod >> inlineCaseStatementBranchesIn: aCodeGen [ +TMethod >> inlineCaseStatementBranchesIn: aCodeGen withReplacementDictionary: replacementDictionary [ | exitLabel | parseTree nodesDo: [ :n | @@ -1260,7 +1283,9 @@ TMethod >> inlineCaseStatementBranchesIn: aCodeGen [ newStatements addFirst: meth asInlineNode; addFirst: (TLabeledCommentNode new setComment: meth selector). - stmtNode setStatements: newStatements ] ] ] ] ] ] + stmtNode setStatements: newStatements. + stmtNode bindVariablesIn: replacementDictionary. + ] ] ] ] ] ] ] { #category : #inlining } @@ -1441,6 +1466,7 @@ TMethod >> inlineReturningConditional: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen [ + "Answer a collection of statements to replace the given send. directReturn indicates that the send is the expression in a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not @@ -1456,70 +1482,77 @@ TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: methArgs := meth args. "convenient for debugging..." aCodeGen maybeBreakForInlineOf: aSendNode in: self. - elidedArgs := #(). - (methArgs notEmpty and: [methArgs first beginsWith: 'self_in_']) - ifTrue: "If the first arg is not used we can and should elide it." - [| varNode | - varNode := TVariableNode new setName: methArgs first. - (meth parseTree noneSatisfy: [:node| varNode isSameAs: node]) ifTrue: - [elidedArgs := {methArgs first}]. - methArgs := methArgs allButFirst]. - methArgs size = aSendNode args size ifFalse: - [^nil]. + elidedArgs := #( ). + (methArgs notEmpty and: [ methArgs first beginsWith: 'self_in_' ]) + ifTrue: [ "If the first arg is not used we can and should elide it." + | varNode | + varNode := TVariableNode new setName: methArgs first. + (meth parseTree noneSatisfy: [ :node | varNode isSameAs: node ]) + ifTrue: [ elidedArgs := { methArgs first } ]. + methArgs := methArgs allButFirst ]. + methArgs size = aSendNode arguments size ifFalse: [ ^ nil ]. meth := meth copy. - (meth statements size > 1 - and: [meth statements first isSend - and: [meth statements first selector == #flag:]]) ifTrue: - [meth statements removeFirst]. + (meth statements size > 1 and: [ + meth statements first isSend and: [ + meth statements first selector == #flag: ] ]) ifTrue: [ + meth statements removeFirst ]. "Propagate the return type of an inlined method" - (directReturn or: [exitVar notNil]) ifTrue: - [exitType := directReturn - ifTrue: [returnType] - ifFalse: [(self typeFor: exitVar in: aCodeGen) ifNil: [#sqInt]]. - (exitType = #void or: [exitType = meth returnType]) ifFalse: - [meth propagateReturnIn: aCodeGen]]. + (directReturn or: [ exitVar notNil ]) ifTrue: [ + exitType := directReturn + ifTrue: [ returnType ] + ifFalse: [ + (self typeFor: exitVar in: aCodeGen) ifNil: [ #sqInt ] ]. + (exitType = #void or: [ exitType = meth returnType ]) ifFalse: [ + meth propagateReturnIn: aCodeGen ] ]. "Propagate any unusual argument types to untyped argument variables" - methArgs - with: aSendNode args - do: [:formal :actual| - (meth declarationAt: formal ifAbsent: nil) ifNil: - [(self typeFor: actual in: aCodeGen) ifNotNil: - [:type| - type ~= #sqInt ifTrue: - [meth declarationAt: formal put: (type last = $* ifTrue: [type, formal] ifFalse: [type, ' ', formal])]]]]. + methArgs with: aSendNode arguments do: [ :formal :actual | + (meth declarationAt: formal ifAbsent: nil) ifNil: [ + (self typeFor: actual in: aCodeGen) ifNotNil: [ :type | + type ~= #sqInt ifTrue: [ + meth declarationAt: formal put: (type last = $* + ifTrue: [ type , formal ] + ifFalse: [ type , ' ' , formal ]) ] ] ] ]. meth renameVarsForInliningInto: self except: elidedArgs in: aCodeGen. meth renameLabelsForInliningInto: self. self addVarsDeclarationsAndLabelsOf: meth except: elidedArgs. - meth hasReturn ifTrue: - [directReturn ifFalse: - [exitLabel := self unusedLabelForInliningInto: self. - (meth exitVar: exitVar label: exitLabel) "is label used?" + meth hasReturn ifTrue: [ + directReturn ifFalse: [ + exitLabel := self unusedLabelForInliningInto: self. + (meth exitVar: exitVar label: exitLabel) ifTrue: [ labels add: exitLabel ] - ifFalse: [ exitLabel := nil ]]]. - (inlineStmts := OrderedCollection new: meth statements size + meth args size + 2) - add: (label := TLabeledCommentNode new setComment: 'begin ', sel); - addAll: (self argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeGen); - addAll: meth statements. "method body" - directReturn ifTrue: - [meth endsWithReturn - ifTrue: - [exitVar ifNotNil: "don't remove the returns if being invoked in the context of a return" - [inlineStmts at: inlineStmts size put: inlineStmts last copyWithoutReturn]] - ifFalse: - [inlineStmts add: - (TReturnNode new setExpression: (TVariableNode new setName: 'nil'))]]. - exitLabel ifNotNil: - [inlineStmts add: - (TLabeledCommentNode new setLabel: - exitLabel comment: 'end ', meth selector)]. - inlineStmts size = 1 ifTrue: "Nuke empty methods; e.g. override of flushAtCache" - [self assert: inlineStmts first isComment. - inlineStmts removeFirst]. - ^inlineStmts + ifFalse: [ exitLabel := nil ] "is label used?" ] ]. + (inlineStmts := OrderedCollection new: + meth statements size + meth args size + 2) + add: (label := TLabeledCommentNode new setComment: 'begin ' , sel); + addAll: (self + argAssignmentsFor: meth + send: aSendNode + except: elidedArgs + in: aCodeGen); + addAll: meth statements. "method body" + directReturn ifTrue: [ + meth endsWithReturn + ifTrue: [ + exitVar ifNotNil: [ "don't remove the returns if being invoked in the context of a return" + inlineStmts + at: inlineStmts size + put: inlineStmts last copyWithoutReturn ] ] + ifFalse: [ + inlineStmts add: + (TReturnNode new setExpression: + (TVariableNode new setName: 'nil')) ] ]. + exitLabel ifNotNil: [ + inlineStmts add: (TLabeledCommentNode new + setLabel: exitLabel + comment: 'end ' , meth selector) ]. + inlineStmts size = 1 ifTrue: [ "Nuke empty methods; e.g. override of flushAtCache" + self assert: inlineStmts first isComment. + inlineStmts removeFirst ]. + ^ inlineStmts ] { #category : #inlining } diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index e2cd754ceb..28d72800e2 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -10,6 +10,14 @@ Class { #category : #'Slang-AST' } +{ #category : #utilities } +TParseNode >> = anotherNode [ + + (anotherNode isKindOf: self species) + ifFalse: [ ^ false ]. + ^ comment = anotherNode comment +] + { #category : #utilities } TParseNode >> allCalls [ "Answer a collection of selectors for the messages sent in this parse tree." @@ -190,6 +198,12 @@ TParseNode >> hasSideEffect [ ^true ] +{ #category : #utilities } +TParseNode >> hash [ + + ^ comment hash +] + { #category : #testing } TParseNode >> isAssertion [ ^false diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index 08bde5bdfe..2b6989da84 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -13,6 +13,16 @@ Class { { #category : #accessing } TSendNode >> args [ + self + deprecated: 'use #arguments instead' + transformWith: '`@rec args' -> '`@rec arguments'. + + ^ self arguments +] + +{ #category : #accessing } +TSendNode >> arguments [ + ^arguments ] diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index a12e725e30..eba4748c09 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -7,6 +7,21 @@ Class { #category : #'Slang-AST' } +{ #category : #'instance creation' } +TVariableNode class >> named: aName [ + + ^ self new + setName: aName; + yourself +] + +{ #category : #transformations } +TVariableNode >> = anotherNode [ + + super = anotherNode ifFalse: [ ^ false ]. + ^ name = anotherNode name +] + { #category : #transformations } TVariableNode >> bindVariableUsesIn: aDictionary [ diff --git a/smalltalksrc/VMMaker/CogVMSimulator.class.st b/smalltalksrc/VMMaker/CogVMSimulator.class.st index 5b5b9925fb..396ada034a 100644 --- a/smalltalksrc/VMMaker/CogVMSimulator.class.st +++ b/smalltalksrc/VMMaker/CogVMSimulator.class.st @@ -2079,145 +2079,6 @@ CogVMSimulator >> localIP [ ^localIP ] -{ #category : #testing } -CogVMSimulator >> logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart [ - "Verify a questionable interpreter against a successful run" - "self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' " - - | logFile rightWord prevCtxt | - logFile := (FileStream readOnlyFileNamed: fileName) binary. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - prevCtxt := 0. prevCtxt := prevCtxt. - [byteCount < nBytes] whileTrue: - [ -" -byteCount > 14560 ifTrue: -[self externalizeIPandSP. -prevCtxt = activeContext ifFalse: - [prevCtxt := activeContext. - transcript cr; nextPutAll: (self printTop: 2); endEntry]. -transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space; - print: (instructionPointer - method - (BaseHeaderSize - 2)); - nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space; - nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space; - print: (self stackPointerIndex - TempFrameStart + 1); endEntry. -byteCount = 14590 ifTrue: [self halt]]. -" - loggingStart >= byteCount ifTrue: - [rightWord := logFile nextWord. - currentBytecode = rightWord ifFalse: - [self halt: 'halt at ', byteCount printString]]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount]. - self externalizeIPandSP. - logFile close. - self inform: nBytes printString , ' bytecodes verfied.' -] - -{ #category : #testing } -CogVMSimulator >> logOfBytesWrite: nBytes toFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfBytesWrite: 10000 toFileNamed: 'clone32Bytecodes.log' " - - | logFile | - logFile := (FileStream newFileNamed: fileName) binary. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - [byteCount < nBytes] whileTrue: - [byteCount >= loggingStart ifTrue: - [logFile nextWordPut: currentBytecode]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount]. - self externalizeIPandSP. - logFile close -] - -{ #category : #testing } -CogVMSimulator >> logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' " - - | logFile priorFrame rightSelector prevCtxt | - logFile := FileStream readOnlyFileNamed: fileName. - transcript clear. - byteCount := 0. - sendCount := 0. - priorFrame := localFP. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - prevCtxt := 0. prevCtxt := prevCtxt. - [sendCount < nSends] whileTrue: - [ -" -byteCount>500 ifTrue: -[byteCount>550 ifTrue: [self halt]. -self externalizeIPandSP. -prevCtxt = localFP ifFalse: - [prevCtxt := localFP. - transcript cr; nextPutAll: (self printTop: 2); endEntry]. -transcript cr; print: byteCount; nextPutAll: ': ' , (localFP hex); space; - print: (instructionPointer - method - (BaseHeaderSize - 2)); - nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space; - nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space; - print: (self stackPointerIndex - TempFrameStart + 1); endEntry. -]. -" - self dispatchOn: currentBytecode in: BytecodeTable. - localFP = priorFrame ifFalse: - [sendCount := sendCount + 1. - loggingStart >= sendCount ifTrue: - [rightSelector := logFile nextLine. - (self stringOf: messageSelector) = rightSelector ifFalse: - [self halt: 'halt at ', sendCount printString]]. - priorFrame := localFP]. - self incrementByteCount]. - self externalizeIPandSP. - logFile close. - self inform: nSends printString , ' sends verfied.' -] - -{ #category : #testing } -CogVMSimulator >> logOfSendsWrite: nSends toFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' fromStart: 2500" - - | logFile priorFrame | - logFile := FileStream newFileNamed: fileName. - transcript clear. - byteCount := 0. - sendCount := 0. - priorFrame := localFP. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - [sendCount < nSends] whileTrue: - [self dispatchOn: currentBytecode in: BytecodeTable. - localFP == priorFrame ifFalse: - [sendCount >= loggingStart ifTrue: - [sendCount := sendCount + 1. - logFile nextPutAll: (self stringOf: messageSelector); cr]. - priorFrame := localFP]. - self incrementByteCount]. - self externalizeIPandSP. - logFile close -] - { #category : #'debugging traps' } CogVMSimulator >> logSend: oop [ sendCount := sendCount + 1. diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index 92724b99be..7c789cb156 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -8079,12 +8079,13 @@ StackInterpreter >> internalAboutToReturn: resultOop through: aContext [ { #category : #'message sending' } StackInterpreter >> internalActivateNewMethod [ - | methodHeader numTemps rcvr | - + + | methodHeader numTemps rcvr | methodHeader := objectMemory methodHeaderOf: newMethod. numTemps := self temporaryCountOfMethodHeader: methodHeader. - self assert: argumentCount = (self argumentCountOfMethodHeader: methodHeader). + self assert: + argumentCount = (self argumentCountOfMethodHeader: methodHeader). rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. @@ -8094,35 +8095,38 @@ StackInterpreter >> internalActivateNewMethod [ self internalPush: newMethod. self setMethod: newMethod methodHeader: methodHeader. self internalPush: (self - encodeFrameFieldHasContext: false - isBlock: false - numArgs: (self argumentCountOfMethodHeader: methodHeader)). + encodeFrameFieldHasContext: false + isBlock: false + numArgs: (self argumentCountOfMethodHeader: methodHeader)). self internalPush: objectMemory nilObject. "FxThisContext field" self internalPush: rcvr. "Initialize temps..." - argumentCount + 1 to: numTemps do: - [:i | self internalPush: objectMemory nilObject]. + argumentCount + 1 to: numTemps do: [ :i | + self internalPush: objectMemory nilObject ]. "-1 to account for pre-increment in fetchNextBytecode" - localIP := self pointerForOop: (self initialIPForHeader: methodHeader method: newMethod) - 1. + localIP := self pointerForOop: + (self initialIPForHeader: methodHeader method: newMethod) + - 1. - (self methodHeaderHasPrimitive: methodHeader) ifTrue: - ["Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts + (self methodHeaderHasPrimitive: methodHeader) ifTrue: [ "Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts with a long store temp. Strictly no need to skip the store because it's effectively a noop." - localIP := localIP + (self sizeOfCallPrimitiveBytecode: methodHeader). - primFailCode ~= 0 ifTrue: - [self reapAndResetErrorCodeTo: localSP header: methodHeader]]. + localIP := localIP + + (self sizeOfCallPrimitiveBytecode: methodHeader). + primFailCode ~= 0 ifTrue: [ + self reapAndResetErrorCodeTo: localSP header: methodHeader ] ]. self assert: (self frameNumArgs: localFP) = argumentCount. self assert: (self frameIsBlockActivation: localFP) not. self assert: (self frameHasContext: localFP) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." - localSP < stackLimit ifTrue: - [self externalizeIPandSP. - self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: newMethod header: methodHeader). - self internalizeIPandSP] + localSP < stackLimit ifTrue: [ + self externalizeIPandSP. + self handleStackOverflowOrEventAllowContextSwitch: + (self canContextSwitchIfActivating: newMethod header: methodHeader). + self internalizeIPandSP ] ] { #category : #'return bytecodes' } diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index 4880a7d690..de121c32ae 100644 --- a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st @@ -1235,145 +1235,6 @@ StackInterpreterSimulator >> localSP [ ^localSP ] -{ #category : #testing } -StackInterpreterSimulator >> logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart [ - "Verify a questionable interpreter against a successful run" - "self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' " - - | logFile rightWord prevCtxt | - logFile := (FileStream readOnlyFileNamed: fileName) binary. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - prevCtxt := 0. prevCtxt := prevCtxt. - [byteCount < nBytes] whileTrue: - [ -" -byteCount > 14560 ifTrue: -[self externalizeIPandSP. -prevCtxt = activeContext ifFalse: - [prevCtxt := activeContext. - transcript cr; nextPutAll: (self printTop: 2); endEntry]. -transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space; - print: (instructionPointer - method - (BaseHeaderSize - 2)); - nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space; - nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space; - print: (self stackPointerIndex - TempFrameStart + 1); endEntry. -byteCount = 14590 ifTrue: [self halt]]. -" - loggingStart >= byteCount ifTrue: - [rightWord := logFile nextWord. - currentBytecode = rightWord ifFalse: - [self halt: 'halt at ', byteCount printString]]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount]. - self externalizeIPandSP. - logFile close. - self inform: nBytes printString , ' bytecodes verfied.' -] - -{ #category : #testing } -StackInterpreterSimulator >> logOfBytesWrite: nBytes toFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfBytesWrite: 10000 toFileNamed: 'clone32Bytecodes.log' " - - | logFile | - logFile := (FileStream newFileNamed: fileName) binary. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - [byteCount < nBytes] whileTrue: - [byteCount >= loggingStart ifTrue: - [logFile nextWordPut: currentBytecode]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount]. - self externalizeIPandSP. - logFile close -] - -{ #category : #testing } -StackInterpreterSimulator >> logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' " - - | logFile priorFrame rightSelector prevCtxt | - logFile := FileStream readOnlyFileNamed: fileName. - transcript clear. - byteCount := 0. - sendCount := 0. - priorFrame := localFP. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - prevCtxt := 0. prevCtxt := prevCtxt. - [sendCount < nSends] whileTrue: - [ -" -byteCount>500 ifTrue: -[byteCount>550 ifTrue: [self halt]. -self externalizeIPandSP. -prevCtxt = localFP ifFalse: - [prevCtxt := localFP. - transcript cr; nextPutAll: (self printTop: 2); endEntry]. -transcript cr; print: byteCount; nextPutAll: ': ' , (localFP hex); space; - print: (instructionPointer - method - (BaseHeaderSize - 2)); - nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space; - nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space; - print: (self stackPointerIndex - TempFrameStart + 1); endEntry. -]. -" - self dispatchOn: currentBytecode in: BytecodeTable. - localFP = priorFrame ifFalse: - [sendCount := sendCount + 1. - loggingStart >= sendCount ifTrue: - [rightSelector := logFile nextLine. - (self stringOf: messageSelector) = rightSelector ifFalse: - [self halt: 'halt at ', sendCount printString]]. - priorFrame := localFP]. - self incrementByteCount]. - self externalizeIPandSP. - logFile close. - self inform: nSends printString , ' sends verfied.' -] - -{ #category : #testing } -StackInterpreterSimulator >> logOfSendsWrite: nSends toFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' " - - | logFile priorFrame | - logFile := FileStream newFileNamed: fileName. - transcript clear. - byteCount := 0. - sendCount := 0. - priorFrame := localFP. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - [sendCount < nSends] whileTrue: - [self dispatchOn: currentBytecode in: BytecodeTable. - localFP = priorFrame ifFalse: - [sendCount >= loggingStart ifTrue: - [sendCount := sendCount + 1. - logFile nextPutAll: (self stringOf: messageSelector); cr]. - priorFrame := localFP]. - self incrementByteCount]. - self externalizeIPandSP. - logFile close -] - { #category : #'memory access' } StackInterpreterSimulator >> longAt: byteAddress [ self deprecated. diff --git a/smalltalksrc/VMMaker/StackMTInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackMTInterpreterSimulator.class.st index 5a0f0113ad..041458b36a 100644 --- a/smalltalksrc/VMMaker/StackMTInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackMTInterpreterSimulator.class.st @@ -1223,145 +1223,6 @@ StackMTInterpreterSimulator >> localSP [ ^localSP ] -{ #category : #testing } -StackMTInterpreterSimulator >> logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart [ - "Verify a questionable interpreter against a successful run" - "self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' " - - | logFile rightWord prevCtxt | - logFile := (FileStream readOnlyFileNamed: fileName) binary. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - prevCtxt := 0. prevCtxt := prevCtxt. - [byteCount < nBytes] whileTrue: - [ -" -byteCount > 14560 ifTrue: -[self externalizeIPandSP. -prevCtxt = activeContext ifFalse: - [prevCtxt := activeContext. - transcript cr; nextPutAll: (self printTop: 2); endEntry]. -transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space; - print: (instructionPointer - method - (BaseHeaderSize - 2)); - nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space; - nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space; - print: (self stackPointerIndex - TempFrameStart + 1); endEntry. -byteCount = 14590 ifTrue: [self halt]]. -" - loggingStart >= byteCount ifTrue: - [rightWord := logFile nextWord. - currentBytecode = rightWord ifFalse: - [self halt: 'halt at ', byteCount printString]]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount]. - self externalizeIPandSP. - logFile close. - self inform: nBytes printString , ' bytecodes verfied.' -] - -{ #category : #testing } -StackMTInterpreterSimulator >> logOfBytesWrite: nBytes toFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfBytesWrite: 10000 toFileNamed: 'clone32Bytecodes.log' " - - | logFile | - logFile := (FileStream newFileNamed: fileName) binary. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - [byteCount < nBytes] whileTrue: - [byteCount >= loggingStart ifTrue: - [logFile nextWordPut: currentBytecode]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount]. - self externalizeIPandSP. - logFile close -] - -{ #category : #testing } -StackMTInterpreterSimulator >> logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' " - - | logFile priorFrame rightSelector prevCtxt | - logFile := FileStream readOnlyFileNamed: fileName. - transcript clear. - byteCount := 0. - sendCount := 0. - priorFrame := localFP. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - prevCtxt := 0. prevCtxt := prevCtxt. - [sendCount < nSends] whileTrue: - [ -" -byteCount>500 ifTrue: -[byteCount>550 ifTrue: [self halt]. -self externalizeIPandSP. -prevCtxt = localFP ifFalse: - [prevCtxt := localFP. - transcript cr; nextPutAll: (self printTop: 2); endEntry]. -transcript cr; print: byteCount; nextPutAll: ': ' , (localFP hex); space; - print: (instructionPointer - method - (BaseHeaderSize - 2)); - nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space; - nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space; - print: (self stackPointerIndex - TempFrameStart + 1); endEntry. -]. -" - self dispatchOn: currentBytecode in: BytecodeTable. - localFP = priorFrame ifFalse: - [sendCount := sendCount + 1. - loggingStart >= sendCount ifTrue: - [rightSelector := logFile nextLine. - (self stringOf: messageSelector) = rightSelector ifFalse: - [self halt: 'halt at ', sendCount printString]]. - priorFrame := localFP]. - self incrementByteCount]. - self externalizeIPandSP. - logFile close. - self inform: nSends printString , ' sends verfied.' -] - -{ #category : #testing } -StackMTInterpreterSimulator >> logOfSendsWrite: nSends toFileNamed: fileName fromStart: loggingStart [ - "Write a log file for testing a flaky interpreter on the same image" - "self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' " - - | logFile priorFrame | - logFile := FileStream newFileNamed: fileName. - transcript clear. - byteCount := 0. - sendCount := 0. - priorFrame := localFP. - quitBlock := [^self close]. - self initStackPages. - self loadInitialContext. - self internalizeIPandSP. - self fetchNextBytecode. - [sendCount < nSends] whileTrue: - [self dispatchOn: currentBytecode in: BytecodeTable. - localFP = priorFrame ifFalse: - [sendCount >= loggingStart ifTrue: - [sendCount := sendCount + 1. - logFile nextPutAll: (self stringOf: messageSelector); cr]. - priorFrame := localFP]. - self incrementByteCount]. - self externalizeIPandSP. - logFile close -] - { #category : #'memory access' } StackMTInterpreterSimulator >> longAt: byteAddress [ self deprecated. From 1c75b7f6e7efd5ad86d43836a9709111dda51160 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 22:44:29 +0200 Subject: [PATCH 07/75] Wrap sends with externalizations/externalizations --- .../MockLocalizationInterpreterMock.class.st | 10 ++- .../SlangLocalizationTestCase.class.st | 74 +++++++++++++++-- smalltalksrc/Slang/CCodeGenerator.class.st | 2 +- smalltalksrc/Slang/TMethod.class.st | 82 +++++++++++++------ smalltalksrc/Slang/TStmtListNode.class.st | 14 ++++ 5 files changed, 147 insertions(+), 35 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 95f55f1b25..719dde1001 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -46,7 +46,8 @@ MockLocalizationInterpreterMock >> bytecodeToInline [ { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingAutoLocalizedVariable [ - autoLocalizedVariable := 17 + autoLocalizedVariable := 17. + self nonInlinedMethodUsingAutolocalizedVariable ] { #category : #'interpreter shell' } @@ -86,3 +87,10 @@ MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ sharedVariableToLocalize := 17 ] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable [ + + + ^ autoLocalizedVariable +] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 387b8af5b1..876ed310cb 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -4,6 +4,22 @@ Class { #category : #'Slang-Tests' } +{ #category : #tests } +SlangLocalizationTestCase >> externalizationOf: aVariableName [ + + ^ (TAssignmentNode + variableNamed: aVariableName + expression: (TVariableNode named: #local_, aVariableName)) +] + +{ #category : #tests } +SlangLocalizationTestCase >> internalizationOf: aVariableName [ + + ^ (TAssignmentNode + variableNamed: #local_, aVariableName + expression: (TVariableNode named: aVariableName)) +] + { #category : #tests } SlangLocalizationTestCase >> setUp [ @@ -11,6 +27,31 @@ SlangLocalizationTestCase >> setUp [ MockLocalizationInterpreterMock initialize. ] +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableAppendsInternalizationToSends [ + + | interpretMethod case | + MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Fail if we find some node inside the case that uses the localized variable" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + case statements do: [ :statement | + statement nodesWithParentsDo: [ :node :parent | + node isSend ifTrue: [ | statementAfter | + statementAfter := parent children after: node. + self + assert: statementAfter + equals: (self internalizationOf: #autoLocalizedVariable) ] ] + ]. +] + { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ @@ -36,9 +77,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ self assert: internalizationStatement - equals: (TAssignmentNode - variableNamed: #autoLocalizedVariable - expression: (TVariableNode named: #local_autoLocalizedVariable)) + equals: (self externalizationOf: #autoLocalizedVariable) ] { #category : #tests } @@ -54,9 +93,32 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning self assert: internalizationStatement - equals: (TAssignmentNode - variableNamed: #local_autoLocalizedVariable - expression: (TVariableNode named: #autoLocalizedVariable)) + equals: (self internalizationOf: #autoLocalizedVariable) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariablePrependsExternalizationToSends [ + + | interpretMethod case | + MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Fail if we find some node inside the case that uses the localized variable" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + case statements do: [ :statement | + statement nodesWithParentsDo: [ :node :parent | + node isSend ifTrue: [ | statementBefore | + statementBefore := parent children before: node. + self + assert: statementBefore + equals: (self externalizationOf: #autoLocalizedVariable) ] ] + ]. ] { #category : #tests } diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 10953f7b3c..6148267d13 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3372,7 +3372,7 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ m inlineCaseStatementBranchesIn: self - withReplacementDictionary: (variablesToLocalize collect: [ :v | + withLocalizationReplacements: (variablesToLocalize collect: [ :v | v -> (TVariableNode named: #local_, v) ]) asDictionary. m parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 0e8be8e3f5..1b0aded190 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -1252,40 +1252,20 @@ TMethod >> inlineBuiltin: aSendNode in: aCodeGen [ ] { #category : #inlining } -TMethod >> inlineCaseStatementBranchesIn: aCodeGen withReplacementDictionary: replacementDictionary [ +TMethod >> inlineCaseStatementBranchesIn: aCodeGen withLocalizationReplacements: replacementDictionary [ - | exitLabel | parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ n cases do: [ :stmtNode | - | newStatements stmt meth | + | stmt meth | (stmt := stmtNode statements first) isSend ifTrue: [ (meth := aCodeGen methodNamed: stmt selector) ifNotNil: [ (meth hasUnrenamableCCode not and: [ meth args isEmpty ]) - ifTrue: [ - "We can inline!" - meth := meth copy. - meth hasReturn - ifTrue: [ - exitLabel := meth unusedLabelForInliningInto: self. - meth exitVar: nil label: exitLabel. - labels add: exitLabel ] - ifFalse: [ exitLabel := nil ]. - meth renameLabelsForInliningInto: self. - labels addAll: meth labels. - newStatements := stmtNode statements asOrderedCollection - allButFirst. - exitLabel ifNotNil: [ - newStatements addFirst: - (TLabeledCommentNode new - setLabel: exitLabel - comment: 'end case') ]. - newStatements - addFirst: meth asInlineNode; - addFirst: (TLabeledCommentNode new setComment: meth selector). - stmtNode setStatements: newStatements. - stmtNode bindVariablesIn: replacementDictionary. - ] ] ] ] ] ] + ifTrue: [ + self + inlineMethod: meth copy + inCaseStatement: stmtNode + withLocalizationReplacements: replacementDictionary ] ] ] ] ] ] ] { #category : #inlining } @@ -1411,6 +1391,54 @@ TMethod >> inlineGuardingConditional: aSendNode in: aCodeGen [ [replacementTree statements, {evaluateLabel}, aSendNode args first statements, {skipLabel}]) ] +{ #category : #inlining } +TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacements: replacementDictionary [ + + | exitLabel newStatements externalizations sendReplacements internalizations | + + "Perform the main inlining" + meth hasReturn + ifTrue: [ + exitLabel := meth unusedLabelForInliningInto: self. + meth exitVar: nil label: exitLabel. + labels add: exitLabel ] + ifFalse: [ exitLabel := nil ]. + meth renameLabelsForInliningInto: self. + labels addAll: meth labels. + + newStatements := stmtNode statements asOrderedCollection allButFirst. + exitLabel ifNotNil: [ + newStatements addFirst: + (TLabeledCommentNode new setLabel: exitLabel comment: 'end case') ]. + newStatements + addFirst: meth asInlineNode; + addFirst: (TLabeledCommentNode new setComment: meth selector). + + stmtNode setStatements: newStatements. + + "Replace all localized variables by their localized versions" + stmtNode bindVariablesIn: replacementDictionary. + + "Wrap sends with externalization/internalization statements" + sendReplacements := Dictionary new. + stmtNode nodesDo: [ :node | + node isSend ifTrue: [ + externalizations := replacementDictionary associations collect: [ + :globalToLocalAssociation | + TAssignmentNode + variableNamed: globalToLocalAssociation key + expression: globalToLocalAssociation value ]. + internalizations := replacementDictionary associations collect: [ + :globalToLocalAssociation | + TAssignmentNode + variableNamed: globalToLocalAssociation value name + expression: (TVariableNode named: globalToLocalAssociation key) ]. + sendReplacements + at: node + put: (TStmtListNode statements: externalizations , { node }, internalizations) ] ]. + ^ stmtNode replaceNodesIn: sendReplacements +] + { #category : #inlining } TMethod >> inlineReturningConditional: aSendNode in: aCodeGen [ "Inline diff --git a/smalltalksrc/Slang/TStmtListNode.class.st b/smalltalksrc/Slang/TStmtListNode.class.st index 3c5486be50..d2464d7530 100644 --- a/smalltalksrc/Slang/TStmtListNode.class.st +++ b/smalltalksrc/Slang/TStmtListNode.class.st @@ -8,6 +8,14 @@ Class { #category : #'Slang-AST' } +{ #category : #accessing } +TStmtListNode class >> statements: statements [ + + ^ self new + setStatements: statements; + yourself +] + { #category : #utilities } TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ "Add any variables in variables that are read before written to readBeforeAssigned. @@ -126,6 +134,12 @@ TStmtListNode >> bindVariablesIn: aDictionary [ statements := statements collect: [ :s | s bindVariablesIn: aDictionary ]. ] +{ #category : #enumerating } +TStmtListNode >> children [ + + ^ statements +] + { #category : #transformations } TStmtListNode >> copyWithoutReturn [ self assert: self endsWithReturn. From 76c1b6a0557f4ea3438d436f9038d6629819c7b7 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 14 Sep 2021 23:39:48 +0200 Subject: [PATCH 08/75] Simplify tests and make them more robust --- .../MockLocalizationInterpreterMock.class.st | 16 ++++++ .../SlangLocalizationTestCase.class.st | 49 ++++++++----------- 2 files changed, 37 insertions(+), 28 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 719dde1001..3472b20901 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -37,6 +37,16 @@ MockLocalizationInterpreterMock class >> initializeWithAutoLocalizedVariableOnly ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalizedVariableOnly [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingExternalizedAutoLocalizedVariable) + ) +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeToInline [ @@ -46,6 +56,12 @@ MockLocalizationInterpreterMock >> bytecodeToInline [ { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingAutoLocalizedVariable [ + autoLocalizedVariable := 17 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariable [ + autoLocalizedVariable := 17. self nonInlinedMethodUsingAutolocalizedVariable ] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 876ed310cb..8bc6708190 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -30,8 +30,8 @@ SlangLocalizationTestCase >> setUp [ { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableAppendsInternalizationToSends [ - | interpretMethod case | - MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + | interpretMethod case inlinedMethod sendStatementList | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableOnly. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -39,17 +39,13 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableAppendsInternalizationToSen ccg inlineDispatchesInMethodNamed: #interpret. - "Fail if we find some node inside the case that uses the localized variable" + "Assert that the send node is preceded by variable externalization" interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. - case statements do: [ :statement | - statement nodesWithParentsDo: [ :node :parent | - node isSend ifTrue: [ | statementAfter | - statementAfter := parent children after: node. - self - assert: statementAfter - equals: (self internalizationOf: #autoLocalizedVariable) ] ] - ]. + inlinedMethod := case statements second method. + sendStatementList := inlinedMethod statements second statements. + self assert: sendStatementList second isSend. + self assert: sendStatementList third equals: (self internalizationOf: #autoLocalizedVariable) ] { #category : #tests } @@ -99,8 +95,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariablePrependsExternalizationToSends [ - | interpretMethod case | - MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + | interpretMethod case inlinedMethod sendStatementList | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableOnly. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -108,24 +104,20 @@ SlangLocalizationTestCase >> testAutoLocalizeVariablePrependsExternalizationToSe ccg inlineDispatchesInMethodNamed: #interpret. - "Fail if we find some node inside the case that uses the localized variable" + "Assert that the send node is preceded by variable externalization" interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. - case statements do: [ :statement | - statement nodesWithParentsDo: [ :node :parent | - node isSend ifTrue: [ | statementBefore | - statementBefore := parent children before: node. - self - assert: statementBefore - equals: (self externalizationOf: #autoLocalizedVariable) ] ] - ]. + inlinedMethod := case statements second method. + sendStatementList := inlinedMethod statements second statements. + self assert: sendStatementList second isSend. + self assert: sendStatementList first equals: (self externalizationOf: #autoLocalizedVariable) ] { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod | + | interpretMethod variableNode case | MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. @@ -134,11 +126,9 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ "Fail if we find some node inside the case that uses the localized variable" interpretMethod := ccg methodNamed: #interpret. - interpretMethod statements second cases do: [ :e | - e nodesDo: [ :node | - (node isVariable and: [ node name = #autoLocalizedVariable ]) - ifTrue: [ self fail ] ] - ]. + case := interpretMethod statements second cases first. + variableNode := case statements second method statements first variable. + self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). ] { #category : #tests } @@ -163,7 +153,9 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUse ccg addClass: MockLocalizationInterpreterMock. ccg retainMethods: #( interpret ). ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. ccg pruneUnreachableMethods. + "This should not fail" [ ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret). @@ -182,6 +174,7 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAre ccg retainMethods: #( interpret ). ccg prepareMethods. ccg doBasicInlining: true. + ccg inlineDispatchesInMethodNamed: #interpret. ccg pruneUnreachableMethods. "This should not fail" From 0d9e99f69d6c2ec3e9defd5023f510d9f154cff9 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 21 Sep 2021 09:58:57 +0200 Subject: [PATCH 09/75] Rename args=>arguments --- smalltalksrc/Slang/TMethod.class.st | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 1b0aded190..84d7555958 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -933,18 +933,20 @@ TMethod >> extractExportDirective [ { #category : #'inlining support' } TMethod >> extractInlineDirective [ + "Scan the pragmas (or top-level statements) for an inlining directive of the form: Answer a boolean equivalent to the argument of the directive or #dontCare if there is no inlining directive." - sharedCase ifNotNil: [^false]. "don't auto-inline shared code; it gets handled specially" - ^self - extractDirective: #inline: - valueBlock: - [:sendNode| #(true always) includes: (inline := sendNode args first value)] - default: #dontCare + sharedCase ifNotNil: [ ^ false ]. "don't auto-inline shared code; it gets handled specially" + ^ self + extractDirective: #inline: + valueBlock: [ :sendNode | + #( true always ) includes: + (inline := sendNode arguments first value) ] + default: #dontCare ] { #category : #transformations } From d9efe620fde8700ee986076b580b7cf80ab5a31b Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Fri, 24 Sep 2021 16:01:16 +0200 Subject: [PATCH 10/75] Adding external send node --- .../MockLocalizationInterpreterMock.class.st | 16 ++++++ .../SlangLocalizationTestCase.class.st | 55 ++++++------------- smalltalksrc/Slang/TExternalSendNode.class.st | 15 +++++ smalltalksrc/Slang/TMethod.class.st | 14 +---- smalltalksrc/Slang/TParseNode.class.st | 6 ++ 5 files changed, 56 insertions(+), 50 deletions(-) create mode 100644 smalltalksrc/Slang/TExternalSendNode.class.st diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 3472b20901..fd967325c3 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -37,6 +37,16 @@ MockLocalizationInterpreterMock class >> initializeWithAutoLocalizedVariableOnly ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalizedVariableInExpressionOnly [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingExternalizedAutoLocalizedVariableAsExpression) + ) +] + { #category : #initialization } MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalizedVariableOnly [ @@ -66,6 +76,12 @@ MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariabl self nonInlinedMethodUsingAutolocalizedVariable ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariableAsExpression [ + + self foo: self nonInlinedMethodUsingAutolocalizedVariable +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 8bc6708190..50cc4ea8fd 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -27,27 +27,6 @@ SlangLocalizationTestCase >> setUp [ MockLocalizationInterpreterMock initialize. ] -{ #category : #tests } -SlangLocalizationTestCase >> testAutoLocalizeVariableAppendsInternalizationToSends [ - - | interpretMethod case inlinedMethod sendStatementList | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableOnly. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpret. - - - "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - sendStatementList := inlinedMethod statements second statements. - self assert: sendStatementList second isSend. - self assert: sendStatementList third equals: (self internalizationOf: #autoLocalizedVariable) -] - { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ @@ -93,42 +72,42 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning ] { #category : #tests } -SlangLocalizationTestCase >> testAutoLocalizeVariablePrependsExternalizationToSends [ - - | interpretMethod case inlinedMethod sendStatementList | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableOnly. - ccg addClass: MockLocalizationInterpreterMock. +SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + | interpretMethod variableNode case | + MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. ccg inlineDispatchesInMethodNamed: #interpret. - "Assert that the send node is preceded by variable externalization" + "Fail if we find some node inside the case that uses the localized variable" interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - sendStatementList := inlinedMethod statements second statements. - self assert: sendStatementList second isSend. - self assert: sendStatementList first equals: (self externalizationOf: #autoLocalizedVariable) + variableNode := case statements second method statements first variable. + + self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). ] { #category : #tests } -SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ +SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendNodes [ - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod variableNode case | - MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. + | interpretMethod case inlinedMethod | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. ccg inlineDispatchesInMethodNamed: #interpret. - "Fail if we find some node inside the case that uses the localized variable" + "Assert that the send node is preceded by variable externalization" interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. - variableNode := case statements second method statements first variable. - self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). + inlinedMethod := case statements second method. + + self assert: inlinedMethod statements first isExternalSend ] { #category : #tests } diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st new file mode 100644 index 0000000000..197b318014 --- /dev/null +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -0,0 +1,15 @@ +Class { + #name : #TExternalSendNode, + #superclass : #TParseNode, + #instVars : [ + 'sendNode', + 'variableBindings' + ], + #category : #'Slang-AST' +} + +{ #category : #accessing } +TExternalSendNode >> variableBindings: aCollection [ + + variableBindings := aCollection +] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 84d7555958..c2a8c24002 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -1396,7 +1396,7 @@ TMethod >> inlineGuardingConditional: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacements: replacementDictionary [ - | exitLabel newStatements externalizations sendReplacements internalizations | + | exitLabel newStatements sendReplacements | "Perform the main inlining" meth hasReturn @@ -1425,19 +1425,9 @@ TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacem sendReplacements := Dictionary new. stmtNode nodesDo: [ :node | node isSend ifTrue: [ - externalizations := replacementDictionary associations collect: [ - :globalToLocalAssociation | - TAssignmentNode - variableNamed: globalToLocalAssociation key - expression: globalToLocalAssociation value ]. - internalizations := replacementDictionary associations collect: [ - :globalToLocalAssociation | - TAssignmentNode - variableNamed: globalToLocalAssociation value name - expression: (TVariableNode named: globalToLocalAssociation key) ]. sendReplacements at: node - put: (TStmtListNode statements: externalizations , { node }, internalizations) ] ]. + put: (TExternalSendNode send: node variableBindings: replacementDictionary) ] ]. ^ stmtNode replaceNodesIn: sendReplacements ] diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index 28d72800e2..e75f47c813 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -245,6 +245,12 @@ TParseNode >> isDefine [ ^false ] +{ #category : #testing } +TParseNode >> isExternalSend [ + + ^ false +] + { #category : #testing } TParseNode >> isGoTo [ From 9ab71f2c1de061428c9d74f76cb6cc37f0ef39ae Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Fri, 24 Sep 2021 16:14:37 +0200 Subject: [PATCH 11/75] Finish Merge --- smalltalksrc/Slang/CCodeGenerator.class.st | 2 +- smalltalksrc/VMMaker/InterpreterPrimitives.class.st | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index ee1fb88bcc..4a8dcaaada 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3671,7 +3671,7 @@ CCodeGenerator >> localizeGlobalVariables [ (localized at: name) do: [:var| logger newLine; show: var, ' localised to ', name; cr]]]. - elected do: [:ea| (variables includes: ea) ifTrue: [self checkDeleteVariable: ea]]. + variables removeAllFoundIn: elected ] diff --git a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st index 0014295d61..dc43613f2b 100644 --- a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st +++ b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st @@ -62,7 +62,7 @@ secHasEnvironmentAccess " Class { #name : #InterpreterPrimitives, - #superclass : #VMClass, + #superclass : #AbstractInterpreter, #instVars : [ 'objectMemory', 'messageSelector', @@ -290,7 +290,7 @@ InterpreterPrimitives >> initPrimCall [ { #category : #initialization } InterpreterPrimitives >> initialize [ "Here we can initialize the variables C initializes to zero. #initialize methods do /not/ get translated." - argumentCount := primFailCode := nextProfileTick := osErrorCode := exceptionPC := inFFIFlags := ffiExceptionResponse := 0. + argumentCount := primFailCode := nextProfileTick := osErrorCode := exceptionPC := ffiExceptionResponse := 0. newFinalization := false ] From 7b856e3ad020c6598cfde3bdbc8a2c07caab23be Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Fri, 24 Sep 2021 17:33:12 +0200 Subject: [PATCH 12/75] Handling linearization of calls, name conflicts when extracting arguments to locals --- .../MockLocalizationInterpreterMock.class.st | 26 +++ .../SlangLocalizationTestCase.class.st | 191 +++++++++++++++++- smalltalksrc/Slang/CCodeGenerator.class.st | 33 ++- smalltalksrc/Slang/TExternalSendNode.class.st | 78 ++++++- smalltalksrc/Slang/TMethod.class.st | 19 ++ 5 files changed, 343 insertions(+), 4 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index fd967325c3..9037d79660 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -37,6 +37,16 @@ MockLocalizationInterpreterMock class >> initializeWithAutoLocalizedVariableOnly ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithEscapingCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeWithEscapingCall) + ) +] + { #category : #initialization } MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalizedVariableInExpressionOnly [ @@ -101,6 +111,12 @@ MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariableBeforeInl self methodAlsoSharedLocalizedVariableBeforeInlining ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeWithEscapingCall [ + + self foo: (autoLocalizedVariable := autoLocalizedVariable + 1) +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> interpret [ @@ -108,6 +124,16 @@ MockLocalizationInterpreterMock >> interpret [ self dispatchOn: 1 in: BytecodeTable ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> interpretWithConflict [ + + "This method should create a conflict with automatically inlined arguments" + | arg1 | + + + self dispatchOn: 1 in: BytecodeTable +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> methodAlsoSharedLocalizedVariableBeforeInlining [ diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 50cc4ea8fd..514bdc543c 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -107,7 +107,196 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendN case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - self assert: inlinedMethod statements first isExternalSend + self assert: inlinedMethod statements first statements last isExternalSend +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ + + | interpretMethod case inlinedMethod externalCall cast printedString | + MockLocalizationInterpreterMock initializeWithEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + externalCall := inlinedMethod statements first. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ + arg1 = (local_autoLocalizedVariable += 1); + { + autoLocalizedVariable = local_autoLocalizedVariable; + foo(arg1); + local_autoLocalizedVariable = autoLocalizedVariable; + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndInternalize [ + + | interpretMethod case inlinedMethod | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + self assert: (inlinedMethod statements first statements last localizedVariables includes: #autoLocalizedVariable) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ + + | interpretMethod case inlinedMethod externalCall cast printedString | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + externalCall := inlinedMethod statements first. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ + arg1 = nonInlinedMethodUsingAutolocalizedVariable(); + { + autoLocalizedVariable = local_autoLocalizedVariable; + foo(arg1); + local_autoLocalizedVariable = autoLocalizedVariable; + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testLinearizationOfExternalCalls [ + + | interpretMethod case inlinedMethod externalCall argumentStatement replacementBlock | + MockLocalizationInterpreterMock initializeWithEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + replacementBlock := inlinedMethod statements first. + argumentStatement := replacementBlock statements first. + externalCall := replacementBlock statements second. + + self assert: externalCall wrappedSendNode arguments first equals: argumentStatement variable. + self + assert: argumentStatement expression + equals: (TAssignmentNode + variableNamed: 'local_autoLocalizedVariable' + expression:(TSendNode + receiver: (TVariableNode named: 'local_autoLocalizedVariable') + selector: #+ + arguments: { TConstantNode value: 1 } )) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testLinearizationShouldBeTranslatedWithExternalizationAndInternalizations [ + + | interpretMethod case inlinedMethod externalCall cast printedString | + MockLocalizationInterpreterMock initializeWithEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + externalCall := inlinedMethod statements first. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ + arg1 = (local_autoLocalizedVariable += 1); + { + autoLocalizedVariable = local_autoLocalizedVariable; + foo(arg1); + local_autoLocalizedVariable = autoLocalizedVariable; + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testLinearizationShouldDeclareArgumentVariables [ + + | interpretMethod case inlinedMethod | + MockLocalizationInterpreterMock initializeWithEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpret. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + self assert: (interpretMethod locals includes: 'arg1') +] + +{ #category : #tests } +SlangLocalizationTestCase >> testLinearizationShouldRenameArgumentVariablesWhenConflicts [ + + | interpretMethod case inlinedMethod | + MockLocalizationInterpreterMock initializeWithEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithConflict. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpretWithConflict. + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + + "Conflicts are resolved by automatically renaming the conflicting definitions with a suffix underscore" + self assert: (interpretMethod locals includes: 'arg1_') ] { #category : #tests } diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 4a8dcaaada..26736c6b8c 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3387,12 +3387,15 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ inlineCaseStatementBranchesIn: self withLocalizationReplacements: (variablesToLocalize collect: [ :v | v -> (TVariableNode named: #local_, v) ]) asDictionary. + + self lineariseExternalCallsIn: m. + m parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ n customizeShortCasesForDispatchVar: 'currentBytecode' in: self - method: m ] ] + method: m ] ]. ] { #category : #utilities } @@ -3630,6 +3633,34 @@ CCodeGenerator >> isVoidPointer: aCType [ "" ^#('void *' 'void*') includes: aCType asString ] +{ #category : #'automatic-localization' } +CCodeGenerator >> lineariseExternalCallsIn: aTMethod [ + + | replacementDictionary argumentAssignments newExternalSend | + replacementDictionary := Dictionary new. + aTMethod nodesDo: [ :e | + e isExternalSend ifTrue: [ + argumentAssignments := e wrappedSendNode arguments collectWithIndex: [ :arg :index | | variableName | + variableName := aTMethod declareNonConflictingLocalNamedLike: 'arg', index asString. + TAssignmentNode + variable: (TVariableNode named: variableName) + expression: arg. + ]. + newExternalSend := TExternalSendNode + send: (TSendNode + receiver: e wrappedSendNode receiver + selector: e wrappedSendNode selector + arguments: (argumentAssignments collect: [ :ass | ass variable ])) + variableBindings: e variableBindings. + replacementDictionary + at: e + put: (TStmtListNode statements: argumentAssignments , { newExternalSend } ). + ]. + ]. + + aTMethod replaceNodesIn: replacementDictionary +] + { #category : #utilities } CCodeGenerator >> localizeGlobalVariables [ | candidates elected localized | diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 197b318014..2d3be1fc43 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -2,14 +2,88 @@ Class { #name : #TExternalSendNode, #superclass : #TParseNode, #instVars : [ - 'sendNode', - 'variableBindings' + 'variableBindings', + 'wrappedSendNode' ], #category : #'Slang-AST' } +{ #category : #'instance-creation' } +TExternalSendNode class >> send: aWrappedSendNode variableBindings: bindings [ + + ^ self new + wrappedSendNode: aWrappedSendNode; + variableBindings: bindings; + yourself +] + +{ #category : #tranforming } +TExternalSendNode >> asCASTIn: aCodeGenerator [ + + ^ CCompoundStatementNode statements: (self cExternalizationsIn: aCodeGenerator) + , { (wrappedSendNode asCASTIn: aCodeGenerator) } + , (self cInternalizationsIn: aCodeGenerator) +] + +{ #category : #'c-translation' } +TExternalSendNode >> cExternalizationsIn: codeGenerator [ + + | tAssignments | + tAssignments := OrderedCollection new. + variableBindings keysAndValuesDo: [ :global :local | + tAssignments add: (TAssignmentNode + variable: (TVariableNode named: global) + expression: (TVariableNode named: local name)) + ]. + + ^ tAssignments collect: [ :e | e asCASTIn: codeGenerator ] +] + +{ #category : #'c-translations' } +TExternalSendNode >> cInternalizationsIn: codeGenerator [ + + | tAssignments | + tAssignments := OrderedCollection new. + variableBindings keysAndValuesDo: [ :global :local | + tAssignments add: (TAssignmentNode + variable: (TVariableNode named: local name) + expression: (TVariableNode named: global)) + ]. + + ^ tAssignments collect: [ :e | e asCASTIn: codeGenerator ] +] + +{ #category : #accessing } +TExternalSendNode >> isExternalSend [ + + ^ true +] + +{ #category : #accessing } +TExternalSendNode >> localizedVariables [ + + ^ variableBindings keys +] + +{ #category : #accessing } +TExternalSendNode >> variableBindings [ + ^ variableBindings +] + { #category : #accessing } TExternalSendNode >> variableBindings: aCollection [ variableBindings := aCollection ] + +{ #category : #accessing } +TExternalSendNode >> wrappedSendNode [ + + ^ wrappedSendNode +] + +{ #category : #accessing } +TExternalSendNode >> wrappedSendNode: anObject [ + + wrappedSendNode := anObject +] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 5a16168ced..ec7ff8b3aa 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -638,6 +638,19 @@ TMethod >> declarations [ ^declarations ] +{ #category : #'automatic-localization' } +TMethod >> declareNonConflictingLocalNamedLike: aString [ + + | maybeAllocatedName | + maybeAllocatedName := aString. + [locals includes: maybeAllocatedName] + whileTrue: [ maybeAllocatedName := maybeAllocatedName, '_' ]. + + "Found a unique name, declare it and return it" + self localizeVariables: {maybeAllocatedName}. + ^ maybeAllocatedName +] + { #category : #testing } TMethod >> definedAsMacro [ ^properties notNil @@ -2009,6 +2022,12 @@ TMethod >> nodeCount [ ^cnt ] +{ #category : #iterating } +TMethod >> nodesDo: aBlock [ + + parseTree nodesDo: aBlock +] + { #category : #utilities } TMethod >> noteUsedVariableName: token [ usedVariablesCache ifNotNil: From c2b9f28678cef628238137410d328aa33f2d2e81 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Fri, 24 Sep 2021 17:38:50 +0200 Subject: [PATCH 13/75] Fixing iteration of the children of external send nodes --- .../Slang-Tests/SlangLocalizationTestCase.class.st | 4 +++- smalltalksrc/Slang/TExternalSendNode.class.st | 7 +++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 514bdc543c..b0c13eda0d 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -324,9 +324,11 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUse ccg inlineDispatchesInMethodNamed: #interpret. ccg pruneUnreachableMethods. + self assert: (ccg methodNamed: #methodAlsoSharedLocalizedVariableBeforeInlining) notNil. "This should not fail" - [ ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret). + [ + ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret). "This should not arrive here" self fail diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 2d3be1fc43..2933567744 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -65,6 +65,13 @@ TExternalSendNode >> localizedVariables [ ^ variableBindings keys ] +{ #category : #accessing } +TExternalSendNode >> nodesDo: aBlock [ + + aBlock value: wrappedSendNode. + super nodesDo: aBlock +] + { #category : #accessing } TExternalSendNode >> variableBindings [ ^ variableBindings From 45a044f11901839a0420a703ab22cd3d196151d5 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Fri, 1 Oct 2021 13:21:56 +0200 Subject: [PATCH 14/75] Experimental: - Removing the manual localization of the instruction pointer variable - This goes in the direction of automatically localizing it on demand --- .../SimulatorHarnessForTests.class.st | 2 +- smalltalksrc/VMMaker/CoInterpreter.class.st | 46 +++---- smalltalksrc/VMMaker/CogVMSimulator.class.st | 125 +----------------- .../VMMaker/SimulatorHarness.class.st | 82 ------------ .../VMMaker/StackInterpreter.class.st | 89 ++++++------- .../StackInterpreterSimulator.class.st | 94 ++----------- 6 files changed, 81 insertions(+), 357 deletions(-) delete mode 100644 smalltalksrc/VMMaker/SimulatorHarness.class.st diff --git a/smalltalksrc/VMMaker-OriginalTests/SimulatorHarnessForTests.class.st b/smalltalksrc/VMMaker-OriginalTests/SimulatorHarnessForTests.class.st index 2a8c796b6b..f9d2efa662 100644 --- a/smalltalksrc/VMMaker-OriginalTests/SimulatorHarnessForTests.class.st +++ b/smalltalksrc/VMMaker-OriginalTests/SimulatorHarnessForTests.class.st @@ -1,6 +1,6 @@ Class { #name : #SimulatorHarnessForTests, - #superclass : #SimulatorHarness, + #superclass : #Object, #instVars : [ 'simulator' ], diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index ca48a0be09..29884bef52 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -990,12 +990,12 @@ CoInterpreter >> baseFrameReturn [ self assert: (stackPages stackPageFor: theFP) = stackPage. localSP := theSP. localFP := theFP. - localIP := self pointerForOop: self internalStackTop. - localIP asUnsignedInteger < objectMemory startOfMemory ifTrue: - [localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: + instructionPointer := self pointerForOop: self internalStackTop. + instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: + [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: ["localIP in the cog method zone indicates a return to machine code." ^self returnToMachineCodeFrame]. - localIP := self pointerForOop: (self iframeSavedIP: localFP)]. + instructionPointer := self pointerForOop: (self iframeSavedIP: localFP)]. self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). self setMethod: (self iframeMethod: localFP). self internalStackTopPut: localReturnValue. @@ -2410,14 +2410,14 @@ CoInterpreter >> commonCallerReturn [ [self assert: localFP = stackPage baseFP. ^self baseFrameReturn]. - localIP := self frameCallerSavedIP: localFP. + instructionPointer := self frameCallerSavedIP: localFP. localSP := localFP + (self frameStackedReceiverOffset: localFP). localFP := callersFPOrNull. - localIP asUnsignedInteger < objectMemory startOfMemory ifTrue: - [localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: + instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: + [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: ["localIP in the cog method zone indicates a return to machine code." ^self returnToMachineCodeFrame]. - localIP := self pointerForOop: (self iframeSavedIP: localFP)]. + instructionPointer := self pointerForOop: (self iframeSavedIP: localFP)]. self setMethod: (self iframeMethod: localFP). self fetchNextBytecode. self internalStackTopPut: localReturnValue @@ -3086,8 +3086,7 @@ CoInterpreter >> externalWriteBackHeadStackPointer [ CoInterpreter >> externalizeIPandSP [ "Copy the local instruction, stack and frame pointers to global variables for use in primitives and other functions outside the interpret loop." - self assert: localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC. - instructionPointer := self oopForPointer: localIP. + self assert: instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC. stackPointer := localSP. framePointer := localFP ] @@ -3709,7 +3708,7 @@ CoInterpreter >> ifBackwardsCheckForEvents: offsetToJumpBytecode [ ifTrue: [(self methodWithHeaderShouldBeCogged: (objectMemory methodHeaderOf: method)) ifTrue: [self externalizeIPandSP. - self attemptToSwitchToMachineCode: (self oopForPointer: localIP) - offsetToJumpBytecode - method - objectMemory baseHeaderSize - 1 + self attemptToSwitchToMachineCode: (self oopForPointer: instructionPointer) - offsetToJumpBytecode - method - objectMemory baseHeaderSize - 1 "If attemptToSwitchToMachineCode: returns the method could not be cogged, hence..."]. "can't cog method; avoid asking to cog it again for the longest possible time." backwardJumpCountByte := 16r7F] @@ -3875,7 +3874,7 @@ CoInterpreter >> instVar: offset ofContext: aContext [ [self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext). ^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)]. offset = InstructionPointerIndex ifTrue: - [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: (self oopForPointer: localIP)]. + [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: (self oopForPointer: instructionPointer)]. self error: 'bad index'. ^0 ] @@ -3940,7 +3939,7 @@ CoInterpreter >> internalActivateNewMethod [ rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. - self internalPush: localIP. + self internalPush: instructionPointer. self internalPush: localFP. localFP := localSP. self internalPush: newMethod. @@ -3958,12 +3957,12 @@ CoInterpreter >> internalActivateNewMethod [ [:i | self internalPush: objectMemory nilObject]. "-1 to account for pre-increment in fetchNextBytecode" - localIP := self pointerForOop: (self initialIPForHeader: methodHeader method: newMethod) - 1. + instructionPointer := self pointerForOop: (self initialIPForHeader: methodHeader method: newMethod) - 1. (self methodHeaderHasPrimitive: methodHeader) ifTrue: ["Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts with a long store temp. Strictly no need to skip the store because it's effectively a noop." - localIP := localIP + (self sizeOfCallPrimitiveBytecode: methodHeader). + instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader). primFailCode ~= 0 ifTrue: [self reapAndResetErrorCodeTo: localSP header: methodHeader]]. @@ -4003,7 +4002,7 @@ CoInterpreter >> internalExecuteNewMethod [ ^nil]]. "if not primitive, or primitive failed, activate the method" (self methodHasCogMethod: newMethod) - ifTrue: [self iframeSavedIP: localFP put: localIP asInteger. + ifTrue: [self iframeSavedIP: localFP put: instructionPointer asInteger. instructionPointer := cogit ceReturnToInterpreterPC. self externalizeFPandSP. self activateCoggedNewMethod: true. @@ -4053,7 +4052,6 @@ CoInterpreter >> internalizeIPandSP [ "Copy the instruction, stack and frame pointers to local variables for rapid access within the interpret loop." self assert: instructionPointer ~= cogit ceReturnToInterpreterPC. - localIP := self pointerForOop: instructionPointer. localSP := self pointerForOop: stackPointer. localFP := self pointerForOop: framePointer. ] @@ -4944,11 +4942,11 @@ CoInterpreter >> maybeReturnToMachineCodeFrame [ "If the frame we're returning to is a machine code one, then return to it. Otherwise, if it's an interpreter frame, load the saved ip." - localIP asUnsignedInteger < objectMemory startOfMemory ifTrue: - [localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: + instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: + [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: ["localIP in the cog method zone indicates a return to machine code." ^self returnToMachineCodeFrame]. - localIP := self pointerForOop: (self iframeSavedIP: localFP)] + instructionPointer := self pointerForOop: (self iframeSavedIP: localFP)] ] { #category : #'debug support' } @@ -6212,14 +6210,14 @@ CoInterpreter >> returnToMachineCodeFrame [ "Return to the previous context/frame after assigning localIP, localSP and localFP." cogit assertCStackWellAligned. - self assert: localIP asUnsignedInteger < objectMemory startOfMemory. + self assert: instructionPointer asUnsignedInteger < objectMemory startOfMemory. self assert: (self isMachineCodeFrame: localFP). - self assertValidExecutionPointe: localIP asUnsignedInteger r: localFP s: localSP imbar: false line: #'__LINE__'. - self internalStackTopPut: localIP. + self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: localFP s: localSP imbar: false line: #'__LINE__'. + self internalStackTopPut: instructionPointer. self internalPush: localReturnValue. self externalizeFPandSP. self cCode: '' inSmalltalk: - [self maybeCheckStackDepth: 1 sp: stackPointer pc: localIP]. + [self maybeCheckStackDepth: 1 sp: stackPointer pc: instructionPointer]. cogit ceEnterCogCodePopReceiverReg "NOTREACHED" ] diff --git a/smalltalksrc/VMMaker/CogVMSimulator.class.st b/smalltalksrc/VMMaker/CogVMSimulator.class.st index 2e90d0c9de..242c751697 100644 --- a/smalltalksrc/VMMaker/CogVMSimulator.class.st +++ b/smalltalksrc/VMMaker/CogVMSimulator.class.st @@ -831,7 +831,7 @@ CogVMSimulator >> expectSends: anArray [ CogVMSimulator >> extABytecode [ "224 11100000 aaaaaaaa Extend A (Ext A = Ext A prev * 256 + Ext A)" (extA = 0 and: [extB = 0]) ifTrue: - [lastExtPC := localIP]. + [lastExtPC := instructionPointer]. ^super extABytecode ] @@ -839,7 +839,7 @@ CogVMSimulator >> extABytecode [ CogVMSimulator >> extBBytecode [ "225 11100001 sbbbbbbb Extend B (Ext B = Ext B prev * 256 + Ext B)" (extA = 0 and: [extB = 0]) ifTrue: - [lastExtPC := localIP]. + [lastExtPC := instructionPointer]. ^super extBBytecode ] @@ -925,7 +925,7 @@ CogVMSimulator >> externalSetStackPageAndPointersForSuspendedContextOfProcess: a { #category : #'interpreter shell' } CogVMSimulator >> fetchByte [ - ^objectMemory byteAt: (localIP := localIP + 1) + ^objectMemory byteAt: (instructionPointer := instructionPointer + 1) ] { #category : #'interpreter access' } @@ -1367,7 +1367,7 @@ CogVMSimulator >> interpret [ atEachStepBlock value. "N.B. may be nil" self dispatchOn: currentBytecode in: BytecodeTable. self incrementByteCount]. - localIP := localIP - 1. "undo the pre-increment of IP before returning" + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP. ^nil @@ -1686,11 +1686,6 @@ CogVMSimulator >> loadNewPlugin: pluginString [ entry] ] -{ #category : #accessing } -CogVMSimulator >> localIP [ - ^localIP -] - { #category : #'debugging traps' } CogVMSimulator >> logSend: oop [ sendCount := sendCount + 1. @@ -2317,7 +2312,7 @@ CogVMSimulator >> printChar: aByte [ CogVMSimulator >> printCurrentBytecodeOn: aStream [ | code | code := currentBytecode radix: 16. - aStream newLine; print: localIP - method - 3; tab. + aStream newLine; print: instructionPointer - method - 3; tab. bytecodeSetSelector > 0 ifTrue: [aStream nextPutAll: 'ALT ']. aStream @@ -2886,116 +2881,6 @@ CogVMSimulator >> updateStateOfSpouseContextForFrame: theFP WithSP: theSP [ ^super updateStateOfSpouseContextForFrame: theFP WithSP: theSP ] -{ #category : #UI } -CogVMSimulator >> utilitiesMenu: aMenuMorph [ - aMenuMorph - add: 'toggle transcript' action: #toggleTranscript; - add: 'clone VM' action: #cloneSimulationWindow; - addLine; - add: 'print ext head frame' action: #printExternalHeadFrame; - add: 'print int head frame' action: #printHeadFrame; - add: 'print mc/cog head frame' action: [self printFrame: cogit processor fp WithSP: cogit processor sp]; - add: 'short print ext head frame & callers' action: [self shortPrintFrameAndCallers: framePointer]; - add: 'short print int head frame & callers' action: [self shortPrintFrameAndCallers: localFP]; - add: 'short print mc/cog head frame & callers' action: [self shortPrintFrameAndCallers: cogit processor fp]; - add: 'long print ext head frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer]; - add: 'long print int head frame & callers' action: [self printFrameAndCallers: localFP SP: localSP]; - add: 'long print mc/cog head frame & callers' action: [self printFrameAndCallers: cogit processor fp SP: cogit processor sp]; - add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]]; - add: 'print call stack' action: #printCallStack; - add: 'print stack call stack' action: #printStackCallStack; - add: 'print stack call stack of...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printStackCallStackOf: fp]]; - add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]]; - add: 'print call stack of frame...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printCallStackFP: fp]]; - add: 'print all stacks' action: #printAllStacks; - add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP. - self writeBackHeadFramePointers]; - add: 'write back mc ptrs' action: [stackPointer := cogit processor sp. framePointer := cogit processor fp. instructionPointer := cogit processor pc. - self externalWriteBackHeadFramePointers]; - addLine; - add: 'print rump C stack' action: [objectMemory printMemoryFrom: cogit processor sp to: cogit getCStackPointer]; - add: 'print registers' action: [cogit processor printRegistersOn: transcript]; - add: 'print register map' action: [cogit printRegisterMapOn: transcript]; - add: 'disassemble method/trampoline...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit disassembleCodeAt: pc]]; - add: 'disassemble method/trampoline at pc' action: - [cogit disassembleCodeAt: (((cogit codeEntryFor: cogit processor pc) isNil - and: [(cogit methodZone methodFor: cogit processor pc) = 0]) - ifTrue: [instructionPointer] - ifFalse: [cogit processor pc])]; - add: 'disassemble ext head frame method' action: [cogit disassembleMethod: (self frameMethod: framePointer)]; - add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]]; - add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]]; - add: 'print context...' action: [(self promptHex: 'print context') ifNotNil: [:oop| self printContext: oop]]; - add: 'symbolic method...' action: [(self promptHex: 'method bytecodes') ifNotNil: [:oop| self symbolicMethod: oop]]; - addLine; - add: 'inspect object memory' target: objectMemory action: #inspect; - add: 'run leak checker' action: [Cursor execute showWhile: [self runLeakChecker]]; - add: 'inspect cointerpreter' action: #inspect; - add: 'inspect cogit' target: cogit action: #inspect; - add: 'inspect method zone' target: cogit methodZone action: #inspect. - - aMenuMorph - addLine; - add: 'print cog methods' target: cogMethodZone action: #printCogMethods; - add: 'print cog methods with prim...' action: - [(self promptNum: 'prim index') ifNotNil: [:pix| cogMethodZone printCogMethodsWithPrimitive: pix]]; - add: 'print cog methods with selector...' action: - [|s| s := UIManager default request: 'selector'. - s notEmpty ifTrue: - [s = 'nil' ifTrue: [s := nil]. - cogMethodZone methodsDo: - [:m| - (s ifNil: [m selector = objectMemory nilObject] - ifNotNil: [(objectMemory numBytesOf: m selector) = s size - and: [(self strncmp: s - _: (m selector + objectMemory baseHeaderSize) - _: (objectMemory numBytesOf: m selector)) = 0]]) ifTrue: - [cogit printCogMethod: m]]]]; - add: 'print cog methods with method...' action: - [(self promptHex: 'method') ifNotNil: [:methodOop| cogMethodZone printCogMethodsWithMethod: methodOop]]; - add: 'print cog method for...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit printCogMethodFor: pc]]; - add: 'print cog method header for...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit printCogMethodHeaderFor: pc]]; - add: 'print trampoline table' target: cogit action: #printTrampolineTable; - add: 'print prim trace log' action: #dumpPrimTraceLog; - add: 'report recent instructions' target: cogit action: #reportLastNInstructions; - add: (cogit printRegisters - ifTrue: ['no print registers each instruction'] - ifFalse: ['print registers each instruction']) - action: [cogit printRegisters: cogit printRegisters not]; - add: (cogit printInstructions - ifTrue: ['no print instructions each instruction'] - ifFalse: ['print instructions each instruction']) - action: [cogit printInstructions: cogit printInstructions not]; - addLine; - add: (cogit singleStep - ifTrue: ['no single step'] - ifFalse: ['single step']) - action: [cogit singleStep: cogit singleStep not]; - add: 'click step' action: [cogit setClickStepBreakBlock]; - add: 'set break pc', cogit breakPC menuPrompt, '...-ve to disable or remove' action: [cogit promptForBreakPC]; - add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'. - s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]]; - add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector (MNU:foo for MNU)'. - s notEmpty ifTrue: - [(s size > 4 and: [s beginsWith: 'MNU:']) - ifTrue: [self setBreakMNUSelector: (s allButFirst: 4)] - ifFalse: [self setBreakSelector: s]]]; - add: 'set break block...' action: [|s| s := UIManager default request: 'break block' initialAnswer: '[:theCogit| false]'. - s notEmpty ifTrue: [self setBreakBlockFromString: s]]; - add: 'set cogit break method...' action: [(self promptHex: 'cogit breakMethod') ifNotNil: [:bm| cogit setBreakMethod: bm]]; - add: (printBytecodeAtEachStep - ifTrue: ['no print bytecode each bytecode'] - ifFalse: ['print bytecode each bytecode']) - action: [self ensureDebugAtEachStepBlock. - printBytecodeAtEachStep := printBytecodeAtEachStep not]; - add: (printFrameAtEachStep - ifTrue: ['no print frame each bytecode'] - ifFalse: ['print frame each bytecode']) - action: [self ensureDebugAtEachStepBlock. - printFrameAtEachStep := printFrameAtEachStep not]. - ^aMenuMorph -] - { #category : #'debug support' } CogVMSimulator >> veryDeepCopyWith: deepCopier [ "Override to short-circuit the copying of any VMPluginCodeGenerators referenced from mappedPluginEntries and diff --git a/smalltalksrc/VMMaker/SimulatorHarness.class.st b/smalltalksrc/VMMaker/SimulatorHarness.class.st deleted file mode 100644 index 3e52bed183..0000000000 --- a/smalltalksrc/VMMaker/SimulatorHarness.class.st +++ /dev/null @@ -1,82 +0,0 @@ -" -SimulatorHarness provides machinery for executing code within a simulator that is initialized with an image but not up and running. -" -Class { - #name : #SimulatorHarness, - #superclass : #Object, - #pools : [ - 'VMObjectIndices' - ], - #category : #'VMMaker-Support' -} - -{ #category : #testing } -SimulatorHarness >> deny: aBooleanOrBlock [ - aBooleanOrBlock value ifTrue: [AssertionFailure signal: 'Assertion failed'] -] - -{ #category : #execution } -SimulatorHarness >> interpreter: sim object: receiver perform: selector withArguments: arguments [ - "Interpret an expression in oldHeap using oldInterpreter. - Answer the result." - | fp savedpc savedsp savedStackPages result startByteCount | - self assert: ({receiver. selector}, arguments allSatisfy: - [:oop| oop isInteger and: [sim objectMemory addressCouldBeOop: oop]]). - savedpc := sim localIP. - savedsp := sim localSP. - savedStackPages := Set with: sim stackPage. - sim internalPush: receiver. - arguments do: [:arg| sim internalPush: arg]. - sim - argumentCount: arguments size; - messageSelector: selector. - fp := sim localFP. - startByteCount := sim byteCount. - "sim byteCount = 66849 ifTrue: [self halt]." - sim normalSend. - sim incrementByteCount. "otherwise, send is not counted" - ["sim printFrame: sim localFP WithSP: sim localSP" - "sim setBreakSelector: #elementsForwardIdentityTo:" - "sim byteCount = 66849 ifTrue: [self halt]." - "(sim byteCount > 7508930 and: [sim localFP = -16r27894]) ifTrue: - [self halt]." - fp = sim localFP] whileFalse: - [sim singleStep. - (savedStackPages includes: sim stackPage) ifFalse: "If the stack gets deep something has probably gone wrong..." - [savedStackPages size > 20 ifTrue: [self halt]. - savedStackPages add: sim stackPage]]. - result := sim internalPopStack. - self assert: savedsp = sim localSP. - self assert: sim localIP - 1 = savedpc. - sim localIP: savedpc. - ^result -] - -{ #category : #execution } -SimulatorHarness >> withExecutableInterpreter: sim do: aBlock [ - "With the oldInterpreter ready to execute code, evaluate aBlock, - then return the interpreter (and the heap) to the ``just snapshotted'' state." - | savedpc savedfp initialContext finalContext | - sim - initStackPages; - loadInitialContext; - internalizeIPandSP. - savedpc := sim localIP. - savedfp := sim localFP. - "sim printHeadFrame." - aBlock cull: sim cull: self. - "sim printHeadFrame." - sim - internalPush: sim localIP; - externalizeIPandSP. - "now undo the execution state" - self assert: sim localFP = savedfp. - initialContext := sim frameContext: savedfp. - finalContext := sim voidVMStateForSnapshotFlushingExternalPrimitivesIf: false. - self assert: initialContext = finalContext. - self assert: sim localIP = savedpc. - sim objectMemory - storePointer: SuspendedContextIndex - ofObject: sim activeProcess - withValue: finalContext -] diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index d9008740c5..dee9abdc0f 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -317,7 +317,6 @@ Class { 'currentBytecode', 'bytecodeSetSelector', 'localFP', - 'localIP', 'localSP', 'stackLimit', 'stackPage', @@ -531,11 +530,11 @@ If ffi is put as a separate header, slang will sort the header and put it outsid declareVar: #sendTrace type: 'volatile int'; declareVar: #byteCount type: #usqInt. "These need to be pointers or unsigned." - self declareC: #(instructionPointer method newMethod) + self declareC: #(method newMethod) as: #usqInt in: aCCodeGenerator. "These are all pointers; char * because Slang has no support for C pointer arithmetic." - self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit breakSelector) + self declareC: #(instructionPointer localSP localFP stackPointer framePointer stackLimit breakSelector) as: #'char *' in: aCCodeGenerator. aCCodeGenerator @@ -1503,7 +1502,7 @@ StackInterpreter class >> mustBeGlobal: var [ { #category : #translation } StackInterpreter class >> namesOfVariablesToLocalize [ - ^#(currentBytecode localFP localIP localSP localReturnValue) + ^#(currentBytecode localFP localSP localReturnValue) ] { #category : #translation } @@ -2204,7 +2203,7 @@ StackInterpreter >> assertValidExecutionPointe: lip r: lfp s: lsp imbar: inInter { #category : #'debug support' } StackInterpreter >> assertValidExecutionPointers [ "simulator only" - self assertValidExecutionPointe: localIP r: localFP s: localSP + self assertValidExecutionPointe: instructionPointer r: localFP s: localSP ] { #category : #'process primitive support' } @@ -2265,7 +2264,7 @@ StackInterpreter >> baseFrameReturn [ localSP := theSP. localFP := theFP. self setMethod: (self frameMethod: localFP). - localIP := self pointerForOop: self internalStackTop. + instructionPointer := self pointerForOop: self internalStackTop. self internalStackTopPut: localReturnValue. self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). ^self fetchNextBytecode @@ -3612,7 +3611,7 @@ StackInterpreter >> callMappedInlinedPrimitive [ self fetchNextBytecode. self sistaMappedInlinePrimitive: primIndex] ifFalse: - [localIP := localIP - 2. + [instructionPointer := instructionPointer - 2. self respondToUnknownBytecode]. ] @@ -3633,25 +3632,25 @@ StackInterpreter >> callPrimitiveBytecode [ byte2 < 128 ifTrue: [header := objectMemory methodHeaderOf: method. ((self methodHeaderHasPrimitive: header) - and: [localIP asUnsignedInteger + and: [instructionPointer asUnsignedInteger = (self initialIPForHeader: header method: method) + (self sizeOfCallPrimitiveBytecode: header)]) ifTrue: [^self]. - localIP := localIP - 3. + instructionPointer := instructionPointer - 3. ^self respondToUnknownBytecode]. prim := byte2 - 128 << 8 + byte1. primSet := prim >> 13 bitAnd: 3. prim := prim bitAnd: 8191. primSet = 0 ifTrue: [^self sistaInlinePrimitive: prim]. - localIP := localIP - 3. + instructionPointer := instructionPointer - 3. ^self respondToUnknownBytecode] ifFalse: [| header | header := objectMemory methodHeaderOf: method. ((self methodHeaderHasPrimitive: header) - and: [localIP asInteger = (self initialIPForHeader: header method: method)]) + and: [instructionPointer asInteger = (self initialIPForHeader: header method: method)]) ifTrue: - [localIP := localIP + (self sizeOfCallPrimitiveBytecode: header) - 1. + [instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: header) - 1. ^self fetchNextBytecode] ifFalse: [^self respondToUnknownBytecode]] @@ -4565,7 +4564,7 @@ StackInterpreter >> commonCallerReturn [ [self assert: localFP = stackPage baseFP. ^self baseFrameReturn]. - localIP := self frameCallerSavedIP: localFP. + instructionPointer := self frameCallerSavedIP: localFP. localSP := localFP + (self frameStackedReceiverOffset: localFP). localFP := callersFPOrNull. self setMethod: (self frameMethod: localFP). @@ -4678,12 +4677,12 @@ StackInterpreter >> commonReturn [ localFP = frameToReturnTo ifTrue: "pop the saved IP, push the return value and continue." - [localIP := self pointerForOop: self internalStackTop] + [instructionPointer := self pointerForOop: self internalStackTop] ifFalse: [[callerFP := localFP. localFP := self frameCallerFP: localFP. localFP ~~ frameToReturnTo] whileTrue. - localIP := self frameCallerSavedIP: callerFP. + instructionPointer := self frameCallerSavedIP: callerFP. localSP := (self frameCallerSP: callerFP) - objectMemory wordSize]. self maybeReturnToMachineCodeFrame. self setMethod: (self frameMethod: localFP). @@ -5644,7 +5643,7 @@ StackInterpreter >> extUnconditionalJump [ bcpcDelta := offset < 0 ifTrue: [numExtB * 2] ifFalse: [0]. extB := 0. numExtB := 0. - localIP := localIP + offset. + instructionPointer := instructionPointer + offset. self ifBackwardsCheckForEvents: offset + bcpcDelta. self fetchNextBytecode ] @@ -5925,7 +5924,6 @@ StackInterpreter >> externalizeFPandSP [ StackInterpreter >> externalizeIPandSP [ "Copy the local instruction, stack and frame pointers to global variables for use in primitives and other functions outside the interpret loop." - instructionPointer := self oopForPointer: localIP. stackPointer := localSP. framePointer := localFP ] @@ -5953,7 +5951,7 @@ StackInterpreter >> fetchArray: fieldIndex ofObject: objectPointer [ StackInterpreter >> fetchByte [ "This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator." - ^objectMemory byteAtPointer: localIP preIncrement + ^objectMemory byteAtPointer: instructionPointer preIncrement ] { #category : #utilities } @@ -7874,7 +7872,7 @@ StackInterpreter >> instVar: offset ofContext: aContext [ [self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext). ^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)]. offset = InstructionPointerIndex ifTrue: - [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: (self oopForPointer: localIP)]. + [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: (self oopForPointer: instructionPointer)]. self error: 'bad index'. ^0 ] @@ -7919,7 +7917,7 @@ StackInterpreter >> instVar: index ofContext: aMarriedContext put: anOop [ self internalizeIPandSP. "Assigning various fields can force a divorce which can change the stackPage." stackPages markStackPageMostRecentlyUsed: stackPage. - self assertValidExecutionPointe: localIP asUnsignedInteger r: localFP s: localSP imbar: true line: #'__LINE__' + self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: localFP s: localSP imbar: true line: #'__LINE__' ] { #category : #'indexing primitive support' } @@ -8028,7 +8026,7 @@ StackInterpreter >> internalActivateNewMethod [ rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. - self internalPush: localIP. + self internalPush: instructionPointer. self internalPush: localFP. localFP := localSP. self internalPush: newMethod. @@ -8045,13 +8043,13 @@ StackInterpreter >> internalActivateNewMethod [ self internalPush: objectMemory nilObject ]. "-1 to account for pre-increment in fetchNextBytecode" - localIP := self pointerForOop: + instructionPointer := self pointerForOop: (self initialIPForHeader: methodHeader method: newMethod) - 1. (self methodHeaderHasPrimitive: methodHeader) ifTrue: [ "Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts with a long store temp. Strictly no need to skip the store because it's effectively a noop." - localIP := localIP + instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader). primFailCode ~= 0 ifTrue: [ self reapAndResetErrorCodeTo: localSP header: methodHeader ] ]. @@ -8210,7 +8208,6 @@ StackInterpreter >> internalStackValue: offset put: aValue [ { #category : #utilities } StackInterpreter >> internalizeIPandSP [ "Copy the instruction, stack and frame pointers to local variables for rapid access within the interpret loop." - localIP := self pointerForOop: instructionPointer. localSP := self pointerForOop: stackPointer. localFP := self pointerForOop: framePointer. ] @@ -8228,7 +8225,7 @@ StackInterpreter >> interpret [ self initExtensions. self fetchNextBytecode. [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable]. - localIP := localIP - 1. "undo the pre-increment of IP before returning" + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP. ^nil @@ -8711,10 +8708,10 @@ StackInterpreter >> isWriteMediatedContextInstVarIndex: index [ { #category : #'jump bytecodes' } StackInterpreter >> jump: offset [ - localIP := localIP + offset + 1. + instructionPointer := instructionPointer + offset + 1. self cppIf: MULTIPLEBYTECODESETS - ifTrue: [currentBytecode := (objectMemory byteAtPointer: localIP) + bytecodeSetSelector] - ifFalse: [currentBytecode := objectMemory byteAtPointer: localIP] + ifTrue: [currentBytecode := (objectMemory byteAtPointer: instructionPointer) + bytecodeSetSelector] + ifFalse: [currentBytecode := objectMemory byteAtPointer: instructionPointer] ] { #category : #'sista bytecodes' } @@ -8731,24 +8728,24 @@ StackInterpreter >> jumpBinaryInlinePrimitive: primIndex [ Not a forwarder, literal which is a Smi" [16] -> [self deny: (objectMemory isOopForwarded: test). self deny: (objectMemory isImmediate: test). - (objectMemory isImmutable: test) ifFalse: [localIP := localIP + offset]]. + (objectMemory isImmutable: test) ifFalse: [instructionPointer := instructionPointer + offset]]. "7017 jumpIfReadOnly: Not a forwarder, literal which is a Smi" [17] -> [self deny: (objectMemory isOopForwarded: test). self deny: (objectMemory isImmediate: test). - (objectMemory isImmutable: test) ifTrue: [localIP := localIP + offset]]. + (objectMemory isImmutable: test) ifTrue: [instructionPointer := instructionPointer + offset]]. "7018 jumpIfYoung: Not a forwarder, literal which is a Smi" [18] -> [self deny: (objectMemory isOopForwarded: test). self deny: (objectMemory isImmediate: test). - (objectMemory isYoungObject: test) ifTrue: [localIP := localIP + offset]]. + (objectMemory isYoungObject: test) ifTrue: [instructionPointer := instructionPointer + offset]]. "7019 jumpIfOld: Not a forwarder, literal which is a Smi" [19] -> [self deny: (objectMemory isOopForwarded: test). self deny: (objectMemory isImmediate: test). - (objectMemory isYoungObject: test) ifFalse: [localIP := localIP + offset]]. + (objectMemory isYoungObject: test) ifFalse: [instructionPointer := instructionPointer + offset]]. }. - localIP := localIP - 1. "we've already fetched, but we may have incorrectly fetched if jump" + instructionPointer := instructionPointer - 1. "we've already fetched, but we may have incorrectly fetched if jump" self fetchNextBytecode. self internalPop: 2. @@ -8772,13 +8769,13 @@ StackInterpreter >> jumpTrinaryInlinePrimitive: primIndex [ self assert: (self objCouldBeClassObj: classObj). classTag := objectMemory fetchClassTagOf: test. classTag = (objectMemory rawClassTagForClass: classObj) ifTrue: - [localIP := localIP + offset]]. + [instructionPointer := instructionPointer + offset]]. [1] -> ["8001 jumpIfNotInstanceOf:distance: Anything, literal which is a Behavior, literal which is a Smi" self assert: (self objCouldBeClassObj: classObj). classTag := objectMemory fetchClassTagOf: test. classTag = (objectMemory rawClassTagForClass: classObj) ifFalse: - [localIP := localIP + offset]]. + [instructionPointer := instructionPointer + offset]]. [2] -> ["8002 jumpIfInstanceOfOneOf:distance: Anything, Array of behaviors, literal which is a Smi" self assert: (objectMemory isArrayNonImm: classObj). @@ -8786,7 +8783,7 @@ StackInterpreter >> jumpTrinaryInlinePrimitive: primIndex [ 0 to: (objectMemory numSlotsOf: classObj) asInteger - 1 do: [:i | classTag = (objectMemory rawClassTagForClass: (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: - [localIP := localIP + offset]]]. + [instructionPointer := instructionPointer + offset]]]. [3] -> ["8003 jumpIfNotInstanceOfOneOf:distance: Anything, Array of behaviors, literal which is a Smi" self assert: (objectMemory isArrayNonImm: classObj). @@ -8794,12 +8791,12 @@ StackInterpreter >> jumpTrinaryInlinePrimitive: primIndex [ 0 to: (objectMemory numSlotsOf: classObj) asInteger - 1 do: [:i | classTag = (objectMemory rawClassTagForClass: (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: - [localIP := localIP - 1. + [instructionPointer := instructionPointer - 1. self fetchNextBytecode. ^self internalPop: 3]]. - localIP := localIP + offset]. + instructionPointer := instructionPointer + offset]. }. - localIP := localIP - 1. "we've already fetched, but we may have incorrectly fetched if jump" + instructionPointer := instructionPointer - 1. "we've already fetched, but we may have incorrectly fetched if jump" self fetchNextBytecode. self internalPop: 3 @@ -8816,7 +8813,7 @@ StackInterpreter >> jumpUnaryInlinePrimitive: primIndex [ [self assert: (objectMemory isIntegerObject: top). self assert: (objectMemory integerValueOf: top) < 0. "We've already fetched next bytecode, so we add -1" - localIP := localIP + (objectMemory integerValueOf: top) - 1. + instructionPointer := instructionPointer + (objectMemory integerValueOf: top) - 1. self fetchNextBytecode. ^self internalPop: 1]. ^ self unknownInlinePrimitive @@ -9155,7 +9152,7 @@ StackInterpreter >> longStoreTemporaryVariableBytecode [ StackInterpreter >> longUnconditionalJump [ | offset | offset := (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte. - localIP := localIP + offset. + instructionPointer := instructionPointer + offset. self ifBackwardsCheckForEvents: offset. self fetchNextBytecode ] @@ -9632,11 +9629,11 @@ StackInterpreter >> mappedBackjumpAlwaysInterrupt [ top := self internalStackTop. self assert: (objectMemory isIntegerObject: top). offset := objectMemory integerObjectOf: top. - localIP := localIP - offset. + instructionPointer := instructionPointer - offset. self internalPop: 1. "+1 since this instr is 3 bytes not 2" self ifBackwardsCheckForEvents: 0 - offset + 1. - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. self fetchNextBytecode ] @@ -13242,7 +13239,7 @@ StackInterpreter >> respondToUnknownBytecode [ [self error: 'Unknown bytecode']. ourContext := self ensureFrameIsMarried: localFP SP: localSP. "undo fetch of bytecode so that context's pc is pointing to the unknown bytecode." - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. self internalPush: ourContext. argumentCount := 0. self normalSend @@ -15660,7 +15657,7 @@ StackInterpreter >> unconditionnalTrapBytecode [ StackInterpreter >> undoFetchNextBytecode [ "Backup the ip when it has been incremented to fetch the next bytecode." - localIP := localIP - 1 + instructionPointer := instructionPointer - 1 ] { #category : #'compiled methods' } @@ -15692,7 +15689,7 @@ StackInterpreter >> unknownBytecode [ { #category : #'sista bytecodes' } StackInterpreter >> unknownInlinePrimitive [ "Should be inlined everywhere to access localIP" - localIP := localIP - 3. + instructionPointer := instructionPointer - 3. self respondToUnknownBytecode ] diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index eea578cd34..984925885c 100644 --- a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st @@ -652,7 +652,7 @@ StackInterpreterSimulator >> externalInstVar: index ofContext: aMarriedContext p { #category : #'interpreter shell' } StackInterpreterSimulator >> fetchByte [ - ^objectMemory byteAt: (localIP := localIP + 1). + ^objectMemory byteAt: (instructionPointer := instructionPointer + 1). ] { #category : #'control primitives' } @@ -900,7 +900,7 @@ StackInterpreterSimulator >> interpret [ atEachStepBlock value. "N.B. may be nil" self dispatchOn: currentBytecode in: BytecodeTable. self incrementByteCount]. - localIP := localIP - 1. "undo the pre-increment of IP before returning" + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP. ^nil ] @@ -917,7 +917,7 @@ StackInterpreterSimulator >> interpretWhile: aFullBlockClosure [ [aFullBlockClosure value] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. self incrementByteCount]. - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP ] @@ -1215,16 +1215,6 @@ StackInterpreterSimulator >> localFP [ ^localFP ] -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localIP [ - ^localIP -] - -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localIP: pc [ - localIP := pc -] - { #category : #'spur bootstrap' } StackInterpreterSimulator >> localSP [ ^localSP @@ -1567,7 +1557,7 @@ StackInterpreterSimulator >> printChar: aByte [ StackInterpreterSimulator >> printCurrentBytecodeOn: aStream [ | code | code := currentBytecode radix: 16. - aStream newLine; print: localIP - method - 3; tab. + aStream newLine; print: instructionPointer - method - 3; tab. bytecodeSetSelector > 0 ifTrue: [aStream nextPutAll: 'ALT ']. aStream @@ -1793,7 +1783,7 @@ StackInterpreterSimulator >> run [ self initStackPages. self loadInitialContext. self initialEnterSmalltalkExecutive. - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP ] @@ -1809,13 +1799,13 @@ StackInterpreterSimulator >> runAtEachStep: aBlock [ aBlock value: currentBytecode. self dispatchOn: currentBytecode in: BytecodeTable. self incrementByteCount]. - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP ] { #category : #testing } -StackInterpreterSimulator >> runAtEachStep: aBlock breakCount: breakCount [ +StackInterpreterSimulator >> runAtEachStep: aBlock breakCount: aBreakCount [ self initStackPages. self loadInitialContext. self internalizeIPandSP. @@ -1825,9 +1815,9 @@ StackInterpreterSimulator >> runAtEachStep: aBlock breakCount: breakCount [ aBlock value: currentBytecode. self dispatchOn: currentBytecode in: BytecodeTable. self incrementByteCount. - byteCount = breakCount ifTrue: + byteCount = aBreakCount ifTrue: [self halt]]. - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP ] @@ -1846,7 +1836,7 @@ StackInterpreterSimulator >> runForNBytes: nBytecodes [ [byteCount < endCount] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. self incrementByteCount]. - localIP := localIP - 1. + instructionPointer := instructionPointer - 1. "undo the pre-increment of IP before returning" self externalizeIPandSP ] @@ -2266,70 +2256,6 @@ StackInterpreterSimulator >> updateStateOfSpouseContextForFrame: theFP WithSP: t ^super updateStateOfSpouseContextForFrame: theFP WithSP: theSP ] -{ #category : #UI } -StackInterpreterSimulator >> utilitiesMenu: aMenuMorph [ - aMenuMorph - add: 'toggle transcript' action: #toggleTranscript; - add: 'clone VM' action: #cloneSimulationWindow; - addLine; - add: 'print ext head frame' action: #printExternalHeadFrame; - add: 'print int head frame' action: #printHeadFrame; - add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer]; - add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP]; - add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer]; - add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP]; - add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]]; - add: 'print call stack' action: #printCallStack; - add: 'print stack call stack' action: #printStackCallStack; - add: 'print stack call stack of...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printStackCallStackOf: fp]]; - add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]]; - add: 'print call stack of frame...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printCallStackFP: fp]]; - add: 'print all stacks' action: #printAllStacks; - add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP. - self writeBackHeadFramePointers]; - add: 'print prim trace log' action: #dumpPrimTraceLog; - addLine; - add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]]; - add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]]; - add: 'print context...' action: [(self promptHex: 'print context') ifNotNil: [:oop| self printContext: oop]]; - addLine; - add: 'inspect object memory' target: objectMemory action: #inspect; - add: 'run leak checker' action: [Cursor execute showWhile: [self runLeakChecker]]; - add: 'inspect interpreter' action: #inspect; - addLine; - add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'. - s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]]; - add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector (MNU:foo for MNU)'. - s notEmpty ifTrue: - [(s size > 4 and: [s beginsWith: 'MNU:']) - ifTrue: [self setBreakMNUSelector: (s allButFirst: 4)] - ifFalse: [self setBreakSelector: s]]]; - add: 'turn valid exec ptrs assert o', (assertVEPAES ifTrue: ['ff'] ifFalse: ['n']) action: [assertVEPAES := assertVEPAES not]; - add: 'click step' action: [self setClickStepBreakBlock]; - add: (printSends - ifTrue: ['no print sends'] - ifFalse: ['print sends']) - action: [self ensureDebugAtEachStepBlock. - printSends := printSends not]; - "currently printReturns does nothing" - "add: (printReturns - ifTrue: ['no print returns'] - ifFalse: ['print returns']) - action: [self ensureDebugAtEachStepBlock. - printReturns := printReturns not];" - add: (printBytecodeAtEachStep - ifTrue: ['no print bytecode each bytecode'] - ifFalse: ['print bytecode each bytecode']) - action: [self ensureDebugAtEachStepBlock. - printBytecodeAtEachStep := printBytecodeAtEachStep not]; - add: (printFrameAtEachStep - ifTrue: ['no print frame each bytecode'] - ifFalse: ['print frame each bytecode']) - action: [self ensureDebugAtEachStepBlock. - printFrameAtEachStep := printFrameAtEachStep not]. - ^aMenuMorph -] - { #category : #'debug support' } StackInterpreterSimulator >> veryDeepCopyWith: deepCopier [ "Override to short-circuit the copying of any VMPluginCodeGenerators referenced from mappedPluginEntries. From 650f6da70fd4470a5f4569a13beb341c2aca33e1 Mon Sep 17 00:00:00 2001 From: labsari Date: Thu, 7 Oct 2021 11:25:30 +0200 Subject: [PATCH 15/75] Add tests for automatic localization. --- .../MockLocalizationInterpreterMock.class.st | 101 +++++++++++- .../SlangLocalizationTestCase.class.st | 153 +++++++++++++++++- 2 files changed, 250 insertions(+), 4 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 9037d79660..3d0dfdb16a 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -5,7 +5,11 @@ Class { 'variableToLocalize', 'sharedVariableToLocalize', 'sharedVariableToLocalizeBeforeInlining', - 'autoLocalizedVariable' + 'autoLocalizedVariable', + 'autoLocalizedVariable1', + 'autoLocalizedVariable2', + 'autoLocalizedVariable3', + 'autoLocalizedVariable4' ], #classVars : [ 'BytecodeTable' @@ -67,6 +71,16 @@ MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalized ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingSafeExternalCall) + ) +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeToInline [ @@ -98,6 +112,12 @@ MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ variableToLocalize := 42 ] +{ #category : #'as yet unclassified' } +MockLocalizationInterpreterMock >> bytecodeUsingSafeExternalCall [ + + self nonInlinedMethodNotUsingAutolocalizedVariables: (autoLocalizedVariable := autoLocalizedVariable +1) +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariable [ @@ -117,6 +137,21 @@ MockLocalizationInterpreterMock >> bytecodeWithEscapingCall [ self foo: (autoLocalizedVariable := autoLocalizedVariable + 1) ] +{ #category : #'as yet unclassified' } +MockLocalizationInterpreterMock >> foo2 [ + + + autoLocalizedVariable := 10 +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> foo: anObject [ + + + autoLocalizedVariable2 := 11. + self foo2 +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> interpret [ @@ -134,6 +169,56 @@ MockLocalizationInterpreterMock >> interpretWithConflict [ self dispatchOn: 1 in: BytecodeTable ] +{ #category : #inline } +MockLocalizationInterpreterMock >> interpretWithExternalCallBeforeDispatch [ + + + self nonInlinedMethodUsingAutolocalizedVariable. + self dispatchOn: 1 in: BytecodeTable +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> interpretWithLocalizedVariableConflict [ + + "This method should create a conflict with automatically inlined arguments" + | local_autoLocalizedVariable | + + + self dispatchOn: 1 in: BytecodeTable +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> interpretWithReturnExpression [ + + + self dispatchOn: 1 in: BytecodeTable. + true + ifTrue: [ ^ 2 + 2 ] + ifFalse: [ ^ 1 + 1 ] +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> interpretWithReturnExpressionUpdatingAutoLocalizedVariable [ + + + + self dispatchOn: 1 in: BytecodeTable. + + ^ autoLocalizedVariable := autoLocalizedVariable + 1 +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> interpretWithSeveralVariablesToLocalize [ + + + + + + + + self dispatchOn: 1 in: BytecodeTable +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> methodAlsoSharedLocalizedVariableBeforeInlining [ @@ -146,6 +231,20 @@ MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ sharedVariableToLocalize := 17 ] +{ #category : #inline } +MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables [ + + + ^ 10 +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables: anObject [ + + + ^ anObject + 10 +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable [ diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index b0c13eda0d..6c63348154 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -38,20 +38,93 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ self assert: ((ccg methodNamed: #interpret) locals includes: #local_autoLocalizedVariable) ] +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariableWhenNameConflict [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithLocalizedVariableConflict. + self assert: ((ccg methodNamed: #interpretWithLocalizedVariableConflict) locals includes: #local_autoLocalizedVariable_) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + | method | + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + method := (ccg methodNamed: #interpretWithSeveralVariablesToLocalize). + self assert: ( method locals includes: #local_autoLocalizedVariable1). + self assert: (method locals includes: #local_autoLocalizedVariable) +] + { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ - | internalizationStatement | + | externalizationStatement | "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. ccg inlineDispatchesInMethodNamed: #interpret. - internalizationStatement := (ccg methodNamed: #interpret) statements last. + externalizationStatement := (ccg methodNamed: #interpret) statements last statements first. self - assert: internalizationStatement + assert: externalizationStatement + equals: (self externalizationOf: #autoLocalizedVariable) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnReferenchingAutoLocalizedVariable [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + + | interpretMethod printedString | + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: + #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. + interpretMethod := ccg methodNamed: + #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. + ccg currentMethod: interpretMethod. + printedString := String streamContents: [ :str | + (interpretMethod statements last asCASTIn: ccg) + prettyPrintOn: str ]. + + self assert: printedString equals: '{ + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable = local_autoLocalizedVariable; + return (autoLocalizedVariable += 1); +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + + | interpretMethod | + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithReturnExpression. + interpretMethod := ccg methodNamed: #interpretWithReturnExpression. + self assert: + interpretMethod statements last arguments first statements last statements last + isReturn. + self + assert: + interpretMethod statements last arguments first statements last statements first + equals: (self externalizationOf: #autoLocalizedVariable). + self assert: + interpretMethod statements last arguments second statements first statements last + isReturn. + self + assert: + interpretMethod statements last arguments second statements first statements first equals: (self externalizationOf: #autoLocalizedVariable) ] @@ -142,6 +215,55 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE }' ] +{ #category : #tests } +SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ + + | interpretMethod | + MockLocalizationInterpreterMock. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithExternalCallBeforeDispatch. + + interpretMethod := ccg methodNamed: #interpretWithExternalCallBeforeDispatch. + self assert: interpretMethod statements second statements first isExternalSend +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ + + | interpretMethod case inlinedMethod externalCall cast printedString | + MockLocalizationInterpreterMock initializeWithEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. + case := interpretMethod statements sixth cases first. + inlinedMethod := case statements second method. + + externalCall := inlinedMethod statements first. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ + arg1 = (local_autoLocalizedVariable += 1); + { + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + foo(arg1); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable2 = autoLocalizedVariable2; + } +}' +] + { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndInternalize [ @@ -350,3 +472,28 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAre "This should not fail" ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret) ] + +{ #category : #tests } +SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ + + | interpretMethod case inlinedMethod externalCall cast printedString | + MockLocalizationInterpreterMock initializeWithSafeEscapingCall. + ccg addClass: MockLocalizationInterpreterMock. + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + + + "Assert that the send node is preceded by variable externalization" + interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. + case := interpretMethod statements sixth cases first. + inlinedMethod := case statements second method. + + externalCall := inlinedMethod statements first. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: 'nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' +] From 3a271a48595dd2cd55c75dd710fb88387219aa9a Mon Sep 17 00:00:00 2001 From: labsari Date: Thu, 7 Oct 2021 11:31:50 +0200 Subject: [PATCH 16/75] Adding first iteration on automatic localization of variables: - Externalize at return with multiple returns - Extenralize at return when the return has an expression, replace local references by global references. - Manage name conflicts - Wrapping non-inlined calls optimizing to wrap only with variables in the called methods. --- smalltalksrc/Slang/CCodeGenerator.class.st | 130 +++++++++++++++++---- smalltalksrc/Slang/TConstantNode.class.st | 6 + smalltalksrc/Slang/TMethod.class.st | 51 ++++---- smalltalksrc/Slang/TReturnNode.class.st | 9 ++ smalltalksrc/Slang/TSendNode.class.st | 13 +++ smalltalksrc/Slang/TStmtListNode.class.st | 11 ++ 6 files changed, 172 insertions(+), 48 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 26736c6b8c..d75b73c528 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -1265,6 +1265,30 @@ CCodeGenerator >> exportedPrimitiveNames [ ] +{ #category : #'automatic-localization' } +CCodeGenerator >> externalizeAtReturnsIn: aTMethod withVariablesToLocalize: variablesReplacement [ + + | replacementDictionary variablesReplacementDict | + replacementDictionary := Dictionary new. + variablesReplacementDict := (variablesReplacement collect: + [ :each | + each value + -> (TVariableNode named: each key) ]) + asDictionary. + aTMethod nodesDo: [ :e | + e isReturn ifTrue: [ + e bindVariablesIn: variablesReplacementDict. + replacementDictionary + at: e + put: + (TStmtListNode statements: + (variablesReplacement collect: [ :each | + TAssignmentNode + variableNamed: each key + expression: (TVariableNode named: each value) ]) , { e }) ] ]. + aTMethod replaceNodesIn: replacementDictionary +] + { #category : #utilities } CCodeGenerator >> extractTypeFor: aVariable fromDeclaration: aVariableDeclaration [ "Eliminate inessentials from aVariableDeclaration to answer a C type without the variable, @@ -3363,39 +3387,65 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ "Inline dispatches (case statements) in the method with the given name. Then localize variables" - | m variablesToLocalize | + | m variablesToLocalize replacementDict sendReplacements variablesToLocalizeAssociations methodsReferencesToVarsToLocalize | (m := self methodNamed: selector) ifNil: [ ^ self ]. - + variablesToLocalize := Set new. - m - extractDirective: #localizedVariable: - valueBlock: [:sendNode| variablesToLocalize add: sendNode arguments first value ] - default: nil. - m localizeVariables: (variablesToLocalize collect: [ :e | 'local_', e ]). - variablesToLocalize do: [ :e | - m statements addFirst: (TAssignmentNode - variableNamed: #local_, e - expression: (TVariableNode named: e)). - self haltIf: (m statements last isReturn and: [m statements last expression name ~= 'self']). - m statements addLast: (TAssignmentNode - variableNamed: e - expression: (TVariableNode named: #local_, e)). - ]. - - + replacementDict := Dictionary new. + "Look for variables to localize, hinted by localizedVariable: pragma." + m properties pragmasDo: [ :pragma | + pragma selector = #localizedVariable: ifTrue: [ + variablesToLocalize add: pragma arguments first ] ]. + variablesToLocalizeAssociations := OrderedCollection new. + variablesToLocalize do: [ :e | + | localName | + localName := m declareNonConflictingLocalNamedLike: #local_ , e. + variablesToLocalizeAssociations add: e -> localName. + replacementDict at: e put: (TVariableNode named: localName) ]. + m inlineCaseStatementBranchesIn: self - withLocalizationReplacements: (variablesToLocalize collect: [ :v | - v -> (TVariableNode named: #local_, v) ]) asDictionary. - + withLocalizationReplacements: replacementDict. + "Replace all localized variables by their localized versions" + m parseTree bindVariablesIn: replacementDict. + "Wrap sends with externalization/internalization statements" + sendReplacements := Dictionary new. + methodsReferencesToVarsToLocalize := Dictionary new. + + m parseTree + nodesDo: [ :node | + (node isSend and: [ self isFunctionCall: node ]) ifTrue: [ + | externalVars | + externalVars := self + localizedVariablesReferences: variablesToLocalize + inMethod: node selector + withDictionary: methodsReferencesToVarsToLocalize. + + externalVars ifNotEmpty: [ + sendReplacements at: node put: (TExternalSendNode + send: node + variableBindings: + (externalVars collect: [ :var | + var -> (replacementDict at: var) ]) asDictionary) ] ] ] + unless: [ :e | e isReturn ]. + sendReplacements ifNotEmpty: [ + m parseTree replaceNodesIn: sendReplacements ]. + self lineariseExternalCallsIn: m. - + + self + externalizeAtReturnsIn: m + withVariablesToLocalize: variablesToLocalizeAssociations. + variablesToLocalize do: [ :e | + m statements addFirst: (TAssignmentNode + variable: (replacementDict at: e) + expression: (TVariableNode named: e)) ]. m parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ n customizeShortCasesForDispatchVar: 'currentBytecode' in: self - method: m ] ]. + method: m ] ] ] { #category : #utilities } @@ -3504,6 +3554,15 @@ CCodeGenerator >> isFloatingPointCType: aCType [ "" ^#('float' 'double' 'long double') includes: aCType asString ] +{ #category : #utilities } +CCodeGenerator >> isFunctionCall: aNode [ + + ^ aNode isSend and: [ + (self isBuiltinSelector: aNode selector) not and: [ + (self isStructSend: aNode) not and: [ + (self anyMethodNamed: aNode selector) notNil ] ] ] +] + { #category : #'type inference' } CCodeGenerator >> isFunctionalCType: aType [ "Answer if aType is either a function or a pointer to a function." @@ -3722,6 +3781,31 @@ CCodeGenerator >> localizeVariables: varsList inMethod: m [ variableDeclarations removeKey: varString ] ] ] +{ #category : #'automatic-localization' } +CCodeGenerator >> localizedVariablesReferences: variablesToLocalize inMethod: selector withDictionary: associationDictionary [ + + "Return the references to global variables that are in variablesToLocalize in method selector." + + | currentMeth externalCalls globalReferences variablesReferences | + associationDictionary at: selector ifPresent: [ :vars | ^ vars ]. + currentMeth := self methodNamed: selector. + externalCalls := currentMeth externalCallsIn: self. + globalReferences := currentMeth freeVariableReferences. + variablesReferences := (variablesToLocalize select: [ :var | + globalReferences includes: var ]) asSet. + externalCalls ifEmpty: [ + associationDictionary at: selector put: variablesReferences. + ^ variablesReferences ]. + + externalCalls do: [ :s | + variablesReferences addAll: (self + localizedVariablesReferences: variablesToLocalize + inMethod: s + withDictionary: associationDictionary) ]. + associationDictionary at: selector put: variablesReferences. + ^ variablesReferences +] + { #category : #utilities } CCodeGenerator >> logger [ ^logger diff --git a/smalltalksrc/Slang/TConstantNode.class.st b/smalltalksrc/Slang/TConstantNode.class.st index 7228630d64..7b9ad382dc 100644 --- a/smalltalksrc/Slang/TConstantNode.class.st +++ b/smalltalksrc/Slang/TConstantNode.class.st @@ -15,6 +15,12 @@ TConstantNode class >> value: aValue [ yourself ] +{ #category : #comparing } +TConstantNode >> = aNode [ + + ^ aNode isConstant and: [ value = aNode value ] +] + { #category : #tranforming } TConstantNode >> asCASTIn: aBuilder [ diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index ec7ff8b3aa..ebe5d81f71 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -906,6 +906,17 @@ TMethod >> export: aBoolean [ export := aBoolean ] +{ #category : #'automatic-localization' } +TMethod >> externalCallsIn: codeGenerator [ + + | calls | + calls := Set new. + parseTree nodesDo: [ :node | + (codeGenerator isFunctionCall: node) ifTrue: [ + calls add: node selector ] ]. + ^ calls +] + { #category : #initialization } TMethod >> extraVariableName: root [ extraVariableNumber := extraVariableNumber @@ -1007,6 +1018,7 @@ TMethod >> extractInlineDirective [ { #category : #transformations } TMethod >> extractSharedCase [ + "Scan the pragmas for an shared case directive of the form: @@ -1015,19 +1027,21 @@ TMethod >> extractSharedCase [ self sharedCodeInCase: 'sharedCase'. in which case remove the directive from the method body." - self extractDirective: #sharedCodeNamed:inCase: - valueBlock: [:sendNode| - args isEmpty ifFalse: - [self error: 'Cannot share code sections in methods with arguments']. - sharedLabel := sendNode args first value. - sharedCase := sendNode args last value] + self + extractDirective: #sharedCodeNamed:inCase: + valueBlock: [ :sendNode | + args isEmpty ifFalse: [ + self error: 'Cannot share code sections in methods with arguments' ]. + sharedLabel := sendNode arguments first value. + sharedCase := sendNode arguments last value ] default: nil. - self extractDirective: #sharedCodeInCase: - valueBlock: [:sendNode| - args isEmpty ifFalse: - [self error: 'Cannot share code sections in methods with arguments']. + self + extractDirective: #sharedCodeInCase: + valueBlock: [ :sendNode | + args isEmpty ifFalse: [ + self error: 'Cannot share code sections in methods with arguments' ]. sharedLabel := selector. - sharedCase := sendNode args last value] + sharedCase := sendNode arguments last value ] default: nil ] @@ -1388,8 +1402,7 @@ TMethod >> inlineGuardingConditional: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacements: replacementDictionary [ - | exitLabel newStatements sendReplacements | - + | exitLabel newStatements | "Perform the main inlining" meth hasReturn ifTrue: [ @@ -1409,18 +1422,6 @@ TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacem addFirst: (TLabeledCommentNode new setComment: meth selector). stmtNode setStatements: newStatements. - - "Replace all localized variables by their localized versions" - stmtNode bindVariablesIn: replacementDictionary. - - "Wrap sends with externalization/internalization statements" - sendReplacements := Dictionary new. - stmtNode nodesDo: [ :node | - node isSend ifTrue: [ - sendReplacements - at: node - put: (TExternalSendNode send: node variableBindings: replacementDictionary) ] ]. - ^ stmtNode replaceNodesIn: sendReplacements ] { #category : #inlining } diff --git a/smalltalksrc/Slang/TReturnNode.class.st b/smalltalksrc/Slang/TReturnNode.class.st index 2da953906f..f261e73aa8 100644 --- a/smalltalksrc/Slang/TReturnNode.class.st +++ b/smalltalksrc/Slang/TReturnNode.class.st @@ -15,6 +15,15 @@ TReturnNode class >> expression: anExpression [ yourself ] +{ #category : #comparing } +TReturnNode >> = aNode [ + + super = aNode ifFalse: [ ^false ]. + aNode isReturn ifFalse: [ ^false ]. + expression = aNode expression ifFalse: [ ^ false ]. + ^ true +] + { #category : #tranforming } TReturnNode >> asCASTIn: aBuilder [ diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index 1d53e5d537..a253b69eba 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -20,6 +20,19 @@ TSendNode class >> receiver: aReceiverNode selector: aString arguments: aCollect yourself ] +{ #category : #comparing } +TSendNode >> = aNode [ + + super = aNode ifFalse: [ ^ false ]. + aNode isSend ifFalse: [ ^ false ]. + selector = aNode selector ifFalse: [ ^ false ]. + receiver = aNode receiver ifFalse: [ ^ false ]. + arguments size = aNode arguments size ifFalse: [ ^ false ]. + arguments doWithIndex: [ :arg :i | + (arg = (aNode arguments at: i)) ifFalse: [ ^ false ] ]. + ^ true +] + { #category : #accessing } TSendNode >> args [ diff --git a/smalltalksrc/Slang/TStmtListNode.class.st b/smalltalksrc/Slang/TStmtListNode.class.st index e5de8a6dde..96c8443208 100644 --- a/smalltalksrc/Slang/TStmtListNode.class.st +++ b/smalltalksrc/Slang/TStmtListNode.class.st @@ -16,6 +16,17 @@ TStmtListNode class >> statements: aCollection [ yourself ] +{ #category : #comparing } +TStmtListNode >> = aNode [ + + super = aNode ifFalse: [ ^ false ]. + aNode isStmtList ifFalse: [ ^ false ]. + statements size = aNode statements size ifFalse: [ ^ false ]. + statements doWithIndex: [ :stmt :i | + stmt = (aNode statements at: i) ifFalse: [ ^ false ] ]. + ^ true +] + { #category : #utilities } TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ "Add any variables in variables that are read before written to readBeforeAssigned. From 1d3c701a5fe6142d041e77b312ef09ea3aece846 Mon Sep 17 00:00:00 2001 From: labsari Date: Tue, 26 Oct 2021 14:12:22 +0200 Subject: [PATCH 17/75] Correct autolocalization transpilation errors. --- .../MockLocalizationInterpreterMock.class.st | 67 +- .../SlangLocalizationTestCase.class.st | 239 ++--- smalltalksrc/Slang/CCodeGenerator.class.st | 836 ++++++++++-------- smalltalksrc/Slang/SlangTyper.class.st | 73 +- smalltalksrc/Slang/TAssignmentNode.class.st | 10 +- smalltalksrc/Slang/TBraceCaseNode.class.st | 8 + smalltalksrc/Slang/TCaseStmtNode.class.st | 8 + smalltalksrc/Slang/TExternalSendNode.class.st | 7 + smalltalksrc/Slang/TInlineNode.class.st | 8 + smalltalksrc/Slang/TMethod.class.st | 525 ++++++----- smalltalksrc/Slang/TParseNode.class.st | 6 + smalltalksrc/Slang/TReturnNode.class.st | 7 + smalltalksrc/Slang/TSendNode.class.st | 25 +- smalltalksrc/Slang/TStmtListNode.class.st | 116 +-- smalltalksrc/Slang/TSwitchStmtNode.class.st | 13 + smalltalksrc/Slang/TVariableNode.class.st | 7 + 16 files changed, 1135 insertions(+), 820 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 3d0dfdb16a..1036ab2750 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -51,6 +51,26 @@ MockLocalizationInterpreterMock class >> initializeWithEscapingCall [ ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithEscapingCallAsArgument [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeWithEscapingCallAsArgument) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithEscapingCallAsArgumentOfExternalCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeWithEscapingCallAsArgumentOfExternalCall) + ) +] + { #category : #initialization } MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalizedVariableInExpressionOnly [ @@ -71,6 +91,16 @@ MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalized ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithInlinedMethodCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingInlinedCall) + ) +] + { #category : #initialization } MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ @@ -106,6 +136,12 @@ MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariabl self foo: self nonInlinedMethodUsingAutolocalizedVariable ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingInlinedCall [ + + self inlinedMethodUsingExternalCall +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ @@ -137,11 +173,25 @@ MockLocalizationInterpreterMock >> bytecodeWithEscapingCall [ self foo: (autoLocalizedVariable := autoLocalizedVariable + 1) ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeWithEscapingCallAsArgument [ + + 1 = self foo2 ifTrue: [ ] +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeWithEscapingCallAsArgumentOfExternalCall [ + + self foo: self nonInlinedMethodUsingAutolocalizedVariable1 +] + { #category : #'as yet unclassified' } MockLocalizationInterpreterMock >> foo2 [ - autoLocalizedVariable := 10 + autoLocalizedVariable := 10. + autoLocalizedVariable1 := 11. + ^ 1 ] { #category : #inline } @@ -152,6 +202,14 @@ MockLocalizationInterpreterMock >> foo: anObject [ self foo2 ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> inlinedMethodUsingExternalCall [ + + + |arg arg1| + self foo2 +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> interpret [ @@ -251,3 +309,10 @@ MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable [ ^ autoLocalizedVariable ] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable1 [ + + + ^ autoLocalizedVariable1 +] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 6c63348154..7ca5b7e745 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -32,8 +32,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpret. + ccg initAutoLocalizationOfVariablesIn: #interpret. self assert: ((ccg methodNamed: #interpret) locals includes: #local_autoLocalizedVariable) ] @@ -43,9 +42,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariableWhen "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpretWithLocalizedVariableConflict. - self assert: ((ccg methodNamed: #interpretWithLocalizedVariableConflict) locals includes: #local_autoLocalizedVariable_) + ccg initAutoLocalizationOfVariablesIn: #interpretWithLocalizedVariableConflict. + self assert: ((ccg methodNamed: #interpretWithLocalizedVariableConflict) locals includes: #local_autoLocalizedVariable1) ] { #category : #tests } @@ -54,8 +52,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" | method | ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. method := (ccg methodNamed: #interpretWithSeveralVariablesToLocalize). self assert: ( method locals includes: #local_autoLocalizedVariable1). self assert: (method locals includes: #local_autoLocalizedVariable) @@ -64,12 +61,14 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ - | externalizationStatement | + | externalizationStatement autolocalizedVariables | "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. externalizationStatement := (ccg methodNamed: #interpret) statements last statements first. @@ -83,11 +82,13 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnRef "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod printedString | + | interpretMethod printedString autolocalizedVariables | ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. ccg inlineDispatchesInMethodNamed: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. + ccg autoLocalizationOfVariablesIn: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable withVariableBindings: autolocalizedVariables. interpretMethod := ccg methodNamed: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. ccg currentMethod: interpretMethod. @@ -107,10 +108,12 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod | + | interpretMethod autolocalizedVariables | ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithReturnExpression. ccg inlineDispatchesInMethodNamed: #interpretWithReturnExpression. + ccg autoLocalizationOfVariablesIn: #interpretWithReturnExpression withVariableBindings: autolocalizedVariables. interpretMethod := ccg methodNamed: #interpretWithReturnExpression. self assert: interpretMethod statements last arguments first statements last statements last @@ -131,12 +134,13 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning [ - | internalizationStatement | + | internalizationStatement autolocalizedVariables | "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. - + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. internalizationStatement := (ccg methodNamed: #interpret) statements first. self @@ -148,12 +152,13 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod variableNode case | + | interpretMethod variableNode case autolocalizedVariables | MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. ccg addClass: MockLocalizationInterpreterMock. ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. - + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. "Fail if we find some node inside the case that uses the localized variable" interpretMethod := ccg methodNamed: #interpret. @@ -166,13 +171,15 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendNodes [ - | interpretMethod case inlinedMethod | + | interpretMethod case inlinedMethod autolocalizedVariables | MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" @@ -180,19 +187,22 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendN case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - self assert: inlinedMethod statements first statements last isExternalSend + self assert: inlinedMethod statements first isExternalSend ] { #category : #tests } -SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ +SlangLocalizationTestCase >> testExternalEscapingAsArgument [ - | interpretMethod case inlinedMethod externalCall cast printedString | - MockLocalizationInterpreterMock initializeWithEscapingCall. + | interpretMethod case externalCall cast printedString autolocalizedVariables inlinedMethod | + MockLocalizationInterpreterMock initializeWithEscapingCallAsArgument. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. + ccg doBasicInlining: true. + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" @@ -205,41 +215,26 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - arg1 = (local_autoLocalizedVariable += 1); - { - autoLocalizedVariable = local_autoLocalizedVariable; - foo(arg1); - local_autoLocalizedVariable = autoLocalizedVariable; - } + self assert: printedString equals: 'autoLocalizedVariable = local_autoLocalizedVariable; +arg = foo2(); +local_autoLocalizedVariable = autoLocalizedVariable; +if (1 == r) { }' ] { #category : #tests } -SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ - - | interpretMethod | - MockLocalizationInterpreterMock. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpretWithExternalCallBeforeDispatch. - - interpretMethod := ccg methodNamed: #interpretWithExternalCallBeforeDispatch. - self assert: interpretMethod statements second statements first isExternalSend -] - -{ #category : #tests } -SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ +SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ - | interpretMethod case inlinedMethod externalCall cast printedString | - MockLocalizationInterpreterMock initializeWithEscapingCall. + | interpretMethod case externalCall cast printedString autolocalizedVariables inlinedMethod | + MockLocalizationInterpreterMock initializeWithEscapingCallAsArgumentOfExternalCall. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + ccg doBasicInlining: true. + ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" @@ -253,47 +248,62 @@ SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNe printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ - arg1 = (local_autoLocalizedVariable += 1); - { - autoLocalizedVariable = local_autoLocalizedVariable; - autoLocalizedVariable2 = local_autoLocalizedVariable2; - foo(arg1); - local_autoLocalizedVariable = autoLocalizedVariable; - local_autoLocalizedVariable2 = autoLocalizedVariable2; - } + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + foo(nonInlinedMethodUsingAutolocalizedVariable1()); + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable2 = autoLocalizedVariable2; }' ] { #category : #tests } -SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndInternalize [ +SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ - | interpretMethod case inlinedMethod | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. + | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | + MockLocalizationInterpreterMock initializeWithInlinedMethodCall. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpret. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. + ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + ccg doBasicInlining: true. + ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. - case := interpretMethod statements second cases first. + interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. + case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. - self assert: (inlinedMethod statements first statements last localizedVariables includes: #autoLocalizedVariable) + externalCall := inlinedMethod statements second. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable = local_autoLocalizedVariable; + foo2(); + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable = autoLocalizedVariable; +}' ] { #category : #tests } -SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ +SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod externalCall cast printedString | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. + | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | + MockLocalizationInterpreterMock initializeWithEscapingCall. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" @@ -307,62 +317,46 @@ SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternali printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ - arg1 = nonInlinedMethodUsingAutolocalizedVariable(); - { - autoLocalizedVariable = local_autoLocalizedVariable; - foo(arg1); - local_autoLocalizedVariable = autoLocalizedVariable; - } + autoLocalizedVariable = local_autoLocalizedVariable; + foo((autoLocalizedVariable += 1)); + local_autoLocalizedVariable = autoLocalizedVariable; }' ] { #category : #tests } -SlangLocalizationTestCase >> testLinearizationOfExternalCalls [ +SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ - | interpretMethod case inlinedMethod externalCall argumentStatement replacementBlock | - MockLocalizationInterpreterMock initializeWithEscapingCall. + | interpretMethod autolocalizedVariables | + MockLocalizationInterpreterMock. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpret. - - - "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - - replacementBlock := inlinedMethod statements first. - argumentStatement := replacementBlock statements first. - externalCall := replacementBlock statements second. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithExternalCallBeforeDispatch. + ccg inlineDispatchesInMethodNamed: #interpretWithExternalCallBeforeDispatch. + ccg autoLocalizationOfVariablesIn: #interpretWithExternalCallBeforeDispatch withVariableBindings: autolocalizedVariables. - self assert: externalCall wrappedSendNode arguments first equals: argumentStatement variable. - self - assert: argumentStatement expression - equals: (TAssignmentNode - variableNamed: 'local_autoLocalizedVariable' - expression:(TSendNode - receiver: (TVariableNode named: 'local_autoLocalizedVariable') - selector: #+ - arguments: { TConstantNode value: 1 } )) + interpretMethod := ccg methodNamed: #interpretWithExternalCallBeforeDispatch. + self assert: interpretMethod statements second isExternalSend ] { #category : #tests } -SlangLocalizationTestCase >> testLinearizationShouldBeTranslatedWithExternalizationAndInternalizations [ +SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | MockLocalizationInterpreterMock initializeWithEscapingCall. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpret. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. + ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. - case := interpretMethod statements second cases first. + interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. + case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. externalCall := inlinedMethod statements first. @@ -371,25 +365,28 @@ SlangLocalizationTestCase >> testLinearizationShouldBeTranslatedWithExternalizat printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ - arg1 = (local_autoLocalizedVariable += 1); - { - autoLocalizedVariable = local_autoLocalizedVariable; - foo(arg1); - local_autoLocalizedVariable = autoLocalizedVariable; - } + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + foo((autoLocalizedVariable += 1)); + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable2 = autoLocalizedVariable2; }' ] { #category : #tests } -SlangLocalizationTestCase >> testLinearizationShouldDeclareArgumentVariables [ +SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndInternalize [ - | interpretMethod case inlinedMethod | - MockLocalizationInterpreterMock initializeWithEscapingCall. + | interpretMethod case inlinedMethod autolocalizedVariables | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. ccg inlineDispatchesInMethodNamed: #interpret. + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" @@ -397,28 +394,40 @@ SlangLocalizationTestCase >> testLinearizationShouldDeclareArgumentVariables [ case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - self assert: (interpretMethod locals includes: 'arg1') + self assert: (inlinedMethod statements first localizedVariables includes: #autoLocalizedVariable) ] { #category : #tests } -SlangLocalizationTestCase >> testLinearizationShouldRenameArgumentVariablesWhenConflicts [ +SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod | - MockLocalizationInterpreterMock initializeWithEscapingCall. + | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | + MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpretWithConflict. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. + ccg inlineDispatchesInMethodNamed: #interpret. + ccg doBasicInlining: true. + ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. + "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpretWithConflict. + interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - "Conflicts are resolved by automatically renaming the conflicting definitions with a suffix underscore" - self assert: (interpretMethod locals includes: 'arg1_') + externalCall := inlinedMethod statements first. + cast := externalCall asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ + autoLocalizedVariable = local_autoLocalizedVariable; + foo(nonInlinedMethodUsingAutolocalizedVariable()); + local_autoLocalizedVariable = autoLocalizedVariable; +}' ] { #category : #tests } @@ -476,13 +485,15 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAre { #category : #tests } SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | MockLocalizationInterpreterMock initializeWithSafeEscapingCall. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. + ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. "Assert that the send node is preceded by variable externalization" diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index d75b73c528..4767556700 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -381,19 +381,21 @@ CCodeGenerator >> addStructMethodFor: aClass selector: selector [ { #category : #utilities } CCodeGenerator >> addVariablesInVerbatimCIn: aCCodeSendNode to: aCollection [ + "If aCCodeSendNode has a string argument, parse it and extract anything that looks like a variable, and add the resulting vars to aCollection." + | separators tokens | - (aCCodeSendNode isSend - and: [(aCCodeSendNode selector beginsWith: #cCode:) - and: [aCCodeSendNode args first isConstant - and: [aCCodeSendNode args first value isString]]]) ifFalse: - [^self]. - separators := (Character space to: 255 asCharacter) reject: - [:char| - char isLetter or: [char isDigit or: [char = $_]]]. - tokens := aCCodeSendNode args first value findTokens: separators. - aCollection addAll: (tokens select: [:token| token first isLetter]) asSet + (aCCodeSendNode isSend and: [ + (aCCodeSendNode selector beginsWith: #cCode:) and: [ + aCCodeSendNode arguments first isConstant and: [ + aCCodeSendNode arguments first value isString ] ] ]) ifFalse: [ + ^ self ]. + separators := (Character space to: 255 asCharacter) reject: [ :char | + char isLetter or: [ char isDigit or: [ char = $_ ] ] ]. + tokens := aCCodeSendNode arguments first value findTokens: separators. + aCollection addAll: + (tokens select: [ :token | token first isLetter ]) asSet ] { #category : #utilities } @@ -471,6 +473,32 @@ CCodeGenerator >> asmLabelNodeFor: selector [ arguments: { CIdentifierNode name: label } ] +{ #category : #'automatic-localization' } +CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: replacementDict [ + + | m | + (m := self methodNamed: selector) ifNil: [ ^ self ]. + (replacementDict isNil or: [ replacementDict isEmpty ]) ifTrue: [ ^ self ]. + "Wrap sends with externalization/internalization statements" + self wrapExternalCallsIn: m withVariableBindings: replacementDict. + "Replace all localized variables by their localized versions" + m parseTree + bindVariablesIn: (replacementDict collect: [ :asso | + asso key -> (TVariableNode named: asso value) ]) asDictionary + unless: [ :node | + node isTMethod not and: [ + node isReturn or: [ node isExternalSend ] ] ]. + "self lineariseExternalCallsIn: m." + self + externalizeAtReturnsIn: m + withVariablesToLocalize: replacementDict. + "Intitilize local versions with globals values at the beginning of the function." + replacementDict do: [ :asso | + m statements addFirst: (TAssignmentNode + variable: (TVariableNode named: asso value) + expression: (TVariableNode named: asso key)) ] +] + { #category : #utilities } CCodeGenerator >> baseTypeForPointerType: aCType [ "Answer the type of the referent of a pointer type." @@ -973,7 +1001,7 @@ CCodeGenerator >> doInlining: inlineFlag [ CCodeGenerator >> emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag [ "Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded." - | verbose methodList | + | verbose methodList autoLocalizationBindings | "method preparation" verbose := false. self prepareMethods. @@ -983,8 +1011,9 @@ CCodeGenerator >> emitCCodeOn: aStream doInlining: inlineFlag doAssertions: asse logger cr. ]. assertionFlag ifFalse: [ self removeAssertions ]. + autoLocalizationBindings := self initAutoLocalizationOfVariablesIn: #interpret. self doInlining: inlineFlag. - + self autoLocalizationOfVariablesIn: #interpret withVariableBindings: autoLocalizationBindings. "code generation" "If we're outputting the VM put the main interpreter loop first for two reasons. 1, so that the dispdbg.h header included at the bytecode dispatch can define @@ -1270,14 +1299,12 @@ CCodeGenerator >> externalizeAtReturnsIn: aTMethod withVariablesToLocalize: vari | replacementDictionary variablesReplacementDict | replacementDictionary := Dictionary new. - variablesReplacementDict := (variablesReplacement collect: - [ :each | - each value - -> (TVariableNode named: each key) ]) - asDictionary. + variablesReplacementDict := (variablesReplacement collect: [ :each | + each value + -> (TVariableNode named: each key) ]) + asDictionary. aTMethod nodesDo: [ :e | - e isReturn ifTrue: [ - e bindVariablesIn: variablesReplacementDict. + e isReturn ifTrue: [ replacementDictionary at: e put: @@ -1718,8 +1745,8 @@ CCodeGenerator >> generateCASTBytesPerWord: tast [ CCodeGenerator >> generateCASTCCoercion: tast [ | expr cType literal | - expr := tast args first. - cType := tast args last value. + expr := tast arguments first. + cType := tast arguments last value. (cType = #float and: [ expr isConstant and: [ expr value isFloat and: [ @@ -2126,32 +2153,30 @@ CCodeGenerator >> generateCASTIfTrueIfFalseAsArgument: tast [ ] { #category : #'CAST translation' } -CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ +CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ - aTSendNode args first isConstant ifTrue: [ - "If it is a pre-processor declaration" - (aTSendNode args first value at: 1 ifAbsent: nil) = $# ifTrue: [ - "This was assuming the argument is a preprocessor directive. - So it was printing it in a new line" + aTSendNode arguments first isConstant ifTrue: [ "If it is a pre-processor declaration" + (aTSendNode arguments first value at: 1 ifAbsent: nil) = $# ifTrue: [ "This was assuming the argument is a preprocessor directive. + So it was printing it in a new line" self error: 'unsupported' ]. - - self noteVariableUsageInString: aTSendNode args first value. - ^ CRawCodeNode code: aTSendNode args first value ]. - ^ aTSendNode args first asCASTIn: self. + self noteVariableUsageInString: aTSendNode arguments first value. + ^ CRawCodeNode code: aTSendNode arguments first value ]. + + ^ aTSendNode args first asCASTIn: self ] { #category : #'CAST translation' } CCodeGenerator >> generateCASTInlineCCodeAsArgument: aTSendNode [ - (aTSendNode args first isConstant and: [ - aTSendNode args first value isString ]) ifTrue: [ "If it is a pre-processor declaration" - (aTSendNode args first value at: 1 ifAbsent: nil) = $# ifTrue: [ "This was assuming the argument is a preprocessor directive. + (aTSendNode arguments first isConstant and: [ + aTSendNode arguments first value isString ]) ifTrue: [ "If it is a pre-processor declaration" + (aTSendNode arguments first value at: 1 ifAbsent: nil) = $# ifTrue: [ "This was assuming the argument is a preprocessor directive. So it was printing it in a new line" self error: 'unsupported' ]. - self noteVariableUsageInString: aTSendNode args first value. - ^ CRawCodeNode code: aTSendNode args first value ]. + self noteVariableUsageInString: aTSendNode arguments first value. + ^ CRawCodeNode code: aTSendNode arguments first value ]. ^ aTSendNode args first asCASTExpressionIn: self ] @@ -2198,11 +2223,11 @@ CCodeGenerator >> generateCASTInlineCppIfElseAsArgument: tast [ ] { #category : #'built-ins' } -CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ - +CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ + | expr mustCastToUnsigned type typeIsUnsigned expressionToShift | - expr := msgNode args first. - + expr := msgNode arguments first. + expressionToShift := expr asCASTExpressionIn: self. "Note that the default type of an integer constant in C is int. Hence we /must/ @@ -2212,22 +2237,24 @@ CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ (long)(16r1FFFFF << 3) = (long) 16rFFFFFFF8 = 4294967288." type := self typeFor: expr in: currentMethod. typeIsUnsigned := type first = $u. - mustCastToUnsigned := typeIsUnsigned not - or: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqInt)]. - mustCastToUnsigned ifTrue: [ + mustCastToUnsigned := typeIsUnsigned not or: [ + (self sizeOfIntegralCType: type) + < (self sizeOfIntegralCType: #usqInt) ]. + mustCastToUnsigned ifTrue: [ expressionToShift := CCastExpressionNode - type: (CTypeNameNode symbol: #usqInt) - expression: expressionToShift ]. + type: (CTypeNameNode symbol: #usqInt) + expression: expressionToShift ]. ^ (CBinaryOperatorNode - operator: #| - left: (CBinaryOperatorNode - operator: #<< - left: expressionToShift - right: (CConstantNode value: self vmClass objectMemoryClass numSmallIntegerTagBits)) - right: (CConstantNode value: 1)) - needsParentheses: true; - yourself + operator: #| + left: (CBinaryOperatorNode + operator: #<< + left: expressionToShift + right: (CConstantNode value: + self vmClass objectMemoryClass numSmallIntegerTagBits)) + right: (CConstantNode value: 1)) + needsParentheses: true; + yourself ] { #category : #'CAST translation' } @@ -2240,26 +2267,29 @@ CCodeGenerator >> generateCASTIntegerValueOf: aTSendNode [ ] { #category : #'CAST translation' } -CCodeGenerator >> generateCASTIsIntegerObject: msgNode [ - - self vmClass objectMemoryClass numSmallIntegerTagBits = 1 - ifTrue: [ - ^ (CBinaryOperatorNode - operator: '&' - left: (msgNode args first asCASTExpressionIn: self) - right: (CConstantNode value: 1)) - needsParentheses: true; - yourself ]. - +CCodeGenerator >> generateCASTIsIntegerObject: msgNode [ + + self vmClass objectMemoryClass numSmallIntegerTagBits = 1 ifTrue: [ + ^ (CBinaryOperatorNode + operator: '&' + left: (msgNode arguments first asCASTExpressionIn: self) + right: (CConstantNode value: 1)) + needsParentheses: true; + yourself ]. + ^ (CBinaryOperatorNode - operator: '==' - left: (CBinaryOperatorNode - operator: '&' - left: ((msgNode args first asCASTExpressionIn: self) needsParentheses: true; yourself) - right: (CConstantNode value: 1 << self vmClass objectMemoryClass numSmallIntegerTagBits - 1)) - right: (CConstantNode value: 1)) - needsParentheses: true; - yourself + operator: '==' + left: (CBinaryOperatorNode + operator: '&' + left: ((msgNode arguments first asCASTExpressionIn: self) + needsParentheses: true; + yourself) + right: (CConstantNode value: + 1 << self vmClass objectMemoryClass numSmallIntegerTagBits + - 1)) + right: (CConstantNode value: 1)) + needsParentheses: true; + yourself ] { #category : #'CAST translation' } @@ -2311,15 +2341,15 @@ CCodeGenerator >> generateCASTMin: tast [ CCodeGenerator >> generateCASTMinus: tast [ "Constant fold if possible" - tast constantNumbericValueOrNil ifNotNil: [:value| - (value between: -1 << 31 and: 1 << 31 - 1) - ifFalse: [ ^ CConstantNode value: (self cLiteralFor: value) ] ]. - + + tast constantNumbericValueOrNil ifNotNil: [ :value | + (value between: -1 << 31 and: 1 << 31 - 1) ifFalse: [ + ^ CConstantNode value: (self cLiteralFor: value) ] ]. + "Simplify if possible" - tast args first constantNumbericValueOrNil ifNotNil: [:value| - value = 0 ifTrue: [ - ^ tast receiver asCASTExpressionIn: self ]]. - + tast arguments first constantNumbericValueOrNil ifNotNil: [ :value | + value = 0 ifTrue: [ ^ tast receiver asCASTExpressionIn: self ] ]. + "Otherwise, translate normally" ^ self generateCASTBinary: tast operator: #- ] @@ -2388,17 +2418,17 @@ CCodeGenerator >> generateCASTPerform: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTPlus: tast [ - + "Constant fold if possible" - tast constantNumbericValueOrNil ifNotNil: [:value| - (value between: -1 << 31 and: 1 << 31 - 1) - ifFalse: [ ^ CConstantNode value: (self cLiteralFor: value) ] ]. - + + tast constantNumbericValueOrNil ifNotNil: [ :value | + (value between: -1 << 31 and: 1 << 31 - 1) ifFalse: [ + ^ CConstantNode value: (self cLiteralFor: value) ] ]. + "Simplify if possible" - tast args first constantNumbericValueOrNil ifNotNil: [:value| - value = 0 ifTrue: [ - ^ tast receiver asCASTExpressionIn: self ]]. - + tast arguments first constantNumbericValueOrNil ifNotNil: [ :value | + value = 0 ifTrue: [ ^ tast receiver asCASTExpressionIn: self ] ]. + "Otherwise, translate normally" ^ self generateCASTBinary: tast operator: #+ ] @@ -2503,7 +2533,7 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ | finalNode leftNode receiverNode rcvr arg castToLong type mustCastBackToSign mustCastToUnsigned canSuffixTheConstant typeIsUnsigned | rcvr := tast receiver. - arg := tast args first. + arg := tast arguments first. castToLong := false. (rcvr constantNumbericValueIfAtAllPossibleOrNilIn: self) ifNotNil: [ :rcvrVal | @@ -2548,9 +2578,9 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ type: (CTypeNameNode symbol: unsigned) expression: receiverNode ]. finalNode := CBinaryOperatorNode - operator: #<< - left: leftNode - right: (arg asCASTIn: self). + operator: #<< + left: leftNode + right: (arg asCASTIn: self). mustCastBackToSign := typeIsUnsigned not. mustCastBackToSign ifTrue: [ | promotedType | @@ -2562,8 +2592,8 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ ifTrue: [ #sqInt ] ifFalse: [ type ] ]. finalNode := CCastExpressionNode - type: (CTypeNameNode symbol: promotedType) - expression: finalNode ]. + type: (CTypeNameNode symbol: promotedType) + expression: finalNode ]. ^ finalNode ] @@ -2704,19 +2734,18 @@ CCodeGenerator >> generateCASTSmalltalkMetaError: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTTimes: tast [ - + "Constant fold if possible" - tast constantNumbericValueOrNil ifNotNil: [:value| - (value between: -1 << 31 and: 1 << 31 - 1) - ifFalse: [ ^ CConstantNode value: (self cLiteralFor: value) ] ]. - + + tast constantNumbericValueOrNil ifNotNil: [ :value | + (value between: -1 << 31 and: 1 << 31 - 1) ifFalse: [ + ^ CConstantNode value: (self cLiteralFor: value) ] ]. + "Simplify if possible" - tast args first constantNumbericValueOrNil ifNotNil: [:value| - value = 0 ifTrue: [ - ^ tast args first asCASTExpressionIn: self ]. - value = 1 ifTrue: [ - ^ tast receiver asCASTExpressionIn: self ]]. - + tast arguments first constantNumbericValueOrNil ifNotNil: [ :value | + value = 0 ifTrue: [ ^ tast args first asCASTExpressionIn: self ]. + value = 1 ifTrue: [ ^ tast receiver asCASTExpressionIn: self ] ]. + "Otherwise, translate normally" ^ self generateCASTBinary: tast operator: #* ] @@ -2744,14 +2773,14 @@ CCodeGenerator >> generateCASTToByDo: tast [ self error: 'wrong number of block arguments' ]. inits := OrderedCollection new. iterationVar := blockExpr args first. - limitExpr := tast args first. + limitExpr := tast arguments first. inits add: (CAssignmentNode lvalue: (CIdentifierNode name: iterationVar) rvalue: (tast receiver asCASTExpressionIn: self)). self noteUsedVariableName: iterationVar. mayHaveSideEffects := tast arguments size = 4. mayHaveSideEffects ifTrue: [ - limitVar := tast args last. + limitVar := tast arguments last. inits add: (CAssignmentNode lvalue: (CIdentifierNode name: limitVar name) rvalue: (limitExpr asCASTExpressionIn: self)). @@ -2830,8 +2859,9 @@ CCodeGenerator >> generateCASTTouch: tast [ CCodeGenerator >> generateCASTTruncateTo: tast [ | arg | - (self isConstantNode: tast args first valueInto: [ :a | arg := a ]) - ifFalse: [ + (self + isConstantNode: tast arguments first + valueInto: [ :a | arg := a ]) ifFalse: [ self error: 'can''t find method for inlining truncateTo:' ]. self assert: (arg isInteger and: [ arg isPowerOfTwo ]). ^ (CBinaryOperatorNode @@ -2860,14 +2890,14 @@ CCodeGenerator >> generateCASTValue: tast [ | substitution substitutionDict newLabels castStatements | self assert: tast receiver isStmtList. - self assert: tast receiver args size = tast args size. + self assert: tast receiver args size = tast arguments size. castStatements := CCompoundStatementNode statements: OrderedCollection new. castStatements needsBrackets: false. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. - substitutionDict := Dictionary new: tast args size * 2. - tast receiver args with: tast args do: [ :argName :exprNode | + substitutionDict := Dictionary new: tast arguments size * 2. + tast receiver args with: tast arguments do: [ :argName :exprNode | exprNode isLeaf ifTrue: [ substitutionDict at: argName put: exprNode ] ifFalse: [ @@ -2892,14 +2922,15 @@ CCodeGenerator >> generateCASTValueAsArgument: tast [ "Reduce [:formal ... :formalN| body ] value: actual ... value: actualN to body with formals substituted for by actuals." + | substitution substitutionDict newLabels | self assert: tast receiver isStmtList. - self assert: tast receiver args size = tast args size. + self assert: tast receiver args size = tast arguments size. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. - substitutionDict := Dictionary new: tast args size * 2. + substitutionDict := Dictionary new: tast arguments size * 2. tast receiver args - with: tast args + with: tast arguments do: [ :argName :exprNode | substitutionDict at: argName put: exprNode ]. newLabels := Set withAll: currentMethod labels. @@ -2930,11 +2961,11 @@ CCodeGenerator >> generateCASTWhile: boolean loop: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTWhileFalse: tast [ - tast receiver statements size <= 1 - ifTrue: [^self generateCASTWhile: false loop: tast]. - tast args first isNilStmtListNode - ifTrue: [^self generateCASTDoWhileFalse: tast]. - ^self generateCASTWhileForeverBreakIf: true loop: tast + tast receiver statements size <= 1 ifTrue: [ + ^ self generateCASTWhile: false loop: tast ]. + tast arguments first isNilStmtListNode ifTrue: [ + ^ self generateCASTDoWhileFalse: tast ]. + ^ self generateCASTWhileForeverBreakIf: true loop: tast ] { #category : #'CAST translation' } @@ -2955,11 +2986,11 @@ CCodeGenerator >> generateCASTWhileForeverBreakIf: boolean loop: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTWhileTrue: tast [ - tast receiver statements size <= 1 - ifTrue: [^self generateCASTWhile: true loop: tast]. - tast args first isNilStmtListNode - ifTrue: [^self generateCASTDoWhileTrue: tast]. - ^self generateCASTWhileForeverBreakIf: false loop: tast + tast receiver statements size <= 1 ifTrue: [ + ^ self generateCASTWhile: true loop: tast ]. + tast arguments first isNilStmtListNode ifTrue: [ + ^ self generateCASTDoWhileTrue: tast ]. + ^ self generateCASTWhileForeverBreakIf: false loop: tast ] { #category : #accessing } @@ -3135,6 +3166,27 @@ CCodeGenerator >> inferTypes [ inferTypes ] +{ #category : #'automatic-localization' } +CCodeGenerator >> initAutoLocalizationOfVariablesIn: selector [ + "Create local variable versions of variables to localize. Add them in locals of the method described by selector." + | variablesToLocalize m variablesToLocalizeAssociations | + (m := self methodNamed: selector) ifNil: [ ^ nil ]. + variablesToLocalize := Set new. + "Look for variables to localize, hinted by localizedVariable: pragma." + m properties pragmasDo: [ :pragma | + pragma selector = #localizedVariable: ifTrue: [ + variablesToLocalize add: pragma arguments first ] ]. + "If there is no localizedVariable: pragma, nothing to do." + variablesToLocalize ifEmpty: [ ^ nil ]. + + variablesToLocalizeAssociations := OrderedCollection new. + variablesToLocalize do: [ :e | + | localName | + localName := m declareNonConflictingLocalNamedLike: #local_ , e. + variablesToLocalizeAssociations add: e -> localName ]. + ^ variablesToLocalizeAssociations +] + { #category : #'initialize-release' } CCodeGenerator >> initialize [ translationDict := Dictionary new. @@ -3387,59 +3439,11 @@ CCodeGenerator >> inlineDispatchesInMethodNamed: selector [ "Inline dispatches (case statements) in the method with the given name. Then localize variables" - | m variablesToLocalize replacementDict sendReplacements variablesToLocalizeAssociations methodsReferencesToVarsToLocalize | + | m | (m := self methodNamed: selector) ifNil: [ ^ self ]. - variablesToLocalize := Set new. - replacementDict := Dictionary new. - "Look for variables to localize, hinted by localizedVariable: pragma." - m properties pragmasDo: [ :pragma | - pragma selector = #localizedVariable: ifTrue: [ - variablesToLocalize add: pragma arguments first ] ]. - variablesToLocalizeAssociations := OrderedCollection new. - variablesToLocalize do: [ :e | - | localName | - localName := m declareNonConflictingLocalNamedLike: #local_ , e. - variablesToLocalizeAssociations add: e -> localName. - replacementDict at: e put: (TVariableNode named: localName) ]. + m inlineCaseStatementBranchesIn: self. - m - inlineCaseStatementBranchesIn: self - withLocalizationReplacements: replacementDict. - "Replace all localized variables by their localized versions" - m parseTree bindVariablesIn: replacementDict. - "Wrap sends with externalization/internalization statements" - sendReplacements := Dictionary new. - methodsReferencesToVarsToLocalize := Dictionary new. - - m parseTree - nodesDo: [ :node | - (node isSend and: [ self isFunctionCall: node ]) ifTrue: [ - | externalVars | - externalVars := self - localizedVariablesReferences: variablesToLocalize - inMethod: node selector - withDictionary: methodsReferencesToVarsToLocalize. - - externalVars ifNotEmpty: [ - sendReplacements at: node put: (TExternalSendNode - send: node - variableBindings: - (externalVars collect: [ :var | - var -> (replacementDict at: var) ]) asDictionary) ] ] ] - unless: [ :e | e isReturn ]. - sendReplacements ifNotEmpty: [ - m parseTree replaceNodesIn: sendReplacements ]. - - self lineariseExternalCallsIn: m. - - self - externalizeAtReturnsIn: m - withVariablesToLocalize: variablesToLocalizeAssociations. - variablesToLocalize do: [ :e | - m statements addFirst: (TAssignmentNode - variable: (replacementDict at: e) - expression: (TVariableNode named: e)) ]. m parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ n @@ -3782,27 +3786,29 @@ CCodeGenerator >> localizeVariables: varsList inMethod: m [ ] { #category : #'automatic-localization' } -CCodeGenerator >> localizedVariablesReferences: variablesToLocalize inMethod: selector withDictionary: associationDictionary [ +CCodeGenerator >> localizedVariablesReferences: variablesToLocalize inMethod: selector calledBy: caller withDictionary: associationDictionary [ "Return the references to global variables that are in variablesToLocalize in method selector." | currentMeth externalCalls globalReferences variablesReferences | associationDictionary at: selector ifPresent: [ :vars | ^ vars ]. currentMeth := self methodNamed: selector. - externalCalls := currentMeth externalCallsIn: self. + externalCalls := (currentMeth externalCallsIn: self) reject: [ :sel | + sel = selector or: [ sel = caller ] ]. globalReferences := currentMeth freeVariableReferences. variablesReferences := (variablesToLocalize select: [ :var | globalReferences includes: var ]) asSet. - externalCalls ifEmpty: [ - associationDictionary at: selector put: variablesReferences. + associationDictionary at: selector put: variablesReferences. + externalCalls ifEmpty: [ ^ variablesReferences ]. externalCalls do: [ :s | - variablesReferences addAll: (self - localizedVariablesReferences: variablesToLocalize - inMethod: s - withDictionary: associationDictionary) ]. - associationDictionary at: selector put: variablesReferences. + (associationDictionary includesKey: s) ifFalse: [ + (associationDictionary at: selector) addAll: (self + localizedVariablesReferences: variablesToLocalize + inMethod: s + calledBy: selector + withDictionary: associationDictionary) ] ]. ^ variablesReferences ] @@ -3994,6 +4000,7 @@ CCodeGenerator >> needToGenerateHeader: headerName file: interpHdrPath contents: { #category : #utilities } CCodeGenerator >> nilOrBooleanConditionFor: nodeOrNil [ + "If nodeOrNil is one of the conditional sends for which we do translation-time dead code elimination (i.e. cppIf:ifTrue: et al or ifTrue: et al) and the conditional does evaluate to a translation-time boolean constant, answer that constant, otherwise answer nil. Used to prune dead code, @@ -4007,90 +4014,94 @@ CCodeGenerator >> nilOrBooleanConditionFor: nodeOrNil [ ^ self nilOrBooleanConstantReceiverOf: nodeOrNil receiver ]. (#( and: or: ) includes: nodeOrNil selector) ifTrue: [ ^ self nilOrBooleanConstantReceiverOf: nodeOrNil ]. - (#( #cppIf:ifTrue: #cppIf:ifTrue:ifFalse: ) includes: nodeOrNil selector) - ifTrue: [ + (#( #cppIf:ifTrue: #cppIf:ifTrue:ifFalse: ) includes: + nodeOrNil selector) ifTrue: [ | maybeName value | - value := nodeOrNil args first value. + value := nodeOrNil arguments first value. self validateCppIf: nodeOrNil withValue: value. - maybeName := nodeOrNil args first isConstant ifTrue: [ - nodeOrNil args first nameOrValue ]. + maybeName := nodeOrNil arguments first isConstant ifTrue: [ + nodeOrNil arguments first nameOrValue ]. ^ (optionsDictionary notNil and: [ - nodeOrNil args first isConstant and: [ + nodeOrNil arguments first isConstant and: [ (#( true false ) includes: (optionsDictionary at: maybeName ifAbsent: [ nil ])) and: [ - (self defineAtCompileTime: maybeName) not ] ] ]) - ifTrue: [ optionsDictionary at: nodeOrNil args first name ] ]. + (self defineAtCompileTime: maybeName) not ] ] ]) ifTrue: [ + optionsDictionary at: nodeOrNil arguments first name ] ]. ^ nil ] { #category : #utilities } CCodeGenerator >> nilOrBooleanConstantReceiverOf: aNode [ + "Answer nil or the boolean constant that is the receiver of the given message send. Used to suppress conditional code when the condition is a translation-time constant." | val receiver argument arms | - generateDeadCode ifTrue:[^nil]. - ((self isConstantNode: aNode valueInto: [:v| val := v]) - and: [#(true false) includes: val]) ifTrue: - [^val]. - aNode isSend ifTrue: - [aNode selector == #not ifTrue: - [(self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: - [:bool| ^bool not]]. - ((#(isNil notNil) includes: aNode selector) - and: [self isNilConstantReceiverOf: aNode]) ifTrue: - [^aNode selector == #isNil]. - ((#(or: and:) includes: aNode selector) - and: [aNode args last isStmtList - and: [aNode args last statements size = 1]]) ifTrue: - [(self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: - [:rcvr| - ((rcvr == false and: [aNode selector == #and:]) - or: [rcvr == true and: [aNode selector == #or:]]) ifTrue: - [^rcvr]. - (self nilOrBooleanConstantReceiverOf: aNode args last statements first) ifNotNil: - [:arg| - ^rcvr perform: aNode selector with: [arg]]]. - "We can also eliminate expr and: [false], expr or: [true], but only if expr is side-effect free. + generateDeadCode ifTrue: [ ^ nil ]. + ((self isConstantNode: aNode valueInto: [ :v | val := v ]) and: [ + #( true false ) includes: val ]) ifTrue: [ ^ val ]. + aNode isSend ifTrue: [ + aNode selector == #not ifTrue: [ + (self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: [ + :bool | ^ bool not ] ]. + ((#( isNil notNil ) includes: aNode selector) and: [ + self isNilConstantReceiverOf: aNode ]) ifTrue: [ + ^ aNode selector == #isNil ]. + ((#( or: and: ) includes: aNode selector) and: [ + aNode arguments last isStmtList and: [ + aNode arguments last statements size = 1 ] ]) ifTrue: [ + (self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: [ + :rcvr | + ((rcvr == false and: [ aNode selector == #and: ]) or: [ + rcvr == true and: [ aNode selector == #or: ] ]) ifTrue: [ + ^ rcvr ]. + (self nilOrBooleanConstantReceiverOf: + aNode arguments last statements first) ifNotNil: [ :arg | + ^ rcvr perform: aNode selector with: [ arg ] ] ]. + "We can also eliminate expr and: [false], expr or: [true], but only if expr is side-effect free. This is a weak test; we don't traverse calls. Caveat emptor!" - ((aNode receiver noneSatisfy: [:node| node isAssignment]) "No side-effects in the elided expression" - and: [aNode args last statements size = 1]) ifTrue: - [(self nilOrBooleanConstantReceiverOf: aNode args last statements first) ifNotNil: - [:arg| - ((arg == false and: [aNode selector == #and:]) - or: [arg == true and: [aNode selector == #or:]]) ifTrue: - [^arg]]]]. + ((aNode receiver noneSatisfy: [ :node | node isAssignment ]) and: [ + aNode arguments last statements size = 1 ]) ifTrue: [ "No side-effects in the elided expression" + (self nilOrBooleanConstantReceiverOf: + aNode arguments last statements first) ifNotNil: [ :arg | + ((arg == false and: [ aNode selector == #and: ]) or: [ + arg == true and: [ aNode selector == #or: ] ]) ifTrue: [ ^ arg ] ] ] ]. "Look for Const ifTrue: [self foo] ifFalse: [false] => false" - ((#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: aNode selector) - and: [(self isConstantNode: aNode receiver valueInto: [:v| val := v]) - and: [(#(true false) includes: val) - and: [arms := aNode args collect: - [:altBlock| | bval | - (altBlock statements size = 1 - and: [(self isConstantNode: altBlock statements last valueInto: [:v| bval := v]) - and: [#(true false) includes: bval]]) ifTrue: - [bval]]. - arms asArray ~= #(nil nil)]]]) ifTrue: - [| arm | - arm := aNode selector == #ifTrue:ifFalse: == val - ifTrue: [arms first] - ifFalse: [arms last]. - (#(true false) includes: arm) ifTrue: - [^arm]]. - ((#(= ~= < > <= >=) includes: aNode selector) - and: [(self isConstantNode: aNode receiver valueInto: [:v| receiver := v]) - and: [receiver isInteger - and: [(self isConstantNode: aNode args first valueInto: [:v| argument := v]) - and: [argument isInteger]]]]) ifTrue: - [^receiver perform: aNode selector with: argument]. - "Inlining for e.g. CharacterTable ifNil: [...] ifNotNil: [...]], which compiles to CharacterTable == nil ifTrue: [...] ifFalse: [...]" - (aNode selector == #== - and: [aNode args first isVariable - and: [aNode args first name = 'nil' - and: [aNode receiver isConstant - and: [aNode receiver value == nil]]]]) ifTrue: - [^true]]. - ^nil + ((#( #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: aNode selector) + and: [ + (self isConstantNode: aNode receiver valueInto: [ :v | val := v ]) + and: [ + (#( true false ) includes: val) and: [ + arms := aNode arguments collect: [ :altBlock | + | bval | + (altBlock statements size = 1 and: [ + (self + isConstantNode: altBlock statements last + valueInto: [ :v | bval := v ]) and: [ + #( true false ) includes: bval ] ]) ifTrue: [ + bval ] ]. + arms asArray ~= #( nil nil ) ] ] ]) ifTrue: [ + | arm | + arm := aNode selector == #ifTrue:ifFalse: == val + ifTrue: [ arms first ] + ifFalse: [ arms last ]. + (#( true false ) includes: arm) ifTrue: [ ^ arm ] ]. + ((#( = ~= < > <= >= ) includes: aNode selector) and: [ + (self + isConstantNode: aNode receiver + valueInto: [ :v | receiver := v ]) and: [ + receiver isInteger and: [ + (self + isConstantNode: aNode arguments first + valueInto: [ :v | argument := v ]) and: [ argument isInteger ] ] ] ]) + ifTrue: [ ^ receiver perform: aNode selector with: argument ]. + "Inlining for e.g. CharacterTable ifNil: [...] ifNotNil: [...]], which compiles to CharacterTable == nil ifTrue: [...] ifFalse: [...]" + (aNode selector == #== and: [ + aNode arguments first isVariable and: [ + aNode arguments first name = 'nil' and: [ + aNode receiver isConstant and: [ aNode receiver value == nil ] ] ] ]) + ifTrue: [ ^ true ] ]. + ^ nil ] { #category : #'translation support' } @@ -4130,25 +4141,29 @@ CCodeGenerator >> node: exprNode typeCompatibleWith: argName inliningInto: targe { #category : #utilities } CCodeGenerator >> nodeIsDeadCode: aNode withParent: parentNode [ + "Answer if aNode would not be generated due to dead code elimination." - ^(self nilOrBooleanConditionFor: parentNode) - ifNil: [false] - ifNotNil: - [:cond| | filter | - filter := parentNode selector caseOf: - { "First element is accessor for filtered (eliminated) node if expression is true. + + ^ (self nilOrBooleanConditionFor: parentNode) + ifNil: [ false ] + ifNotNil: [ :cond | + | filter | + filter := parentNode selector caseOf: { + ([ #ifFalse: ] -> [ #( first nil ) ]). + ([ #ifFalse:ifTrue: ] -> [ #( first last ) ]). + ([ #ifTrue: ] -> [ #( nil first ) ]). + ([ #ifTrue:ifFalse: ] -> [ #( last first ) ]). + ([ #and: ] -> [ #( nil first ) ]). + ([ #or: ] -> [ #( last nil ) ]). + ([ #cppIf:ifTrue: ] -> [ #( nil #second ) ]). + ([ #cppIf:ifTrue:ifFalse: ] -> [ #( third #second ) ]) }. "First element is accessor for filtered (eliminated) node if expression is true. Second element is accessor for filtered (eliminated) node if expression is false." - [#ifFalse:] -> [#(first nil)]. - [#ifFalse:ifTrue:] -> [#(first last)]. - [#ifTrue:] -> [#(nil first)]. - [#ifTrue:ifFalse:] -> [#(last first)]. - [#and:] -> [#(nil first)]. - [#or:] -> [#(last nil)]. - [#cppIf:ifTrue:] -> [#(nil #second)]. - [#cppIf:ifTrue:ifFalse:] -> [#(third #second)] }. - (cond ifTrue: [filter first] ifFalse: [filter last]) - ifNil: [false] - ifNotNil: [:accessor| aNode == (parentNode args perform: accessor)]] + (cond + ifTrue: [ filter first ] + ifFalse: [ filter last ]) + ifNil: [ false ] + ifNotNil: [ :accessor | + aNode == (parentNode arguments perform: accessor) ] ] ] { #category : #inlining } @@ -4581,6 +4596,7 @@ CCodeGenerator >> returnPrefixFromVariable: aName [ { #category : #'type inference' } CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMethod typeIfNil: typeIfNil [ + "Answer the return type for a send. Unbound sends default to typeIfNil. Methods with types as yet unknown have a type determined either by the kernelReturnTypes or the table below, or, if they are in neither set, then nil. @@ -4589,83 +4605,108 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho If there is a method for sel but its return type is as yet unknown it mustn't be defaulted, since on a subsequent pass its type may be computable." - ^sendNode selector - caseOf: { - [#integerValueOf:] -> [#sqInt]. - [#isIntegerObject:] -> [#int]. - [#negated] -> [self promoteArithmeticTypes: (sendNode receiver typeFrom: self in: aTMethod) and: #int]. - [#+] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#-] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#*] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#/] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#//] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#\\] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#rem:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#quo:] -> [self typeForArithmetic: sendNode in: aTMethod]. - "C99 Sec Bitwise shift operators ... 3 Sematics ... + ^ sendNode selector + caseOf: { + ([ #integerValueOf: ] -> [ #sqInt ]). + ([ #isIntegerObject: ] -> [ #int ]). + ([ #negated ] -> [ + self + promoteArithmeticTypes: + (sendNode receiver typeFrom: self in: aTMethod) + and: #int ]). + ([ #+ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #- ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #* ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #/ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #// ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #\\ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #rem: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #quo: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + "C99 Sec Bitwise shift operators ... 3 Sematics ... The integer promotions are performed on each of the operands. The type of the result is that of the promoted left operand..." - [#>>] -> [sendNode receiver typeFrom: self in: aTMethod]. - [#<<] -> [sendNode receiver typeFrom: self in: aTMethod]. - [#addressOf:] -> [(sendNode receiver typeFrom: self in: aTMethod) - ifNil: [#sqInt] - ifNotNil: [:type| type, (type last isLetter ifTrue: [' *'] ifFalse: ['*'])]]. - [#at:] -> [self typeForDereference: sendNode in: aTMethod]. - [#bitAnd:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitOr:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitXor:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitClear:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitInvert32] -> [#'unsigned int']. - [#bitInvert64] -> [self promoteArithmeticTypes: (sendNode receiver typeFrom: self in: aTMethod) and: #int]. - [#byteSwap32] -> [#'unsigned int']. - [#byteSwap64] -> [#'unsigned long long']. - [#byteSwapped32IfBigEndian:] -> [#'unsigned int']. - [#byteSwapped64IfBigEndian:] -> [#'unsigned long long']. - [#=] -> [#int]. - [#~=] -> [#int]. - [#==] -> [#int]. - [#~~] -> [#int]. - [#<] -> [#int]. - [#<=] -> [#int]. - [#>] -> [#int]. - [#>=] -> [#int]. - [#between:and:] -> [#int]. - [#anyMask:] -> [#int]. - [#allMask:] -> [#int]. - [#noMask:] -> [#int]. - [#isNil] -> [#int]. - [#notNil] -> [#int]. - [#&] -> [#int]. - [#|] -> [#int]. - [#not] -> [#int]. - [#asFloat] -> [#double]. - [#atan] -> [#double]. - [#exp] -> [#double]. - [#log] -> [#double]. - [#sin] -> [#double]. - [#sqrt] -> [#double]. - [#asLong] -> [#long]. - [#asInteger] -> [#sqInt]. - [#asIntegerPtr] -> [#'sqIntptr_t']. - [#asUnsignedInteger] -> [#usqInt]. - [#asUnsignedIntegerPtr]-> [#'usqIntptr_t']. - [#asUnsignedLong] -> [#'unsigned long']. - [#asUnsignedLongLong] -> [#'unsigned long long']. - [#asVoidPointer] -> [#'void *']. - [#signedIntToLong] -> [#usqInt]. "c.f. generateSignedIntToLong:on:indent:" - [#signedIntToShort] -> [#usqInt]. "c.f. generateSignedIntToShort:on:indent:" - [#cCoerce:to:] -> [self conventionalTypeForType: sendNode args last value]. - [#cCoerceSimple:to:] -> [self conventionalTypeForType: sendNode args last value]. - [#sizeof:] -> [#'usqIntptr_t']. "Technically it's a size_t but it matches on target architectures so far..." - [#ifTrue:ifFalse:] -> [self typeForConditional: sendNode in: aTMethod]. - [#ifFalse:ifTrue:] -> [self typeForConditional: sendNode in: aTMethod]. - [#ifTrue:] -> [self typeForConditional: sendNode in: aTMethod]. - [#ifFalse:] -> [self typeForConditional: sendNode in: aTMethod]. - [#and:] -> [#sqInt]. - [#or:] -> [#sqInt]. - [#caseOf:] -> [self typeFor: sendNode args first in: aTMethod] } - otherwise: "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted, - since on a subsequent pass its type may be computable. Only default unbound selectors." - [aCalledMethod ifNotNil: [nil] ifNil: [typeIfNil]] + ([ #>> ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). + ([ #<< ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). + ([ #addressOf: ] -> [ + (sendNode receiver typeFrom: self in: aTMethod) + ifNil: [ #sqInt ] + ifNotNil: [ :type | + type , (type last isLetter + ifTrue: [ ' *' ] + ifFalse: [ '*' ]) ] ]). + ([ #at: ] -> [ self typeForDereference: sendNode in: aTMethod ]). + ([ #bitAnd: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitOr: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitXor: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitClear: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitInvert32 ] -> [ #'unsigned int' ]). + ([ #bitInvert64 ] -> [ + self + promoteArithmeticTypes: + (sendNode receiver typeFrom: self in: aTMethod) + and: #int ]). + ([ #byteSwap32 ] -> [ #'unsigned int' ]). + ([ #byteSwap64 ] -> [ #'unsigned long long' ]). + ([ #byteSwapped32IfBigEndian: ] -> [ #'unsigned int' ]). + ([ #byteSwapped64IfBigEndian: ] -> [ #'unsigned long long' ]). + ([ #= ] -> [ #int ]). + ([ #~= ] -> [ #int ]). + ([ #== ] -> [ #int ]). + ([ #~~ ] -> [ #int ]). + ([ #< ] -> [ #int ]). + ([ #<= ] -> [ #int ]). + ([ #> ] -> [ #int ]). + ([ #>= ] -> [ #int ]). + ([ #between:and: ] -> [ #int ]). + ([ #anyMask: ] -> [ #int ]). + ([ #allMask: ] -> [ #int ]). + ([ #noMask: ] -> [ #int ]). + ([ #isNil ] -> [ #int ]). + ([ #notNil ] -> [ #int ]). + ([ #& ] -> [ #int ]). + ([ #| ] -> [ #int ]). + ([ #not ] -> [ #int ]). + ([ #asFloat ] -> [ #double ]). + ([ #atan ] -> [ #double ]). + ([ #exp ] -> [ #double ]). + ([ #log ] -> [ #double ]). + ([ #sin ] -> [ #double ]). + ([ #sqrt ] -> [ #double ]). + ([ #asLong ] -> [ #long ]). + ([ #asInteger ] -> [ #sqInt ]). + ([ #asIntegerPtr ] -> [ #sqIntptr_t ]). + ([ #asUnsignedInteger ] -> [ #usqInt ]). + ([ #asUnsignedIntegerPtr ] -> [ #usqIntptr_t ]). + ([ #asUnsignedLong ] -> [ #'unsigned long' ]). + ([ #asUnsignedLongLong ] -> [ #'unsigned long long' ]). + ([ #asVoidPointer ] -> [ #'void *' ]). + ([ #signedIntToLong ] -> [ #usqInt ]). "c.f. generateSignedIntToLong:on:indent:" + ([ #signedIntToShort ] -> [ #usqInt ]). "c.f. generateSignedIntToShort:on:indent:" + ([ #cCoerce:to: ] + -> [ + self conventionalTypeForType: sendNode arguments last value ]). + ([ #cCoerceSimple:to: ] + -> [ + self conventionalTypeForType: sendNode arguments last value ]). + ([ #sizeof: ] -> [ #usqIntptr_t ]). "Technically it's a size_t but it matches on target architectures so far..." + ([ #ifTrue:ifFalse: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #ifFalse:ifTrue: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #ifTrue: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #ifFalse: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #and: ] -> [ #sqInt ]). + ([ #or: ] -> [ #sqInt ]). + ([ #caseOf: ] + -> [ self typeFor: sendNode arguments first in: aTMethod ]) } + otherwise: [ "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted, + since on a subsequent pass its type may be computable. Only default unbound selectors." + aCalledMethod ifNotNil: [ nil ] ifNil: [ typeIfNil ] ] ] { #category : #'type inference' } @@ -5046,44 +5087,61 @@ CCodeGenerator >> typeFor: aNode in: aTMethod [ { #category : #'type inference' } CCodeGenerator >> typeForArithmetic: sendNode in: aTMethod [ + "Answer the return type for an arithmetic sendThis is so that the inliner can still inline simple expressions. Deal with pointer arithmetic, floating point arithmetic and promotion." + | rcvrType argType arg | rcvrType := sendNode receiver typeOrNilFrom: self in: aTMethod. - argType := (arg := sendNode args first) typeOrNilFrom: self in: aTMethod. + argType := (arg := sendNode arguments first) + typeOrNilFrom: self + in: aTMethod. "deal with pointer arithmetic" - ((rcvrType notNil and: [rcvrType last == $*]) or: [argType notNil and: [argType last == $*]]) ifTrue: - [(rcvrType isNil or: [argType isNil]) ifTrue: - [^nil]. - (rcvrType last == $* and: [argType last == $*]) ifTrue: - [sendNode selector == #- ifTrue: - [^#int]. - self error: 'invalid pointer arithmetic']. - ^rcvrType last == $* - ifTrue: [rcvrType] - ifFalse: [argType]]. - ^(self promoteArithmeticTypes: rcvrType and: argType) ifNotNil: - [:promotedType| - "We have to be very careful with subtraction. The difference between two unsigned types is signed. + ((rcvrType notNil and: [ rcvrType last == $* ]) or: [ + argType notNil and: [ argType last == $* ] ]) ifTrue: [ + (rcvrType isNil or: [ argType isNil ]) ifTrue: [ ^ nil ]. + (rcvrType last == $* and: [ argType last == $* ]) ifTrue: [ + sendNode selector == #- ifTrue: [ ^ #int ]. + self error: 'invalid pointer arithmetic' ]. + ^ rcvrType last == $* + ifTrue: [ rcvrType ] + ifFalse: [ argType ] ]. + ^ (self promoteArithmeticTypes: rcvrType and: argType) ifNotNil: [ + :promotedType | "We have to be very careful with subtraction. The difference between two unsigned types is signed. But we don't want unsigned - constant to be signed. We almost always want this to stay unsigned." - (sendNode selector == #- and: [promotedType first == $u and: [(arg isConstant and: [arg value isInteger]) not]]) - ifTrue: [promotedType allButFirst: ((promotedType beginsWith: 'unsigned') ifTrue: [9] ifFalse: [1])] - ifFalse: [promotedType]] + (sendNode selector == #- and: [ + promotedType first == $u and: [ + (arg isConstant and: [ arg value isInteger ]) not ] ]) + ifTrue: [ + promotedType allButFirst: + ((promotedType beginsWith: 'unsigned') + ifTrue: [ 9 ] + ifFalse: [ 1 ]) ] + ifFalse: [ promotedType ] ] ] { #category : #'type inference' } CCodeGenerator >> typeForConditional: sendNode in: aTMethod [ + "Answer the return type for a conditional, ifTrue:ifFalse: et al" + | firstType secondType | - firstType := self typeFor: sendNode args first statements last in: aTMethod. - sendNode selector numArgs = 1 ifTrue: - [^firstType]. - secondType := self typeFor: sendNode args second statements last in: aTMethod. - ((firstType notNil and: [(self isIntegralCType: firstType) or: [self isFloatingPointCType: firstType]]) - and: [secondType notNil and: [(self isIntegralCType: secondType) or: [self isFloatingPointCType: secondType]]]) ifTrue: - [^self promoteArithmeticTypes: firstType and: secondType]. - ^firstType ifNil: [secondType] + firstType := self + typeFor: sendNode arguments first statements last + in: aTMethod. + sendNode selector numArgs = 1 ifTrue: [ ^ firstType ]. + secondType := self + typeFor: sendNode arguments second statements last + in: aTMethod. + ((firstType notNil and: [ + (self isIntegralCType: firstType) or: [ + self isFloatingPointCType: firstType ] ]) and: [ + secondType notNil and: [ + (self isIntegralCType: secondType) or: [ + self isFloatingPointCType: secondType ] ] ]) ifTrue: [ + ^ self promoteArithmeticTypes: firstType and: secondType ]. + ^ firstType ifNil: [ secondType ] ] { #category : #'type inference' } @@ -5374,3 +5432,39 @@ CCodeGenerator >> wordSize: aValue [ wordSize := aValue ] + +{ #category : #'automatic-localization' } +CCodeGenerator >> wrapExternalCallsIn: tMethod withVariableBindings: replacementDict [ + + "Wrap external calls with TExternalSendNode." + + | sendReplacements methodsReferencesToVarsToLocalize variablesDict | + variablesDict := (replacementDict collect: [ :asso | + asso key -> (TVariableNode named: asso value) ]) + asDictionary. + + + sendReplacements := Dictionary new. + methodsReferencesToVarsToLocalize := Dictionary new. + tMethod parseTree + nodesDo: [ :node :parent | + (node isSend and: [ self isFunctionCall: node ]) ifTrue: [ + | externalVars | + externalVars := self + localizedVariablesReferences: + (replacementDict collect: [ :asso | asso key ]) + inMethod: node selector + calledBy: nil + withDictionary: methodsReferencesToVarsToLocalize. + + externalVars ifNotEmpty: [ + sendReplacements at: node put: (TExternalSendNode + send: node + variableBindings: + (externalVars collect: [ :var | + var -> (variablesDict at: var) ]) asDictionary) ] ] ] + parent: nil + unless: [ :e :parent | e isReturn ]. + sendReplacements ifNotEmpty: [ + tMethod parseTree replaceNodesIn: sendReplacements ] +] diff --git a/smalltalksrc/Slang/SlangTyper.class.st b/smalltalksrc/Slang/SlangTyper.class.st index fe58ce820f..7b8ad12b81 100644 --- a/smalltalksrc/Slang/SlangTyper.class.st +++ b/smalltalksrc/Slang/SlangTyper.class.st @@ -18,42 +18,44 @@ SlangTyper class >> on: aCCodeGenerator [ { #category : #'type inference' } SlangTyper >> addTypesFor: node inMethod: method to: typeSet [ + "Add the value types for the node to typeSet. Answer if any type was derived from an as-yet-untyped method or variable, which allows us to abort inferReturnTypeFromReturnsIn: if the return type depends on a yet-to-be-typed method or variable." + | expr | expr := node. - [expr isAssignment or: [expr isStmtList]] whileTrue: - [expr isAssignment ifTrue: - [expr := expr variable]. - expr isStmtList ifTrue: - [expr := expr statements last]]. - expr isSend ifTrue: [ - (#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: expr selector) ifTrue: [ - ^expr args - inject: false - into: [:asYetUntyped :block| - asYetUntyped | (self addTypesFor: block inMethod: method to: typeSet) ] ]. + [ expr isAssignment or: [ expr isStmtList ] ] whileTrue: [ + expr isAssignment ifTrue: [ expr := expr variable ]. + expr isStmtList ifTrue: [ expr := expr statements last ] ]. + expr isSend ifTrue: [ + (#( ifTrue: ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: + expr selector) ifTrue: [ + ^ expr arguments inject: false into: [ :asYetUntyped :block | + asYetUntyped + | (self addTypesFor: block inMethod: method to: typeSet) ] ]. (codeGenerator returnTypeForSend: expr in: method ifNil: nil) - ifNil: [^(codeGenerator methodNamed: expr selector) notNil and: [expr selector ~~ method selector]] - ifNotNil: - [:type | + ifNil: [ + ^ (codeGenerator methodNamed: expr selector) notNil and: [ + expr selector ~~ method selector ] ] + ifNotNil: [ :type | typeSet add: type. - ^false]]. - expr isVariable ifTrue: - [(codeGenerator typeOfVariable: expr name) - ifNotNil: [:type| typeSet add: type] - ifNil: [(typeSet add: (expr name = 'self' - ifTrue: [#void] - ifFalse: [ expr typeFrom: codeGenerator in: method ])) == #sqInt ifTrue: - [^true]]]. - expr isConstant ifTrue: - [(expr value isInteger and: [expr value >= 0]) "cannot determine if signed or unsigned yet..." - ifTrue: [typeSet add: expr value] - ifFalse: - [(expr typeOrNilFrom: codeGenerator in: method) ifNotNil: - [:type | typeSet add: type]]]. - ^false + ^ false ] ]. + expr isVariable ifTrue: [ + (codeGenerator typeOfVariable: expr name) + ifNotNil: [ :type | typeSet add: type ] + ifNil: [ + (typeSet add: (expr name = 'self' + ifTrue: [ #void ] + ifFalse: [ expr typeFrom: codeGenerator in: method ])) + == #sqInt ifTrue: [ ^ true ] ] ]. + expr isConstant ifTrue: [ + (expr value isInteger and: [ expr value >= 0 ]) + ifTrue: [ typeSet add: expr value ] + ifFalse: [ + (expr typeOrNilFrom: codeGenerator in: method) ifNotNil: [ :type | + typeSet add: type ] ] "cannot determine if signed or unsigned yet..." ]. + ^ false ] { #category : #accessing } @@ -219,8 +221,9 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ (aMethod locals includes: (var := node receiver variableNameOrNil)) and: [ (#( <= < >= > ) includes: node selector) and: [ - node args first isConstant and: [ node args first value = 0 ] ] ] ]) - ifTrue: [ mustBeSigned add: var ]. + node arguments first isConstant and: [ + node arguments first value = 0 ] ] ] ]) ifTrue: [ + mustBeSigned add: var ]. "if an assignment to an untyped local of a known type, set the local's type to that type. Only observe known sends (methods in the current set) and typed local variables." @@ -228,14 +231,16 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ (aMethod locals includes: (var := node variable name)) and: [ (alreadyExplicitlyTypedOrNotToBeTyped includes: var) not ] ]) ifTrue: [ "don't be fooled by previously inferred types" - type := self tryExtractTypeFromAssignmentNode: node inMethod: aMethod. + type := self + tryExtractTypeFromAssignmentNode: node + inMethod: aMethod. type ifNil: [ "Further, if the type derives from an as-yet-untyped method, we must defer." alreadyExplicitlyTypedOrNotToBeTyped add: var. (node expression isSend and: [ (codeGenerator methodNamed: node expression selector) notNil ]) ifTrue: [ newDeclarations removeKey: var ifAbsent: nil ] ] - ifNotNil: [ "Merge simple types (but *don't* merge untyped vars); complex types must be defined by the programmer." + ifNotNil: [ "Merge simple types (but *don't* merge untyped vars); complex types must be defined by the programmer.""If untyped, then cannot type the variable yet. A subsequent assignment may assign a subtype of what this type ends up being" (codeGenerator isSimpleType: type) ifTrue: [ (asYetUntyped includes: var) ifTrue: [ @@ -246,7 +251,7 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ mergeTypeOf: var in: newDeclarations with: type - method: aMethod ] ] ] "If untyped, then cannot type the variable yet. A subsequent assignment may assign a subtype of what this type ends up being" ] ]. + method: aMethod ] ] ] ] ]. mustBeSigned do: [ :var | diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index 69c3f73a5a..56f1a7f7d3 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -136,7 +136,7 @@ TAssignmentNode >> asCASTValueExpansionIn: aCodeGen [ ^ (TSendNode new setSelector: expression selector receiver: copy - arguments: expression args) asCASTIn: aCodeGen + arguments: expression arguments) asCASTIn: aCodeGen ] { #category : #transformations } @@ -167,6 +167,14 @@ TAssignmentNode >> bindVariablesIn: aDictionary [ expression := expression bindVariablesIn: aDictionary. ] +{ #category : #transformations } +TAssignmentNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + variable := variable bindVariablesIn: aDictionary unless: cautionaryBlock. + expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. +] + { #category : #accessing } TAssignmentNode >> expression [ diff --git a/smalltalksrc/Slang/TBraceCaseNode.class.st b/smalltalksrc/Slang/TBraceCaseNode.class.st index 36d4dd8db2..803c748389 100644 --- a/smalltalksrc/Slang/TBraceCaseNode.class.st +++ b/smalltalksrc/Slang/TBraceCaseNode.class.st @@ -37,6 +37,14 @@ TBraceCaseNode >> bindVariablesIn: aDictionary [ cases := cases collect: [:node| node bindVariablesIn: aDictionary] ] +{ #category : #transformations } +TBraceCaseNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + caseLabels := caseLabels collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock]. + cases := cases collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock] +] + { #category : #accessing } TBraceCaseNode >> caseLabels [ "Answer the value of caseLabels" diff --git a/smalltalksrc/Slang/TCaseStmtNode.class.st b/smalltalksrc/Slang/TCaseStmtNode.class.st index 36aed0e74a..9951c45503 100644 --- a/smalltalksrc/Slang/TCaseStmtNode.class.st +++ b/smalltalksrc/Slang/TCaseStmtNode.class.st @@ -133,6 +133,14 @@ TCaseStmtNode >> bindVariablesIn: aDictionary [ cases := cases collect: [ :c | c bindVariablesIn: aDictionary ]. ] +{ #category : #transformations } +TCaseStmtNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. + cases := cases collect: [ :c | c bindVariablesIn: aDictionary unless: cautionaryBlock ]. +] + { #category : #accessing } TCaseStmtNode >> cases [ diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 2933567744..1fd4c1e1e9 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -72,6 +72,13 @@ TExternalSendNode >> nodesDo: aBlock [ super nodesDo: aBlock ] +{ #category : #accessing } +TExternalSendNode >> nodesDo: aBlock parent: parent [ + + wrappedSendNode nodesDo: aBlock parent: self. + aBlock value: self value: parent +] + { #category : #accessing } TExternalSendNode >> variableBindings [ ^ variableBindings diff --git a/smalltalksrc/Slang/TInlineNode.class.st b/smalltalksrc/Slang/TInlineNode.class.st index 47c650c53f..3d0d2ff657 100644 --- a/smalltalksrc/Slang/TInlineNode.class.st +++ b/smalltalksrc/Slang/TInlineNode.class.st @@ -38,6 +38,14 @@ TInlineNode >> bindVariablesIn: aDictionary [ ] +{ #category : #transformations } +TInlineNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + method := method bindVariablesIn: aDictionary unless: cautionaryBlock. + +] + { #category : #testing } TInlineNode >> isInline [ ^true diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index ebe5d81f71..3d5a69ee6d 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -161,7 +161,7 @@ TMethod >> allReferencedVariablesUsing: aCodeGen [ nodesWithParentsDo: [:node :parent| node isVariable ifTrue: [refs add: node name asString]. - node isStmtList ifTrue: [refs addAll: node args]. + node isStmtList ifTrue: [ node args ifNotNil: [ refs addAll: node args ]]. (node isSend and: [node selector value beginsWith: #cCode:]) ifTrue: [aCodeGen addVariablesInVerbatimCIn: node to: refs]] @@ -183,7 +183,7 @@ TMethod >> argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeG | stmtList substitutionDict argList | meth args size > (argList := aSendNode arguments) size ifTrue: [ self assert: (meth args first beginsWith: 'self_in_'). - argList := { aSendNode receiver } , aSendNode args ]. + argList := { aSendNode receiver } , aSendNode arguments ]. stmtList := OrderedCollection new: argList size. substitutionDict := Dictionary new: argList size. @@ -439,6 +439,14 @@ TMethod >> bindVariablesIn: constantDictionary [ parseTree := parseTree bindVariablesIn: constantDictionary. ] +{ #category : #transformations } +TMethod >> bindVariablesIn: constantDictionary unless: cautionaryBlock [ + "Class variables are used as constants. This method replaces all references to class variables in the body of this method with the corresponding constant looked up in the class pool dictionary of the source class. The source class class variables should be initialized before this method is called." + + (cautionaryBlock value: self) ifTrue: [^self]. + parseTree := parseTree bindVariablesIn: constantDictionary unless: cautionaryBlock. +] + { #category : #transformations } TMethod >> buildCaseStmt: aSendNode in: aCodeGen [ @@ -479,15 +487,20 @@ TMethod >> buildCaseStmt: aSendNode in: aCodeGen [ { #category : #transformations } TMethod >> buildSwitchStmt: aSendNode parent: parentNode [ + "Build a switch statement node for the given send of caseOf: or caseOf:otherwise:." + | switch | switch := TSwitchStmtNode new - expression: aSendNode receiver - cases: aSendNode args first - otherwiseOrNil: (aSendNode args at: 2 ifAbsent: [nil]). - (aSendNode receiver isVariable or: [parentNode isStmtList]) ifFalse: - [switch switchVariable: (locals add: (self extraVariableName: 'switch'))]. - ^switch + expression: aSendNode receiver + cases: aSendNode arguments first + otherwiseOrNil: + (aSendNode arguments at: 2 ifAbsent: [ nil ]). + (aSendNode receiver isVariable or: [ parentNode isStmtList ]) + ifFalse: [ + switch switchVariable: + (locals add: (self extraVariableName: 'switch')) ]. + ^ switch ] { #category : #'inlining support' } @@ -639,16 +652,18 @@ TMethod >> declarations [ ] { #category : #'automatic-localization' } -TMethod >> declareNonConflictingLocalNamedLike: aString [ - - | maybeAllocatedName | - maybeAllocatedName := aString. - [locals includes: maybeAllocatedName] - whileTrue: [ maybeAllocatedName := maybeAllocatedName, '_' ]. - - "Found a unique name, declare it and return it" - self localizeVariables: {maybeAllocatedName}. - ^ maybeAllocatedName +TMethod >> declareNonConflictingLocalNamedLike: aString [ + + | definedVariables n newVarName | + definedVariables := (locals , args) asSet. + n := 1. + newVarName := aString. + [ definedVariables includes: newVarName ] whileTrue: [ + newVarName := aString , n printString. + n := n + 1 ]. + + locals add: newVarName. + ^ newVarName ] { #category : #testing } @@ -795,31 +810,39 @@ TMethod >> ensureConditionalAssignmentsAreTransformedIn: aCodeGen [ { #category : #transformations } TMethod >> ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen [ + "For both safety and efficiency, make sure that to:[by:]do: loops with complex limits have a variable to hold the limit expression. In C the limit expression is evaluated each time round the loop so if the loop has side-effects (which it usually will), the C compiler may not be able to optimize the limit expression itself." + | limitExpr hasSideEffects | - limitExpr := node args first. - hasSideEffects := limitExpr anySatisfy: - [:subNode| - subNode isSend - and: [(aCodeGen isBuiltinSelector: subNode selector) not - and: [(aCodeGen isStructSend: subNode) not]]]. - node args size = 4 - ifTrue: - [hasSideEffects - ifTrue: [locals add: node args last name] - ifFalse: [node arguments: node args allButLast]] - ifFalse: "If the expression is complex but as yet there is no limit variable, add it" - [hasSideEffects ifTrue: - [| var | - var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: locals. "N.B. adds it to locals!!" - node arguments: node args, {TVariableNode new setName: var; yourself}. - declarations - at: node args third args first - ifPresent: [:decl| self declarationAt: var put: (self typeFor: node args third args first in: aCodeGen), ' ', var]]] + limitExpr := node arguments first. + hasSideEffects := limitExpr anySatisfy: [ :subNode | + subNode isSend and: [ + (aCodeGen isBuiltinSelector: subNode selector) + not and: [ (aCodeGen isStructSend: subNode) not ] ] ]. + node arguments size = 4 + ifTrue: [ + hasSideEffects + ifTrue: [ locals add: node arguments last name ] + ifFalse: [ node arguments: node arguments allButLast ] ] + ifFalse: [ "If the expression is complex but as yet there is no limit variable, add it" + hasSideEffects ifTrue: [ + | var | + var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: locals. "N.B. adds it to locals!!" + node arguments: node arguments , { (TVariableNode new + setName: var; + yourself) }. + declarations + at: node arguments third args first + ifPresent: [ :decl | + self + declarationAt: var + put: + (self typeFor: node arguments third args first in: aCodeGen) + , ' ' , var ] ] ] ] { #category : #inlining } @@ -985,6 +1008,7 @@ TMethod >> extractExpandCaseDirective [ { #category : #transformations } TMethod >> extractExportDirective [ + "Scan the top-level statements for an inlining directive of the form: self export: @@ -992,10 +1016,10 @@ TMethod >> extractExportDirective [ and remove the directive from the method body. Answer the argument of the directive or false if there is no export directive." - ^self - extractDirective: #export: - valueBlock: [:sendNode| sendNode args first value ~= false] - default: false + ^ self + extractDirective: #export: + valueBlock: [ :sendNode | sendNode arguments first value ~= false ] + default: false ] { #category : #'inlining support' } @@ -1047,6 +1071,7 @@ TMethod >> extractSharedCase [ { #category : #transformations } TMethod >> extractStaticDirective [ + "Scan the top-level statements for an inlining directive of the form: self static: @@ -1054,10 +1079,10 @@ TMethod >> extractStaticDirective [ and remove the directive from the method body. Answer the argument of the directive or true if there is no static directive." - ^self - extractDirective: #static: - valueBlock: [:sendNode| sendNode args first value ~= false] - default: (export or: [ self isAPIMethod ]) not + ^ self + extractDirective: #static: + valueBlock: [ :sendNode | sendNode arguments first value ~= false ] + default: (export or: [ self isAPIMethod ]) not ] { #category : #'primitive compilation' } @@ -1240,27 +1265,31 @@ TMethod >> inline: aBoolean [ { #category : #inlining } TMethod >> inlineBuiltin: aSendNode in: aCodeGen [ + | sel meth inlinedReplacement | - (aSendNode selector beginsWith: 'perform:') ifTrue: - [^self inlineFunctionCall: aSendNode asTransformedConstantPerform in: aCodeGen]. + (aSendNode selector beginsWith: 'perform:') ifTrue: [ + ^ self + inlineFunctionCall: aSendNode asTransformedConstantPerform + in: aCodeGen ]. sel := aSendNode receiver selector. meth := aCodeGen methodNamed: sel. - (meth notNil and: [meth inline == true]) ifFalse: [^nil]. - (meth isFunctionalIn: aCodeGen) ifTrue: - [inlinedReplacement := (aCodeGen methodNamed: aSendNode receiver selector) copy - inlineFunctionCall: aSendNode receiver - in: aCodeGen. - ^TSendNode new - setSelector: aSendNode selector - receiver: inlinedReplacement - arguments: aSendNode args copy]. - (self isInlineableConditional: aSendNode in: aCodeGen) ifTrue: - [^self inlineConditional: aSendNode in: aCodeGen]. - ^nil + (meth notNil and: [ meth inline == true ]) ifFalse: [ ^ nil ]. + (meth isFunctionalIn: aCodeGen) ifTrue: [ + inlinedReplacement := (aCodeGen methodNamed: + aSendNode receiver selector) copy + inlineFunctionCall: aSendNode receiver + in: aCodeGen. + ^ TSendNode new + setSelector: aSendNode selector + receiver: inlinedReplacement + arguments: aSendNode arguments copy ]. + (self isInlineableConditional: aSendNode in: aCodeGen) ifTrue: [ + ^ self inlineConditional: aSendNode in: aCodeGen ]. + ^ nil ] { #category : #inlining } -TMethod >> inlineCaseStatementBranchesIn: aCodeGen withLocalizationReplacements: replacementDictionary [ +TMethod >> inlineCaseStatementBranchesIn: aCodeGen [ parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ @@ -1269,11 +1298,8 @@ TMethod >> inlineCaseStatementBranchesIn: aCodeGen withLocalizationReplacements: (stmt := stmtNode statements first) isSend ifTrue: [ (meth := aCodeGen methodNamed: stmt selector) ifNotNil: [ (meth hasUnrenamableCCode not and: [ meth args isEmpty ]) - ifTrue: [ - self - inlineMethod: meth copy - inCaseStatement: stmtNode - withLocalizationReplacements: replacementDictionary ] ] ] ] ] ] + ifTrue: [ + self inlineMethod: meth copy inCaseStatement: stmtNode ] ] ] ] ] ] ] { #category : #inlining } @@ -1301,16 +1327,18 @@ TMethod >> inlineCodeOrNilForStatement: aNode returningNodes: returningNodes in: { #category : #inlining } TMethod >> inlineConditional: aSendNode in: aCodeGen [ + "If possible answer the inlining of a conditional, otherwise answer nil. Currently the only pattern we support is aSend ifTrue:/ifFalse: [...] where aSend is marked inline and always answers booleans." + self assert: (self isInlineableConditional: aSendNode in: aCodeGen). - self assert: aSendNode args first isStmtList. - ^(aSendNode args first statements size = 1 - and: [aSendNode args first statements first isReturn]) - ifTrue: [self inlineReturningConditional: aSendNode in: aCodeGen] - ifFalse: [self inlineGuardingConditional: aSendNode in: aCodeGen] + self assert: aSendNode arguments first isStmtList. + ^ (aSendNode arguments first statements size = 1 and: [ + aSendNode arguments first statements first isReturn ]) + ifTrue: [ self inlineReturningConditional: aSendNode in: aCodeGen ] + ifFalse: [ self inlineGuardingConditional: aSendNode in: aCodeGen ] ] { #category : #inlining } @@ -1353,54 +1381,60 @@ TMethod >> inlineFunctionCall: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineGuardingConditional: aSendNode in: aCodeGen [ + "Inline aSend ifTrue:/ifFalse: [statements] where aSend is inlineable and always answers booleans. We convert the boolean returns in aSend to jumps." + | evaluateIfTrue replacementTree map lastNode evaluateLabel skipLabel method | self assert: self == aCodeGen currentMethod. self assert: (self isInlineableConditional: aSendNode in: aCodeGen). aCodeGen maybeBreakForInlineOf: aSendNode in: self. evaluateIfTrue := aSendNode selector = #ifTrue:. method := (aCodeGen methodNamed: aSendNode receiver selector) copy. - replacementTree := method inlineFunctionCall: aSendNode receiver in: aCodeGen. + replacementTree := method + inlineFunctionCall: aSendNode receiver + in: aCodeGen. map := Dictionary new. - (replacementTree statements last isReturn - and: [replacementTree statements last expression value = evaluateIfTrue]) ifTrue: - [lastNode := replacementTree statements last]. + (replacementTree statements last isReturn and: [ + replacementTree statements last expression value = evaluateIfTrue ]) + ifTrue: [ lastNode := replacementTree statements last ]. skipLabel := TLabeledCommentNode new setLabel: - (self unusedLabelForInlining: method). - replacementTree nodesDo: - [:node| | expr | - node isReturn ifTrue: - [expr := node expression. - self assert: (expr isConstant and: [#(true false) includes: expr value]). - map - at: node - put: (expr value ~~ evaluateIfTrue - ifTrue: [TGoToNode label: skipLabel label] - ifFalse: - [node == lastNode - ifTrue: [TLabeledCommentNode new setComment: 'end ', aSendNode receiver selector, '; fall through'] - ifFalse: - [evaluateLabel ifNil: - [evaluateLabel := TLabeledCommentNode new setLabel: - (self unusedLabelForInlining: method)]. - TGoToNode label: evaluateLabel label]])]]. + (self unusedLabelForInlining: method). + replacementTree nodesDo: [ :node | + | expr | + node isReturn ifTrue: [ + expr := node expression. + self assert: + (expr isConstant and: [ #( true false ) includes: expr value ]). + map at: node put: (expr value ~~ evaluateIfTrue + ifTrue: [ TGoToNode label: skipLabel label ] + ifFalse: [ + node == lastNode + ifTrue: [ + TLabeledCommentNode new setComment: + 'end ' , aSendNode receiver selector , '; fall through' ] + ifFalse: [ + evaluateLabel ifNil: [ + evaluateLabel := TLabeledCommentNode new setLabel: + (self unusedLabelForInlining: method) ]. + TGoToNode label: evaluateLabel label ] ]) ] ]. replacementTree replaceNodesIn: map. - replacementTree comment: {'inline ', aSendNode receiver selector}. + replacementTree comment: + { ('inline ' , aSendNode receiver selector) }. self addVarsDeclarationsAndLabelsOf: method except: method args. - ^TStmtListNode new - setArguments: #() - statements: - (evaluateLabel - ifNil: [replacementTree statements, aSendNode args first statements, {skipLabel}] - ifNotNil: - [replacementTree statements, {evaluateLabel}, aSendNode args first statements, {skipLabel}]) + ^ TStmtListNode new setArguments: #( ) statements: (evaluateLabel + ifNil: [ + replacementTree statements + , aSendNode arguments first statements , { skipLabel } ] + ifNotNil: [ + replacementTree statements , { evaluateLabel } + , aSendNode arguments first statements , { skipLabel } ]) ] { #category : #inlining } -TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacements: replacementDictionary [ +TMethod >> inlineMethod: meth inCaseStatement: stmtNode [ | exitLabel newStatements | "Perform the main inlining" @@ -1426,55 +1460,62 @@ TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacem { #category : #inlining } TMethod >> inlineReturningConditional: aSendNode in: aCodeGen [ + "Inline aSend ifTrue:/ifFalse: [^expr] where aSend is inlineable and always answers booleans. We inline ^expr into aSend." + | returnIfTrue returnNode replacementTree map lastNode label method | self assert: self == aCodeGen currentMethod. self assert: (self isInlineableConditional: aSendNode in: aCodeGen). aCodeGen maybeBreakForInlineOf: aSendNode receiver in: self. returnIfTrue := aSendNode selector = #ifTrue:. - returnNode := aSendNode args first. + returnNode := aSendNode arguments first. method := (aCodeGen methodNamed: aSendNode receiver selector) copy. - replacementTree := method inlineFunctionCall: aSendNode receiver in: aCodeGen. + replacementTree := method + inlineFunctionCall: aSendNode receiver + in: aCodeGen. map := Dictionary new. "The last node is either a return or a boolean constant." lastNode := replacementTree statements last. replacementTree statements last isReturn - ifTrue: - [replacementTree statements last expression value == returnIfTrue ifTrue: - [lastNode := nil "i.e. take the fall-through path and /don't/ return"]] - ifFalse: - [self assert: (lastNode isConstant and: [#(true false) includes: lastNode value]). - lastNode value == returnIfTrue ifTrue: "i.e. /do/ return" - [map at: lastNode put: returnNode]]. - replacementTree nodesDo: - [:node| | expr | - node isReturn ifTrue: - [expr := node expression. - self assert: (expr isConstant and: [#(true false) includes: expr value]). - map - at: node - put: (expr value == returnIfTrue - ifTrue: [returnNode] - ifFalse: - [node == lastNode - ifTrue: [TLabeledCommentNode new setComment: 'end ', aSendNode receiver selector, '; fall through'] - ifFalse: - [label ifNil: - [label := TLabeledCommentNode new setLabel: - (self unusedLabelForInlining: method)]. - TGoToNode label: label label]])]]. + ifTrue: [ + replacementTree statements last expression value == returnIfTrue + ifTrue: [ + lastNode := nil "i.e. take the fall-through path and /don't/ return" ] ] + ifFalse: [ + self assert: + (lastNode isConstant and: [ + #( true false ) includes: lastNode value ]). + lastNode value == returnIfTrue ifTrue: [ "i.e. /do/ return" + map at: lastNode put: returnNode ] ]. + replacementTree nodesDo: [ :node | + | expr | + node isReturn ifTrue: [ + expr := node expression. + self assert: + (expr isConstant and: [ #( true false ) includes: expr value ]). + map at: node put: (expr value == returnIfTrue + ifTrue: [ returnNode ] + ifFalse: [ + node == lastNode + ifTrue: [ + TLabeledCommentNode new setComment: + 'end ' , aSendNode receiver selector , '; fall through' ] + ifFalse: [ + label ifNil: [ + label := TLabeledCommentNode new setLabel: + (self unusedLabelForInlining: method) ]. + TGoToNode label: label label ] ]) ] ]. replacementTree replaceNodesIn: map. self addVarsDeclarationsAndLabelsOf: method except: method args. - replacementTree comment: {'inline ', aSendNode receiver selector}. - ^label - ifNil: [replacementTree] - ifNotNil: - [TStmtListNode new - setArguments: #() - statements: {replacementTree. label}] + replacementTree comment: + { ('inline ' , aSendNode receiver selector) }. + ^ label ifNil: [ replacementTree ] ifNotNil: [ + TStmtListNode new setArguments: #( ) statements: { + replacementTree. + label } ] ] { #category : #inlining } @@ -1570,24 +1611,25 @@ TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: { #category : #inlining } TMethod >> inlineableFunctionCall: aNode in: aCodeGen [ + "Answer if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted." aCodeGen maybeBreakForTestToInline: aNode in: self. - aNode isSend ifFalse: - [^false]. - ^(aCodeGen methodNamed: aNode selector) - ifNil: - [aNode asTransformedConstantPerform - ifNil: [self isInlineableConditional: aNode in: aCodeGen] - ifNotNil: [:n| self inlineableFunctionCall: n in: aCodeGen]] - ifNotNil: - [:m| - (m ~~ self - and: [((m isFunctionalIn: aCodeGen) or: [m mustBeInlined and: [m isComplete]]) - and: [m mayBeInlined - and: [(aCodeGen mayInline: m selector) - and: [aNode args allSatisfy: [:a| self isSubstitutableNode: a intoMethod: m in: aCodeGen]]]]]) - or: [m checkForRequiredInlinability]] + aNode isSend ifFalse: [ ^ false ]. + ^ (aCodeGen methodNamed: aNode selector) + ifNil: [ + aNode asTransformedConstantPerform + ifNil: [ self isInlineableConditional: aNode in: aCodeGen ] + ifNotNil: [ :n | self inlineableFunctionCall: n in: aCodeGen ] ] + ifNotNil: [ :m | + (m ~~ self and: [ + ((m isFunctionalIn: aCodeGen) or: [ + m mustBeInlined and: [ m isComplete ] ]) and: [ + m mayBeInlined and: [ + (aCodeGen mayInline: m selector) and: [ + aNode arguments allSatisfy: [ :a | + self isSubstitutableNode: a intoMethod: m in: aCodeGen ] ] ] ] ]) + or: [ m checkForRequiredInlinability ] ] ] { #category : #inlining } @@ -1667,21 +1709,25 @@ TMethod >> isComplete [ { #category : #inlining } TMethod >> isConditionalToBeTransformedForAssignment: aSend in: aCodeGen [ + "Answer if a send is of the form e1 ifTrue: [e2 ifTrue: [self m1] ifFalse: [self m2]] ifFalse: [self m3] such that at least one of the sends mN may be inlined.." - ^(#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: aSend selector) - and: [aSend args anySatisfy: - [:arg| | stmt | - self assert: arg isStmtList. - arg statements size > 1 - or: [(stmt := arg statements first) isSwitch - or: [stmt isSend - and: [(aCodeGen mayInline: stmt selector) - or: [self isConditionalToBeTransformedForAssignment: stmt in: aCodeGen]]]]]] + ^ (#( #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: aSend selector) + and: [ + aSend arguments anySatisfy: [ :arg | + | stmt | + self assert: arg isStmtList. + arg statements size > 1 or: [ + (stmt := arg statements first) isSwitch or: [ + stmt isSend and: [ + (aCodeGen mayInline: stmt selector) or: [ + self + isConditionalToBeTransformedForAssignment: stmt + in: aCodeGen ] ] ] ] ] ] ] { #category : #inlining } @@ -2745,6 +2791,7 @@ TMethod >> statementsFor: sourceText varName: varName [ { #category : #inlining } TMethod >> statementsListsForInliningIn: aCodeGen [ + "Answer a collection of statement list nodes that are candidates for inlining. Currently, we cannot inline into the argument blocks of and: and or: messages. We do not want to inline code strings within cCode:inSmalltalk: blocks (those with a @@ -2754,46 +2801,43 @@ TMethod >> statementsListsForInliningIn: aCodeGen [ | stmtLists | stmtLists := OrderedCollection new: 10. parseTree - nodesDo: - [:node| - node isStmtList ifTrue: [stmtLists add: node]] - unless: - [:node| - node isSend - and: [node selector == #cCode:inSmalltalk: - or: [aCodeGen isAssertSelector: node selector]]]. - parseTree nodesDo: - [:node| - node isSend ifTrue: - [node selector = #cCode:inSmalltalk: ifTrue: - [node nodesDo: - [:ccisNode| stmtLists remove: ccisNode ifAbsent: []]]. - (node selector = #cppIf:ifTrue:ifFalse: or: [node selector = #cppIf:ifTrue:]) ifTrue: - [node args first nodesDo: - [:inCondNode| stmtLists remove: inCondNode ifAbsent: []]]. - ((node selector = #and:) or: [node selector = #or:]) ifTrue: - "Note: the PP 2.3 compiler produces two arg nodes for these selectors" - [stmtLists remove: node args first ifAbsent: []. - stmtLists remove: node args last ifAbsent: []]. - (#( #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: - #ifNil: #ifNotNil: #ifNil:ifNotNil: #ifNotNil:ifNil: ) includes: node selector) ifTrue: - [stmtLists remove: node receiver ifAbsent: []]. - (#(whileTrue whileTrue: whilefalse whileFalse:) includes: node selector) ifTrue: - "Allow inlining if it is a [...] whileTrue/whileFalse. + nodesDo: [ :node | node isStmtList ifTrue: [ stmtLists add: node ] ] + unless: [ :node | + node isSend and: [ + node selector == #cCode:inSmalltalk: or: [ + aCodeGen isAssertSelector: node selector ] ] ]. + parseTree nodesDo: [ :node | + node isSend ifTrue: [ + node selector = #cCode:inSmalltalk: ifTrue: [ + node nodesDo: [ :ccisNode | + stmtLists remove: ccisNode ifAbsent: [ ] ] ]. + (node selector = #cppIf:ifTrue:ifFalse: or: [ + node selector = #cppIf:ifTrue: ]) ifTrue: [ + node arguments first nodesDo: [ :inCondNode | + stmtLists remove: inCondNode ifAbsent: [ ] ] ]. + (node selector = #and: or: [ node selector = #or: ]) ifTrue: [ "Note: the PP 2.3 compiler produces two arg nodes for these selectors" + stmtLists remove: node arguments first ifAbsent: [ ]. + stmtLists remove: node arguments last ifAbsent: [ ] ]. + (#( #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: + #ifNil: #ifNotNil: #ifNil:ifNotNil: #ifNotNil:ifNil: ) + includes: node selector) ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ] ]. + (#( whileTrue whileTrue: whilefalse whileFalse: ) includes: + node selector) ifTrue: [ "Allow inlining if it is a [...] whileTrue/whileFalse. This is identified by having more than one statement in the receiver block in which case the C code wouldn't work anyways" - [node receiver statements size = 1 ifTrue: - [stmtLists remove: node receiver ifAbsent: []]]. - (node selector = #to:do:) ifTrue: - [stmtLists remove: node receiver ifAbsent: []. - stmtLists remove: node args first ifAbsent: []]. - (node selector = #to:by:do:) ifTrue: - [stmtLists remove: node receiver ifAbsent: []. - stmtLists remove: node args first ifAbsent: []. - stmtLists remove: node args second ifAbsent: []]]. - node isCaseStmt ifTrue: "don't inline cases" - [node cases do: [:case| stmtLists remove: case ifAbsent: []]]]. - ^stmtLists + node receiver statements size = 1 ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ] ] ]. + node selector = #to:do: ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ]. + stmtLists remove: node args first ifAbsent: [ ] ]. + node selector = #to:by:do: ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ]. + stmtLists remove: node arguments first ifAbsent: [ ]. + stmtLists remove: node arguments second ifAbsent: [ ] ] ]. + node isCaseStmt ifTrue: [ "don't inline cases" + node cases do: [ :case | stmtLists remove: case ifAbsent: [ ] ] ] ]. + ^ stmtLists ] { #category : #accessing } @@ -2861,6 +2905,7 @@ TMethod >> terminateConditionalDefineFor: compileTimeOptionPragmas on: aStream [ { #category : #inlining } TMethod >> transformConditionalAssignment: node in: aCodeGen [ + "If possible answer the transformation of code of the form var := e1 ifTrue: [e2 ifTrue: [self m1] ifFalse: [self m2]] @@ -2872,15 +2917,17 @@ TMethod >> transformConditionalAssignment: node in: aCodeGen [ to allow inlining of m1, m2, et al. Otherwise answer nil." | expr | - ^(node isAssignment - and: [(expr := node expression) isSend - and: [(#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: expr selector) - and: [self isConditionalToBeTransformedForAssignment: expr in: aCodeGen]]]) ifTrue: - [expr copy - arguments: - (expr args collect: - [:stmtList| stmtList copy assignLastExpressionTo: node variable]); - yourself] + ^ (node isAssignment and: [ + (expr := node expression) isSend and: [ + (#( #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: expr selector) + and: [ + self + isConditionalToBeTransformedForAssignment: expr + in: aCodeGen ] ] ]) ifTrue: [ + expr copy + arguments: (expr arguments collect: [ :stmtList | + stmtList copy assignLastExpressionTo: node variable ]); + yourself ] ] { #category : #inlining } @@ -3008,45 +3055,49 @@ TMethod >> tryToInlineMethodExpressionsIn: aCodeGen [ { #category : #inlining } TMethod >> tryToInlineMethodStatementsIn: aCodeGen statementListsInto: aBlock [ + "Expand any (complete) inline methods sent by this method as top-level statements. Answer if anything was inlined." | stmtLists didSomething newStatements returningNodes | didSomething := false. returningNodes := Set new. - parseTree nodesDo: - [:node| - node isReturn ifTrue: - [returningNodes add: node expression. - node expression isConditionalSend ifTrue: - [returningNodes addAll: (node expression args collect: [:stmtList| stmtList statements last])]]]. + parseTree nodesDo: [ :node | + node isReturn ifTrue: [ + returningNodes add: node expression. + node expression isConditionalSend ifTrue: [ + returningNodes addAll: + (node expression arguments collect: [ :stmtList | + stmtList statements last ]) ] ] ]. stmtLists := self statementsListsForInliningIn: aCodeGen. - stmtLists do: - [:stmtList| + stmtLists do: [ :stmtList | newStatements := OrderedCollection new: stmtList statements size. - stmtList statements do: - [:stmt| - (self inlineCodeOrNilForStatement: stmt returningNodes: returningNodes in: aCodeGen) - ifNil: [newStatements addLast: stmt] - ifNotNil: [:inlinedStmts| + stmtList statements do: [ :stmt | + (self + inlineCodeOrNilForStatement: stmt + returningNodes: returningNodes + in: aCodeGen) + ifNil: [ newStatements addLast: stmt ] + ifNotNil: [ :inlinedStmts | didSomething := true. - newStatements addAllLast: inlinedStmts]]. - stmtList setStatements: newStatements asArray]. + newStatements addAllLast: inlinedStmts ] ]. + stmtList setStatements: newStatements asArray ]. "This is a hack; forgive me. The inlining above tends to keep return statements in statement lists. In the case of returning ifs we don't want the returns in case the returning if is generated as an expression." - returningNodes do: - [:returningNode| - (returningNode isConditionalSend - and: [returningNode args anySatisfy: [:alternativeNode| alternativeNode endsWithReturn]]) ifTrue: - [returningNode args withIndexDo: - [:alternativeNode :index| - alternativeNode endsWithReturn ifTrue: - [returningNode args at: index put: alternativeNode copyWithoutReturn]]]]. + returningNodes do: [ :returningNode | + (returningNode isConditionalSend and: [ + returningNode arguments anySatisfy: [ :alternativeNode | + alternativeNode endsWithReturn ] ]) ifTrue: [ + returningNode arguments withIndexDo: [ :alternativeNode :index | + alternativeNode endsWithReturn ifTrue: [ + returningNode arguments + at: index + put: alternativeNode copyWithoutReturn ] ] ] ]. aBlock value: stmtLists. - ^didSomething + ^ didSomething ] { #category : #inlining } @@ -3138,15 +3189,13 @@ TMethod >> usedVariablesCache [ { #category : #inlining } TMethod >> usesVariableUninlinably: argName in: aCodeGen [ - ^parseTree anySatisfy: - [:node| - node isSend - and: [(aCodeGen isAssertSelector: node selector) - and: [node args anySatisfy: - [:argNode| - argNode anySatisfy: - [:subNode| - subNode isVariable and: [subNode name = argName]]]]]] + + ^ parseTree anySatisfy: [ :node | + node isSend and: [ + (aCodeGen isAssertSelector: node selector) and: [ + node arguments anySatisfy: [ :argNode | + argNode anySatisfy: [ :subNode | + subNode isVariable and: [ subNode name = argName ] ] ] ] ] ] ] { #category : #utilities } diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index 7b71f8db8e..46200d9897 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -111,6 +111,12 @@ TParseNode >> bindVariablesIn: aDictionary [ ^self ] +{ #category : #transformations } +TParseNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + ^self +] + { #category : #enumerating } TParseNode >> collect: aBlock [ | nodes | diff --git a/smalltalksrc/Slang/TReturnNode.class.st b/smalltalksrc/Slang/TReturnNode.class.st index f261e73aa8..e8c060a1b8 100644 --- a/smalltalksrc/Slang/TReturnNode.class.st +++ b/smalltalksrc/Slang/TReturnNode.class.st @@ -86,6 +86,13 @@ TReturnNode >> bindVariablesIn: aDictionary [ expression := expression bindVariablesIn: aDictionary. ] +{ #category : #transformations } +TReturnNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. +] + { #category : #transformations } TReturnNode >> copyWithoutReturn [ ^expression diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index a253b69eba..4c32b6b748 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -243,6 +243,14 @@ TSendNode >> bindVariablesIn: aDictionary [ arguments := arguments collect: [ :a | a bindVariablesIn: aDictionary ]. ] +{ #category : #transformations } +TSendNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + receiver := receiver bindVariablesIn: aDictionary unless: cautionaryBlock. + arguments := arguments collect: [ :a | a bindVariablesIn: aDictionary unless: cautionaryBlock]. +] + { #category : #accessing } TSendNode >> constantNumbericValueIfAtAllPossibleOrNilIn: aCCodeGen [ "This is a version of constantNumbericValueOrNil for type checking rather than code generation. @@ -348,15 +356,14 @@ TSendNode >> isReturningIf [ { #category : #comparing } TSendNode >> isSameAs: aTParseNode [ - (aTParseNode isSend - and: [selector == aTParseNode selector - and: [receiver isSameAs: aTParseNode receiver]]) ifFalse: - [^false]. - arguments with: aTParseNode args do: - [:a :b| - (a isSameAs: b) ifFalse: - [^false]]. - ^true + + (aTParseNode isSend and: [ + selector == aTParseNode selector and: [ + receiver isSameAs: aTParseNode receiver ] ]) ifFalse: [ ^ false ]. + arguments + with: aTParseNode arguments + do: [ :a :b | (a isSameAs: b) ifFalse: [ ^ false ] ]. + ^ true ] { #category : #'C code generation' } diff --git a/smalltalksrc/Slang/TStmtListNode.class.st b/smalltalksrc/Slang/TStmtListNode.class.st index 96c8443208..74510431a3 100644 --- a/smalltalksrc/Slang/TStmtListNode.class.st +++ b/smalltalksrc/Slang/TStmtListNode.class.st @@ -29,67 +29,72 @@ TStmtListNode >> = aNode [ { #category : #utilities } TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ + "Add any variables in variables that are read before written to readBeforeAssigned. Add unconditional assignments to assigned. For convenience answer assigned." + self - nodesWithParentsDo: - [:node :parent| - (node isAssignment - and: [variables includes: node variable name]) ifTrue: - [assigned add: node variable name]. - (node isVariable - and: [(variables includes: node name) - and: [(assigned includes: node name) not - and: [(#(nil pointer) includes: (node structTargetKindIn: aCodeGen)) - and: [(parent notNil and: [parent isAssignment and: [parent variable == node]]) not]]]]) ifTrue: - [node name = 'theCalloutState' ifTrue: - [self halt]. - readBeforeAssigned add: node name]] - unless: - [:node :parent| | conditionalAssignments mayHaveSideEffects | + nodesWithParentsDo: [ :node :parent | + (node isAssignment and: [ variables includes: node variable name ]) + ifTrue: [ assigned add: node variable name ]. + (node isVariable and: [ + (variables includes: node name) and: [ + (assigned includes: node name) not and: [ + (#( nil pointer ) includes: (node structTargetKindIn: aCodeGen)) + and: [ + (parent notNil and: [ + parent isAssignment and: [ parent variable == node ] ]) not ] ] ] ]) + ifTrue: [ + node name = 'theCalloutState' ifTrue: [ self halt ]. + readBeforeAssigned add: node name ] ] + unless: [ :node :parent | + | conditionalAssignments mayHaveSideEffects | node isSend - ifTrue: - ["First deal with implicit assignments..." - node isValueExpansion ifTrue: - [assigned addAll: node receiver args]. - (#(#'memcpy:_:_:' #'memmove:_:_:') includes: node selector) ifTrue: - [assigned add: (node args first detect: [:subnode| subnode isVariable]) name]. - (#(to:do: to:by:do:) includes: node selector) ifTrue: - [assigned addAll: (node args at: node selector numArgs) args. - mayHaveSideEffects := node args size = 4. "See TMethod>>prepareMethodIn:" - mayHaveSideEffects ifTrue: - [assigned add: node args last name]]. + ifTrue: [ "First deal with implicit assignments..." + node isValueExpansion ifTrue: [ + assigned addAll: node receiver args ]. + (#( #memcpy:_:_: #memmove:_:_: ) includes: node selector) + ifTrue: [ + assigned add: + (node arguments first detect: [ :subnode | subnode isVariable ]) + name ]. + (#( #to:do: #to:by:do: ) includes: node selector) ifTrue: [ + assigned addAll: (node arguments at: node selector numArgs) args. + mayHaveSideEffects := node arguments size = 4. "See TMethod>>prepareMethodIn:" + mayHaveSideEffects ifTrue: [ + assigned add: node arguments last name ] ]. "Then deal with read-before-written in the arms of conditionals..." - (#(ifTrue: ifFalse: ifNil: ifNotNil:) intersection: node selector keywords) notEmpty - ifTrue: - ["First find assignments in the expression..." - (TStmtListNode new setStatements: {node receiver}; yourself) + (#( ifTrue: ifFalse: ifNil: ifNotNil: ) intersection: + node selector keywords) notEmpty + ifTrue: [ "First find assignments in the expression..." + (TStmtListNode new + setStatements: { node receiver }; + yourself) addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen. - "Now find read-before-written in each arm, and collect the assignments to spot those assigned in both arms" - conditionalAssignments := - node args - collect: - [:block| - block isStmtList ifTrue: - [block - addReadBeforeAssignedIn: variables - to: readBeforeAssigned - assignments: assigned copy - in: aCodeGen]] - thenSelect: [:each| each notNil]. - "add to assigned those variables written to in both arms" - conditionalAssignments size = 2 ifTrue: - [conditionalAssignments := conditionalAssignments collect: [:set| set difference: assigned]. - assigned addAll: (conditionalAssignments first intersection: conditionalAssignments last)]. - true] - ifFalse: - [false]] - ifFalse: - [false]]. - ^assigned + "Now find read-before-written in each arm, and collect the assignments to spot those assigned in both arms" + conditionalAssignments := node arguments + collect: [ :block | + block isStmtList ifTrue: [ + block + addReadBeforeAssignedIn: + variables + to: readBeforeAssigned + assignments: assigned copy + in: aCodeGen ] ] + thenSelect: [ :each | each notNil ]. + "add to assigned those variables written to in both arms" + conditionalAssignments size = 2 ifTrue: [ + conditionalAssignments := conditionalAssignments collect: [ + :set | set difference: assigned ]. + assigned addAll: (conditionalAssignments first intersection: + conditionalAssignments last) ]. + true ] + ifFalse: [ false ] ] + ifFalse: [ false ] ]. + ^ assigned ] { #category : #accessing } @@ -183,6 +188,13 @@ TStmtListNode >> bindVariablesIn: aDictionary [ statements := statements collect: [ :s | s bindVariablesIn: aDictionary ]. ] +{ #category : #transformations } +TStmtListNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + statements := statements collect: [ :s | s bindVariablesIn: aDictionary unless: cautionaryBlock]. +] + { #category : #enumerating } TStmtListNode >> children [ diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index f652ef9e48..2f971c4b3c 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -209,6 +209,19 @@ TSwitchStmtNode >> bindVariablesIn: aDictionary [ [otherwiseOrNil := otherwiseOrNil bindVariablesIn: aDictionary] ] +{ #category : #transformations } +TSwitchStmtNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. + cases := (cases collect: + [:pair| " with: TStmtListNode" + { pair first collect: [:labelNode| labelNode bindVariablesIn: aDictionary unless: cautionaryBlock]. + pair last bindVariablesIn: aDictionary unless: cautionaryBlock }]). + otherwiseOrNil ifNotNil: + [otherwiseOrNil := otherwiseOrNil bindVariablesIn: aDictionary unless: cautionaryBlock] +] + { #category : #accessing } TSwitchStmtNode >> cases [ "Answer the value of cases" diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index 4969799db5..245f76526e 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -49,6 +49,13 @@ TVariableNode >> bindVariablesIn: aDictionary [ ^ (aDictionary at: name ifAbsent: [^ self]) copy ] +{ #category : #transformations } +TVariableNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + ^ (aDictionary at: name ifAbsent: [^ self]) copy +] + { #category : #testing } TVariableNode >> hasSideEffect [ "Answer if the parse tree rooted at this node has a side-effect or not." From b9c2cf26e54bb08796123ed42d405a4c680d750f Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 14:13:48 +0200 Subject: [PATCH 18/75] Reformatting due to automatic deprecation of args->arguments --- .../MLAccessorDepthCalculator.class.st | 170 +++-- .../Melchor/MLVMCCodeGenerator.class.st | 3 +- .../Melchor/VMPluginCodeGenerator.class.st | 4 +- .../MockLocalizationInterpreterMock.class.st | 19 + .../SlangLocalizationTestCase.class.st | 8 +- smalltalksrc/Slang/CCodeGenerator.class.st | 668 ++++++++++-------- smalltalksrc/Slang/SlangTyper.class.st | 73 +- smalltalksrc/Slang/TAssignmentNode.class.st | 17 +- smalltalksrc/Slang/TExternalSendNode.class.st | 76 +- smalltalksrc/Slang/TMethod.class.st | 482 +++++++------ smalltalksrc/Slang/TParseNode.class.st | 14 - smalltalksrc/Slang/TSendNode.class.st | 17 +- smalltalksrc/Slang/TStmtListNode.class.st | 119 ++-- smalltalksrc/Slang/TVariableNode.class.st | 7 - 14 files changed, 931 insertions(+), 746 deletions(-) diff --git a/smalltalksrc/Melchor/MLAccessorDepthCalculator.class.st b/smalltalksrc/Melchor/MLAccessorDepthCalculator.class.st index 4f89ded752..ff21ebfe0e 100644 --- a/smalltalksrc/Melchor/MLAccessorDepthCalculator.class.st +++ b/smalltalksrc/Melchor/MLAccessorDepthCalculator.class.st @@ -17,6 +17,7 @@ MLAccessorDepthCalculator class >> forCodeGenerator: aCodeGenerator [ { #category : #'spur primitive compilation' } MLAccessorDepthCalculator >> accessorChainsForMethod: method interpreterClass: interpreterClass [ + "Answer a set of access paths from arguments through objects, in the method, assuming it is a primitive. This is in support of Spur's lazy become. A primitive may fail because it may encounter a forwarder. The primitive failure code needs to know to what depth it @@ -31,53 +32,61 @@ MLAccessorDepthCalculator >> accessorChainsForMethod: method interpreterClass: i has depth 2, since field is accessed, and field is an element of obj." | accessors assignments roots chains extendedChains extended lastPass | - self accessorsAndAssignmentsForMethod: method + self + accessorsAndAssignmentsForMethod: method actuals: (self actualsForMethod: method) depth: 0 interpreterClass: interpreterClass - into: [:theRoots :theAccessors :theAssignments| + into: [ :theRoots :theAccessors :theAssignments | roots := theRoots. accessors := theAccessors. - assignments := theAssignments]. + assignments := theAssignments ]. "Compute the transitive closure of assignments of accessor sends or variables to variables from the roots. Start from the stack accesses (the roots). On the last pass look only for accessors of the targets of the tip assignments." chains := OrderedCollection new. - roots do: [:root| chains addAll: (assignments - select: [:assignment| assignment expression = root] - thenCollect: [:assignment| OrderedCollection with: assignment])]. + roots do: [ :root | + chains addAll: (assignments + select: [ :assignment | assignment expression = root ] + thenCollect: [ :assignment | OrderedCollection with: assignment ]) ]. lastPass := false. - [extended := false. - extendedChains := OrderedCollection new: chains size * 2. - chains do: - [:chain| | tip refs accessorRefs variableRefs | + [ + extended := false. + extendedChains := OrderedCollection new: chains size * 2. + chains do: [ :chain | + | tip refs accessorRefs variableRefs | tip := chain last variable. - refs := accessors select: [:send| send args anySatisfy: [:arg| tip isSameAs: arg]]. - lastPass ifFalse: - [accessorRefs := refs collect: [:send| - assignments - detect: [:assignment| - assignment expression = send - and: [(chain includes: assignment) not]] - ifNone: []] - thenSelect: [:assignmentOrNil| assignmentOrNil notNil]. - variableRefs := assignments select: - [:assignment| - (tip isSameAs: assignment expression) - and: [(tip isSameAs: assignment variable) not - and: [(chain includes: assignment) not]]]. - refs := (Set withAll: accessorRefs) addAll: variableRefs; yourself]. + refs := accessors select: [ :send | + send arguments anySatisfy: [ :arg | tip isSameAs: arg ] ]. + lastPass ifFalse: [ + accessorRefs := refs + collect: [ :send | + assignments + detect: [ :assignment | + assignment expression = send and: [ + (chain includes: assignment) not ] ] + ifNone: [ ] ] + thenSelect: [ :assignmentOrNil | + assignmentOrNil notNil ]. + variableRefs := assignments select: [ :assignment | + (tip isSameAs: assignment expression) and: [ + (tip isSameAs: assignment variable) not and: [ + (chain includes: assignment) not ] ] ]. + refs := (Set withAll: accessorRefs) + addAll: variableRefs; + yourself ]. refs isEmpty - ifTrue: - [extendedChains add: chain] - ifFalse: - [lastPass ifFalse: [extended := true]. - self assert: (refs noneSatisfy: [:assignment| chain includes: assignment]). - extendedChains addAll: (refs collect: [:assignment| chain, {assignment}])]]. - extended or: [lastPass not]] whileTrue: - [chains := extendedChains. - extended ifFalse: [lastPass := true]]. - ^chains + ifTrue: [ extendedChains add: chain ] + ifFalse: [ + lastPass ifFalse: [ extended := true ]. + self assert: + (refs noneSatisfy: [ :assignment | chain includes: assignment ]). + extendedChains addAll: + (refs collect: [ :assignment | chain , { assignment } ]) ] ]. + extended or: [ lastPass not ] ] whileTrue: [ + chains := extendedChains. + extended ifFalse: [ lastPass := true ] ]. + ^ chains ] { #category : #'spur primitive compilation' } @@ -135,55 +144,60 @@ MLAccessorDepthCalculator >> accessorDepthForSelector: selector [ { #category : #'spur primitive compilation' } MLAccessorDepthCalculator >> accessorsAndAssignmentsForMethod: method actuals: actualParameters depth: depth interpreterClass: interpreterClass into: aTrinaryBlock [ + "Evaluate aTrinaryBlock with the root accessor sends, accessor sends and assignments in the method." + | accessors assignments roots | accessors := Set new. assignments := Set new. roots := Set new. - actualParameters with: method args do: - [:actual :argName| - (actual isVariable or: [actual isSend]) ifTrue: - [(actual isSend and: [self isStackAccessor: actual selector given: interpreterClass]) ifTrue: - [roots add: actual]. + actualParameters with: method args do: [ :actual :argName | + (actual isVariable or: [ actual isSend ]) ifTrue: [ + (actual isSend and: [ + self isStackAccessor: actual selector given: interpreterClass ]) + ifTrue: [ roots add: actual ]. assignments add: (TAssignmentNode new - setVariable: (TVariableNode new setName: argName) - expression: actual)]]. - method parseTree nodesDo: - [:node| - node isSend ifTrue: - [(self isStackAccessor: node selector given: interpreterClass) ifTrue: - [roots add: node]. - (self isObjectAccessor: node selector given: interpreterClass) ifTrue: - [accessors add: node]. - (self accessorDepthDeterminationFollowsSelfSends - and: [node receiver isVariable - and: [node receiver name = 'self' - and: [roots isEmpty - or: [node args anySatisfy: - [:arg| - (roots includes: arg) - or: [(accessors includes: arg) - or: [assignments anySatisfy: [:assignment| assignment variable isSameAs: arg]]]]]]]]) ifTrue: - [self accessorsAndAssignmentsForSubMethodNamed: node selector - actuals: node args - depth: depth + 1 - interpreterClass: interpreterClass - into: [:subRoots :subAccessors :subAssignments| - (subRoots isEmpty and: [subAccessors isEmpty and: [subAssignments isEmpty]]) ifFalse: - [roots addAll: subRoots. - accessors add: node. - accessors addAll: subAccessors. - assignments addAll: subAssignments]]]]. - (node isAssignment - and: [(node expression isSend and: [codeGenerator vmmakerConfiguration baseObjectMemoryManagerClass isTerminalObjectAccessor: node expression selector]) not - and: [(roots includes: node expression) - or: [(accessors includes: node expression) - or: [node expression isVariable and: [node expression name ~= 'nil']]]]]) ifTrue: - [assignments add: node]]. - ^aTrinaryBlock - value: roots - value: accessors - value: assignments + setVariable: (TVariableNode new setName: argName) + expression: actual) ] ]. + method parseTree nodesDo: [ :node | + node isSend ifTrue: [ + (self isStackAccessor: node selector given: interpreterClass) + ifTrue: [ roots add: node ]. + (self isObjectAccessor: node selector given: interpreterClass) + ifTrue: [ accessors add: node ]. + (self accessorDepthDeterminationFollowsSelfSends and: [ + node receiver isVariable and: [ + node receiver name = 'self' and: [ + roots isEmpty or: [ + node arguments anySatisfy: [ :arg | + (roots includes: arg) or: [ + (accessors includes: arg) or: [ + assignments anySatisfy: [ :assignment | + assignment variable isSameAs: arg ] ] ] ] ] ] ] ]) + ifTrue: [ + self + accessorsAndAssignmentsForSubMethodNamed: node selector + actuals: node arguments + depth: depth + 1 + interpreterClass: interpreterClass + into: [ :subRoots :subAccessors :subAssignments | + (subRoots isEmpty and: [ + subAccessors isEmpty and: [ subAssignments isEmpty ] ]) + ifFalse: [ + roots addAll: subRoots. + accessors add: node. + accessors addAll: subAccessors. + assignments addAll: subAssignments ] ] ] ]. + (node isAssignment and: [ + (node expression isSend and: [ + codeGenerator vmmakerConfiguration baseObjectMemoryManagerClass + isTerminalObjectAccessor: node expression selector ]) not and: [ + (roots includes: node expression) or: [ + (accessors includes: node expression) or: [ + node expression isVariable and: [ + node expression name ~= 'nil' ] ] ] ] ]) ifTrue: [ + assignments add: node ] ]. + ^ aTrinaryBlock value: roots value: accessors value: assignments ] { #category : #'spur primitive compilation' } diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index f7009eb056..3d8d8796f0 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -523,8 +523,9 @@ MLVMCCodeGenerator >> unusedConstants [ { #category : #'C code generator' } MLVMCCodeGenerator >> validateCppIf: nodeOrNil withValue: value [ + (self vmClass notNil and: [ - nodeOrNil args first isConstant and: [ + nodeOrNil arguments first isConstant and: [ value isSymbol and: [ (self vmClass defineAtCompileTime: value) not and: [ (self vmClass bindingOf: value) notNil ] ] ] ]) ifTrue: [ diff --git a/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st b/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st index e39913021e..082380428f 100644 --- a/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st +++ b/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st @@ -241,9 +241,9 @@ VMPluginCodeGenerator >> generateCASTRemapOopIn: aTSendNode [ ] { #category : #'CAST translation' } -VMPluginCodeGenerator >> generateCASTSpurRemapOopIn: aTSendNode [ +VMPluginCodeGenerator >> generateCASTSpurRemapOopIn: aTSendNode [ - ^ aTSendNode args second asCASTIn: self + ^ aTSendNode arguments second asCASTIn: self ] { #category : #'C translation' } diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 3d0dfdb16a..aa96af06ef 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -81,6 +81,18 @@ MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ ) ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeInliningSharedMethod [ + + self sharedMethod +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeNotInliningSharedMethod [ + + self sharedMethod +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeToInline [ @@ -251,3 +263,10 @@ MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable [ ^ autoLocalizedVariable ] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> sharedMethod [ + + + ^ 1 +] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 6c63348154..6b0cab88b0 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -140,8 +140,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning internalizationStatement := (ccg methodNamed: #interpret) statements first. self - assert: internalizationStatement - equals: (self internalizationOf: #autoLocalizedVariable) + assert: (internalizationStatement isSameAs: (self internalizationOf: #autoLocalizedVariable)) ] { #category : #tests } @@ -339,13 +338,12 @@ SlangLocalizationTestCase >> testLinearizationOfExternalCalls [ self assert: externalCall wrappedSendNode arguments first equals: argumentStatement variable. self - assert: argumentStatement expression - equals: (TAssignmentNode + assert: (argumentStatement expression isSameAs: (TAssignmentNode variableNamed: 'local_autoLocalizedVariable' expression:(TSendNode receiver: (TVariableNode named: 'local_autoLocalizedVariable') selector: #+ - arguments: { TConstantNode value: 1 } )) + arguments: { TConstantNode value: 1 } ))) ] { #category : #tests } diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index d75b73c528..584b2441d7 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -381,19 +381,21 @@ CCodeGenerator >> addStructMethodFor: aClass selector: selector [ { #category : #utilities } CCodeGenerator >> addVariablesInVerbatimCIn: aCCodeSendNode to: aCollection [ + "If aCCodeSendNode has a string argument, parse it and extract anything that looks like a variable, and add the resulting vars to aCollection." + | separators tokens | - (aCCodeSendNode isSend - and: [(aCCodeSendNode selector beginsWith: #cCode:) - and: [aCCodeSendNode args first isConstant - and: [aCCodeSendNode args first value isString]]]) ifFalse: - [^self]. - separators := (Character space to: 255 asCharacter) reject: - [:char| - char isLetter or: [char isDigit or: [char = $_]]]. - tokens := aCCodeSendNode args first value findTokens: separators. - aCollection addAll: (tokens select: [:token| token first isLetter]) asSet + (aCCodeSendNode isSend and: [ + (aCCodeSendNode selector beginsWith: #cCode:) and: [ + aCCodeSendNode arguments first isConstant and: [ + aCCodeSendNode arguments first value isString ] ] ]) ifFalse: [ + ^ self ]. + separators := (Character space to: 255 asCharacter) reject: [ :char | + char isLetter or: [ char isDigit or: [ char = $_ ] ] ]. + tokens := aCCodeSendNode arguments first value findTokens: separators. + aCollection addAll: + (tokens select: [ :token | token first isLetter ]) asSet ] { #category : #utilities } @@ -1718,8 +1720,8 @@ CCodeGenerator >> generateCASTBytesPerWord: tast [ CCodeGenerator >> generateCASTCCoercion: tast [ | expr cType literal | - expr := tast args first. - cType := tast args last value. + expr := tast arguments first. + cType := tast arguments last value. (cType = #float and: [ expr isConstant and: [ expr value isFloat and: [ @@ -2126,32 +2128,30 @@ CCodeGenerator >> generateCASTIfTrueIfFalseAsArgument: tast [ ] { #category : #'CAST translation' } -CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ +CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ - aTSendNode args first isConstant ifTrue: [ - "If it is a pre-processor declaration" - (aTSendNode args first value at: 1 ifAbsent: nil) = $# ifTrue: [ - "This was assuming the argument is a preprocessor directive. - So it was printing it in a new line" + aTSendNode arguments first isConstant ifTrue: [ "If it is a pre-processor declaration" + (aTSendNode arguments first value at: 1 ifAbsent: nil) = $# ifTrue: [ "This was assuming the argument is a preprocessor directive. + So it was printing it in a new line" self error: 'unsupported' ]. - - self noteVariableUsageInString: aTSendNode args first value. - ^ CRawCodeNode code: aTSendNode args first value ]. - ^ aTSendNode args first asCASTIn: self. + self noteVariableUsageInString: aTSendNode arguments first value. + ^ CRawCodeNode code: aTSendNode arguments first value ]. + + ^ aTSendNode args first asCASTIn: self ] { #category : #'CAST translation' } CCodeGenerator >> generateCASTInlineCCodeAsArgument: aTSendNode [ - (aTSendNode args first isConstant and: [ - aTSendNode args first value isString ]) ifTrue: [ "If it is a pre-processor declaration" - (aTSendNode args first value at: 1 ifAbsent: nil) = $# ifTrue: [ "This was assuming the argument is a preprocessor directive. + (aTSendNode arguments first isConstant and: [ + aTSendNode arguments first value isString ]) ifTrue: [ "If it is a pre-processor declaration" + (aTSendNode arguments first value at: 1 ifAbsent: nil) = $# ifTrue: [ "This was assuming the argument is a preprocessor directive. So it was printing it in a new line" self error: 'unsupported' ]. - self noteVariableUsageInString: aTSendNode args first value. - ^ CRawCodeNode code: aTSendNode args first value ]. + self noteVariableUsageInString: aTSendNode arguments first value. + ^ CRawCodeNode code: aTSendNode arguments first value ]. ^ aTSendNode args first asCASTExpressionIn: self ] @@ -2198,11 +2198,11 @@ CCodeGenerator >> generateCASTInlineCppIfElseAsArgument: tast [ ] { #category : #'built-ins' } -CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ - +CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ + | expr mustCastToUnsigned type typeIsUnsigned expressionToShift | - expr := msgNode args first. - + expr := msgNode arguments first. + expressionToShift := expr asCASTExpressionIn: self. "Note that the default type of an integer constant in C is int. Hence we /must/ @@ -2212,22 +2212,24 @@ CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ (long)(16r1FFFFF << 3) = (long) 16rFFFFFFF8 = 4294967288." type := self typeFor: expr in: currentMethod. typeIsUnsigned := type first = $u. - mustCastToUnsigned := typeIsUnsigned not - or: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqInt)]. - mustCastToUnsigned ifTrue: [ + mustCastToUnsigned := typeIsUnsigned not or: [ + (self sizeOfIntegralCType: type) + < (self sizeOfIntegralCType: #usqInt) ]. + mustCastToUnsigned ifTrue: [ expressionToShift := CCastExpressionNode - type: (CTypeNameNode symbol: #usqInt) - expression: expressionToShift ]. + type: (CTypeNameNode symbol: #usqInt) + expression: expressionToShift ]. ^ (CBinaryOperatorNode - operator: #| - left: (CBinaryOperatorNode - operator: #<< - left: expressionToShift - right: (CConstantNode value: self vmClass objectMemoryClass numSmallIntegerTagBits)) - right: (CConstantNode value: 1)) - needsParentheses: true; - yourself + operator: #| + left: (CBinaryOperatorNode + operator: #<< + left: expressionToShift + right: (CConstantNode value: + self vmClass objectMemoryClass numSmallIntegerTagBits)) + right: (CConstantNode value: 1)) + needsParentheses: true; + yourself ] { #category : #'CAST translation' } @@ -2240,26 +2242,29 @@ CCodeGenerator >> generateCASTIntegerValueOf: aTSendNode [ ] { #category : #'CAST translation' } -CCodeGenerator >> generateCASTIsIntegerObject: msgNode [ - - self vmClass objectMemoryClass numSmallIntegerTagBits = 1 - ifTrue: [ - ^ (CBinaryOperatorNode - operator: '&' - left: (msgNode args first asCASTExpressionIn: self) - right: (CConstantNode value: 1)) - needsParentheses: true; - yourself ]. - +CCodeGenerator >> generateCASTIsIntegerObject: msgNode [ + + self vmClass objectMemoryClass numSmallIntegerTagBits = 1 ifTrue: [ + ^ (CBinaryOperatorNode + operator: '&' + left: (msgNode arguments first asCASTExpressionIn: self) + right: (CConstantNode value: 1)) + needsParentheses: true; + yourself ]. + ^ (CBinaryOperatorNode - operator: '==' - left: (CBinaryOperatorNode - operator: '&' - left: ((msgNode args first asCASTExpressionIn: self) needsParentheses: true; yourself) - right: (CConstantNode value: 1 << self vmClass objectMemoryClass numSmallIntegerTagBits - 1)) - right: (CConstantNode value: 1)) - needsParentheses: true; - yourself + operator: '==' + left: (CBinaryOperatorNode + operator: '&' + left: ((msgNode arguments first asCASTExpressionIn: self) + needsParentheses: true; + yourself) + right: (CConstantNode value: + 1 << self vmClass objectMemoryClass numSmallIntegerTagBits + - 1)) + right: (CConstantNode value: 1)) + needsParentheses: true; + yourself ] { #category : #'CAST translation' } @@ -2311,15 +2316,15 @@ CCodeGenerator >> generateCASTMin: tast [ CCodeGenerator >> generateCASTMinus: tast [ "Constant fold if possible" - tast constantNumbericValueOrNil ifNotNil: [:value| - (value between: -1 << 31 and: 1 << 31 - 1) - ifFalse: [ ^ CConstantNode value: (self cLiteralFor: value) ] ]. - + + tast constantNumbericValueOrNil ifNotNil: [ :value | + (value between: -1 << 31 and: 1 << 31 - 1) ifFalse: [ + ^ CConstantNode value: (self cLiteralFor: value) ] ]. + "Simplify if possible" - tast args first constantNumbericValueOrNil ifNotNil: [:value| - value = 0 ifTrue: [ - ^ tast receiver asCASTExpressionIn: self ]]. - + tast arguments first constantNumbericValueOrNil ifNotNil: [ :value | + value = 0 ifTrue: [ ^ tast receiver asCASTExpressionIn: self ] ]. + "Otherwise, translate normally" ^ self generateCASTBinary: tast operator: #- ] @@ -2388,17 +2393,17 @@ CCodeGenerator >> generateCASTPerform: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTPlus: tast [ - + "Constant fold if possible" - tast constantNumbericValueOrNil ifNotNil: [:value| - (value between: -1 << 31 and: 1 << 31 - 1) - ifFalse: [ ^ CConstantNode value: (self cLiteralFor: value) ] ]. - + + tast constantNumbericValueOrNil ifNotNil: [ :value | + (value between: -1 << 31 and: 1 << 31 - 1) ifFalse: [ + ^ CConstantNode value: (self cLiteralFor: value) ] ]. + "Simplify if possible" - tast args first constantNumbericValueOrNil ifNotNil: [:value| - value = 0 ifTrue: [ - ^ tast receiver asCASTExpressionIn: self ]]. - + tast arguments first constantNumbericValueOrNil ifNotNil: [ :value | + value = 0 ifTrue: [ ^ tast receiver asCASTExpressionIn: self ] ]. + "Otherwise, translate normally" ^ self generateCASTBinary: tast operator: #+ ] @@ -2503,7 +2508,7 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ | finalNode leftNode receiverNode rcvr arg castToLong type mustCastBackToSign mustCastToUnsigned canSuffixTheConstant typeIsUnsigned | rcvr := tast receiver. - arg := tast args first. + arg := tast arguments first. castToLong := false. (rcvr constantNumbericValueIfAtAllPossibleOrNilIn: self) ifNotNil: [ :rcvrVal | @@ -2548,9 +2553,9 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ type: (CTypeNameNode symbol: unsigned) expression: receiverNode ]. finalNode := CBinaryOperatorNode - operator: #<< - left: leftNode - right: (arg asCASTIn: self). + operator: #<< + left: leftNode + right: (arg asCASTIn: self). mustCastBackToSign := typeIsUnsigned not. mustCastBackToSign ifTrue: [ | promotedType | @@ -2562,8 +2567,8 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ ifTrue: [ #sqInt ] ifFalse: [ type ] ]. finalNode := CCastExpressionNode - type: (CTypeNameNode symbol: promotedType) - expression: finalNode ]. + type: (CTypeNameNode symbol: promotedType) + expression: finalNode ]. ^ finalNode ] @@ -2704,19 +2709,18 @@ CCodeGenerator >> generateCASTSmalltalkMetaError: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTTimes: tast [ - + "Constant fold if possible" - tast constantNumbericValueOrNil ifNotNil: [:value| - (value between: -1 << 31 and: 1 << 31 - 1) - ifFalse: [ ^ CConstantNode value: (self cLiteralFor: value) ] ]. - + + tast constantNumbericValueOrNil ifNotNil: [ :value | + (value between: -1 << 31 and: 1 << 31 - 1) ifFalse: [ + ^ CConstantNode value: (self cLiteralFor: value) ] ]. + "Simplify if possible" - tast args first constantNumbericValueOrNil ifNotNil: [:value| - value = 0 ifTrue: [ - ^ tast args first asCASTExpressionIn: self ]. - value = 1 ifTrue: [ - ^ tast receiver asCASTExpressionIn: self ]]. - + tast arguments first constantNumbericValueOrNil ifNotNil: [ :value | + value = 0 ifTrue: [ ^ tast args first asCASTExpressionIn: self ]. + value = 1 ifTrue: [ ^ tast receiver asCASTExpressionIn: self ] ]. + "Otherwise, translate normally" ^ self generateCASTBinary: tast operator: #* ] @@ -2744,14 +2748,14 @@ CCodeGenerator >> generateCASTToByDo: tast [ self error: 'wrong number of block arguments' ]. inits := OrderedCollection new. iterationVar := blockExpr args first. - limitExpr := tast args first. + limitExpr := tast arguments first. inits add: (CAssignmentNode lvalue: (CIdentifierNode name: iterationVar) rvalue: (tast receiver asCASTExpressionIn: self)). self noteUsedVariableName: iterationVar. mayHaveSideEffects := tast arguments size = 4. mayHaveSideEffects ifTrue: [ - limitVar := tast args last. + limitVar := tast arguments last. inits add: (CAssignmentNode lvalue: (CIdentifierNode name: limitVar name) rvalue: (limitExpr asCASTExpressionIn: self)). @@ -2830,8 +2834,9 @@ CCodeGenerator >> generateCASTTouch: tast [ CCodeGenerator >> generateCASTTruncateTo: tast [ | arg | - (self isConstantNode: tast args first valueInto: [ :a | arg := a ]) - ifFalse: [ + (self + isConstantNode: tast arguments first + valueInto: [ :a | arg := a ]) ifFalse: [ self error: 'can''t find method for inlining truncateTo:' ]. self assert: (arg isInteger and: [ arg isPowerOfTwo ]). ^ (CBinaryOperatorNode @@ -2860,14 +2865,14 @@ CCodeGenerator >> generateCASTValue: tast [ | substitution substitutionDict newLabels castStatements | self assert: tast receiver isStmtList. - self assert: tast receiver args size = tast args size. + self assert: tast receiver args size = tast arguments size. castStatements := CCompoundStatementNode statements: OrderedCollection new. castStatements needsBrackets: false. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. - substitutionDict := Dictionary new: tast args size * 2. - tast receiver args with: tast args do: [ :argName :exprNode | + substitutionDict := Dictionary new: tast arguments size * 2. + tast receiver args with: tast arguments do: [ :argName :exprNode | exprNode isLeaf ifTrue: [ substitutionDict at: argName put: exprNode ] ifFalse: [ @@ -2892,14 +2897,15 @@ CCodeGenerator >> generateCASTValueAsArgument: tast [ "Reduce [:formal ... :formalN| body ] value: actual ... value: actualN to body with formals substituted for by actuals." + | substitution substitutionDict newLabels | self assert: tast receiver isStmtList. - self assert: tast receiver args size = tast args size. + self assert: tast receiver args size = tast arguments size. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. - substitutionDict := Dictionary new: tast args size * 2. + substitutionDict := Dictionary new: tast arguments size * 2. tast receiver args - with: tast args + with: tast arguments do: [ :argName :exprNode | substitutionDict at: argName put: exprNode ]. newLabels := Set withAll: currentMethod labels. @@ -2930,11 +2936,11 @@ CCodeGenerator >> generateCASTWhile: boolean loop: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTWhileFalse: tast [ - tast receiver statements size <= 1 - ifTrue: [^self generateCASTWhile: false loop: tast]. - tast args first isNilStmtListNode - ifTrue: [^self generateCASTDoWhileFalse: tast]. - ^self generateCASTWhileForeverBreakIf: true loop: tast + tast receiver statements size <= 1 ifTrue: [ + ^ self generateCASTWhile: false loop: tast ]. + tast arguments first isNilStmtListNode ifTrue: [ + ^ self generateCASTDoWhileFalse: tast ]. + ^ self generateCASTWhileForeverBreakIf: true loop: tast ] { #category : #'CAST translation' } @@ -2955,11 +2961,11 @@ CCodeGenerator >> generateCASTWhileForeverBreakIf: boolean loop: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTWhileTrue: tast [ - tast receiver statements size <= 1 - ifTrue: [^self generateCASTWhile: true loop: tast]. - tast args first isNilStmtListNode - ifTrue: [^self generateCASTDoWhileTrue: tast]. - ^self generateCASTWhileForeverBreakIf: false loop: tast + tast receiver statements size <= 1 ifTrue: [ + ^ self generateCASTWhile: true loop: tast ]. + tast arguments first isNilStmtListNode ifTrue: [ + ^ self generateCASTDoWhileTrue: tast ]. + ^ self generateCASTWhileForeverBreakIf: false loop: tast ] { #category : #accessing } @@ -3994,6 +4000,7 @@ CCodeGenerator >> needToGenerateHeader: headerName file: interpHdrPath contents: { #category : #utilities } CCodeGenerator >> nilOrBooleanConditionFor: nodeOrNil [ + "If nodeOrNil is one of the conditional sends for which we do translation-time dead code elimination (i.e. cppIf:ifTrue: et al or ifTrue: et al) and the conditional does evaluate to a translation-time boolean constant, answer that constant, otherwise answer nil. Used to prune dead code, @@ -4007,90 +4014,94 @@ CCodeGenerator >> nilOrBooleanConditionFor: nodeOrNil [ ^ self nilOrBooleanConstantReceiverOf: nodeOrNil receiver ]. (#( and: or: ) includes: nodeOrNil selector) ifTrue: [ ^ self nilOrBooleanConstantReceiverOf: nodeOrNil ]. - (#( #cppIf:ifTrue: #cppIf:ifTrue:ifFalse: ) includes: nodeOrNil selector) - ifTrue: [ + (#( #cppIf:ifTrue: #cppIf:ifTrue:ifFalse: ) includes: + nodeOrNil selector) ifTrue: [ | maybeName value | - value := nodeOrNil args first value. + value := nodeOrNil arguments first value. self validateCppIf: nodeOrNil withValue: value. - maybeName := nodeOrNil args first isConstant ifTrue: [ - nodeOrNil args first nameOrValue ]. + maybeName := nodeOrNil arguments first isConstant ifTrue: [ + nodeOrNil arguments first nameOrValue ]. ^ (optionsDictionary notNil and: [ - nodeOrNil args first isConstant and: [ + nodeOrNil arguments first isConstant and: [ (#( true false ) includes: (optionsDictionary at: maybeName ifAbsent: [ nil ])) and: [ - (self defineAtCompileTime: maybeName) not ] ] ]) - ifTrue: [ optionsDictionary at: nodeOrNil args first name ] ]. + (self defineAtCompileTime: maybeName) not ] ] ]) ifTrue: [ + optionsDictionary at: nodeOrNil arguments first name ] ]. ^ nil ] { #category : #utilities } CCodeGenerator >> nilOrBooleanConstantReceiverOf: aNode [ + "Answer nil or the boolean constant that is the receiver of the given message send. Used to suppress conditional code when the condition is a translation-time constant." | val receiver argument arms | - generateDeadCode ifTrue:[^nil]. - ((self isConstantNode: aNode valueInto: [:v| val := v]) - and: [#(true false) includes: val]) ifTrue: - [^val]. - aNode isSend ifTrue: - [aNode selector == #not ifTrue: - [(self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: - [:bool| ^bool not]]. - ((#(isNil notNil) includes: aNode selector) - and: [self isNilConstantReceiverOf: aNode]) ifTrue: - [^aNode selector == #isNil]. - ((#(or: and:) includes: aNode selector) - and: [aNode args last isStmtList - and: [aNode args last statements size = 1]]) ifTrue: - [(self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: - [:rcvr| - ((rcvr == false and: [aNode selector == #and:]) - or: [rcvr == true and: [aNode selector == #or:]]) ifTrue: - [^rcvr]. - (self nilOrBooleanConstantReceiverOf: aNode args last statements first) ifNotNil: - [:arg| - ^rcvr perform: aNode selector with: [arg]]]. - "We can also eliminate expr and: [false], expr or: [true], but only if expr is side-effect free. + generateDeadCode ifTrue: [ ^ nil ]. + ((self isConstantNode: aNode valueInto: [ :v | val := v ]) and: [ + #( true false ) includes: val ]) ifTrue: [ ^ val ]. + aNode isSend ifTrue: [ + aNode selector == #not ifTrue: [ + (self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: [ + :bool | ^ bool not ] ]. + ((#( isNil notNil ) includes: aNode selector) and: [ + self isNilConstantReceiverOf: aNode ]) ifTrue: [ + ^ aNode selector == #isNil ]. + ((#( or: and: ) includes: aNode selector) and: [ + aNode arguments last isStmtList and: [ + aNode arguments last statements size = 1 ] ]) ifTrue: [ + (self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: [ + :rcvr | + ((rcvr == false and: [ aNode selector == #and: ]) or: [ + rcvr == true and: [ aNode selector == #or: ] ]) ifTrue: [ + ^ rcvr ]. + (self nilOrBooleanConstantReceiverOf: + aNode arguments last statements first) ifNotNil: [ :arg | + ^ rcvr perform: aNode selector with: [ arg ] ] ]. + "We can also eliminate expr and: [false], expr or: [true], but only if expr is side-effect free. This is a weak test; we don't traverse calls. Caveat emptor!" - ((aNode receiver noneSatisfy: [:node| node isAssignment]) "No side-effects in the elided expression" - and: [aNode args last statements size = 1]) ifTrue: - [(self nilOrBooleanConstantReceiverOf: aNode args last statements first) ifNotNil: - [:arg| - ((arg == false and: [aNode selector == #and:]) - or: [arg == true and: [aNode selector == #or:]]) ifTrue: - [^arg]]]]. + ((aNode receiver noneSatisfy: [ :node | node isAssignment ]) and: [ + aNode arguments last statements size = 1 ]) ifTrue: [ "No side-effects in the elided expression" + (self nilOrBooleanConstantReceiverOf: + aNode arguments last statements first) ifNotNil: [ :arg | + ((arg == false and: [ aNode selector == #and: ]) or: [ + arg == true and: [ aNode selector == #or: ] ]) ifTrue: [ ^ arg ] ] ] ]. "Look for Const ifTrue: [self foo] ifFalse: [false] => false" - ((#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: aNode selector) - and: [(self isConstantNode: aNode receiver valueInto: [:v| val := v]) - and: [(#(true false) includes: val) - and: [arms := aNode args collect: - [:altBlock| | bval | - (altBlock statements size = 1 - and: [(self isConstantNode: altBlock statements last valueInto: [:v| bval := v]) - and: [#(true false) includes: bval]]) ifTrue: - [bval]]. - arms asArray ~= #(nil nil)]]]) ifTrue: - [| arm | - arm := aNode selector == #ifTrue:ifFalse: == val - ifTrue: [arms first] - ifFalse: [arms last]. - (#(true false) includes: arm) ifTrue: - [^arm]]. - ((#(= ~= < > <= >=) includes: aNode selector) - and: [(self isConstantNode: aNode receiver valueInto: [:v| receiver := v]) - and: [receiver isInteger - and: [(self isConstantNode: aNode args first valueInto: [:v| argument := v]) - and: [argument isInteger]]]]) ifTrue: - [^receiver perform: aNode selector with: argument]. - "Inlining for e.g. CharacterTable ifNil: [...] ifNotNil: [...]], which compiles to CharacterTable == nil ifTrue: [...] ifFalse: [...]" - (aNode selector == #== - and: [aNode args first isVariable - and: [aNode args first name = 'nil' - and: [aNode receiver isConstant - and: [aNode receiver value == nil]]]]) ifTrue: - [^true]]. - ^nil + ((#( #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: aNode selector) + and: [ + (self isConstantNode: aNode receiver valueInto: [ :v | val := v ]) + and: [ + (#( true false ) includes: val) and: [ + arms := aNode arguments collect: [ :altBlock | + | bval | + (altBlock statements size = 1 and: [ + (self + isConstantNode: altBlock statements last + valueInto: [ :v | bval := v ]) and: [ + #( true false ) includes: bval ] ]) ifTrue: [ + bval ] ]. + arms asArray ~= #( nil nil ) ] ] ]) ifTrue: [ + | arm | + arm := aNode selector == #ifTrue:ifFalse: == val + ifTrue: [ arms first ] + ifFalse: [ arms last ]. + (#( true false ) includes: arm) ifTrue: [ ^ arm ] ]. + ((#( = ~= < > <= >= ) includes: aNode selector) and: [ + (self + isConstantNode: aNode receiver + valueInto: [ :v | receiver := v ]) and: [ + receiver isInteger and: [ + (self + isConstantNode: aNode arguments first + valueInto: [ :v | argument := v ]) and: [ argument isInteger ] ] ] ]) + ifTrue: [ ^ receiver perform: aNode selector with: argument ]. + "Inlining for e.g. CharacterTable ifNil: [...] ifNotNil: [...]], which compiles to CharacterTable == nil ifTrue: [...] ifFalse: [...]" + (aNode selector == #== and: [ + aNode arguments first isVariable and: [ + aNode arguments first name = 'nil' and: [ + aNode receiver isConstant and: [ aNode receiver value == nil ] ] ] ]) + ifTrue: [ ^ true ] ]. + ^ nil ] { #category : #'translation support' } @@ -4130,25 +4141,29 @@ CCodeGenerator >> node: exprNode typeCompatibleWith: argName inliningInto: targe { #category : #utilities } CCodeGenerator >> nodeIsDeadCode: aNode withParent: parentNode [ + "Answer if aNode would not be generated due to dead code elimination." - ^(self nilOrBooleanConditionFor: parentNode) - ifNil: [false] - ifNotNil: - [:cond| | filter | - filter := parentNode selector caseOf: - { "First element is accessor for filtered (eliminated) node if expression is true. + + ^ (self nilOrBooleanConditionFor: parentNode) + ifNil: [ false ] + ifNotNil: [ :cond | + | filter | + filter := parentNode selector caseOf: { + ([ #ifFalse: ] -> [ #( first nil ) ]). + ([ #ifFalse:ifTrue: ] -> [ #( first last ) ]). + ([ #ifTrue: ] -> [ #( nil first ) ]). + ([ #ifTrue:ifFalse: ] -> [ #( last first ) ]). + ([ #and: ] -> [ #( nil first ) ]). + ([ #or: ] -> [ #( last nil ) ]). + ([ #cppIf:ifTrue: ] -> [ #( nil #second ) ]). + ([ #cppIf:ifTrue:ifFalse: ] -> [ #( third #second ) ]) }. "First element is accessor for filtered (eliminated) node if expression is true. Second element is accessor for filtered (eliminated) node if expression is false." - [#ifFalse:] -> [#(first nil)]. - [#ifFalse:ifTrue:] -> [#(first last)]. - [#ifTrue:] -> [#(nil first)]. - [#ifTrue:ifFalse:] -> [#(last first)]. - [#and:] -> [#(nil first)]. - [#or:] -> [#(last nil)]. - [#cppIf:ifTrue:] -> [#(nil #second)]. - [#cppIf:ifTrue:ifFalse:] -> [#(third #second)] }. - (cond ifTrue: [filter first] ifFalse: [filter last]) - ifNil: [false] - ifNotNil: [:accessor| aNode == (parentNode args perform: accessor)]] + (cond + ifTrue: [ filter first ] + ifFalse: [ filter last ]) + ifNil: [ false ] + ifNotNil: [ :accessor | + aNode == (parentNode arguments perform: accessor) ] ] ] { #category : #inlining } @@ -4454,7 +4469,9 @@ CCodeGenerator >> pruneUnreachableMethods [ [visited add: m. (m isRealMethod and: [self shouldGenerateMethod: m]) ifTrue: - [neededSelectors addAll: m allCalls]]]]. + [ + self haltIf: [ m allCalls includes: #respondToUnknownBytecode ]. + neededSelectors addAll: m allCalls]]]]. neededSelectors size > previousSize] whileTrue: [previousSize := neededSelectors size]. @@ -4581,6 +4598,7 @@ CCodeGenerator >> returnPrefixFromVariable: aName [ { #category : #'type inference' } CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMethod typeIfNil: typeIfNil [ + "Answer the return type for a send. Unbound sends default to typeIfNil. Methods with types as yet unknown have a type determined either by the kernelReturnTypes or the table below, or, if they are in neither set, then nil. @@ -4589,83 +4607,108 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho If there is a method for sel but its return type is as yet unknown it mustn't be defaulted, since on a subsequent pass its type may be computable." - ^sendNode selector - caseOf: { - [#integerValueOf:] -> [#sqInt]. - [#isIntegerObject:] -> [#int]. - [#negated] -> [self promoteArithmeticTypes: (sendNode receiver typeFrom: self in: aTMethod) and: #int]. - [#+] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#-] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#*] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#/] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#//] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#\\] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#rem:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#quo:] -> [self typeForArithmetic: sendNode in: aTMethod]. - "C99 Sec Bitwise shift operators ... 3 Sematics ... + ^ sendNode selector + caseOf: { + ([ #integerValueOf: ] -> [ #sqInt ]). + ([ #isIntegerObject: ] -> [ #int ]). + ([ #negated ] -> [ + self + promoteArithmeticTypes: + (sendNode receiver typeFrom: self in: aTMethod) + and: #int ]). + ([ #+ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #- ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #* ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #/ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #// ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #\\ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #rem: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #quo: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + "C99 Sec Bitwise shift operators ... 3 Sematics ... The integer promotions are performed on each of the operands. The type of the result is that of the promoted left operand..." - [#>>] -> [sendNode receiver typeFrom: self in: aTMethod]. - [#<<] -> [sendNode receiver typeFrom: self in: aTMethod]. - [#addressOf:] -> [(sendNode receiver typeFrom: self in: aTMethod) - ifNil: [#sqInt] - ifNotNil: [:type| type, (type last isLetter ifTrue: [' *'] ifFalse: ['*'])]]. - [#at:] -> [self typeForDereference: sendNode in: aTMethod]. - [#bitAnd:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitOr:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitXor:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitClear:] -> [self typeForArithmetic: sendNode in: aTMethod]. - [#bitInvert32] -> [#'unsigned int']. - [#bitInvert64] -> [self promoteArithmeticTypes: (sendNode receiver typeFrom: self in: aTMethod) and: #int]. - [#byteSwap32] -> [#'unsigned int']. - [#byteSwap64] -> [#'unsigned long long']. - [#byteSwapped32IfBigEndian:] -> [#'unsigned int']. - [#byteSwapped64IfBigEndian:] -> [#'unsigned long long']. - [#=] -> [#int]. - [#~=] -> [#int]. - [#==] -> [#int]. - [#~~] -> [#int]. - [#<] -> [#int]. - [#<=] -> [#int]. - [#>] -> [#int]. - [#>=] -> [#int]. - [#between:and:] -> [#int]. - [#anyMask:] -> [#int]. - [#allMask:] -> [#int]. - [#noMask:] -> [#int]. - [#isNil] -> [#int]. - [#notNil] -> [#int]. - [#&] -> [#int]. - [#|] -> [#int]. - [#not] -> [#int]. - [#asFloat] -> [#double]. - [#atan] -> [#double]. - [#exp] -> [#double]. - [#log] -> [#double]. - [#sin] -> [#double]. - [#sqrt] -> [#double]. - [#asLong] -> [#long]. - [#asInteger] -> [#sqInt]. - [#asIntegerPtr] -> [#'sqIntptr_t']. - [#asUnsignedInteger] -> [#usqInt]. - [#asUnsignedIntegerPtr]-> [#'usqIntptr_t']. - [#asUnsignedLong] -> [#'unsigned long']. - [#asUnsignedLongLong] -> [#'unsigned long long']. - [#asVoidPointer] -> [#'void *']. - [#signedIntToLong] -> [#usqInt]. "c.f. generateSignedIntToLong:on:indent:" - [#signedIntToShort] -> [#usqInt]. "c.f. generateSignedIntToShort:on:indent:" - [#cCoerce:to:] -> [self conventionalTypeForType: sendNode args last value]. - [#cCoerceSimple:to:] -> [self conventionalTypeForType: sendNode args last value]. - [#sizeof:] -> [#'usqIntptr_t']. "Technically it's a size_t but it matches on target architectures so far..." - [#ifTrue:ifFalse:] -> [self typeForConditional: sendNode in: aTMethod]. - [#ifFalse:ifTrue:] -> [self typeForConditional: sendNode in: aTMethod]. - [#ifTrue:] -> [self typeForConditional: sendNode in: aTMethod]. - [#ifFalse:] -> [self typeForConditional: sendNode in: aTMethod]. - [#and:] -> [#sqInt]. - [#or:] -> [#sqInt]. - [#caseOf:] -> [self typeFor: sendNode args first in: aTMethod] } - otherwise: "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted, - since on a subsequent pass its type may be computable. Only default unbound selectors." - [aCalledMethod ifNotNil: [nil] ifNil: [typeIfNil]] + ([ #>> ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). + ([ #<< ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). + ([ #addressOf: ] -> [ + (sendNode receiver typeFrom: self in: aTMethod) + ifNil: [ #sqInt ] + ifNotNil: [ :type | + type , (type last isLetter + ifTrue: [ ' *' ] + ifFalse: [ '*' ]) ] ]). + ([ #at: ] -> [ self typeForDereference: sendNode in: aTMethod ]). + ([ #bitAnd: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitOr: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitXor: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitClear: ] + -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #bitInvert32 ] -> [ #'unsigned int' ]). + ([ #bitInvert64 ] -> [ + self + promoteArithmeticTypes: + (sendNode receiver typeFrom: self in: aTMethod) + and: #int ]). + ([ #byteSwap32 ] -> [ #'unsigned int' ]). + ([ #byteSwap64 ] -> [ #'unsigned long long' ]). + ([ #byteSwapped32IfBigEndian: ] -> [ #'unsigned int' ]). + ([ #byteSwapped64IfBigEndian: ] -> [ #'unsigned long long' ]). + ([ #= ] -> [ #int ]). + ([ #~= ] -> [ #int ]). + ([ #== ] -> [ #int ]). + ([ #~~ ] -> [ #int ]). + ([ #< ] -> [ #int ]). + ([ #<= ] -> [ #int ]). + ([ #> ] -> [ #int ]). + ([ #>= ] -> [ #int ]). + ([ #between:and: ] -> [ #int ]). + ([ #anyMask: ] -> [ #int ]). + ([ #allMask: ] -> [ #int ]). + ([ #noMask: ] -> [ #int ]). + ([ #isNil ] -> [ #int ]). + ([ #notNil ] -> [ #int ]). + ([ #& ] -> [ #int ]). + ([ #| ] -> [ #int ]). + ([ #not ] -> [ #int ]). + ([ #asFloat ] -> [ #double ]). + ([ #atan ] -> [ #double ]). + ([ #exp ] -> [ #double ]). + ([ #log ] -> [ #double ]). + ([ #sin ] -> [ #double ]). + ([ #sqrt ] -> [ #double ]). + ([ #asLong ] -> [ #long ]). + ([ #asInteger ] -> [ #sqInt ]). + ([ #asIntegerPtr ] -> [ #sqIntptr_t ]). + ([ #asUnsignedInteger ] -> [ #usqInt ]). + ([ #asUnsignedIntegerPtr ] -> [ #usqIntptr_t ]). + ([ #asUnsignedLong ] -> [ #'unsigned long' ]). + ([ #asUnsignedLongLong ] -> [ #'unsigned long long' ]). + ([ #asVoidPointer ] -> [ #'void *' ]). + ([ #signedIntToLong ] -> [ #usqInt ]). "c.f. generateSignedIntToLong:on:indent:" + ([ #signedIntToShort ] -> [ #usqInt ]). "c.f. generateSignedIntToShort:on:indent:" + ([ #cCoerce:to: ] + -> [ + self conventionalTypeForType: sendNode arguments last value ]). + ([ #cCoerceSimple:to: ] + -> [ + self conventionalTypeForType: sendNode arguments last value ]). + ([ #sizeof: ] -> [ #usqIntptr_t ]). "Technically it's a size_t but it matches on target architectures so far..." + ([ #ifTrue:ifFalse: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #ifFalse:ifTrue: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #ifTrue: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #ifFalse: ] + -> [ self typeForConditional: sendNode in: aTMethod ]). + ([ #and: ] -> [ #sqInt ]). + ([ #or: ] -> [ #sqInt ]). + ([ #caseOf: ] + -> [ self typeFor: sendNode arguments first in: aTMethod ]) } + otherwise: [ "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted, + since on a subsequent pass its type may be computable. Only default unbound selectors." + aCalledMethod ifNotNil: [ nil ] ifNil: [ typeIfNil ] ] ] { #category : #'type inference' } @@ -5046,44 +5089,61 @@ CCodeGenerator >> typeFor: aNode in: aTMethod [ { #category : #'type inference' } CCodeGenerator >> typeForArithmetic: sendNode in: aTMethod [ + "Answer the return type for an arithmetic sendThis is so that the inliner can still inline simple expressions. Deal with pointer arithmetic, floating point arithmetic and promotion." + | rcvrType argType arg | rcvrType := sendNode receiver typeOrNilFrom: self in: aTMethod. - argType := (arg := sendNode args first) typeOrNilFrom: self in: aTMethod. + argType := (arg := sendNode arguments first) + typeOrNilFrom: self + in: aTMethod. "deal with pointer arithmetic" - ((rcvrType notNil and: [rcvrType last == $*]) or: [argType notNil and: [argType last == $*]]) ifTrue: - [(rcvrType isNil or: [argType isNil]) ifTrue: - [^nil]. - (rcvrType last == $* and: [argType last == $*]) ifTrue: - [sendNode selector == #- ifTrue: - [^#int]. - self error: 'invalid pointer arithmetic']. - ^rcvrType last == $* - ifTrue: [rcvrType] - ifFalse: [argType]]. - ^(self promoteArithmeticTypes: rcvrType and: argType) ifNotNil: - [:promotedType| - "We have to be very careful with subtraction. The difference between two unsigned types is signed. + ((rcvrType notNil and: [ rcvrType last == $* ]) or: [ + argType notNil and: [ argType last == $* ] ]) ifTrue: [ + (rcvrType isNil or: [ argType isNil ]) ifTrue: [ ^ nil ]. + (rcvrType last == $* and: [ argType last == $* ]) ifTrue: [ + sendNode selector == #- ifTrue: [ ^ #int ]. + self error: 'invalid pointer arithmetic' ]. + ^ rcvrType last == $* + ifTrue: [ rcvrType ] + ifFalse: [ argType ] ]. + ^ (self promoteArithmeticTypes: rcvrType and: argType) ifNotNil: [ + :promotedType | "We have to be very careful with subtraction. The difference between two unsigned types is signed. But we don't want unsigned - constant to be signed. We almost always want this to stay unsigned." - (sendNode selector == #- and: [promotedType first == $u and: [(arg isConstant and: [arg value isInteger]) not]]) - ifTrue: [promotedType allButFirst: ((promotedType beginsWith: 'unsigned') ifTrue: [9] ifFalse: [1])] - ifFalse: [promotedType]] + (sendNode selector == #- and: [ + promotedType first == $u and: [ + (arg isConstant and: [ arg value isInteger ]) not ] ]) + ifTrue: [ + promotedType allButFirst: + ((promotedType beginsWith: 'unsigned') + ifTrue: [ 9 ] + ifFalse: [ 1 ]) ] + ifFalse: [ promotedType ] ] ] { #category : #'type inference' } CCodeGenerator >> typeForConditional: sendNode in: aTMethod [ + "Answer the return type for a conditional, ifTrue:ifFalse: et al" + | firstType secondType | - firstType := self typeFor: sendNode args first statements last in: aTMethod. - sendNode selector numArgs = 1 ifTrue: - [^firstType]. - secondType := self typeFor: sendNode args second statements last in: aTMethod. - ((firstType notNil and: [(self isIntegralCType: firstType) or: [self isFloatingPointCType: firstType]]) - and: [secondType notNil and: [(self isIntegralCType: secondType) or: [self isFloatingPointCType: secondType]]]) ifTrue: - [^self promoteArithmeticTypes: firstType and: secondType]. - ^firstType ifNil: [secondType] + firstType := self + typeFor: sendNode arguments first statements last + in: aTMethod. + sendNode selector numArgs = 1 ifTrue: [ ^ firstType ]. + secondType := self + typeFor: sendNode arguments second statements last + in: aTMethod. + ((firstType notNil and: [ + (self isIntegralCType: firstType) or: [ + self isFloatingPointCType: firstType ] ]) and: [ + secondType notNil and: [ + (self isIntegralCType: secondType) or: [ + self isFloatingPointCType: secondType ] ] ]) ifTrue: [ + ^ self promoteArithmeticTypes: firstType and: secondType ]. + ^ firstType ifNil: [ secondType ] ] { #category : #'type inference' } diff --git a/smalltalksrc/Slang/SlangTyper.class.st b/smalltalksrc/Slang/SlangTyper.class.st index fe58ce820f..7b8ad12b81 100644 --- a/smalltalksrc/Slang/SlangTyper.class.st +++ b/smalltalksrc/Slang/SlangTyper.class.st @@ -18,42 +18,44 @@ SlangTyper class >> on: aCCodeGenerator [ { #category : #'type inference' } SlangTyper >> addTypesFor: node inMethod: method to: typeSet [ + "Add the value types for the node to typeSet. Answer if any type was derived from an as-yet-untyped method or variable, which allows us to abort inferReturnTypeFromReturnsIn: if the return type depends on a yet-to-be-typed method or variable." + | expr | expr := node. - [expr isAssignment or: [expr isStmtList]] whileTrue: - [expr isAssignment ifTrue: - [expr := expr variable]. - expr isStmtList ifTrue: - [expr := expr statements last]]. - expr isSend ifTrue: [ - (#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: expr selector) ifTrue: [ - ^expr args - inject: false - into: [:asYetUntyped :block| - asYetUntyped | (self addTypesFor: block inMethod: method to: typeSet) ] ]. + [ expr isAssignment or: [ expr isStmtList ] ] whileTrue: [ + expr isAssignment ifTrue: [ expr := expr variable ]. + expr isStmtList ifTrue: [ expr := expr statements last ] ]. + expr isSend ifTrue: [ + (#( ifTrue: ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: + expr selector) ifTrue: [ + ^ expr arguments inject: false into: [ :asYetUntyped :block | + asYetUntyped + | (self addTypesFor: block inMethod: method to: typeSet) ] ]. (codeGenerator returnTypeForSend: expr in: method ifNil: nil) - ifNil: [^(codeGenerator methodNamed: expr selector) notNil and: [expr selector ~~ method selector]] - ifNotNil: - [:type | + ifNil: [ + ^ (codeGenerator methodNamed: expr selector) notNil and: [ + expr selector ~~ method selector ] ] + ifNotNil: [ :type | typeSet add: type. - ^false]]. - expr isVariable ifTrue: - [(codeGenerator typeOfVariable: expr name) - ifNotNil: [:type| typeSet add: type] - ifNil: [(typeSet add: (expr name = 'self' - ifTrue: [#void] - ifFalse: [ expr typeFrom: codeGenerator in: method ])) == #sqInt ifTrue: - [^true]]]. - expr isConstant ifTrue: - [(expr value isInteger and: [expr value >= 0]) "cannot determine if signed or unsigned yet..." - ifTrue: [typeSet add: expr value] - ifFalse: - [(expr typeOrNilFrom: codeGenerator in: method) ifNotNil: - [:type | typeSet add: type]]]. - ^false + ^ false ] ]. + expr isVariable ifTrue: [ + (codeGenerator typeOfVariable: expr name) + ifNotNil: [ :type | typeSet add: type ] + ifNil: [ + (typeSet add: (expr name = 'self' + ifTrue: [ #void ] + ifFalse: [ expr typeFrom: codeGenerator in: method ])) + == #sqInt ifTrue: [ ^ true ] ] ]. + expr isConstant ifTrue: [ + (expr value isInteger and: [ expr value >= 0 ]) + ifTrue: [ typeSet add: expr value ] + ifFalse: [ + (expr typeOrNilFrom: codeGenerator in: method) ifNotNil: [ :type | + typeSet add: type ] ] "cannot determine if signed or unsigned yet..." ]. + ^ false ] { #category : #accessing } @@ -219,8 +221,9 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ (aMethod locals includes: (var := node receiver variableNameOrNil)) and: [ (#( <= < >= > ) includes: node selector) and: [ - node args first isConstant and: [ node args first value = 0 ] ] ] ]) - ifTrue: [ mustBeSigned add: var ]. + node arguments first isConstant and: [ + node arguments first value = 0 ] ] ] ]) ifTrue: [ + mustBeSigned add: var ]. "if an assignment to an untyped local of a known type, set the local's type to that type. Only observe known sends (methods in the current set) and typed local variables." @@ -228,14 +231,16 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ (aMethod locals includes: (var := node variable name)) and: [ (alreadyExplicitlyTypedOrNotToBeTyped includes: var) not ] ]) ifTrue: [ "don't be fooled by previously inferred types" - type := self tryExtractTypeFromAssignmentNode: node inMethod: aMethod. + type := self + tryExtractTypeFromAssignmentNode: node + inMethod: aMethod. type ifNil: [ "Further, if the type derives from an as-yet-untyped method, we must defer." alreadyExplicitlyTypedOrNotToBeTyped add: var. (node expression isSend and: [ (codeGenerator methodNamed: node expression selector) notNil ]) ifTrue: [ newDeclarations removeKey: var ifAbsent: nil ] ] - ifNotNil: [ "Merge simple types (but *don't* merge untyped vars); complex types must be defined by the programmer." + ifNotNil: [ "Merge simple types (but *don't* merge untyped vars); complex types must be defined by the programmer.""If untyped, then cannot type the variable yet. A subsequent assignment may assign a subtype of what this type ends up being" (codeGenerator isSimpleType: type) ifTrue: [ (asYetUntyped includes: var) ifTrue: [ @@ -246,7 +251,7 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ mergeTypeOf: var in: newDeclarations with: type - method: aMethod ] ] ] "If untyped, then cannot type the variable yet. A subsequent assignment may assign a subtype of what this type ends up being" ] ]. + method: aMethod ] ] ] ] ]. mustBeSigned do: [ :var | diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index 69c3f73a5a..7dda4cfe05 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -25,15 +25,6 @@ TAssignmentNode class >> variableNamed: aVariableName expression: anExpression [ yourself ] -{ #category : #comparing } -TAssignmentNode >> = anotherNode [ - - super = anotherNode ifFalse: [ ^ false ]. - variable = anotherNode variable ifFalse: [ ^ false ]. - expression = anotherNode expression ifFalse: [ ^ false ]. - ^ true -] - { #category : #'C code generation' } TAssignmentNode >> asCASTExpressionIn: aCodeGen [ @@ -136,7 +127,7 @@ TAssignmentNode >> asCASTValueExpansionIn: aCodeGen [ ^ (TSendNode new setSelector: expression selector receiver: copy - arguments: expression args) asCASTIn: aCodeGen + arguments: expression arguments) asCASTIn: aCodeGen ] { #category : #transformations } @@ -173,12 +164,6 @@ TAssignmentNode >> expression [ ^expression ] -{ #category : #comparing } -TAssignmentNode >> hash [ - - ^ variable hash + expression hash -] - { #category : #testing } TAssignmentNode >> isAssignment [ diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 2933567744..538c64f691 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -1,6 +1,6 @@ Class { #name : #TExternalSendNode, - #superclass : #TParseNode, + #superclass : #Object, #instVars : [ 'variableBindings', 'wrappedSendNode' @@ -8,6 +8,14 @@ Class { #category : #'Slang-AST' } +{ #category : #'instance-creation' } +TExternalSendNode class >> receiver: aReceiverNode selector: aString arguments: aCollection variableBindings: bindings [ + + ^ (self receiver: aReceiverNode selector: aString arguments: aCollection) + variableBindings: bindings; + yourself +] + { #category : #'instance-creation' } TExternalSendNode class >> send: aWrappedSendNode variableBindings: bindings [ @@ -17,6 +25,12 @@ TExternalSendNode class >> send: aWrappedSendNode variableBindings: bindings [ yourself ] +{ #category : #tranforming } +TExternalSendNode >> asCASTExpressionIn: aCodeGenerator [ + + self halt. +] + { #category : #tranforming } TExternalSendNode >> asCASTIn: aCodeGenerator [ @@ -25,6 +39,20 @@ TExternalSendNode >> asCASTIn: aCodeGenerator [ , (self cInternalizationsIn: aCodeGenerator) ] +{ #category : #transformations } +TExternalSendNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen [ + + | newExpression | + newExpression := wrappedSendNode bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen. + ^newExpression = wrappedSendNode + ifTrue: [self] + ifFalse: [ + self haltIf: [ newExpression isSend not ]. + self shallowCopy + wrappedSendNode: newExpression; + yourself] +] + { #category : #'c-translation' } TExternalSendNode >> cExternalizationsIn: codeGenerator [ @@ -53,23 +81,63 @@ TExternalSendNode >> cInternalizationsIn: codeGenerator [ ^ tAssignments collect: [ :e | e asCASTIn: codeGenerator ] ] +{ #category : #testing } +TExternalSendNode >> isCaseStmt [ + + ^ false +] + +{ #category : #testing } +TExternalSendNode >> isConstant [ + + ^ false +] + { #category : #accessing } TExternalSendNode >> isExternalSend [ ^ true ] +{ #category : #testing } +TExternalSendNode >> isLeaf [ + + ^ false +] + +{ #category : #testing } +TExternalSendNode >> isSend [ + + ^ true +] + { #category : #accessing } TExternalSendNode >> localizedVariables [ ^ variableBindings keys ] -{ #category : #accessing } +{ #category : #asd } TExternalSendNode >> nodesDo: aBlock [ + "Apply aBlock to all nodes in the receiver. + N.B. This is assumed to be bottom-up, leaves first." + wrappedSendNode nodesDo: aBlock. + aBlock value: self +] + +{ #category : #asd } +TExternalSendNode >> replaceNodesIn: aDictionary [ - aBlock value: wrappedSendNode. - super nodesDo: aBlock + ^aDictionary at: self ifAbsent: [ | newNode | + newNode := wrappedSendNode replaceNodesIn: aDictionary. + wrappedSendNode := newNode. + self] +] + +{ #category : #accessing } +TExternalSendNode >> selector [ + + ^ wrappedSendNode selector ] { #category : #accessing } diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index ebe5d81f71..eb9f27c000 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -183,7 +183,7 @@ TMethod >> argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeG | stmtList substitutionDict argList | meth args size > (argList := aSendNode arguments) size ifTrue: [ self assert: (meth args first beginsWith: 'self_in_'). - argList := { aSendNode receiver } , aSendNode args ]. + argList := { aSendNode receiver } , aSendNode arguments ]. stmtList := OrderedCollection new: argList size. substitutionDict := Dictionary new: argList size. @@ -479,15 +479,20 @@ TMethod >> buildCaseStmt: aSendNode in: aCodeGen [ { #category : #transformations } TMethod >> buildSwitchStmt: aSendNode parent: parentNode [ + "Build a switch statement node for the given send of caseOf: or caseOf:otherwise:." + | switch | switch := TSwitchStmtNode new - expression: aSendNode receiver - cases: aSendNode args first - otherwiseOrNil: (aSendNode args at: 2 ifAbsent: [nil]). - (aSendNode receiver isVariable or: [parentNode isStmtList]) ifFalse: - [switch switchVariable: (locals add: (self extraVariableName: 'switch'))]. - ^switch + expression: aSendNode receiver + cases: aSendNode arguments first + otherwiseOrNil: + (aSendNode arguments at: 2 ifAbsent: [ nil ]). + (aSendNode receiver isVariable or: [ parentNode isStmtList ]) + ifFalse: [ + switch switchVariable: + (locals add: (self extraVariableName: 'switch')) ]. + ^ switch ] { #category : #'inlining support' } @@ -795,31 +800,39 @@ TMethod >> ensureConditionalAssignmentsAreTransformedIn: aCodeGen [ { #category : #transformations } TMethod >> ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen [ + "For both safety and efficiency, make sure that to:[by:]do: loops with complex limits have a variable to hold the limit expression. In C the limit expression is evaluated each time round the loop so if the loop has side-effects (which it usually will), the C compiler may not be able to optimize the limit expression itself." + | limitExpr hasSideEffects | - limitExpr := node args first. - hasSideEffects := limitExpr anySatisfy: - [:subNode| - subNode isSend - and: [(aCodeGen isBuiltinSelector: subNode selector) not - and: [(aCodeGen isStructSend: subNode) not]]]. - node args size = 4 - ifTrue: - [hasSideEffects - ifTrue: [locals add: node args last name] - ifFalse: [node arguments: node args allButLast]] - ifFalse: "If the expression is complex but as yet there is no limit variable, add it" - [hasSideEffects ifTrue: - [| var | - var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: locals. "N.B. adds it to locals!!" - node arguments: node args, {TVariableNode new setName: var; yourself}. - declarations - at: node args third args first - ifPresent: [:decl| self declarationAt: var put: (self typeFor: node args third args first in: aCodeGen), ' ', var]]] + limitExpr := node arguments first. + hasSideEffects := limitExpr anySatisfy: [ :subNode | + subNode isSend and: [ + (aCodeGen isBuiltinSelector: subNode selector) + not and: [ (aCodeGen isStructSend: subNode) not ] ] ]. + node arguments size = 4 + ifTrue: [ + hasSideEffects + ifTrue: [ locals add: node arguments last name ] + ifFalse: [ node arguments: node arguments allButLast ] ] + ifFalse: [ "If the expression is complex but as yet there is no limit variable, add it" + hasSideEffects ifTrue: [ + | var | + var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: locals. "N.B. adds it to locals!!" + node arguments: node arguments , { (TVariableNode new + setName: var; + yourself) }. + declarations + at: node arguments third args first + ifPresent: [ :decl | + self + declarationAt: var + put: + (self typeFor: node arguments third args first in: aCodeGen) + , ' ' , var ] ] ] ] { #category : #inlining } @@ -985,6 +998,7 @@ TMethod >> extractExpandCaseDirective [ { #category : #transformations } TMethod >> extractExportDirective [ + "Scan the top-level statements for an inlining directive of the form: self export: @@ -992,10 +1006,10 @@ TMethod >> extractExportDirective [ and remove the directive from the method body. Answer the argument of the directive or false if there is no export directive." - ^self - extractDirective: #export: - valueBlock: [:sendNode| sendNode args first value ~= false] - default: false + ^ self + extractDirective: #export: + valueBlock: [ :sendNode | sendNode arguments first value ~= false ] + default: false ] { #category : #'inlining support' } @@ -1047,6 +1061,7 @@ TMethod >> extractSharedCase [ { #category : #transformations } TMethod >> extractStaticDirective [ + "Scan the top-level statements for an inlining directive of the form: self static: @@ -1054,10 +1069,10 @@ TMethod >> extractStaticDirective [ and remove the directive from the method body. Answer the argument of the directive or true if there is no static directive." - ^self - extractDirective: #static: - valueBlock: [:sendNode| sendNode args first value ~= false] - default: (export or: [ self isAPIMethod ]) not + ^ self + extractDirective: #static: + valueBlock: [ :sendNode | sendNode arguments first value ~= false ] + default: (export or: [ self isAPIMethod ]) not ] { #category : #'primitive compilation' } @@ -1240,23 +1255,27 @@ TMethod >> inline: aBoolean [ { #category : #inlining } TMethod >> inlineBuiltin: aSendNode in: aCodeGen [ + | sel meth inlinedReplacement | - (aSendNode selector beginsWith: 'perform:') ifTrue: - [^self inlineFunctionCall: aSendNode asTransformedConstantPerform in: aCodeGen]. + (aSendNode selector beginsWith: 'perform:') ifTrue: [ + ^ self + inlineFunctionCall: aSendNode asTransformedConstantPerform + in: aCodeGen ]. sel := aSendNode receiver selector. meth := aCodeGen methodNamed: sel. - (meth notNil and: [meth inline == true]) ifFalse: [^nil]. - (meth isFunctionalIn: aCodeGen) ifTrue: - [inlinedReplacement := (aCodeGen methodNamed: aSendNode receiver selector) copy - inlineFunctionCall: aSendNode receiver - in: aCodeGen. - ^TSendNode new - setSelector: aSendNode selector - receiver: inlinedReplacement - arguments: aSendNode args copy]. - (self isInlineableConditional: aSendNode in: aCodeGen) ifTrue: - [^self inlineConditional: aSendNode in: aCodeGen]. - ^nil + (meth notNil and: [ meth inline == true ]) ifFalse: [ ^ nil ]. + (meth isFunctionalIn: aCodeGen) ifTrue: [ + inlinedReplacement := (aCodeGen methodNamed: + aSendNode receiver selector) copy + inlineFunctionCall: aSendNode receiver + in: aCodeGen. + ^ TSendNode new + setSelector: aSendNode selector + receiver: inlinedReplacement + arguments: aSendNode arguments copy ]. + (self isInlineableConditional: aSendNode in: aCodeGen) ifTrue: [ + ^ self inlineConditional: aSendNode in: aCodeGen ]. + ^ nil ] { #category : #inlining } @@ -1301,16 +1320,18 @@ TMethod >> inlineCodeOrNilForStatement: aNode returningNodes: returningNodes in: { #category : #inlining } TMethod >> inlineConditional: aSendNode in: aCodeGen [ + "If possible answer the inlining of a conditional, otherwise answer nil. Currently the only pattern we support is aSend ifTrue:/ifFalse: [...] where aSend is marked inline and always answers booleans." + self assert: (self isInlineableConditional: aSendNode in: aCodeGen). - self assert: aSendNode args first isStmtList. - ^(aSendNode args first statements size = 1 - and: [aSendNode args first statements first isReturn]) - ifTrue: [self inlineReturningConditional: aSendNode in: aCodeGen] - ifFalse: [self inlineGuardingConditional: aSendNode in: aCodeGen] + self assert: aSendNode arguments first isStmtList. + ^ (aSendNode arguments first statements size = 1 and: [ + aSendNode arguments first statements first isReturn ]) + ifTrue: [ self inlineReturningConditional: aSendNode in: aCodeGen ] + ifFalse: [ self inlineGuardingConditional: aSendNode in: aCodeGen ] ] { #category : #inlining } @@ -1353,50 +1374,56 @@ TMethod >> inlineFunctionCall: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineGuardingConditional: aSendNode in: aCodeGen [ + "Inline aSend ifTrue:/ifFalse: [statements] where aSend is inlineable and always answers booleans. We convert the boolean returns in aSend to jumps." + | evaluateIfTrue replacementTree map lastNode evaluateLabel skipLabel method | self assert: self == aCodeGen currentMethod. self assert: (self isInlineableConditional: aSendNode in: aCodeGen). aCodeGen maybeBreakForInlineOf: aSendNode in: self. evaluateIfTrue := aSendNode selector = #ifTrue:. method := (aCodeGen methodNamed: aSendNode receiver selector) copy. - replacementTree := method inlineFunctionCall: aSendNode receiver in: aCodeGen. + replacementTree := method + inlineFunctionCall: aSendNode receiver + in: aCodeGen. map := Dictionary new. - (replacementTree statements last isReturn - and: [replacementTree statements last expression value = evaluateIfTrue]) ifTrue: - [lastNode := replacementTree statements last]. + (replacementTree statements last isReturn and: [ + replacementTree statements last expression value = evaluateIfTrue ]) + ifTrue: [ lastNode := replacementTree statements last ]. skipLabel := TLabeledCommentNode new setLabel: - (self unusedLabelForInlining: method). - replacementTree nodesDo: - [:node| | expr | - node isReturn ifTrue: - [expr := node expression. - self assert: (expr isConstant and: [#(true false) includes: expr value]). - map - at: node - put: (expr value ~~ evaluateIfTrue - ifTrue: [TGoToNode label: skipLabel label] - ifFalse: - [node == lastNode - ifTrue: [TLabeledCommentNode new setComment: 'end ', aSendNode receiver selector, '; fall through'] - ifFalse: - [evaluateLabel ifNil: - [evaluateLabel := TLabeledCommentNode new setLabel: - (self unusedLabelForInlining: method)]. - TGoToNode label: evaluateLabel label]])]]. + (self unusedLabelForInlining: method). + replacementTree nodesDo: [ :node | + | expr | + node isReturn ifTrue: [ + expr := node expression. + self assert: + (expr isConstant and: [ #( true false ) includes: expr value ]). + map at: node put: (expr value ~~ evaluateIfTrue + ifTrue: [ TGoToNode label: skipLabel label ] + ifFalse: [ + node == lastNode + ifTrue: [ + TLabeledCommentNode new setComment: + 'end ' , aSendNode receiver selector , '; fall through' ] + ifFalse: [ + evaluateLabel ifNil: [ + evaluateLabel := TLabeledCommentNode new setLabel: + (self unusedLabelForInlining: method) ]. + TGoToNode label: evaluateLabel label ] ]) ] ]. replacementTree replaceNodesIn: map. - replacementTree comment: {'inline ', aSendNode receiver selector}. + replacementTree comment: + { ('inline ' , aSendNode receiver selector) }. self addVarsDeclarationsAndLabelsOf: method except: method args. - ^TStmtListNode new - setArguments: #() - statements: - (evaluateLabel - ifNil: [replacementTree statements, aSendNode args first statements, {skipLabel}] - ifNotNil: - [replacementTree statements, {evaluateLabel}, aSendNode args first statements, {skipLabel}]) + ^ TStmtListNode new setArguments: #( ) statements: (evaluateLabel + ifNil: [ + replacementTree statements + , aSendNode arguments first statements , { skipLabel } ] + ifNotNil: [ + replacementTree statements , { evaluateLabel } + , aSendNode arguments first statements , { skipLabel } ]) ] { #category : #inlining } @@ -1426,55 +1453,62 @@ TMethod >> inlineMethod: meth inCaseStatement: stmtNode withLocalizationReplacem { #category : #inlining } TMethod >> inlineReturningConditional: aSendNode in: aCodeGen [ + "Inline aSend ifTrue:/ifFalse: [^expr] where aSend is inlineable and always answers booleans. We inline ^expr into aSend." + | returnIfTrue returnNode replacementTree map lastNode label method | self assert: self == aCodeGen currentMethod. self assert: (self isInlineableConditional: aSendNode in: aCodeGen). aCodeGen maybeBreakForInlineOf: aSendNode receiver in: self. returnIfTrue := aSendNode selector = #ifTrue:. - returnNode := aSendNode args first. + returnNode := aSendNode arguments first. method := (aCodeGen methodNamed: aSendNode receiver selector) copy. - replacementTree := method inlineFunctionCall: aSendNode receiver in: aCodeGen. + replacementTree := method + inlineFunctionCall: aSendNode receiver + in: aCodeGen. map := Dictionary new. "The last node is either a return or a boolean constant." lastNode := replacementTree statements last. replacementTree statements last isReturn - ifTrue: - [replacementTree statements last expression value == returnIfTrue ifTrue: - [lastNode := nil "i.e. take the fall-through path and /don't/ return"]] - ifFalse: - [self assert: (lastNode isConstant and: [#(true false) includes: lastNode value]). - lastNode value == returnIfTrue ifTrue: "i.e. /do/ return" - [map at: lastNode put: returnNode]]. - replacementTree nodesDo: - [:node| | expr | - node isReturn ifTrue: - [expr := node expression. - self assert: (expr isConstant and: [#(true false) includes: expr value]). - map - at: node - put: (expr value == returnIfTrue - ifTrue: [returnNode] - ifFalse: - [node == lastNode - ifTrue: [TLabeledCommentNode new setComment: 'end ', aSendNode receiver selector, '; fall through'] - ifFalse: - [label ifNil: - [label := TLabeledCommentNode new setLabel: - (self unusedLabelForInlining: method)]. - TGoToNode label: label label]])]]. + ifTrue: [ + replacementTree statements last expression value == returnIfTrue + ifTrue: [ + lastNode := nil "i.e. take the fall-through path and /don't/ return" ] ] + ifFalse: [ + self assert: + (lastNode isConstant and: [ + #( true false ) includes: lastNode value ]). + lastNode value == returnIfTrue ifTrue: [ "i.e. /do/ return" + map at: lastNode put: returnNode ] ]. + replacementTree nodesDo: [ :node | + | expr | + node isReturn ifTrue: [ + expr := node expression. + self assert: + (expr isConstant and: [ #( true false ) includes: expr value ]). + map at: node put: (expr value == returnIfTrue + ifTrue: [ returnNode ] + ifFalse: [ + node == lastNode + ifTrue: [ + TLabeledCommentNode new setComment: + 'end ' , aSendNode receiver selector , '; fall through' ] + ifFalse: [ + label ifNil: [ + label := TLabeledCommentNode new setLabel: + (self unusedLabelForInlining: method) ]. + TGoToNode label: label label ] ]) ] ]. replacementTree replaceNodesIn: map. self addVarsDeclarationsAndLabelsOf: method except: method args. - replacementTree comment: {'inline ', aSendNode receiver selector}. - ^label - ifNil: [replacementTree] - ifNotNil: - [TStmtListNode new - setArguments: #() - statements: {replacementTree. label}] + replacementTree comment: + { ('inline ' , aSendNode receiver selector) }. + ^ label ifNil: [ replacementTree ] ifNotNil: [ + TStmtListNode new setArguments: #( ) statements: { + replacementTree. + label } ] ] { #category : #inlining } @@ -1570,24 +1604,25 @@ TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: { #category : #inlining } TMethod >> inlineableFunctionCall: aNode in: aCodeGen [ + "Answer if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted." aCodeGen maybeBreakForTestToInline: aNode in: self. - aNode isSend ifFalse: - [^false]. - ^(aCodeGen methodNamed: aNode selector) - ifNil: - [aNode asTransformedConstantPerform - ifNil: [self isInlineableConditional: aNode in: aCodeGen] - ifNotNil: [:n| self inlineableFunctionCall: n in: aCodeGen]] - ifNotNil: - [:m| - (m ~~ self - and: [((m isFunctionalIn: aCodeGen) or: [m mustBeInlined and: [m isComplete]]) - and: [m mayBeInlined - and: [(aCodeGen mayInline: m selector) - and: [aNode args allSatisfy: [:a| self isSubstitutableNode: a intoMethod: m in: aCodeGen]]]]]) - or: [m checkForRequiredInlinability]] + aNode isSend ifFalse: [ ^ false ]. + ^ (aCodeGen methodNamed: aNode selector) + ifNil: [ + aNode asTransformedConstantPerform + ifNil: [ self isInlineableConditional: aNode in: aCodeGen ] + ifNotNil: [ :n | self inlineableFunctionCall: n in: aCodeGen ] ] + ifNotNil: [ :m | + (m ~~ self and: [ + ((m isFunctionalIn: aCodeGen) or: [ + m mustBeInlined and: [ m isComplete ] ]) and: [ + m mayBeInlined and: [ + (aCodeGen mayInline: m selector) and: [ + aNode arguments allSatisfy: [ :a | + self isSubstitutableNode: a intoMethod: m in: aCodeGen ] ] ] ] ]) + or: [ m checkForRequiredInlinability ] ] ] { #category : #inlining } @@ -1667,21 +1702,25 @@ TMethod >> isComplete [ { #category : #inlining } TMethod >> isConditionalToBeTransformedForAssignment: aSend in: aCodeGen [ + "Answer if a send is of the form e1 ifTrue: [e2 ifTrue: [self m1] ifFalse: [self m2]] ifFalse: [self m3] such that at least one of the sends mN may be inlined.." - ^(#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: aSend selector) - and: [aSend args anySatisfy: - [:arg| | stmt | - self assert: arg isStmtList. - arg statements size > 1 - or: [(stmt := arg statements first) isSwitch - or: [stmt isSend - and: [(aCodeGen mayInline: stmt selector) - or: [self isConditionalToBeTransformedForAssignment: stmt in: aCodeGen]]]]]] + ^ (#( #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: aSend selector) + and: [ + aSend arguments anySatisfy: [ :arg | + | stmt | + self assert: arg isStmtList. + arg statements size > 1 or: [ + (stmt := arg statements first) isSwitch or: [ + stmt isSend and: [ + (aCodeGen mayInline: stmt selector) or: [ + self + isConditionalToBeTransformedForAssignment: stmt + in: aCodeGen ] ] ] ] ] ] ] { #category : #inlining } @@ -2745,6 +2784,7 @@ TMethod >> statementsFor: sourceText varName: varName [ { #category : #inlining } TMethod >> statementsListsForInliningIn: aCodeGen [ + "Answer a collection of statement list nodes that are candidates for inlining. Currently, we cannot inline into the argument blocks of and: and or: messages. We do not want to inline code strings within cCode:inSmalltalk: blocks (those with a @@ -2754,46 +2794,43 @@ TMethod >> statementsListsForInliningIn: aCodeGen [ | stmtLists | stmtLists := OrderedCollection new: 10. parseTree - nodesDo: - [:node| - node isStmtList ifTrue: [stmtLists add: node]] - unless: - [:node| - node isSend - and: [node selector == #cCode:inSmalltalk: - or: [aCodeGen isAssertSelector: node selector]]]. - parseTree nodesDo: - [:node| - node isSend ifTrue: - [node selector = #cCode:inSmalltalk: ifTrue: - [node nodesDo: - [:ccisNode| stmtLists remove: ccisNode ifAbsent: []]]. - (node selector = #cppIf:ifTrue:ifFalse: or: [node selector = #cppIf:ifTrue:]) ifTrue: - [node args first nodesDo: - [:inCondNode| stmtLists remove: inCondNode ifAbsent: []]]. - ((node selector = #and:) or: [node selector = #or:]) ifTrue: - "Note: the PP 2.3 compiler produces two arg nodes for these selectors" - [stmtLists remove: node args first ifAbsent: []. - stmtLists remove: node args last ifAbsent: []]. - (#( #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: - #ifNil: #ifNotNil: #ifNil:ifNotNil: #ifNotNil:ifNil: ) includes: node selector) ifTrue: - [stmtLists remove: node receiver ifAbsent: []]. - (#(whileTrue whileTrue: whilefalse whileFalse:) includes: node selector) ifTrue: - "Allow inlining if it is a [...] whileTrue/whileFalse. + nodesDo: [ :node | node isStmtList ifTrue: [ stmtLists add: node ] ] + unless: [ :node | + node isSend and: [ + node selector == #cCode:inSmalltalk: or: [ + aCodeGen isAssertSelector: node selector ] ] ]. + parseTree nodesDo: [ :node | + node isSend ifTrue: [ + node selector = #cCode:inSmalltalk: ifTrue: [ + node nodesDo: [ :ccisNode | + stmtLists remove: ccisNode ifAbsent: [ ] ] ]. + (node selector = #cppIf:ifTrue:ifFalse: or: [ + node selector = #cppIf:ifTrue: ]) ifTrue: [ + node arguments first nodesDo: [ :inCondNode | + stmtLists remove: inCondNode ifAbsent: [ ] ] ]. + (node selector = #and: or: [ node selector = #or: ]) ifTrue: [ "Note: the PP 2.3 compiler produces two arg nodes for these selectors" + stmtLists remove: node arguments first ifAbsent: [ ]. + stmtLists remove: node arguments last ifAbsent: [ ] ]. + (#( #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: + #ifNil: #ifNotNil: #ifNil:ifNotNil: #ifNotNil:ifNil: ) + includes: node selector) ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ] ]. + (#( whileTrue whileTrue: whilefalse whileFalse: ) includes: + node selector) ifTrue: [ "Allow inlining if it is a [...] whileTrue/whileFalse. This is identified by having more than one statement in the receiver block in which case the C code wouldn't work anyways" - [node receiver statements size = 1 ifTrue: - [stmtLists remove: node receiver ifAbsent: []]]. - (node selector = #to:do:) ifTrue: - [stmtLists remove: node receiver ifAbsent: []. - stmtLists remove: node args first ifAbsent: []]. - (node selector = #to:by:do:) ifTrue: - [stmtLists remove: node receiver ifAbsent: []. - stmtLists remove: node args first ifAbsent: []. - stmtLists remove: node args second ifAbsent: []]]. - node isCaseStmt ifTrue: "don't inline cases" - [node cases do: [:case| stmtLists remove: case ifAbsent: []]]]. - ^stmtLists + node receiver statements size = 1 ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ] ] ]. + node selector = #to:do: ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ]. + stmtLists remove: node args first ifAbsent: [ ] ]. + node selector = #to:by:do: ifTrue: [ + stmtLists remove: node receiver ifAbsent: [ ]. + stmtLists remove: node arguments first ifAbsent: [ ]. + stmtLists remove: node arguments second ifAbsent: [ ] ] ]. + node isCaseStmt ifTrue: [ "don't inline cases" + node cases do: [ :case | stmtLists remove: case ifAbsent: [ ] ] ] ]. + ^ stmtLists ] { #category : #accessing } @@ -2861,6 +2898,7 @@ TMethod >> terminateConditionalDefineFor: compileTimeOptionPragmas on: aStream [ { #category : #inlining } TMethod >> transformConditionalAssignment: node in: aCodeGen [ + "If possible answer the transformation of code of the form var := e1 ifTrue: [e2 ifTrue: [self m1] ifFalse: [self m2]] @@ -2872,15 +2910,17 @@ TMethod >> transformConditionalAssignment: node in: aCodeGen [ to allow inlining of m1, m2, et al. Otherwise answer nil." | expr | - ^(node isAssignment - and: [(expr := node expression) isSend - and: [(#(ifTrue:ifFalse: ifFalse:ifTrue:) includes: expr selector) - and: [self isConditionalToBeTransformedForAssignment: expr in: aCodeGen]]]) ifTrue: - [expr copy - arguments: - (expr args collect: - [:stmtList| stmtList copy assignLastExpressionTo: node variable]); - yourself] + ^ (node isAssignment and: [ + (expr := node expression) isSend and: [ + (#( #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: expr selector) + and: [ + self + isConditionalToBeTransformedForAssignment: expr + in: aCodeGen ] ] ]) ifTrue: [ + expr copy + arguments: (expr arguments collect: [ :stmtList | + stmtList copy assignLastExpressionTo: node variable ]); + yourself ] ] { #category : #inlining } @@ -3008,45 +3048,49 @@ TMethod >> tryToInlineMethodExpressionsIn: aCodeGen [ { #category : #inlining } TMethod >> tryToInlineMethodStatementsIn: aCodeGen statementListsInto: aBlock [ + "Expand any (complete) inline methods sent by this method as top-level statements. Answer if anything was inlined." | stmtLists didSomething newStatements returningNodes | didSomething := false. returningNodes := Set new. - parseTree nodesDo: - [:node| - node isReturn ifTrue: - [returningNodes add: node expression. - node expression isConditionalSend ifTrue: - [returningNodes addAll: (node expression args collect: [:stmtList| stmtList statements last])]]]. + parseTree nodesDo: [ :node | + node isReturn ifTrue: [ + returningNodes add: node expression. + node expression isConditionalSend ifTrue: [ + returningNodes addAll: + (node expression arguments collect: [ :stmtList | + stmtList statements last ]) ] ] ]. stmtLists := self statementsListsForInliningIn: aCodeGen. - stmtLists do: - [:stmtList| + stmtLists do: [ :stmtList | newStatements := OrderedCollection new: stmtList statements size. - stmtList statements do: - [:stmt| - (self inlineCodeOrNilForStatement: stmt returningNodes: returningNodes in: aCodeGen) - ifNil: [newStatements addLast: stmt] - ifNotNil: [:inlinedStmts| + stmtList statements do: [ :stmt | + (self + inlineCodeOrNilForStatement: stmt + returningNodes: returningNodes + in: aCodeGen) + ifNil: [ newStatements addLast: stmt ] + ifNotNil: [ :inlinedStmts | didSomething := true. - newStatements addAllLast: inlinedStmts]]. - stmtList setStatements: newStatements asArray]. + newStatements addAllLast: inlinedStmts ] ]. + stmtList setStatements: newStatements asArray ]. "This is a hack; forgive me. The inlining above tends to keep return statements in statement lists. In the case of returning ifs we don't want the returns in case the returning if is generated as an expression." - returningNodes do: - [:returningNode| - (returningNode isConditionalSend - and: [returningNode args anySatisfy: [:alternativeNode| alternativeNode endsWithReturn]]) ifTrue: - [returningNode args withIndexDo: - [:alternativeNode :index| - alternativeNode endsWithReturn ifTrue: - [returningNode args at: index put: alternativeNode copyWithoutReturn]]]]. + returningNodes do: [ :returningNode | + (returningNode isConditionalSend and: [ + returningNode arguments anySatisfy: [ :alternativeNode | + alternativeNode endsWithReturn ] ]) ifTrue: [ + returningNode arguments withIndexDo: [ :alternativeNode :index | + alternativeNode endsWithReturn ifTrue: [ + returningNode arguments + at: index + put: alternativeNode copyWithoutReturn ] ] ] ]. aBlock value: stmtLists. - ^didSomething + ^ didSomething ] { #category : #inlining } @@ -3138,15 +3182,13 @@ TMethod >> usedVariablesCache [ { #category : #inlining } TMethod >> usesVariableUninlinably: argName in: aCodeGen [ - ^parseTree anySatisfy: - [:node| - node isSend - and: [(aCodeGen isAssertSelector: node selector) - and: [node args anySatisfy: - [:argNode| - argNode anySatisfy: - [:subNode| - subNode isVariable and: [subNode name = argName]]]]]] + + ^ parseTree anySatisfy: [ :node | + node isSend and: [ + (aCodeGen isAssertSelector: node selector) and: [ + node arguments anySatisfy: [ :argNode | + argNode anySatisfy: [ :subNode | + subNode isVariable and: [ subNode name = argName ] ] ] ] ] ] ] { #category : #utilities } diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index 7b71f8db8e..95c268b8f0 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -10,14 +10,6 @@ Class { #category : #'Slang-AST' } -{ #category : #utilities } -TParseNode >> = anotherNode [ - - (anotherNode isKindOf: self species) - ifFalse: [ ^ false ]. - ^ comment = anotherNode comment -] - { #category : #utilities } TParseNode >> allCalls [ "Answer a collection of selectors for the messages sent in this parse tree." @@ -176,12 +168,6 @@ TParseNode >> hasSideEffect [ ^true ] -{ #category : #utilities } -TParseNode >> hash [ - - ^ comment hash -] - { #category : #testing } TParseNode >> isAssertion [ ^false diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index a253b69eba..094ea0eb9d 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -348,15 +348,14 @@ TSendNode >> isReturningIf [ { #category : #comparing } TSendNode >> isSameAs: aTParseNode [ - (aTParseNode isSend - and: [selector == aTParseNode selector - and: [receiver isSameAs: aTParseNode receiver]]) ifFalse: - [^false]. - arguments with: aTParseNode args do: - [:a :b| - (a isSameAs: b) ifFalse: - [^false]]. - ^true + + (aTParseNode isSend and: [ + selector == aTParseNode selector and: [ + receiver isSameAs: aTParseNode receiver ] ]) ifFalse: [ ^ false ]. + arguments + with: aTParseNode arguments + do: [ :a :b | (a isSameAs: b) ifFalse: [ ^ false ] ]. + ^ true ] { #category : #'C code generation' } diff --git a/smalltalksrc/Slang/TStmtListNode.class.st b/smalltalksrc/Slang/TStmtListNode.class.st index 96c8443208..271682e051 100644 --- a/smalltalksrc/Slang/TStmtListNode.class.st +++ b/smalltalksrc/Slang/TStmtListNode.class.st @@ -29,67 +29,72 @@ TStmtListNode >> = aNode [ { #category : #utilities } TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ + "Add any variables in variables that are read before written to readBeforeAssigned. Add unconditional assignments to assigned. For convenience answer assigned." + self - nodesWithParentsDo: - [:node :parent| - (node isAssignment - and: [variables includes: node variable name]) ifTrue: - [assigned add: node variable name]. - (node isVariable - and: [(variables includes: node name) - and: [(assigned includes: node name) not - and: [(#(nil pointer) includes: (node structTargetKindIn: aCodeGen)) - and: [(parent notNil and: [parent isAssignment and: [parent variable == node]]) not]]]]) ifTrue: - [node name = 'theCalloutState' ifTrue: - [self halt]. - readBeforeAssigned add: node name]] - unless: - [:node :parent| | conditionalAssignments mayHaveSideEffects | + nodesWithParentsDo: [ :node :parent | + (node isAssignment and: [ variables includes: node variable name ]) + ifTrue: [ assigned add: node variable name ]. + (node isVariable and: [ + (variables includes: node name) and: [ + (assigned includes: node name) not and: [ + (#( nil pointer ) includes: (node structTargetKindIn: aCodeGen)) + and: [ + (parent notNil and: [ + parent isAssignment and: [ parent variable == node ] ]) not ] ] ] ]) + ifTrue: [ + node name = 'theCalloutState' ifTrue: [ self halt ]. + readBeforeAssigned add: node name ] ] + unless: [ :node :parent | + | conditionalAssignments mayHaveSideEffects | node isSend - ifTrue: - ["First deal with implicit assignments..." - node isValueExpansion ifTrue: - [assigned addAll: node receiver args]. - (#(#'memcpy:_:_:' #'memmove:_:_:') includes: node selector) ifTrue: - [assigned add: (node args first detect: [:subnode| subnode isVariable]) name]. - (#(to:do: to:by:do:) includes: node selector) ifTrue: - [assigned addAll: (node args at: node selector numArgs) args. - mayHaveSideEffects := node args size = 4. "See TMethod>>prepareMethodIn:" - mayHaveSideEffects ifTrue: - [assigned add: node args last name]]. + ifTrue: [ "First deal with implicit assignments..." + node isValueExpansion ifTrue: [ + assigned addAll: node receiver args ]. + (#( #memcpy:_:_: #memmove:_:_: ) includes: node selector) + ifTrue: [ + assigned add: + (node arguments first detect: [ :subnode | subnode isVariable ]) + name ]. + (#( #to:do: #to:by:do: ) includes: node selector) ifTrue: [ + assigned addAll: (node arguments at: node selector numArgs) args. + mayHaveSideEffects := node arguments size = 4. "See TMethod>>prepareMethodIn:" + mayHaveSideEffects ifTrue: [ + assigned add: node arguments last name ] ]. "Then deal with read-before-written in the arms of conditionals..." - (#(ifTrue: ifFalse: ifNil: ifNotNil:) intersection: node selector keywords) notEmpty - ifTrue: - ["First find assignments in the expression..." - (TStmtListNode new setStatements: {node receiver}; yourself) + (#( ifTrue: ifFalse: ifNil: ifNotNil: ) intersection: + node selector keywords) notEmpty + ifTrue: [ "First find assignments in the expression..." + (TStmtListNode new + setStatements: { node receiver }; + yourself) addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen. - "Now find read-before-written in each arm, and collect the assignments to spot those assigned in both arms" - conditionalAssignments := - node args - collect: - [:block| - block isStmtList ifTrue: - [block - addReadBeforeAssignedIn: variables - to: readBeforeAssigned - assignments: assigned copy - in: aCodeGen]] - thenSelect: [:each| each notNil]. - "add to assigned those variables written to in both arms" - conditionalAssignments size = 2 ifTrue: - [conditionalAssignments := conditionalAssignments collect: [:set| set difference: assigned]. - assigned addAll: (conditionalAssignments first intersection: conditionalAssignments last)]. - true] - ifFalse: - [false]] - ifFalse: - [false]]. - ^assigned + "Now find read-before-written in each arm, and collect the assignments to spot those assigned in both arms" + conditionalAssignments := node arguments + collect: [ :block | + block isStmtList ifTrue: [ + block + addReadBeforeAssignedIn: + variables + to: readBeforeAssigned + assignments: assigned copy + in: aCodeGen ] ] + thenSelect: [ :each | each notNil ]. + "add to assigned those variables written to in both arms" + conditionalAssignments size = 2 ifTrue: [ + conditionalAssignments := conditionalAssignments collect: [ + :set | set difference: assigned ]. + assigned addAll: (conditionalAssignments first intersection: + conditionalAssignments last) ]. + true ] + ifFalse: [ false ] ] + ifFalse: [ false ] ]. + ^ assigned ] { #category : #accessing } @@ -221,6 +226,13 @@ TStmtListNode >> endsWithReturn [ and: [statements last isReturn or: [statements last isReturningIf]] ] +{ #category : #accessing } +TStmtListNode >> initialize [ + + super initialize. + arguments := #() +] + { #category : #testing } TStmtListNode >> isNilStmtListNode [ @@ -291,6 +303,7 @@ TStmtListNode >> nodesDo: aBlock value: parent [ { #category : #copying } TStmtListNode >> postCopy [ +1haltIf: [ arguments isNil ]. arguments := arguments copy. statements := statements collect: [ :s | s copy ] ] @@ -379,6 +392,7 @@ TStmtListNode >> returnsExpression [ { #category : #accessing } TStmtListNode >> setArguments: argList [ +1haltIf: [ argList isNil ]. arguments := argList. ] @@ -386,6 +400,7 @@ TStmtListNode >> setArguments: argList [ TStmtListNode >> setArguments: argList statements: statementList [ "Initialize this method using the given information." +1haltIf: [ argList isNil ]. arguments := argList. statements := statementList. ] diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index 4969799db5..afb88e6729 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -15,13 +15,6 @@ TVariableNode class >> named: aName [ yourself ] -{ #category : #transformations } -TVariableNode >> = anotherNode [ - - super = anotherNode ifFalse: [ ^ false ]. - ^ name = anotherNode name -] - { #category : #tranforming } TVariableNode >> asCASTIn: aBuilder [ From 8f8484e6f9880993c54b786c6b1346be2b36e7c4 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 14:31:16 +0200 Subject: [PATCH 19/75] Fixing tests --- .../MockLocalizationInterpreterMock.class.st | 2 +- .../SlangLocalizationTestCase.class.st | 28 ++++-------- smalltalksrc/Slang/TExternalSendNode.class.st | 43 +++++++------------ 3 files changed, 26 insertions(+), 47 deletions(-) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 6ab69f07c8..f2829fa670 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -334,4 +334,4 @@ MockLocalizationInterpreterMock >> sharedMethod [ ^ 1 -] \ No newline at end of file +] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 083bad1693..c4b08e301e 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -73,8 +73,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ externalizationStatement := (ccg methodNamed: #interpret) statements last statements first. self - assert: externalizationStatement - equals: (self externalizationOf: #autoLocalizedVariable) + assert: (externalizationStatement + isSameAs: (self externalizationOf: #autoLocalizedVariable)) ] { #category : #tests } @@ -119,16 +119,14 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ interpretMethod statements last arguments first statements last statements last isReturn. self - assert: - interpretMethod statements last arguments first statements last statements first - equals: (self externalizationOf: #autoLocalizedVariable). + assert: (interpretMethod statements last arguments first statements last statements first + isSameAs: (self externalizationOf: #autoLocalizedVariable)). self assert: interpretMethod statements last arguments second statements first statements last isReturn. self - assert: - interpretMethod statements last arguments second statements first statements first - equals: (self externalizationOf: #autoLocalizedVariable) + assert: (interpretMethod statements last arguments second statements first statements first + isSameAs: (self externalizationOf: #autoLocalizedVariable)) ] { #category : #tests } @@ -325,24 +323,16 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ - | interpretMethod autolocalizedVariables | + | interpretMethod | MockLocalizationInterpreterMock. ccg addClass: MockLocalizationInterpreterMock. "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithExternalCallBeforeDispatch. ccg inlineDispatchesInMethodNamed: #interpretWithExternalCallBeforeDispatch. - ccg autoLocalizationOfVariablesIn: #interpretWithExternalCallBeforeDispatch withVariableBindings: autolocalizedVariables. - self assert: externalCall wrappedSendNode arguments first equals: argumentStatement variable. - self - assert: (argumentStatement expression isSameAs: (TAssignmentNode - variableNamed: 'local_autoLocalizedVariable' - expression:(TSendNode - receiver: (TVariableNode named: 'local_autoLocalizedVariable') - selector: #+ - arguments: { TConstantNode value: 1 } ))) + interpretMethod := ccg methodNamed: #interpretWithExternalCallBeforeDispatch. + self assert: interpretMethod statements second statements first isExternalSend ] { #category : #tests } diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 031a06b88d..184ff18eb4 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -1,6 +1,6 @@ Class { #name : #TExternalSendNode, - #superclass : #Object, + #superclass : #TParseNode, #instVars : [ 'variableBindings', 'wrappedSendNode' @@ -28,7 +28,7 @@ TExternalSendNode class >> send: aWrappedSendNode variableBindings: bindings [ { #category : #tranforming } TExternalSendNode >> asCASTExpressionIn: aCodeGenerator [ - self halt. + self notYetImplemented ] { #category : #tranforming } @@ -53,6 +53,13 @@ TExternalSendNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constant yourself] ] +{ #category : #transformations } +TExternalSendNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + wrappedSendNode := wrappedSendNode bindVariablesIn: aDictionary unless: cautionaryBlock +] + { #category : #'c-translation' } TExternalSendNode >> cExternalizationsIn: codeGenerator [ @@ -81,30 +88,12 @@ TExternalSendNode >> cInternalizationsIn: codeGenerator [ ^ tAssignments collect: [ :e | e asCASTIn: codeGenerator ] ] -{ #category : #testing } -TExternalSendNode >> isCaseStmt [ - - ^ false -] - -{ #category : #testing } -TExternalSendNode >> isConstant [ - - ^ false -] - { #category : #accessing } TExternalSendNode >> isExternalSend [ ^ true ] -{ #category : #testing } -TExternalSendNode >> isLeaf [ - - ^ false -] - { #category : #testing } TExternalSendNode >> isSend [ @@ -125,6 +114,13 @@ TExternalSendNode >> nodesDo: aBlock [ aBlock value: self ] +{ #category : #accessing } +TExternalSendNode >> nodesDo: aBlock parent: parent [ + + wrappedSendNode nodesDo: aBlock parent: self. + aBlock value: self value: parent +] + { #category : #asd } TExternalSendNode >> replaceNodesIn: aDictionary [ @@ -140,13 +136,6 @@ TExternalSendNode >> selector [ ^ wrappedSendNode selector ] -{ #category : #accessing } -TExternalSendNode >> nodesDo: aBlock parent: parent [ - - wrappedSendNode nodesDo: aBlock parent: self. - aBlock value: self value: parent -] - { #category : #accessing } TExternalSendNode >> variableBindings [ ^ variableBindings From 50e24fc6738a4ee2cb8c19daacd27eac85490f31 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 14:35:16 +0200 Subject: [PATCH 20/75] Fix test after bad merge --- .../SlangLocalizationTestCase.class.st | 20 +++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index c4b08e301e..bde21f9876 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -322,17 +322,25 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ - - | interpretMethod | + + | interpretMethod autolocalizedVariables | MockLocalizationInterpreterMock. ccg addClass: MockLocalizationInterpreterMock. - + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" ccg prepareMethods. - ccg inlineDispatchesInMethodNamed: #interpretWithExternalCallBeforeDispatch. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: + #interpretWithExternalCallBeforeDispatch. + ccg inlineDispatchesInMethodNamed: + #interpretWithExternalCallBeforeDispatch. + ccg + autoLocalizationOfVariablesIn: + #interpretWithExternalCallBeforeDispatch + withVariableBindings: autolocalizedVariables. - interpretMethod := ccg methodNamed: #interpretWithExternalCallBeforeDispatch. - self assert: interpretMethod statements second statements first isExternalSend + interpretMethod := ccg methodNamed: + #interpretWithExternalCallBeforeDispatch. + self assert: interpretMethod statements second isExternalSend ] { #category : #tests } From a46b89127537d64ad22de9e45545b59dc140b45f Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 15:46:36 +0200 Subject: [PATCH 21/75] Trying auto localisation of instructionPointer --- smalltalksrc/Slang/TExternalSendNode.class.st | 6 ++++++ smalltalksrc/VMMaker/StackInterpreter.class.st | 1 + 2 files changed, 7 insertions(+) diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 184ff18eb4..537bc89ec1 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -100,6 +100,12 @@ TExternalSendNode >> isSend [ ^ true ] +{ #category : #testing } +TExternalSendNode >> isValueExpansion [ + + ^ wrappedSendNode isValueExpansion +] + { #category : #accessing } TExternalSendNode >> localizedVariables [ diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index dee9abdc0f..20a7fa88fb 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -8217,6 +8217,7 @@ StackInterpreter >> interpret [ "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently." + "If stacklimit is zero then the stack pages have not been initialized." stackLimit = 0 ifTrue: [^self initStackPagesAndInterpret]. From 38e6a73ce57bfe921bb082d817d891b6e1b723e3 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 16:04:01 +0200 Subject: [PATCH 22/75] Simplifying manual localFP by => framePointer to make later automatic localization --- smalltalksrc/VMMaker/CoInterpreter.class.st | 78 ++++++------ .../VMMaker/CogStackPageSurrogate64.class.st | 12 +- smalltalksrc/VMMaker/CogVMSimulator.class.st | 29 +---- .../VMMaker/StackInterpreter.class.st | 115 +++++++++--------- .../StackInterpreterSimulator.class.st | 78 ++---------- 5 files changed, 110 insertions(+), 202 deletions(-) diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index 29884bef52..118b6ca191 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -941,7 +941,7 @@ CoInterpreter >> baseFrameReturn [ - contextToReturnTo := self frameCallerContext: localFP. + contextToReturnTo := self frameCallerContext: framePointer. "The stack page is effectively free now, so free it. We must free it to be correct in determining if contextToReturnTo is still married, and in case @@ -989,15 +989,15 @@ CoInterpreter >> baseFrameReturn [ self setStackPageAndLimit: thePage. self assert: (stackPages stackPageFor: theFP) = stackPage. localSP := theSP. - localFP := theFP. + framePointer := theFP. instructionPointer := self pointerForOop: self internalStackTop. instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: ["localIP in the cog method zone indicates a return to machine code." ^self returnToMachineCodeFrame]. - instructionPointer := self pointerForOop: (self iframeSavedIP: localFP)]. - self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). - self setMethod: (self iframeMethod: localFP). + instructionPointer := self pointerForOop: (self iframeSavedIP: framePointer)]. + self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer). + self setMethod: (self iframeMethod: framePointer). self internalStackTopPut: localReturnValue. ^self fetchNextBytecode ] @@ -2405,20 +2405,20 @@ CoInterpreter >> commonCallerReturn [ | callersFPOrNull | - callersFPOrNull := self frameCallerFP: localFP. + callersFPOrNull := self frameCallerFP: framePointer. callersFPOrNull = 0 "baseFrame" ifTrue: - [self assert: localFP = stackPage baseFP. + [self assert: framePointer = stackPage baseFP. ^self baseFrameReturn]. - instructionPointer := self frameCallerSavedIP: localFP. - localSP := localFP + (self frameStackedReceiverOffset: localFP). - localFP := callersFPOrNull. + instructionPointer := self frameCallerSavedIP: framePointer. + localSP := framePointer + (self frameStackedReceiverOffset: framePointer). + framePointer := callersFPOrNull. instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: ["localIP in the cog method zone indicates a return to machine code." ^self returnToMachineCodeFrame]. - instructionPointer := self pointerForOop: (self iframeSavedIP: localFP)]. - self setMethod: (self iframeMethod: localFP). + instructionPointer := self pointerForOop: (self iframeSavedIP: framePointer)]. + self setMethod: (self iframeMethod: framePointer). self fetchNextBytecode. self internalStackTopPut: localReturnValue ] @@ -3005,7 +3005,7 @@ CoInterpreter >> extendedStoreBytecodePop: popBoolean [ ^ self fetchNextBytecode.]. variableType = 1 ifTrue: [ self fetchNextBytecode. - ^self itemporary: variableIndex in: localFP put: value]. + ^self itemporary: variableIndex in: framePointer put: value]. variableType = 3 ifTrue: [self storeLiteralVariable: variableIndex withValue: value. ^ self fetchNextBytecode.]. @@ -3088,7 +3088,6 @@ CoInterpreter >> externalizeIPandSP [ self assert: instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC. stackPointer := localSP. - framePointer := localFP ] { #category : #'debug support' } @@ -3703,7 +3702,7 @@ CoInterpreter >> ifBackwardsCheckForEvents: offsetToJumpBytecode [ "We use the least significant byte of the flags word (which is marked as an immediate) and subtract two each time to avoid disturbing the least significant tag bit. Since the byte is initialized to 1 (on frame build), on first decrement it will become -1. Trip when it reaches 1 again." - backwardJumpCountByte := self iframeBackwardBranchByte: localFP. + backwardJumpCountByte := self iframeBackwardBranchByte: framePointer. (backwardJumpCountByte := backwardJumpCountByte - 2) = 1 ifTrue: [(self methodWithHeaderShouldBeCogged: (objectMemory methodHeaderOf: method)) ifTrue: @@ -3716,7 +3715,7 @@ CoInterpreter >> ifBackwardsCheckForEvents: offsetToJumpBytecode [ [backwardJumpCountByte = -1 ifTrue: "initialize the count" [self assert: minBackwardJumpCountForCompile <= 128. backwardJumpCountByte := minBackwardJumpCountForCompile - 1 << 1 + 1]]. - self iframeBackwardBranchByte: localFP put: backwardJumpCountByte + self iframeBackwardBranchByte: framePointer put: backwardJumpCountByte ] { #category : #'debug support' } @@ -3874,7 +3873,7 @@ CoInterpreter >> instVar: offset ofContext: aContext [ [self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext). ^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)]. offset = InstructionPointerIndex ifTrue: - [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: (self oopForPointer: instructionPointer)]. + [^self instructionPointerForFrame: spouseFP currentFP: framePointer currentIP: (self oopForPointer: instructionPointer)]. self error: 'bad index'. ^0 ] @@ -3940,8 +3939,8 @@ CoInterpreter >> internalActivateNewMethod [ self assert: (objectMemory isOopForwarded: rcvr) not. self internalPush: instructionPointer. - self internalPush: localFP. - localFP := localSP. + self internalPush: framePointer. + framePointer := localSP. self internalPush: newMethod. self setMethod: newMethod methodHeader: methodHeader. self internalPush: objectMemory nilObject. "FxThisContext field" @@ -3966,9 +3965,9 @@ CoInterpreter >> internalActivateNewMethod [ primFailCode ~= 0 ifTrue: [self reapAndResetErrorCodeTo: localSP header: methodHeader]]. - self assert: (self frameNumArgs: localFP) = argumentCount. - self assert: (self frameIsBlockActivation: localFP) not. - self assert: (self frameHasContext: localFP) not. + self assert: (self frameNumArgs: framePointer) = argumentCount. + self assert: (self frameIsBlockActivation: framePointer) not. + self assert: (self frameHasContext: framePointer) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." localSP < stackLimit ifTrue: @@ -4002,7 +4001,7 @@ CoInterpreter >> internalExecuteNewMethod [ ^nil]]. "if not primitive, or primitive failed, activate the method" (self methodHasCogMethod: newMethod) - ifTrue: [self iframeSavedIP: localFP put: instructionPointer asInteger. + ifTrue: [self iframeSavedIP: framePointer put: instructionPointer asInteger. instructionPointer := cogit ceReturnToInterpreterPC. self externalizeFPandSP. self activateCoggedNewMethod: true. @@ -4052,8 +4051,7 @@ CoInterpreter >> internalizeIPandSP [ "Copy the instruction, stack and frame pointers to local variables for rapid access within the interpret loop." self assert: instructionPointer ~= cogit ceReturnToInterpreterPC. - localSP := self pointerForOop: stackPointer. - localFP := self pointerForOop: framePointer. + localSP := self pointerForOop: stackPointer ] { #category : #'trampoline support' } @@ -4258,7 +4256,7 @@ CoInterpreter >> longPushTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self internalPush: (self itemporary: index in: localFP) + self internalPush: (self itemporary: index in: framePointer) ] { #category : #'stack bytecodes' } @@ -4267,7 +4265,7 @@ CoInterpreter >> longStoreTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self itemporary: index in: localFP put: self internalStackTop + self itemporary: index in: framePointer put: self internalStackTop ] { #category : #simulation } @@ -4946,7 +4944,7 @@ CoInterpreter >> maybeReturnToMachineCodeFrame [ [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: ["localIP in the cog method zone indicates a return to machine code." ^self returnToMachineCodeFrame]. - instructionPointer := self pointerForOop: (self iframeSavedIP: localFP)] + instructionPointer := self pointerForOop: (self iframeSavedIP: framePointer)] ] { #category : #'debug support' } @@ -5345,7 +5343,7 @@ CoInterpreter >> nextProfileTickLow [ { #category : #simulation } CoInterpreter >> nilLocalFP [ - localFP := nil + framePointer := nil ] { #category : #'cog jit support' } @@ -5934,7 +5932,7 @@ CoInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg comp "No need to record the pushed copied values in the outerContext." context := ignoreContext ifTrue: [objectMemory nilObject ] - ifFalse: [self ensureFrameIsMarried: localFP SP: localSP + (numCopiedArg * objectMemory bytesPerOop)]. + ifFalse: [self ensureFrameIsMarried: framePointer SP: localSP + (numCopiedArg * objectMemory bytesPerOop)]. newClosure := self fullClosureIn: context numArgs: numArgs @@ -5969,18 +5967,18 @@ CoInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg comp CoInterpreter >> pushRemoteTemp: index inVectorAt: tempVectorIndex [ "Override to use itemporary:in:put:" | tempVector | - tempVector := self itemporary: tempVectorIndex in: localFP. + tempVector := self itemporary: tempVectorIndex in: framePointer. TempVectReadBarrier ifTrue: [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: localFP]]. + [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. self internalPush: (objectMemory fetchPointer: index ofObject: tempVector) ] { #category : #'stack bytecodes' } CoInterpreter >> pushTemporaryVariable: temporaryIndex [ "Override to use itemporary:in:put:" - self internalPush: (self itemporary: temporaryIndex in: localFP) + self internalPush: (self itemporary: temporaryIndex in: framePointer) ] { #category : #'cog jit support' } @@ -6039,7 +6037,7 @@ CoInterpreter >> rawHeaderOf: methodOop put: cogMethodOrMethodHeader [ { #category : #'internal interpreter access' } CoInterpreter >> receiver [ - ^stackPages longAt: localFP + FoxIFReceiver + ^stackPages longAt: framePointer + FoxIFReceiver ] { #category : #'debug support' } @@ -6211,8 +6209,8 @@ CoInterpreter >> returnToMachineCodeFrame [ cogit assertCStackWellAligned. self assert: instructionPointer asUnsignedInteger < objectMemory startOfMemory. - self assert: (self isMachineCodeFrame: localFP). - self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: localFP s: localSP imbar: false line: #'__LINE__'. + self assert: (self isMachineCodeFrame: framePointer). + self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: localSP imbar: false line: #'__LINE__'. self internalStackTopPut: instructionPointer. self internalPush: localReturnValue. self externalizeFPandSP. @@ -6567,10 +6565,10 @@ CoInterpreter >> storeAndPopTemporaryVariableBytecode [ self cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant" [self fetchNextBytecode. - self itemporary: (currentBytecode bitAnd: 7) in: localFP put: self internalStackTop. + self itemporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. self internalPop: 1] inSmalltalk: "Interpreter version has fetchNextBytecode out of order" - [self itemporary: (currentBytecode bitAnd: 7) in: localFP put: self internalStackTop. + [self itemporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. self fetchNextBytecode. self internalPop: 1] ] @@ -6579,11 +6577,11 @@ CoInterpreter >> storeAndPopTemporaryVariableBytecode [ CoInterpreter >> storeRemoteTemp: index inVectorAt: tempVectorIndex [ "Override to use itemporary:in:put:" | tempVector | - tempVector := self itemporary: tempVectorIndex in: localFP. + tempVector := self itemporary: tempVectorIndex in: framePointer. TempVectReadBarrier ifTrue: [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: localFP]]. + [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop ] diff --git a/smalltalksrc/VMMaker/CogStackPageSurrogate64.class.st b/smalltalksrc/VMMaker/CogStackPageSurrogate64.class.st index 735a641093..11e5dc9e9f 100644 --- a/smalltalksrc/VMMaker/CogStackPageSurrogate64.class.st +++ b/smalltalksrc/VMMaker/CogStackPageSurrogate64.class.st @@ -85,13 +85,13 @@ CogStackPageSurrogate64 >> lastAddress: aValue [ { #category : #accessing } CogStackPageSurrogate64 >> nextPage [ - ^stackPages surrogateAtAddress: (memory unsignedLong64At: address + 60) + ^stackPages surrogateAtAddress: (memory unsignedLong64At: address + 64) ] { #category : #accessing } CogStackPageSurrogate64 >> nextPage: aValue [ - self assert: (address + 60 >= zoneBase and: [address + 67 < zoneLimit]). - memory unsignedLong64At: address + 60 put: aValue asInteger. + self assert: (address + 64 >= zoneBase and: [address + 71 < zoneLimit]). + memory unsignedLong64At: address + 64 put: aValue asInteger. ^aValue ] @@ -108,13 +108,13 @@ CogStackPageSurrogate64 >> padToWord: aValue [ { #category : #accessing } CogStackPageSurrogate64 >> prevPage [ - ^stackPages surrogateAtAddress: (memory unsignedLong64At: address + 68) + ^stackPages surrogateAtAddress: (memory unsignedLong64At: address + 72) ] { #category : #accessing } CogStackPageSurrogate64 >> prevPage: aValue [ - self assert: (address + 68 >= zoneBase and: [address + 75 < zoneLimit]). - memory unsignedLong64At: address + 68 put: aValue asInteger. + self assert: (address + 72 >= zoneBase and: [address + 79 < zoneLimit]). + memory unsignedLong64At: address + 72 put: aValue asInteger. ^aValue ] diff --git a/smalltalksrc/VMMaker/CogVMSimulator.class.st b/smalltalksrc/VMMaker/CogVMSimulator.class.st index 242c751697..ea2bc5f719 100644 --- a/smalltalksrc/VMMaker/CogVMSimulator.class.st +++ b/smalltalksrc/VMMaker/CogVMSimulator.class.st @@ -804,7 +804,7 @@ CogVMSimulator >> ensureContextIsExecutionSafeAfterAssignToStackPointer: aContex { #category : #testing } CogVMSimulator >> ensureDebugAtEachStepBlock [ atEachStepBlock := [printFrameAtEachStep ifTrue: - [self printFrame: localFP WithSP: localSP]. + [self printFrame: framePointer WithSP: localSP]. printBytecodeAtEachStep ifTrue: [self printCurrentBytecodeOn: transcript. transcript cr; flush]. @@ -1667,7 +1667,7 @@ CogVMSimulator >> isWidowedContext: aOnceMarriedContext [ If it is not, turn it into a bereaved single context." (stackPages isFree: stackPage) ifFalse: "in baseReturn the active page has been freed." [((stackPages somePageHasHeadFrameFP: framePointer) - or: [(stackPages somePageHasHeadFrameFP: localFP) + or: [(stackPages somePageHasHeadFrameFP: framePointer) or: [stackPages allPagesFree]]) ifFalse: [(thisContext sender sender method = (CoInterpreter >> #baseFrameReturn) or: [thisContext sender sender method = (CoInterpreter >> #ceBaseFrameReturn:)]) ifFalse: @@ -2440,7 +2440,7 @@ CogVMSimulator >> printHexnpnp: anInteger [ { #category : #'debug printing' } CogVMSimulator >> printLCS [ - self printCallStackFP: localFP + self printCallStackFP: framePointer ] { #category : #'debug printing' } @@ -2767,11 +2767,6 @@ CogVMSimulator >> tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: con ^super tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom to: contextToReturnTo returnValue: returnValue ] -{ #category : #testing } -CogVMSimulator >> test [ - self testBreakCount: -1 printSends: true printFrames: false printBytecodes: false -] - { #category : #testing } CogVMSimulator >> testBecome [ "Become some young things. AA testBecome " @@ -2802,19 +2797,6 @@ CogVMSimulator >> testBecome [ (objectMemory fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt]. ] -{ #category : #testing } -CogVMSimulator >> testBreakCount: breakCount printSends: shouldPrintSends printFrames: shouldPrintFrames printBytecodes: shouldPrintBytecodes [ - self initStackPages. - self loadInitialContext. - transcript clear. - quitBlock := [^self close]. - printSends := true & shouldPrintSends. "true & foo allows evaluating printFoo := true in the debugger" - printFrameAtEachStep := true & shouldPrintFrames. - printBytecodeAtEachStep := true & shouldPrintBytecodes. - self ensureDebugAtEachStepBlock. - self initialEnterSmalltalkExecutive -] - { #category : #testing } CogVMSimulator >> testPCMapping [ objectMemory allObjectsDo: @@ -2839,11 +2821,6 @@ CogVMSimulator >> testPCMapping [ [transcript nextPutAll: 'failed to compile method '; print: o; cr; flush]]] ] -{ #category : #testing } -CogVMSimulator >> testWithBytecodePrint [ - self testBreakCount: -1 printSends: true printFrames: false printBytecodes: true -] - { #category : #UI } CogVMSimulator >> toggleTranscript [ | transcriptPane | diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index 20a7fa88fb..91395230a7 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -316,7 +316,6 @@ Class { #instVars : [ 'currentBytecode', 'bytecodeSetSelector', - 'localFP', 'localSP', 'stackLimit', 'stackPage', @@ -534,7 +533,7 @@ If ffi is put as a separate header, slang will sort the header and put it outsid as: #usqInt in: aCCodeGenerator. "These are all pointers; char * because Slang has no support for C pointer arithmetic." - self declareC: #(instructionPointer localSP localFP stackPointer framePointer stackLimit breakSelector) + self declareC: #(instructionPointer localSP stackPointer framePointer stackLimit breakSelector) as: #'char *' in: aCCodeGenerator. aCCodeGenerator @@ -2203,7 +2202,7 @@ StackInterpreter >> assertValidExecutionPointe: lip r: lfp s: lsp imbar: inInter { #category : #'debug support' } StackInterpreter >> assertValidExecutionPointers [ "simulator only" - self assertValidExecutionPointe: instructionPointer r: localFP s: localSP + self assertValidExecutionPointe: instructionPointer r: framePointer s: localSP ] { #category : #'process primitive support' } @@ -2229,7 +2228,7 @@ StackInterpreter >> baseFrameReturn [ - contextToReturnTo := self frameCallerContext: localFP. + contextToReturnTo := self frameCallerContext: framePointer. isAContext := objectMemory isContext: contextToReturnTo. (isAContext and: [self isStillMarriedContext: contextToReturnTo]) @@ -2262,11 +2261,11 @@ StackInterpreter >> baseFrameReturn [ self setStackPageAndLimit: thePage. self assert: (stackPages stackPageFor: theFP) = stackPage. localSP := theSP. - localFP := theFP. - self setMethod: (self frameMethod: localFP). + framePointer := theFP. + self setMethod: (self frameMethod: framePointer). instructionPointer := self pointerForOop: self internalStackTop. self internalStackTopPut: localReturnValue. - self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). + self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer). ^self fetchNextBytecode ] @@ -4559,15 +4558,15 @@ StackInterpreter >> commonCallerReturn [ | callersFPOrNull | - callersFPOrNull := self frameCallerFP: localFP. + callersFPOrNull := self frameCallerFP: framePointer. callersFPOrNull = 0 "baseFrame" ifTrue: - [self assert: localFP = stackPage baseFP. + [self assert: framePointer = stackPage baseFP. ^self baseFrameReturn]. - instructionPointer := self frameCallerSavedIP: localFP. - localSP := localFP + (self frameStackedReceiverOffset: localFP). - localFP := callersFPOrNull. - self setMethod: (self frameMethod: localFP). + instructionPointer := self frameCallerSavedIP: framePointer. + localSP := framePointer + (self frameStackedReceiverOffset: framePointer). + framePointer := callersFPOrNull. + self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. self internalStackTopPut: localReturnValue ] @@ -4586,7 +4585,7 @@ StackInterpreter >> commonReturn [ "If this is a method simply return to the sender/caller." - (self iframeIsBlockActivation: localFP) ifFalse: + (self iframeIsBlockActivation: framePointer) ifFalse: [^self commonCallerReturn]. "Update the current page's headFrame pointers to enable the search for unwind protects below @@ -4595,7 +4594,7 @@ StackInterpreter >> commonReturn [ self externalizeIPandSP. "Since this is a block activation the closure is on the stack above any args and the frame." - closure := self pushedReceiverOrClosureOfFrame: localFP. + closure := self pushedReceiverOrClosureOfFrame: framePointer. home := nil. "avoid compiler warning" "Walk the closure's lexical chain to find the context or frame to return from (home). If home is missing (Sista closures) then throw cannotReturn rather than crash." @@ -4620,7 +4619,7 @@ StackInterpreter >> commonReturn [ contextToReturnTo := nil. (self isMarriedOrWidowedContext: home) ifTrue: - [self assert: (self checkIsStillMarriedContext: home currentFP: localFP). + [self assert: (self checkIsStillMarriedContext: home currentFP: framePointer). theFP := self frameOfMarriedContext: home. (self isBaseFrame: theFP) ifTrue: @@ -4631,7 +4630,7 @@ StackInterpreter >> commonReturn [ [contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home. ((objectMemory isContext: contextToReturnTo) and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue: - [self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). + [self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer). frameToReturnTo := self frameOfMarriedContext: contextToReturnTo. contextToReturnTo := nil]]. @@ -4669,23 +4668,23 @@ StackInterpreter >> commonReturn [ currentCtx := nextCntx]]. self setStackPageAndLimit: newPage. localSP := stackPage headSP. - localFP := stackPage headFP]. + framePointer := stackPage headFP]. "Two cases. Returning to the top frame on a new page or an interior frame on the current page. The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer in the caller frame. We need to peel back any frames on the page until we get to the correct frame." - localFP = frameToReturnTo + framePointer = frameToReturnTo ifTrue: "pop the saved IP, push the return value and continue." [instructionPointer := self pointerForOop: self internalStackTop] ifFalse: - [[callerFP := localFP. - localFP := self frameCallerFP: localFP. - localFP ~~ frameToReturnTo] whileTrue. + [[callerFP := framePointer. + framePointer := self frameCallerFP: framePointer. + framePointer ~~ frameToReturnTo] whileTrue. instructionPointer := self frameCallerSavedIP: callerFP. localSP := (self frameCallerSP: callerFP) - objectMemory wordSize]. self maybeReturnToMachineCodeFrame. - self setMethod: (self frameMethod: localFP). + self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. self internalStackTopPut: localReturnValue ] @@ -5523,7 +5522,7 @@ StackInterpreter >> extPushPseudoVariable [ | theThingToPush | extB caseOf: { - [0] -> [theThingToPush := self ensureFrameIsMarried: localFP SP: localSP]. + [0] -> [theThingToPush := self ensureFrameIsMarried: framePointer SP: localSP]. [1] -> [theThingToPush := self activeProcess] } otherwise: [self respondToUnknownBytecode]. @@ -5691,7 +5690,7 @@ StackInterpreter >> extendedStoreBytecodePop: popBoolean [ ^ self fetchNextBytecode]. variableType = 1 ifTrue: [ self fetchNextBytecode. - self temporary: variableIndex in: localFP put: value. + self temporary: variableIndex in: framePointer put: value. ^ self "keep slang happy"]. variableType = 3 ifTrue: [self storeLiteralVariable: variableIndex withValue: value. @@ -5917,7 +5916,7 @@ StackInterpreter >> externalizeFPandSP [ self assert: (localSP < stackPage baseAddress and: [localSP > (stackPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop))]). stackPointer := localSP. - framePointer := localFP + framePointer := framePointer ] { #category : #utilities } @@ -5925,7 +5924,6 @@ StackInterpreter >> externalizeIPandSP [ "Copy the local instruction, stack and frame pointers to global variables for use in primitives and other functions outside the interpret loop." stackPointer := localSP. - framePointer := localFP ] { #category : #'primitive support' } @@ -7319,7 +7317,7 @@ StackInterpreter >> handleForwardedSendFaultForTag: classTag [ StackInterpreter >> handleSpecialSelectorSendFaultFor: obj [ - ^self handleSpecialSelectorSendFaultFor: obj fp: localFP sp: localSP + ^self handleSpecialSelectorSendFaultFor: obj fp: framePointer sp: localSP ] { #category : #'message sending' } @@ -7872,7 +7870,7 @@ StackInterpreter >> instVar: offset ofContext: aContext [ [self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext). ^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)]. offset = InstructionPointerIndex ifTrue: - [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: (self oopForPointer: instructionPointer)]. + [^self instructionPointerForFrame: spouseFP currentFP: framePointer currentIP: (self oopForPointer: instructionPointer)]. self error: 'bad index'. ^0 ] @@ -7902,7 +7900,7 @@ StackInterpreter >> instVar: index ofContext: aMarriedContext put: anOop [ self storeSenderOfFrame: theFP withValue: anOop. onCurrentPage ifTrue: - [localFP := stackPage headFP. + [framePointer := stackPage headFP. localSP := stackPage headSP] ifFalse: [stackPages markStackPageMostRecentlyUsed: stackPage]. @@ -7917,7 +7915,7 @@ StackInterpreter >> instVar: index ofContext: aMarriedContext put: anOop [ self internalizeIPandSP. "Assigning various fields can force a divorce which can change the stackPage." stackPages markStackPageMostRecentlyUsed: stackPage. - self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: localFP s: localSP imbar: true line: #'__LINE__' + self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: localSP imbar: true line: #'__LINE__' ] { #category : #'indexing primitive support' } @@ -8005,7 +8003,7 @@ StackInterpreter >> integerArg: index [ StackInterpreter >> internalAboutToReturn: resultOop through: aContext [ | ourContext | - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: localSP. self internalPush: ourContext. self internalPush: resultOop. self internalPush: aContext. @@ -8027,8 +8025,8 @@ StackInterpreter >> internalActivateNewMethod [ self assert: (objectMemory isOopForwarded: rcvr) not. self internalPush: instructionPointer. - self internalPush: localFP. - localFP := localSP. + self internalPush: framePointer. + framePointer := localSP. self internalPush: newMethod. self setMethod: newMethod methodHeader: methodHeader. self internalPush: (self @@ -8054,9 +8052,9 @@ StackInterpreter >> internalActivateNewMethod [ primFailCode ~= 0 ifTrue: [ self reapAndResetErrorCodeTo: localSP header: methodHeader ] ]. - self assert: (self frameNumArgs: localFP) = argumentCount. - self assert: (self frameIsBlockActivation: localFP) not. - self assert: (self frameHasContext: localFP) not. + self assert: (self frameNumArgs: framePointer) = argumentCount. + self assert: (self frameIsBlockActivation: framePointer) not. + self assert: (self frameHasContext: framePointer) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." localSP < stackLimit ifTrue: [ @@ -8070,7 +8068,7 @@ StackInterpreter >> internalActivateNewMethod [ StackInterpreter >> internalCannotReturn: resultOop [ | ourContext | - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: localSP. self internalPush: ourContext. self internalPush: resultOop. messageSelector := objectMemory splObj: SelectorCannotReturn. @@ -8208,8 +8206,7 @@ StackInterpreter >> internalStackValue: offset put: aValue [ { #category : #utilities } StackInterpreter >> internalizeIPandSP [ "Copy the instruction, stack and frame pointers to local variables for rapid access within the interpret loop." - localSP := self pointerForOop: stackPointer. - localFP := self pointerForOop: framePointer. + localSP := self pointerForOop: stackPointer ] { #category : #'interpreter shell' } @@ -8909,7 +8906,7 @@ StackInterpreter >> libFFI: aLibFFI [ { #category : #'compiled methods' } StackInterpreter >> literal: offset [ - self assert: method = (self iframeMethod: localFP). + self assert: method = (self iframeMethod: framePointer). ^self literal: offset ofMethod: method ] @@ -9116,7 +9113,7 @@ StackInterpreter >> longPushTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self internalPush: (self temporary: index in: localFP) + self internalPush: (self temporary: index in: framePointer) ] { #category : #'stack bytecodes' } @@ -9146,7 +9143,7 @@ StackInterpreter >> longStoreTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self temporary: index in: localFP put: self internalStackTop + self temporary: index in: framePointer put: self internalStackTop ] { #category : #'jump bytecodes' } @@ -11856,7 +11853,7 @@ StackInterpreter >> printHeadFrame [ Do not generate this function as there is no way to properly translate it to C. Translating this function requires access to localFP and localSP which are local variables in the interpreter loop function, thus, they are not accessible from within this function." - self printFrame: localFP WithSP: localSP + self printFrame: framePointer WithSP: localSP ] { #category : #'debug printing' } @@ -12251,7 +12248,7 @@ StackInterpreter >> printSends [ { #category : #'debug printing' } StackInterpreter >> printStackCallStack [ - self printStackCallStackOf: (localFP ifNil: [framePointer]) + self printStackCallStackOf: (framePointer ifNil: [framePointer]) ] { #category : #'debug printing' } @@ -12500,7 +12497,7 @@ StackInterpreter >> push: object [ { #category : #'stack bytecodes' } StackInterpreter >> pushActiveContextBytecode [ | ourContext | - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: localSP. self fetchNextBytecode. self internalPush: ourContext ] @@ -12584,7 +12581,7 @@ StackInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg c "No need to record the pushed copied values in the outerContext." context := ignoreContext ifTrue: [objectMemory nilObject ] - ifFalse: [self ensureFrameIsMarried: localFP SP: localSP + (numCopiedArg * objectMemory bytesPerOop)]. + ifFalse: [self ensureFrameIsMarried: framePointer SP: localSP + (numCopiedArg * objectMemory bytesPerOop)]. newClosure := self fullClosureIn: context numArgs: numArgs @@ -12773,11 +12770,11 @@ StackInterpreter >> pushReceiverVariableBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> pushRemoteTemp: index inVectorAt: tempVectorIndex [ | tempVector | - tempVector := self temporary: tempVectorIndex in: localFP. + tempVector := self temporary: tempVectorIndex in: framePointer. TempVectReadBarrier ifTrue: [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: localFP]]. + [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. self internalPush: (objectMemory fetchPointer: index ofObject: tempVector) ] @@ -12793,7 +12790,7 @@ StackInterpreter >> pushRemoteTempLongBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> pushTemporaryVariable: temporaryIndex [ - self internalPush: (self temporary: temporaryIndex in: localFP). + self internalPush: (self temporary: temporaryIndex in: framePointer). ] { #category : #'stack bytecodes' } @@ -13078,7 +13075,7 @@ StackInterpreter >> reapAndResetErrorCodeTo: theSP header: methodHeader [ { #category : #'internal interpreter access' } StackInterpreter >> receiver [ - ^stackPages longAt: localFP + FoxReceiver + ^stackPages longAt: framePointer + FoxReceiver ] { #category : #'callback support' } @@ -13223,7 +13220,7 @@ StackInterpreter >> respondToSistaTrap [ | ourContext | messageSelector := objectMemory splObj: SelectorSistaTrap. - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: localSP. self internalPush: ourContext. argumentCount := 0. self normalSend @@ -13238,7 +13235,7 @@ StackInterpreter >> respondToUnknownBytecode [ (messageSelector isNil or: [messageSelector = objectMemory nilObject]) ifTrue: [self error: 'Unknown bytecode']. - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: localSP. "undo fetch of bytecode so that context's pc is pointing to the unknown bytecode." instructionPointer := instructionPointer - 1. self internalPush: ourContext. @@ -14035,7 +14032,7 @@ StackInterpreter >> shortPrintFrameAndCallers: theFP [ StackInterpreter >> shortPrintFramesInCurrentPage [ self resetStackPrintedCount. - self shortPrintFrameAndCallers: localFP + self shortPrintFrameAndCallers: framePointer ] { #category : #'debug printing' } @@ -14853,10 +14850,10 @@ StackInterpreter >> storeAndPopTemporaryVariableBytecode [ self cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant" [self fetchNextBytecode. - self temporary: (currentBytecode bitAnd: 7) in: localFP put: self internalStackTop. + self temporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. self internalPop: 1] inSmalltalk: "Interpreter version has fetchNextBytecode out of order" - [self temporary: (currentBytecode bitAnd: 7) in: localFP put: self internalStackTop. + [self temporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. self fetchNextBytecode. self internalPop: 1] ] @@ -14913,11 +14910,11 @@ StackInterpreter >> storeMaybeContextReceiverVariable: fieldIndex withValue: anO { #category : #'stack bytecodes' } StackInterpreter >> storeRemoteTemp: index inVectorAt: tempVectorIndex [ | tempVector | - tempVector := self temporary: tempVectorIndex in: localFP. + tempVector := self temporary: tempVectorIndex in: framePointer. TempVectReadBarrier ifTrue: [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: localFP]]. + [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop. ] @@ -15967,7 +15964,7 @@ StackInterpreter >> wordSwapped: w [ { #category : #'stack pages' } StackInterpreter >> writeBackHeadFramePointers [ self assert: stackPage = stackPages mostRecentlyUsedPage. - self setHeadFP: localFP andSP: localSP inPage: stackPage. + self setHeadFP: framePointer andSP: localSP inPage: stackPage. self assert: stackPages pageListIsWellFormed ] diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index 984925885c..7871b7c881 100644 --- a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st @@ -155,7 +155,7 @@ StackInterpreterSimulator >> atEachStepBlock: aBlock [ { #category : #'return bytecodes' } StackInterpreterSimulator >> baseFrameReturn [ | contextToReturnTo | - contextToReturnTo := self frameCallerContext: localFP. + contextToReturnTo := self frameCallerContext: framePointer. ((objectMemory isContext: contextToReturnTo) and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue: [(self checkIsStillMarriedContext: contextToReturnTo currentFP: nil) ifFalse: @@ -615,17 +615,6 @@ StackInterpreterSimulator >> endPCOf: aMethod [ ^end ] -{ #category : #testing } -StackInterpreterSimulator >> ensureDebugAtEachStepBlock [ - atEachStepBlock := [printFrameAtEachStep ifTrue: - [self printFrame: localFP WithSP: localSP]. - printBytecodeAtEachStep ifTrue: - [self printCurrentBytecodeOn: transcript. - transcript cr; flush]. - byteCount = breakCount ifTrue: - ["printFrameAtEachStep :=" printBytecodeAtEachStep := true]] -] - { #category : #'debugging traps' } StackInterpreterSimulator >> externalDivorceFrame: theFP andContext: ctxt [ "(theFP = -208 or: [ctxt = 22189568]) ifTrue: @@ -637,9 +626,9 @@ StackInterpreterSimulator >> externalDivorceFrame: theFP andContext: ctxt [ StackInterpreterSimulator >> externalInstVar: index ofContext: aMarriedContext put: anOop [ | imMarried shesMarried result | index == SenderIndex ifTrue: - [imMarried := self checkIsStillMarriedContext: aMarriedContext currentFP: localFP. + [imMarried := self checkIsStillMarriedContext: aMarriedContext currentFP: framePointer. (objectMemory isContext: anOop) ifTrue: - [shesMarried := self checkIsStillMarriedContext: anOop currentFP: localFP. + [shesMarried := self checkIsStillMarriedContext: anOop currentFP: framePointer. "self shortPrintContext: aMarriedContext. self shortPrintContext: anOop"]]. result := super externalInstVar: index ofContext: aMarriedContext put: anOop. @@ -837,9 +826,9 @@ StackInterpreterSimulator >> initializePluginEntries [ StackInterpreterSimulator >> instVar: index ofContext: aMarriedContext put: anOop [ | imMarried shesMarried result | index == SenderIndex ifTrue: - [imMarried := self checkIsStillMarriedContext: aMarriedContext currentFP: localFP. + [imMarried := self checkIsStillMarriedContext: aMarriedContext currentFP: framePointer. (objectMemory isContext: anOop) ifTrue: - [shesMarried := self checkIsStillMarriedContext: anOop currentFP: localFP. + [shesMarried := self checkIsStillMarriedContext: anOop currentFP: framePointer. "self cr. self shortPrintContext: aMarriedContext. self shortPrintContext: anOop. @@ -1212,7 +1201,7 @@ StackInterpreterSimulator >> loadNewPlugin: pluginString [ { #category : #'spur bootstrap' } StackInterpreterSimulator >> localFP [ - ^localFP + ^framePointer ] { #category : #'spur bootstrap' } @@ -1684,7 +1673,7 @@ StackInterpreterSimulator >> printHexnpnp: anInteger [ { #category : #'debug printing' } StackInterpreterSimulator >> printLCS [ - self printCallStackFP: localFP + self printCallStackFP: framePointer ] { #category : #'debug printing' } @@ -2066,32 +2055,6 @@ StackInterpreterSimulator >> tab [ traceOn ifTrue: [ transcript tab ]. ] -{ #category : #testing } -StackInterpreterSimulator >> test [ - self initStackPages. - self loadInitialContext. - transcript clear. - byteCount := 0. - breakCount := -1. - quitBlock := [^self close]. - printSends := printReturns := true. - self internalizeIPandSP. - self fetchNextBytecode. - [true] whileTrue: - [self assertValidExecutionPointers. - printFrameAtEachStep ifTrue: - [self printFrame: localFP WithSP: localSP]. - printBytecodeAtEachStep ifTrue: - [self printCurrentBytecodeOn: Transcript. - Transcript cr; flush]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount. - byteCount = breakCount ifTrue: - ["printFrameAtEachStep :=" printBytecodeAtEachStep := true. - self halt: 'hit breakCount break-point']]. - self externalizeIPandSP -] - { #category : #testing } StackInterpreterSimulator >> test1 [ self initStackPages. @@ -2158,33 +2121,6 @@ StackInterpreterSimulator >> testBecome [ (objectMemory fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt]. ] -{ #category : #testing } -StackInterpreterSimulator >> testBreakCount: breakCount printSends: shouldPrintSends printFrames: shouldPrintFrames printBytecodes: shouldPrintBytecodes [ - self initStackPages. - self loadInitialContext. - transcript clear. - byteCount := 0. - quitBlock := [^self close]. - printSends := true & shouldPrintSends. "true & foo allows evaluating printFoo := true in the debugger" - printFrameAtEachStep := true & shouldPrintFrames. - printBytecodeAtEachStep := true & shouldPrintBytecodes. - self internalizeIPandSP. - self fetchNextBytecode. - [true] whileTrue: - [self assertValidExecutionPointers. - printFrameAtEachStep ifTrue: - [self printFrame: localFP WithSP: localSP]. - printBytecodeAtEachStep ifTrue: - [self printCurrentBytecodeOn: Transcript. - Transcript cr; flush]. - self dispatchOn: currentBytecode in: BytecodeTable. - self incrementByteCount. - byteCount = breakCount ifTrue: - ["printFrameAtEachStep :=" printBytecodeAtEachStep := true. - self halt: 'hit breakCount break-point']]. - self externalizeIPandSP -] - { #category : #testing } StackInterpreterSimulator >> testWithFramePrint [ printFrameAtEachStep := printBytecodeAtEachStep := true. From 35530b12e0dcab6005bfddac19e2ea9f0b16f831 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 16:11:46 +0200 Subject: [PATCH 23/75] Remove manual localSP optimisation --- smalltalksrc/VMMaker/CoInterpreter.class.st | 20 ++--- smalltalksrc/VMMaker/CogVMSimulator.class.st | 11 --- .../VMMaker/StackInterpreter.class.st | 75 +++++++++---------- .../StackInterpreterSimulator.class.st | 2 +- 4 files changed, 46 insertions(+), 62 deletions(-) diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index 118b6ca191..446cd7e1d0 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -988,7 +988,7 @@ CoInterpreter >> baseFrameReturn [ theSP := thePage headSP]. self setStackPageAndLimit: thePage. self assert: (stackPages stackPageFor: theFP) = stackPage. - localSP := theSP. + stackPointer := theSP. framePointer := theFP. instructionPointer := self pointerForOop: self internalStackTop. instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: @@ -2411,7 +2411,7 @@ CoInterpreter >> commonCallerReturn [ ^self baseFrameReturn]. instructionPointer := self frameCallerSavedIP: framePointer. - localSP := framePointer + (self frameStackedReceiverOffset: framePointer). + stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer). framePointer := callersFPOrNull. instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: @@ -3087,7 +3087,7 @@ CoInterpreter >> externalizeIPandSP [ "Copy the local instruction, stack and frame pointers to global variables for use in primitives and other functions outside the interpret loop." self assert: instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC. - stackPointer := localSP. + stackPointer := stackPointer. ] { #category : #'debug support' } @@ -3690,7 +3690,7 @@ CoInterpreter >> ifBackwardsCheckForEvents: offsetToJumpBytecode [ offsetToJumpBytecode >= 0 ifTrue: [^self]. - localSP < stackLimit ifTrue: + stackPointer < stackLimit ifTrue: [self externalizeIPandSP. switched := self checkForEventsMayContextSwitch: true. self returnToExecutive: true postContextSwitch: switched. @@ -3940,7 +3940,7 @@ CoInterpreter >> internalActivateNewMethod [ self internalPush: instructionPointer. self internalPush: framePointer. - framePointer := localSP. + framePointer := stackPointer. self internalPush: newMethod. self setMethod: newMethod methodHeader: methodHeader. self internalPush: objectMemory nilObject. "FxThisContext field" @@ -3963,14 +3963,14 @@ CoInterpreter >> internalActivateNewMethod [ with a long store temp. Strictly no need to skip the store because it's effectively a noop." instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader). primFailCode ~= 0 ifTrue: - [self reapAndResetErrorCodeTo: localSP header: methodHeader]]. + [self reapAndResetErrorCodeTo: stackPointer header: methodHeader]]. self assert: (self frameNumArgs: framePointer) = argumentCount. self assert: (self frameIsBlockActivation: framePointer) not. self assert: (self frameHasContext: framePointer) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." - localSP < stackLimit ifTrue: + stackPointer < stackLimit ifTrue: [self externalizeIPandSP. switched := self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: newMethod header: methodHeader). @@ -4051,7 +4051,7 @@ CoInterpreter >> internalizeIPandSP [ "Copy the instruction, stack and frame pointers to local variables for rapid access within the interpret loop." self assert: instructionPointer ~= cogit ceReturnToInterpreterPC. - localSP := self pointerForOop: stackPointer + stackPointer := self pointerForOop: stackPointer ] { #category : #'trampoline support' } @@ -5932,7 +5932,7 @@ CoInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg comp "No need to record the pushed copied values in the outerContext." context := ignoreContext ifTrue: [objectMemory nilObject ] - ifFalse: [self ensureFrameIsMarried: framePointer SP: localSP + (numCopiedArg * objectMemory bytesPerOop)]. + ifFalse: [self ensureFrameIsMarried: framePointer SP: stackPointer + (numCopiedArg * objectMemory bytesPerOop)]. newClosure := self fullClosureIn: context numArgs: numArgs @@ -6210,7 +6210,7 @@ CoInterpreter >> returnToMachineCodeFrame [ cogit assertCStackWellAligned. self assert: instructionPointer asUnsignedInteger < objectMemory startOfMemory. self assert: (self isMachineCodeFrame: framePointer). - self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: localSP imbar: false line: #'__LINE__'. + self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: stackPointer imbar: false line: #'__LINE__'. self internalStackTopPut: instructionPointer. self internalPush: localReturnValue. self externalizeFPandSP. diff --git a/smalltalksrc/VMMaker/CogVMSimulator.class.st b/smalltalksrc/VMMaker/CogVMSimulator.class.st index ea2bc5f719..d4ebf98d0a 100644 --- a/smalltalksrc/VMMaker/CogVMSimulator.class.st +++ b/smalltalksrc/VMMaker/CogVMSimulator.class.st @@ -801,17 +801,6 @@ CogVMSimulator >> ensureContextIsExecutionSafeAfterAssignToStackPointer: aContex ^super ensureContextIsExecutionSafeAfterAssignToStackPointer: aContext ] -{ #category : #testing } -CogVMSimulator >> ensureDebugAtEachStepBlock [ - atEachStepBlock := [printFrameAtEachStep ifTrue: - [self printFrame: framePointer WithSP: localSP]. - printBytecodeAtEachStep ifTrue: - [self printCurrentBytecodeOn: transcript. - transcript cr; flush]. - byteCount = breakCount ifTrue: - ["printFrameAtEachStep :=" printBytecodeAtEachStep := true]] -] - { #category : #'frame access' } CogVMSimulator >> ensureMethodIsCogged: methodObj maybeClosure: maybeClosure [ "Uncomment this to compact frequently and hence test if clients are ready for the shock." diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index 91395230a7..c36a122630 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -316,7 +316,6 @@ Class { #instVars : [ 'currentBytecode', 'bytecodeSetSelector', - 'localSP', 'stackLimit', 'stackPage', 'stackPages', @@ -533,7 +532,7 @@ If ffi is put as a separate header, slang will sort the header and put it outsid as: #usqInt in: aCCodeGenerator. "These are all pointers; char * because Slang has no support for C pointer arithmetic." - self declareC: #(instructionPointer localSP stackPointer framePointer stackLimit breakSelector) + self declareC: #(instructionPointer stackPointer framePointer stackLimit breakSelector) as: #'char *' in: aCCodeGenerator. aCCodeGenerator @@ -2202,7 +2201,7 @@ StackInterpreter >> assertValidExecutionPointe: lip r: lfp s: lsp imbar: inInter { #category : #'debug support' } StackInterpreter >> assertValidExecutionPointers [ "simulator only" - self assertValidExecutionPointe: instructionPointer r: framePointer s: localSP + self assertValidExecutionPointe: instructionPointer r: framePointer s: stackPointer ] { #category : #'process primitive support' } @@ -2260,7 +2259,7 @@ StackInterpreter >> baseFrameReturn [ stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows"]. self setStackPageAndLimit: thePage. self assert: (stackPages stackPageFor: theFP) = stackPage. - localSP := theSP. + stackPointer := theSP. framePointer := theFP. self setMethod: (self frameMethod: framePointer). instructionPointer := self pointerForOop: self internalStackTop. @@ -4564,7 +4563,7 @@ StackInterpreter >> commonCallerReturn [ ^self baseFrameReturn]. instructionPointer := self frameCallerSavedIP: framePointer. - localSP := framePointer + (self frameStackedReceiverOffset: framePointer). + stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer). framePointer := callersFPOrNull. self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. @@ -4667,7 +4666,7 @@ StackInterpreter >> commonReturn [ self markContextAsDead: currentCtx. currentCtx := nextCntx]]. self setStackPageAndLimit: newPage. - localSP := stackPage headSP. + stackPointer := stackPage headSP. framePointer := stackPage headFP]. "Two cases. Returning to the top frame on a new page or an interior frame on the current page. @@ -4682,7 +4681,7 @@ StackInterpreter >> commonReturn [ framePointer := self frameCallerFP: framePointer. framePointer ~~ frameToReturnTo] whileTrue. instructionPointer := self frameCallerSavedIP: callerFP. - localSP := (self frameCallerSP: callerFP) - objectMemory wordSize]. + stackPointer := (self frameCallerSP: callerFP) - objectMemory wordSize]. self maybeReturnToMachineCodeFrame. self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. @@ -5522,7 +5521,7 @@ StackInterpreter >> extPushPseudoVariable [ | theThingToPush | extB caseOf: { - [0] -> [theThingToPush := self ensureFrameIsMarried: framePointer SP: localSP]. + [0] -> [theThingToPush := self ensureFrameIsMarried: framePointer SP: stackPointer]. [1] -> [theThingToPush := self activeProcess] } otherwise: [self respondToUnknownBytecode]. @@ -5913,17 +5912,13 @@ StackInterpreter >> externalWriteBackHeadFramePointers [ { #category : #utilities } StackInterpreter >> externalizeFPandSP [ "Copy the frame and stack pointers to global variables for use in primitives and other functions outside the interpret loop." - self assert: (localSP < stackPage baseAddress - and: [localSP > (stackPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop))]). - stackPointer := localSP. - framePointer := framePointer + self assert: (stackPointer < stackPage baseAddress + and: [stackPointer > (stackPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop))]). ] { #category : #utilities } StackInterpreter >> externalizeIPandSP [ "Copy the local instruction, stack and frame pointers to global variables for use in primitives and other functions outside the interpret loop." - - stackPointer := localSP. ] { #category : #'primitive support' } @@ -7317,7 +7312,7 @@ StackInterpreter >> handleForwardedSendFaultForTag: classTag [ StackInterpreter >> handleSpecialSelectorSendFaultFor: obj [ - ^self handleSpecialSelectorSendFaultFor: obj fp: framePointer sp: localSP + ^self handleSpecialSelectorSendFaultFor: obj fp: framePointer sp: stackPointer ] { #category : #'message sending' } @@ -7494,7 +7489,7 @@ StackInterpreter >> ifBackwardsCheckForEvents: offset [ "Backward jump means we're in a loop; check for possible interrupts." (offset < 0 - and: [localSP < stackLimit]) ifTrue: + and: [stackPointer < stackLimit]) ifTrue: [self externalizeIPandSP. self checkForEventsMayContextSwitch: true. self browserPluginReturnIfNeeded. @@ -7901,7 +7896,7 @@ StackInterpreter >> instVar: index ofContext: aMarriedContext put: anOop [ onCurrentPage ifTrue: [framePointer := stackPage headFP. - localSP := stackPage headSP] + stackPointer := stackPage headSP] ifFalse: [stackPages markStackPageMostRecentlyUsed: stackPage]. ^nil]. @@ -7915,7 +7910,7 @@ StackInterpreter >> instVar: index ofContext: aMarriedContext put: anOop [ self internalizeIPandSP. "Assigning various fields can force a divorce which can change the stackPage." stackPages markStackPageMostRecentlyUsed: stackPage. - self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: localSP imbar: true line: #'__LINE__' + self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: stackPointer imbar: true line: #'__LINE__' ] { #category : #'indexing primitive support' } @@ -8003,7 +7998,7 @@ StackInterpreter >> integerArg: index [ StackInterpreter >> internalAboutToReturn: resultOop through: aContext [ | ourContext | - ourContext := self ensureFrameIsMarried: framePointer SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. self internalPush: ourContext. self internalPush: resultOop. self internalPush: aContext. @@ -8026,7 +8021,7 @@ StackInterpreter >> internalActivateNewMethod [ self internalPush: instructionPointer. self internalPush: framePointer. - framePointer := localSP. + framePointer := stackPointer. self internalPush: newMethod. self setMethod: newMethod methodHeader: methodHeader. self internalPush: (self @@ -8050,14 +8045,14 @@ StackInterpreter >> internalActivateNewMethod [ instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader). primFailCode ~= 0 ifTrue: [ - self reapAndResetErrorCodeTo: localSP header: methodHeader ] ]. + self reapAndResetErrorCodeTo: stackPointer header: methodHeader ] ]. self assert: (self frameNumArgs: framePointer) = argumentCount. self assert: (self frameIsBlockActivation: framePointer) not. self assert: (self frameHasContext: framePointer) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." - localSP < stackLimit ifTrue: [ + stackPointer < stackLimit ifTrue: [ self externalizeIPandSP. self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: newMethod header: methodHeader). @@ -8068,7 +8063,7 @@ StackInterpreter >> internalActivateNewMethod [ StackInterpreter >> internalCannotReturn: resultOop [ | ourContext | - ourContext := self ensureFrameIsMarried: framePointer SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. self internalPush: ourContext. self internalPush: resultOop. messageSelector := objectMemory splObj: SelectorCannotReturn. @@ -8127,28 +8122,28 @@ StackInterpreter >> internalMustBeBoolean [ { #category : #'internal interpreter access' } StackInterpreter >> internalPop: nItems [ "In the StackInterpreter stacks grow down." - localSP := localSP + (nItems * objectMemory bytesPerOop) + stackPointer := stackPointer + (nItems * objectMemory bytesPerOop) ] { #category : #'internal interpreter access' } StackInterpreter >> internalPop: nItems thenPush: oop [ "In the StackInterpreter stacks grow down." - stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * objectMemory bytesPerOop)) put: oop + stackPages longAtPointer: (stackPointer := stackPointer + ((nItems - 1) * objectMemory bytesPerOop)) put: oop ] { #category : #'internal interpreter access' } StackInterpreter >> internalPopStack [ "In the StackInterpreter stacks grow down." | top | - top := stackPages longAt: localSP. - localSP := localSP + objectMemory bytesPerOop. + top := stackPages longAt: stackPointer. + stackPointer := stackPointer + objectMemory bytesPerOop. ^top ] { #category : #'internal interpreter access' } StackInterpreter >> internalPush: object [ "In the StackInterpreter stacks grow down." - stackPages longAtPointer: (localSP := localSP - objectMemory bytesPerOop) put: object + stackPages longAtPointer: (stackPointer := stackPointer - objectMemory bytesPerOop) put: object ] { #category : #'primitive support' } @@ -8176,13 +8171,13 @@ StackInterpreter >> internalQuickPrimitiveResponse [ { #category : #'internal interpreter access' } StackInterpreter >> internalStackTop [ - ^stackPages longAtPointer: localSP + ^stackPages longAtPointer: stackPointer ] { #category : #'internal interpreter access' } StackInterpreter >> internalStackTopPut: aValue [ - ^stackPages longAtPointer: localSP put: aValue + ^stackPages longAtPointer: stackPointer put: aValue ] { #category : #'internal interpreter access' } @@ -8194,19 +8189,19 @@ StackInterpreter >> internalStackTopPutIntegerObjectOf: aValue [ { #category : #'internal interpreter access' } StackInterpreter >> internalStackValue: offset [ "In the StackInterpreter stacks grow down." - ^stackPages longAtPointer: localSP + (offset * objectMemory bytesPerOop) + ^stackPages longAtPointer: stackPointer + (offset * objectMemory bytesPerOop) ] { #category : #'internal interpreter access' } StackInterpreter >> internalStackValue: offset put: aValue [ "In the StackInterpreter stacks grow down." - ^stackPages longAtPointer: localSP + (offset * objectMemory bytesPerOop) put: aValue + ^stackPages longAtPointer: stackPointer + (offset * objectMemory bytesPerOop) put: aValue ] { #category : #utilities } StackInterpreter >> internalizeIPandSP [ "Copy the instruction, stack and frame pointers to local variables for rapid access within the interpret loop." - localSP := self pointerForOop: stackPointer + stackPointer := self pointerForOop: stackPointer ] { #category : #'interpreter shell' } @@ -11853,7 +11848,7 @@ StackInterpreter >> printHeadFrame [ Do not generate this function as there is no way to properly translate it to C. Translating this function requires access to localFP and localSP which are local variables in the interpreter loop function, thus, they are not accessible from within this function." - self printFrame: framePointer WithSP: localSP + self printFrame: framePointer WithSP: stackPointer ] { #category : #'debug printing' } @@ -12497,7 +12492,7 @@ StackInterpreter >> push: object [ { #category : #'stack bytecodes' } StackInterpreter >> pushActiveContextBytecode [ | ourContext | - ourContext := self ensureFrameIsMarried: framePointer SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. self fetchNextBytecode. self internalPush: ourContext ] @@ -12581,7 +12576,7 @@ StackInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg c "No need to record the pushed copied values in the outerContext." context := ignoreContext ifTrue: [objectMemory nilObject ] - ifFalse: [self ensureFrameIsMarried: framePointer SP: localSP + (numCopiedArg * objectMemory bytesPerOop)]. + ifFalse: [self ensureFrameIsMarried: framePointer SP: stackPointer + (numCopiedArg * objectMemory bytesPerOop)]. newClosure := self fullClosureIn: context numArgs: numArgs @@ -13220,7 +13215,7 @@ StackInterpreter >> respondToSistaTrap [ | ourContext | messageSelector := objectMemory splObj: SelectorSistaTrap. - ourContext := self ensureFrameIsMarried: framePointer SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. self internalPush: ourContext. argumentCount := 0. self normalSend @@ -13235,7 +13230,7 @@ StackInterpreter >> respondToUnknownBytecode [ (messageSelector isNil or: [messageSelector = objectMemory nilObject]) ifTrue: [self error: 'Unknown bytecode']. - ourContext := self ensureFrameIsMarried: framePointer SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. "undo fetch of bytecode so that context's pc is pointing to the unknown bytecode." instructionPointer := instructionPointer - 1. self internalPush: ourContext. @@ -14123,7 +14118,7 @@ StackInterpreter >> showDisplayBits: aForm Left: l Top: t Right: r Bottom: b [ StackInterpreter >> shuffleArgumentsAndStoreAbsentReceiver: theReceiver [ "For the absent receiver sends move the arguments up the stack and store the supplied receiver." - localSP := localSP - objectMemory bytesPerOop. "a.k.a. self internalPush: anything" + stackPointer := stackPointer - objectMemory bytesPerOop. "a.k.a. self internalPush: anything" 1 to: argumentCount do: [:i| | oop | oop := self internalStackValue: i. @@ -15964,7 +15959,7 @@ StackInterpreter >> wordSwapped: w [ { #category : #'stack pages' } StackInterpreter >> writeBackHeadFramePointers [ self assert: stackPage = stackPages mostRecentlyUsedPage. - self setHeadFP: framePointer andSP: localSP inPage: stackPage. + self setHeadFP: framePointer andSP: stackPointer inPage: stackPage. self assert: stackPages pageListIsWellFormed ] diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index 7871b7c881..47b57ffd9b 100644 --- a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st @@ -1206,7 +1206,7 @@ StackInterpreterSimulator >> localFP [ { #category : #'spur bootstrap' } StackInterpreterSimulator >> localSP [ - ^localSP + ^stackPointer ] { #category : #'memory access' } From 601dbb13637528e48faa90c5a5f5c0434e96502c Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 16:18:12 +0200 Subject: [PATCH 24/75] Replace internalPop => pop --- smalltalksrc/VMMaker/CoInterpreter.class.st | 8 +- .../VMMaker/StackInterpreter.class.st | 82 +++++++++---------- 2 files changed, 42 insertions(+), 48 deletions(-) diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index 446cd7e1d0..2677394a33 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -2999,7 +2999,7 @@ CoInterpreter >> extendedStoreBytecodePop: popBoolean [ variableType := descriptor >> 6 bitAnd: 3. variableIndex := descriptor bitAnd: 63. value := self internalStackTop. - popBoolean ifTrue: [ self internalPop: 1 ]. + popBoolean ifTrue: [ self pop: 1 ]. variableType = 0 ifTrue: [objectMemory storePointerImmutabilityCheck: variableIndex ofObject: self receiver withValue: value. ^ self fetchNextBytecode.]. @@ -5958,7 +5958,7 @@ CoInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg comp objectMemory storePointerUnchecked: i + startIndex ofObject: newClosure withValue: (self internalStackValue: numCopied - i - 1)]. - self internalPop: numCopied]. + self pop: numCopied]. self fetchNextBytecode. self internalPush: newClosure ] @@ -6566,11 +6566,11 @@ CoInterpreter >> storeAndPopTemporaryVariableBytecode [ cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant" [self fetchNextBytecode. self itemporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. - self internalPop: 1] + self pop: 1] inSmalltalk: "Interpreter version has fetchNextBytecode out of order" [self itemporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. self fetchNextBytecode. - self internalPop: 1] + self pop: 1] ] { #category : #'stack bytecodes' } diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index c36a122630..699ba8d1e3 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -2332,7 +2332,7 @@ StackInterpreter >> binaryAtInlinePrimitive: primIndex [ [69] -> [self assert: (objectMemory isLong64s: rec). self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). result := self positive64BitIntegerFor: (objectMemory fetchLong64: argIntAdjusted ofObject: rec)].}. - self internalPop: 1; internalStackTopPut: result + self pop: 1; internalStackTopPut: result ] { #category : #'sista inline primitives - binary' } @@ -2348,7 +2348,7 @@ StackInterpreter >> binaryCompInlinePrimitive: primIndex [ not a forwarder, not a forwarder => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)" [39] -> [result := ((self internalStackValue: 1) ~= self internalStackTop)]. }. - self internalPop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) + self pop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) ] { #category : #'sista inline primitives - binary' } @@ -2440,7 +2440,7 @@ StackInterpreter >> binaryNewInlinePrimitive: primIndex [ self assert: (objectMemory isIntegerObject: top). size := self positiveMachineIntegerValueOf: top. result := objectMemory instantiateClass: classObj indexableSize: size. - self internalPop: 1; internalStackTopPut: result + self pop: 1; internalStackTopPut: result ] { #category : #'sista inline primitives - binary' } @@ -2477,7 +2477,7 @@ StackInterpreter >> binarySmiArithmeticInlinePrimitive: primIndex [ Smi, Smi => Smi (no overflow, optimised if one operand is a constant)" [6] -> [result := self quot: recInt ient: argInt]. }. - self internalPop: 1; internalStackTopPutIntegerObjectOf: result + self pop: 1; internalStackTopPutIntegerObjectOf: result ] { #category : #'sista inline primitives - binary' } @@ -2511,7 +2511,7 @@ StackInterpreter >> binarySmiBitInlinePrimitive: primIndex [ [20] -> [self assert: argInt >= 0. result := recInt >> argInt]. }. - self internalPop: 1; internalStackTopPutIntegerObjectOf: result + self pop: 1; internalStackTopPutIntegerObjectOf: result ] { #category : #'sista inline primitives - binary' } @@ -2543,7 +2543,7 @@ StackInterpreter >> binarySmiCompInlinePrimitive: primIndex [ Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)" [37] -> [result := (rcvr ~= top)]. }. - self internalPop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) + self pop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) ] { #category : #utilities } @@ -2563,7 +2563,7 @@ StackInterpreter >> booleanCheatFalse [ | bytecode offset | bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)" - self internalPop: 2. + self pop: 2. (bytecode < 160 and: [bytecode > 151]) ifTrue: "short jumpIfFalse" [^self jump: bytecode - 151]. @@ -2585,7 +2585,7 @@ StackInterpreter >> booleanCheatFalseSistaV1 [ | bytecode offset | bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)" - self internalPop: 2. + self pop: 2. (bytecode < 199 and: [bytecode > 191]) ifTrue: "short jumpIfFalse" [^self jump: bytecode - 191]. @@ -2607,7 +2607,7 @@ StackInterpreter >> booleanCheatFalseV4 [ | bytecode offset | bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)" - self internalPop: 2. + self pop: 2. (bytecode < 216 and: [bytecode > 207]) ifTrue: "short jumpIfFalse" [^self jump: bytecode - 207]. @@ -2639,7 +2639,7 @@ StackInterpreter >> booleanCheatTrue [ | bytecode offset | bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)" - self internalPop: 2. + self pop: 2. (bytecode < 173 and: [bytecode > 151]) ifTrue: [bytecode < 160 ifTrue: "short jumpIfFalse 152 - 159" [^self fetchNextBytecode]. @@ -2664,7 +2664,7 @@ StackInterpreter >> booleanCheatTrueSistaV1 [ | bytecode offset | bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)" - self internalPop: 2. + self pop: 2. bytecode >= 192 ifTrue: [bytecode <= 199 ifTrue: "short jumpIfFalse 192 - 199" [^self fetchNextBytecode]. @@ -2689,7 +2689,7 @@ StackInterpreter >> booleanCheatTrueV4 [ | bytecode offset | bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)" - self internalPop: 2. + self pop: 2. bytecode >= 208 ifTrue: [bytecode <= 215 ifTrue: "short jumpIfFalse 208 - 215" [^self fetchNextBytecode]. @@ -5594,7 +5594,7 @@ StackInterpreter >> extStoreAndPopLiteralVariableBytecode [ | variableIndex value | variableIndex := self fetchByte + (extA << 8). value := self internalStackTop. - self internalPop: 1. + self pop: 1. extA := 0. self storeLiteralVariable: variableIndex withValue: value. self fetchNextBytecode. @@ -5607,7 +5607,7 @@ StackInterpreter >> extStoreAndPopReceiverVariableBytecode [ variableIndex := self fetchByte + (extA << 8). extA := 0. value := self internalStackTop. - self internalPop: 1. + self pop: 1. self storeMaybeContextReceiverVariable: variableIndex withValue: value. self fetchNextBytecode. ] @@ -5683,7 +5683,7 @@ StackInterpreter >> extendedStoreBytecodePop: popBoolean [ variableType := descriptor >> 6 bitAnd: 3. variableIndex := descriptor bitAnd: 63. value := self internalStackTop. - popBoolean ifTrue: [ self internalPop: 1 ]. + popBoolean ifTrue: [ self pop: 1 ]. variableType = 0 ifTrue: [objectMemory storePointerImmutabilityCheck: variableIndex ofObject: self receiver withValue: value. ^ self fetchNextBytecode]. @@ -8119,12 +8119,6 @@ StackInterpreter >> internalMustBeBoolean [ self normalSend ] -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPop: nItems [ - "In the StackInterpreter stacks grow down." - stackPointer := stackPointer + (nItems * objectMemory bytesPerOop) -] - { #category : #'internal interpreter access' } StackInterpreter >> internalPop: nItems thenPush: oop [ "In the StackInterpreter stacks grow down." @@ -8740,7 +8734,7 @@ StackInterpreter >> jumpBinaryInlinePrimitive: primIndex [ }. instructionPointer := instructionPointer - 1. "we've already fetched, but we may have incorrectly fetched if jump" self fetchNextBytecode. - self internalPop: 2. + self pop: 2. ] @@ -8786,12 +8780,12 @@ StackInterpreter >> jumpTrinaryInlinePrimitive: primIndex [ classTag = (objectMemory rawClassTagForClass: (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: [instructionPointer := instructionPointer - 1. self fetchNextBytecode. - ^self internalPop: 3]]. + ^self pop: 3]]. instructionPointer := instructionPointer + offset]. }. instructionPointer := instructionPointer - 1. "we've already fetched, but we may have incorrectly fetched if jump" self fetchNextBytecode. - self internalPop: 3 + self pop: 3 ] @@ -8808,7 +8802,7 @@ StackInterpreter >> jumpUnaryInlinePrimitive: primIndex [ "We've already fetched next bytecode, so we add -1" instructionPointer := instructionPointer + (objectMemory integerValueOf: top) - 1. self fetchNextBytecode. - ^self internalPop: 1]. + ^self pop: 1]. ^ self unknownInlinePrimitive ] @@ -8822,7 +8816,7 @@ StackInterpreter >> jumplfFalseBy: offset [ [boolean = objectMemory trueObject ifFalse: [^self internalMustBeBoolean]. self fetchNextBytecode]. - self internalPop: 1 + self pop: 1 ] { #category : #'jump bytecodes' } @@ -8835,7 +8829,7 @@ StackInterpreter >> jumplfTrueBy: offset [ [boolean = objectMemory falseObject ifFalse: [^self internalMustBeBoolean]. self fetchNextBytecode]. - self internalPop: 1 + self pop: 1 ] { #category : #'message sending' } @@ -9115,7 +9109,7 @@ StackInterpreter >> longPushTemporaryVariableBytecode [ StackInterpreter >> longStoreAndPopTemporaryVariableBytecode [ "237 11101101 i i i i i i i i Pop and Store Temporary Variable #iiiiiiii" self longStoreTemporaryVariableBytecode. - self internalPop: 1 + self pop: 1 ] { #category : #'compiled methods' } @@ -9623,7 +9617,7 @@ StackInterpreter >> mappedBackjumpAlwaysInterrupt [ self assert: (objectMemory isIntegerObject: top). offset := objectMemory integerObjectOf: top. instructionPointer := instructionPointer - offset. - self internalPop: 1. + self pop: 1. "+1 since this instr is 3 bytes not 2" self ifBackwardsCheckForEvents: 0 - offset + 1. instructionPointer := instructionPointer - 1. @@ -9675,7 +9669,7 @@ StackInterpreter >> mappedImmcheckDataAtPut: primIndex [ argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. self assert: argIntAdjusted >= 0. result := self internalStackTop. - self internalPop: 2; internalStackTopPut: result. + self pop: 2; internalStackTopPut: result. (objectMemory isImmutable: rec) ifTrue: [^self cannotAssign: result to: rec withIndex: argIntAdjusted]. primIndex caseOf: { @@ -9726,7 +9720,7 @@ StackInterpreter >> mappedImmcheckMaybeContextStoreCheckPointerAtPut [ self assert: (objectMemory isIntegerObject: arg1). argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. result := self internalStackTop. - self internalPop: 3. + self pop: 3. self internalPush: result. (self isWriteMediatedContextInstVarIndex: argIntAdjusted) ifFalse: [objectMemory storePointerImmutabilityCheck: argIntAdjusted ofObject: rec withValue: result] @@ -9748,7 +9742,7 @@ StackInterpreter >> mappedImmcheckStoreCheckPointerAtPut [ self assert: argIntAdjusted >= 0. self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). result := self internalStackTop. - self internalPop: 3. + self pop: 3. self internalPush: result. objectMemory storePointerImmutabilityCheck: argIntAdjusted @@ -10918,7 +10912,7 @@ StackInterpreter >> popStack [ StackInterpreter >> popStackBytecode [ self fetchNextBytecode. - self internalPop: 1. + self pop: 1. ] @@ -12600,7 +12594,7 @@ StackInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg c objectMemory storePointerUnchecked: i + startIndex ofObject: newClosure withValue: (self internalStackValue: numCopied - i - 1)]. - self internalPop: numCopied]. + self pop: numCopied]. self fetchNextBytecode. self internalPush: newClosure ] @@ -12728,7 +12722,7 @@ StackInterpreter >> pushNewArrayBytecode [ [:i| "Assume: have just allocated a new Array; it must be young. Thus, can use unchecked stores." objectMemory storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)]. - self internalPop: size] + self pop: size] ifFalse: [0 to: size - 1 do: [:i| @@ -12919,7 +12913,7 @@ StackInterpreter >> quinaryInlinePrimitive: primIndex [ destLimit := (objectMemory integerValueOf: (self internalStackValue: 2)) - 1. src := self internalStackValue: 1. srcIndex := (objectMemory integerValueOf: (self internalStackValue: 0)) - 1. - self internalPop: 4. + self pop: 4. destLimit < destIndex ifTrue: [^self]. (objectMemory isYoung: dest) ifFalse: [objectMemory possibleRootStoreInto: dest]. 0 to: destLimit - destIndex do: @@ -14825,7 +14819,7 @@ StackInterpreter >> storeAndPopReceiverVariableBytecode [ rcvr := self receiver. top := self internalStackTop. instVarIndex := currentBytecode bitAnd: 7. - self internalPop: 1. + self pop: 1. objectMemory storePointerImmutabilityCheck: instVarIndex ofObject: rcvr @@ -14836,7 +14830,7 @@ StackInterpreter >> storeAndPopReceiverVariableBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> storeAndPopRemoteTempLongBytecode [ self storeRemoteTempLongBytecode. - self internalPop: 1 + self pop: 1 ] { #category : #'stack bytecodes' } @@ -14846,11 +14840,11 @@ StackInterpreter >> storeAndPopTemporaryVariableBytecode [ cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant" [self fetchNextBytecode. self temporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. - self internalPop: 1] + self pop: 1] inSmalltalk: "Interpreter version has fetchNextBytecode out of order" [self temporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. self fetchNextBytecode. - self internalPop: 1] + self pop: 1] ] { #category : #utilities } @@ -15313,7 +15307,7 @@ StackInterpreter >> trinaryAtPutInlinePrimitive: primIndex [ ofObject: rec withValue: (objectMemory positive64BitValueOf: result).]. }. - self internalPop: 2; internalStackTopPut: result + self pop: 2; internalStackTopPut: result ] { #category : #'sista bytecodes' } @@ -15342,14 +15336,14 @@ StackInterpreter >> trinaryInlinePrimitive: primIndex [ primIndex = 21 ifTrue: [ | str1 str2 word1 word2 len | len := objectMemory integerValueOf: self internalStackTop. - len = 0 ifTrue: [^self internalPop: 2; internalStackTopPut: objectMemory trueObject]. + len = 0 ifTrue: [^self pop: 2; internalStackTopPut: objectMemory trueObject]. str1 := self internalStackValue: 2. str2 := self internalStackValue: 1. 0 to: len - 1 >> objectMemory shiftForWord do: [:i | word1 := objectMemory fetchPointer: i ofObject: str1. word2 := objectMemory fetchPointer: i ofObject: str2. - word1 = word2 ifFalse: [^self internalPop: 2; internalStackTopPut: objectMemory falseObject] ]. - ^self internalPop: 2; internalStackTopPut: objectMemory trueObject ]. + word1 = word2 ifFalse: [^self pop: 2; internalStackTopPut: objectMemory falseObject] ]. + ^self pop: 2; internalStackTopPut: objectMemory trueObject ]. self unknownInlinePrimitive ] From 1ade953db0afc202557ed5a6c27dea0ea6bd056b Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 16:27:12 +0200 Subject: [PATCH 25/75] removing internal* versions --- smalltalksrc/VMMaker/CoInterpreter.class.st | 26 ++-- .../VMMaker/StackInterpreter.class.st | 145 ++++++++---------- .../StackInterpreterSimulator.class.st | 2 +- 3 files changed, 76 insertions(+), 97 deletions(-) diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index 2677394a33..34382f6c6c 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -3938,22 +3938,22 @@ CoInterpreter >> internalActivateNewMethod [ rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. - self internalPush: instructionPointer. - self internalPush: framePointer. + self push: instructionPointer. + self push: framePointer. framePointer := stackPointer. - self internalPush: newMethod. + self push: newMethod. self setMethod: newMethod methodHeader: methodHeader. - self internalPush: objectMemory nilObject. "FxThisContext field" - self internalPush: (self + self push: objectMemory nilObject. "FxThisContext field" + self push: (self encodeFrameFieldHasContext: false isBlock: false numArgs: (self argumentCountOfMethodHeader: methodHeader)). - self internalPush: 0. "FoxIFSavedIP" - self internalPush: rcvr. + self push: 0. "FoxIFSavedIP" + self push: rcvr. "Initialize temps..." argumentCount + 1 to: numTemps do: - [:i | self internalPush: objectMemory nilObject]. + [:i | self push: objectMemory nilObject]. "-1 to account for pre-increment in fetchNextBytecode" instructionPointer := self pointerForOop: (self initialIPForHeader: methodHeader method: newMethod) - 1. @@ -4256,7 +4256,7 @@ CoInterpreter >> longPushTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self internalPush: (self itemporary: index in: framePointer) + self push: (self itemporary: index in: framePointer) ] { #category : #'stack bytecodes' } @@ -5960,7 +5960,7 @@ CoInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg comp withValue: (self internalStackValue: numCopied - i - 1)]. self pop: numCopied]. self fetchNextBytecode. - self internalPush: newClosure + self push: newClosure ] { #category : #'stack bytecodes' } @@ -5972,13 +5972,13 @@ CoInterpreter >> pushRemoteTemp: index inVectorAt: tempVectorIndex [ ifTrue: [(objectMemory isForwarded: tempVector) ifTrue: [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. - self internalPush: (objectMemory fetchPointer: index ofObject: tempVector) + self push: (objectMemory fetchPointer: index ofObject: tempVector) ] { #category : #'stack bytecodes' } CoInterpreter >> pushTemporaryVariable: temporaryIndex [ "Override to use itemporary:in:put:" - self internalPush: (self itemporary: temporaryIndex in: framePointer) + self push: (self itemporary: temporaryIndex in: framePointer) ] { #category : #'cog jit support' } @@ -6212,7 +6212,7 @@ CoInterpreter >> returnToMachineCodeFrame [ self assert: (self isMachineCodeFrame: framePointer). self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: stackPointer imbar: false line: #'__LINE__'. self internalStackTopPut: instructionPointer. - self internalPush: localReturnValue. + self push: localReturnValue. self externalizeFPandSP. self cCode: '' inSmalltalk: [self maybeCheckStackDepth: 1 sp: stackPointer pc: instructionPointer]. diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index 699ba8d1e3..0f92fe06ec 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -2575,7 +2575,7 @@ StackInterpreter >> booleanCheatFalse [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory falseObject + self push: objectMemory falseObject ] { #category : #utilities } @@ -2597,7 +2597,7 @@ StackInterpreter >> booleanCheatFalseSistaV1 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory falseObject + self push: objectMemory falseObject ] { #category : #utilities } @@ -2619,7 +2619,7 @@ StackInterpreter >> booleanCheatFalseV4 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory falseObject + self push: objectMemory falseObject ] { #category : #utilities } @@ -2654,7 +2654,7 @@ StackInterpreter >> booleanCheatTrue [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory trueObject + self push: objectMemory trueObject ] { #category : #utilities } @@ -2679,7 +2679,7 @@ StackInterpreter >> booleanCheatTrueSistaV1 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory trueObject + self push: objectMemory trueObject ] { #category : #utilities } @@ -2704,7 +2704,7 @@ StackInterpreter >> booleanCheatTrueV4 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory trueObject + self push: objectMemory trueObject ] { #category : #utilities } @@ -2734,7 +2734,7 @@ StackInterpreter >> bytecodePrimAdd [ (objectMemory areIntegers: rcvr and: arg) ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg). (objectMemory isIntegerValue: result) ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + [self pop: 2 thenPush: (objectMemory integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. @@ -2779,7 +2779,7 @@ StackInterpreter >> bytecodePrimAt [ [result := self commonVariable: rcvr at: (objectMemory integerValueOf: index) cacheIndex: atIx]. self successful ifTrue: [self fetchNextBytecode. - ^self internalPop: 2 thenPush: result]. + ^self pop: 2 thenPush: result]. self initPrimCall]. messageSelector := self specialSelector: 16. @@ -2830,7 +2830,7 @@ StackInterpreter >> bytecodePrimAtPut [ [self commonVariable: rcvr at: (objectMemory integerValueOf: index) put: value cacheIndex: atIx]. self successful ifTrue: [self fetchNextBytecode. - ^self internalPop: 3 thenPush: value]. + ^self pop: 3 thenPush: value]. self initPrimCall]. messageSelector := self specialSelector: 17. @@ -2845,7 +2845,7 @@ StackInterpreter >> bytecodePrimBitAnd [ rcvr := self internalStackValue: 1. ((objectMemory isIntegerObject: arg) and: [objectMemory isIntegerObject: rcvr]) ifTrue: - [self internalPop: 2 thenPush: (arg bitAnd: rcvr). + [self pop: 2 thenPush: (arg bitAnd: rcvr). ^self fetchNextBytecode "success"]. self initPrimCall. @@ -2867,7 +2867,7 @@ StackInterpreter >> bytecodePrimBitOr [ rcvr := self internalStackValue: 1. ((objectMemory isIntegerObject: arg) and: [objectMemory isIntegerObject: rcvr]) ifTrue: - [self internalPop: 2 thenPush: (arg bitOr: rcvr). + [self pop: 2 thenPush: (arg bitOr: rcvr). ^self fetchNextBytecode "success"]. self initPrimCall. @@ -2911,7 +2911,7 @@ StackInterpreter >> bytecodePrimDiv [ | quotient | self initPrimCall. quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). - self successful ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: quotient). + self successful ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: quotient). ^ self fetchNextBytecode "success"]. messageSelector := self specialSelector: 13. @@ -2931,7 +2931,7 @@ StackInterpreter >> bytecodePrimDivide [ ifTrue: [result := rcvr // arg. "generates C / operation" (objectMemory isIntegerValue: result) - ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: result). ^ self fetchNextBytecode"success"]]] ifFalse: [self initPrimCall. self externalizeIPandSP. @@ -3291,7 +3291,7 @@ StackInterpreter >> bytecodePrimMakePoint [ objectMemory "No need to check since new object is always new." storePointerUnchecked: XIndex ofObject: pt withValue: rcvr; storePointerUnchecked: YIndex ofObject: pt withValue: arg. - self internalPop: 2 thenPush: pt. + self pop: 2 thenPush: pt. ^self fetchNextBytecode "success"]. messageSelector := self specialSelector: 11. @@ -3305,7 +3305,7 @@ StackInterpreter >> bytecodePrimMod [ self initPrimCall. mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). self successful ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: mod). + [self pop: 2 thenPush: (objectMemory integerObjectOf: mod). ^ self fetchNextBytecode "success"]. messageSelector := self specialSelector: 10. @@ -3332,7 +3332,7 @@ StackInterpreter >> bytecodePrimMultiply [ ifFalse: [result := rcvr * arg. oop := objectMemory integerObjectOf: result. - self internalPop: 2 thenPush: oop. + self pop: 2 thenPush: oop. ^self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. @@ -3536,7 +3536,7 @@ StackInterpreter >> bytecodePrimSubtract [ (objectMemory areIntegers: rcvr and: arg) ifTrue: [result := (objectMemory integerValueOf: rcvr) - (objectMemory integerValueOf: arg). (objectMemory isIntegerValue: result) ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + [self pop: 2 thenPush: (objectMemory integerObjectOf: result). ^self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. @@ -3764,9 +3764,9 @@ StackInterpreter >> canContextSwitchIfActivating: theMethod header: methodHeader StackInterpreter >> cannotAssign: resultObj to: targetObj withIndex: index [ "because of use of normalSend..." - self internalPush: targetObj. - self internalPush: resultObj. - self internalPush: (objectMemory integerObjectOf: index + 1). + self push: targetObj. + self push: resultObj. + self push: (objectMemory integerObjectOf: index + 1). messageSelector := self splObj: SelectorAttemptToAssign. argumentCount := 2. ^ self normalSend @@ -5033,7 +5033,7 @@ StackInterpreter >> directedSuperclassSend [ "" | class superclass | - class := self internalPopStack. + class := self popStack. (objectMemory isForwarded: class) ifTrue: [class := objectMemory followForwarded: class]. superclass := self superclassOf: class. @@ -5238,7 +5238,7 @@ StackInterpreter >> dumpPrimTraceLog [ StackInterpreter >> duplicateTopBytecode [ self fetchNextBytecode. - self internalPush: self internalStackTop. + self push: self internalStackTop. ] @@ -5457,7 +5457,7 @@ StackInterpreter >> extPushCharacterBytecode [ | value | value := self fetchByte + (extB << 8). self fetchNextBytecode. - self internalPush: (objectMemory characterObjectOf: value). + self push: (objectMemory characterObjectOf: value). numExtB := extB := 0 ] @@ -5492,7 +5492,7 @@ StackInterpreter >> extPushIntegerBytecode [ self fetchNextBytecode. extB := 0. numExtB := 0. - self internalPush: (objectMemory integerObjectOf: value) + self push: (objectMemory integerObjectOf: value) ] { #category : #'stack bytecodes' } @@ -5526,7 +5526,7 @@ StackInterpreter >> extPushPseudoVariable [ otherwise: [self respondToUnknownBytecode]. self fetchNextBytecode. - self internalPush: theThingToPush. + self push: theThingToPush. extB := 0. numExtB := 0. ] @@ -7999,9 +7999,9 @@ StackInterpreter >> internalAboutToReturn: resultOop through: aContext [ | ourContext | ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. - self internalPush: ourContext. - self internalPush: resultOop. - self internalPush: aContext. + self push: ourContext. + self push: resultOop. + self push: aContext. messageSelector := objectMemory splObj: SelectorAboutToReturn. argumentCount := 2. ^self normalSend @@ -8019,21 +8019,21 @@ StackInterpreter >> internalActivateNewMethod [ rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. - self internalPush: instructionPointer. - self internalPush: framePointer. + self push: instructionPointer. + self push: framePointer. framePointer := stackPointer. - self internalPush: newMethod. + self push: newMethod. self setMethod: newMethod methodHeader: methodHeader. - self internalPush: (self + self push: (self encodeFrameFieldHasContext: false isBlock: false numArgs: (self argumentCountOfMethodHeader: methodHeader)). - self internalPush: objectMemory nilObject. "FxThisContext field" - self internalPush: rcvr. + self push: objectMemory nilObject. "FxThisContext field" + self push: rcvr. "Initialize temps..." argumentCount + 1 to: numTemps do: [ :i | - self internalPush: objectMemory nilObject ]. + self push: objectMemory nilObject ]. "-1 to account for pre-increment in fetchNextBytecode" instructionPointer := self pointerForOop: @@ -8064,8 +8064,8 @@ StackInterpreter >> internalCannotReturn: resultOop [ | ourContext | ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. - self internalPush: ourContext. - self internalPush: resultOop. + self push: ourContext. + self push: resultOop. messageSelector := objectMemory splObj: SelectorCannotReturn. argumentCount := 1. ^self normalSend @@ -8119,27 +8119,6 @@ StackInterpreter >> internalMustBeBoolean [ self normalSend ] -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPop: nItems thenPush: oop [ - "In the StackInterpreter stacks grow down." - stackPages longAtPointer: (stackPointer := stackPointer + ((nItems - 1) * objectMemory bytesPerOop)) put: oop -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPopStack [ - "In the StackInterpreter stacks grow down." - | top | - top := stackPages longAt: stackPointer. - stackPointer := stackPointer + objectMemory bytesPerOop. - ^top -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPush: object [ - "In the StackInterpreter stacks grow down." - stackPages longAtPointer: (stackPointer := stackPointer - objectMemory bytesPerOop) put: object -] - { #category : #'primitive support' } StackInterpreter >> internalQuickPrimitiveResponse [ "Invoke a quick primitive. @@ -9102,7 +9081,7 @@ StackInterpreter >> longPushTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self internalPush: (self temporary: index in: framePointer) + self push: (self temporary: index in: framePointer) ] { #category : #'stack bytecodes' } @@ -9629,7 +9608,7 @@ StackInterpreter >> mappedDirectCall [ "250 directCall literal index of the method to call on top of stack => (variable number of parameters)" |methodHeader localPrimIndex methodIndex| - methodIndex := self internalPopStack. "Can't write this inside next line for Slang inliner" + methodIndex := self popStack. "Can't write this inside next line for Slang inliner" newMethod := self literal: (objectMemory integerValueOf: methodIndex). self assert: (objectMemory isCompiledMethod: newMethod). methodHeader := objectMemory methodHeaderOf: newMethod. @@ -9721,7 +9700,7 @@ StackInterpreter >> mappedImmcheckMaybeContextStoreCheckPointerAtPut [ argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. result := self internalStackTop. self pop: 3. - self internalPush: result. + self push: result. (self isWriteMediatedContextInstVarIndex: argIntAdjusted) ifFalse: [objectMemory storePointerImmutabilityCheck: argIntAdjusted ofObject: rec withValue: result] ifTrue: [self externalizeIPandSP. @@ -9743,7 +9722,7 @@ StackInterpreter >> mappedImmcheckStoreCheckPointerAtPut [ self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). result := self internalStackTop. self pop: 3. - self internalPush: result. + self push: result. objectMemory storePointerImmutabilityCheck: argIntAdjusted ofObject: rec @@ -12488,7 +12467,7 @@ StackInterpreter >> pushActiveContextBytecode [ | ourContext | ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. self fetchNextBytecode. - self internalPush: ourContext + self push: ourContext ] { #category : #'internal interpreter access' } @@ -12501,7 +12480,7 @@ StackInterpreter >> pushBool: trueOrFalse [ StackInterpreter >> pushConstantFalseBytecode [ self fetchNextBytecode. - self internalPush: objectMemory falseObject. + self push: objectMemory falseObject. ] @@ -12509,7 +12488,7 @@ StackInterpreter >> pushConstantFalseBytecode [ StackInterpreter >> pushConstantMinusOneBytecode [ self fetchNextBytecode. - self internalPush: ConstMinusOne. + self push: ConstMinusOne. ] @@ -12517,7 +12496,7 @@ StackInterpreter >> pushConstantMinusOneBytecode [ StackInterpreter >> pushConstantNilBytecode [ self fetchNextBytecode. - self internalPush: objectMemory nilObject. + self push: objectMemory nilObject. ] @@ -12525,7 +12504,7 @@ StackInterpreter >> pushConstantNilBytecode [ StackInterpreter >> pushConstantOneBytecode [ self fetchNextBytecode. - self internalPush: ConstOne. + self push: ConstOne. ] @@ -12533,7 +12512,7 @@ StackInterpreter >> pushConstantOneBytecode [ StackInterpreter >> pushConstantTrueBytecode [ self fetchNextBytecode. - self internalPush: objectMemory trueObject. + self push: objectMemory trueObject. ] @@ -12541,7 +12520,7 @@ StackInterpreter >> pushConstantTrueBytecode [ StackInterpreter >> pushConstantTwoBytecode [ self fetchNextBytecode. - self internalPush: ConstTwo. + self push: ConstTwo. ] @@ -12549,7 +12528,7 @@ StackInterpreter >> pushConstantTwoBytecode [ StackInterpreter >> pushConstantZeroBytecode [ self fetchNextBytecode. - self internalPush: ConstZero. + self push: ConstZero. ] @@ -12596,7 +12575,7 @@ StackInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg c withValue: (self internalStackValue: numCopied - i - 1)]. self pop: numCopied]. self fetchNextBytecode. - self internalPush: newClosure + self push: newClosure ] { #category : #'internal interpreter access' } @@ -12608,7 +12587,7 @@ StackInterpreter >> pushInteger: integerValue [ { #category : #'stack bytecodes' } StackInterpreter >> pushLiteralConstant: literalIndex [ - self internalPush: (self literal: literalIndex). + self push: (self literal: literalIndex). ] { #category : #'stack bytecodes' } @@ -12647,10 +12626,10 @@ StackInterpreter >> pushLiteralVariable: literalIndex [ litVar := self literal: literalIndex. (objectMemory isForwarded: litVar) ifTrue: [litVar := self unfollow: litVar atIndex: literalIndex]. - self internalPush: + self push: (objectMemory fetchPointer: ValueIndex ofObject: litVar)] ifFalse: - [self internalPush: + [self push: (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex))] ] @@ -12679,9 +12658,9 @@ StackInterpreter >> pushMaybeContext: obj receiverVariable: fieldIndex [ ((self isReadMediatedContextInstVarIndex: fieldIndex) and: [objectMemory isContextNonImm: obj]) ifTrue: - [self internalPush: (self instVar: fieldIndex ofContext: obj)] + [self push: (self instVar: fieldIndex ofContext: obj)] ifFalse: - [self internalPush: (objectMemory fetchPointer: fieldIndex ofObject: obj)] + [self push: (objectMemory fetchPointer: fieldIndex ofObject: obj)] ] { #category : #'stack bytecodes' } @@ -12727,21 +12706,21 @@ StackInterpreter >> pushNewArrayBytecode [ [0 to: size - 1 do: [:i| objectMemory storePointerUnchecked: i ofObject: array withValue: objectMemory nilObject]]. - self internalPush: array + self push: array ] { #category : #'stack bytecodes' } StackInterpreter >> pushReceiverBytecode [ self fetchNextBytecode. - self internalPush: self receiver. + self push: self receiver. ] { #category : #'stack bytecodes' } StackInterpreter >> pushReceiverVariable: fieldIndex [ - self internalPush: (objectMemory fetchPointer: fieldIndex ofObject: self receiver). + self push: (objectMemory fetchPointer: fieldIndex ofObject: self receiver). ] { #category : #'stack bytecodes' } @@ -12764,7 +12743,7 @@ StackInterpreter >> pushRemoteTemp: index inVectorAt: tempVectorIndex [ ifTrue: [(objectMemory isForwarded: tempVector) ifTrue: [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. - self internalPush: (objectMemory fetchPointer: index ofObject: tempVector) + self push: (objectMemory fetchPointer: index ofObject: tempVector) ] { #category : #'stack bytecodes' } @@ -12779,7 +12758,7 @@ StackInterpreter >> pushRemoteTempLongBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> pushTemporaryVariable: temporaryIndex [ - self internalPush: (self temporary: temporaryIndex in: framePointer). + self push: (self temporary: temporaryIndex in: framePointer). ] { #category : #'stack bytecodes' } @@ -13210,7 +13189,7 @@ StackInterpreter >> respondToSistaTrap [ messageSelector := objectMemory splObj: SelectorSistaTrap. ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. - self internalPush: ourContext. + self push: ourContext. argumentCount := 0. self normalSend ] @@ -13227,7 +13206,7 @@ StackInterpreter >> respondToUnknownBytecode [ ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. "undo fetch of bytecode so that context's pc is pointing to the unknown bytecode." instructionPointer := instructionPointer - 1. - self internalPush: ourContext. + self push: ourContext. argumentCount := 0. self normalSend ] diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index 47b57ffd9b..99a1ce85e2 100644 --- a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st @@ -216,7 +216,7 @@ StackInterpreterSimulator >> basicInitialize [ { #category : #utilities } StackInterpreterSimulator >> booleanCheat: cond [ disableBooleanCheat - ifTrue: [self internalPop: 2 + ifTrue: [self pop: 2 thenPush: (cond ifTrue: [objectMemory trueObject] ifFalse: [objectMemory falseObject]). From daedc404a9bbe412a846346e26401ba5dc29dec1 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 26 Oct 2021 16:53:27 +0200 Subject: [PATCH 26/75] Cleanups with automatic rewrites --- smalltalksrc/VMMaker/CoInterpreter.class.st | 309 ++-- .../VMMaker/StackInterpreter.class.st | 1501 +++++++++-------- .../StackInterpreterSimulator.class.st | 10 - .../VMMakerTests/StackBuilderTest.class.st | 16 +- 4 files changed, 1024 insertions(+), 812 deletions(-) diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index 34382f6c6c..f84aa8acf2 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -932,15 +932,17 @@ CoInterpreter >> attemptToSwitchToMachineCode: bcpc [ { #category : #'return bytecodes' } CoInterpreter >> baseFrameReturn [ + "Return from a baseFrame (the bottom frame in a stackPage). The context to return to (which may be married) is stored in the first word of the stack." + - | contextToReturnTo retToContext theFP theSP thePage newPage frameAbove | + | contextToReturnTo retToContext theFP theSP thePage newPage frameAbove | contextToReturnTo := self frameCallerContext: framePointer. "The stack page is effectively free now, so free it. We must free it to be @@ -951,55 +953,64 @@ CoInterpreter >> baseFrameReturn [ ordering invariant, use the assert-free version." stackPages freeStackPageNoAssert: stackPage. retToContext := objectMemory isContext: contextToReturnTo. - (retToContext - and: [self isStillMarriedContext: contextToReturnTo]) - ifTrue: - [theFP := self frameOfMarriedContext: contextToReturnTo. - thePage := stackPages stackPageFor: theFP. - theFP = thePage headFP - ifTrue: - [theSP := thePage headSP] - ifFalse: - ["Returning to some interior frame, presumably because of a sender assignment. + (retToContext and: [ self isStillMarriedContext: contextToReturnTo ]) + ifTrue: [ + theFP := self frameOfMarriedContext: contextToReturnTo. + thePage := stackPages stackPageFor: theFP. + theFP = thePage headFP + ifTrue: [ theSP := thePage headSP ] + ifFalse: [ "Returning to some interior frame, presumably because of a sender assignment. Move the frames above to another page (they may be in use, e.g. via coroutining). Make the interior frame the top frame." - frameAbove := self findFrameAbove: theFP inPage: thePage. - "Since we've just deallocated a page we know that newStackPage won't deallocate an existing one." - newPage := stackPages newStackPage. - self assert: newPage = stackPage. - self moveFramesIn: thePage through: frameAbove toPage: newPage. - stackPages markStackPageMostRecentlyUsed: newPage. - theFP := thePage headFP. - theSP := thePage headSP]] - ifFalse: - [(retToContext - and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse: - [| contextToReturnFrom | - contextToReturnFrom := stackPages longAt: stackPage baseAddress - objectMemory wordSize. - self tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom + frameAbove := self findFrameAbove: theFP inPage: thePage. + "Since we've just deallocated a page we know that newStackPage won't deallocate an existing one." + newPage := stackPages newStackPage. + self assert: newPage = stackPage. + self moveFramesIn: thePage through: frameAbove toPage: newPage. + stackPages markStackPageMostRecentlyUsed: newPage. + theFP := thePage headFP. + theSP := thePage headSP ] ] + ifFalse: [ + (retToContext and: [ + objectMemory isIntegerObject: (objectMemory + fetchPointer: InstructionPointerIndex + ofObject: contextToReturnTo) ]) ifFalse: [ + | contextToReturnFrom | + contextToReturnFrom := stackPages longAt: + stackPage baseAddress + - objectMemory wordSize. + self + tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: + contextToReturnFrom to: contextToReturnTo returnValue: localReturnValue. - ^self externalCannotReturn: localReturnValue from: contextToReturnFrom]. - "We must void the instructionPointer to stop it being updated if makeBaseFrameFor: + ^ self + externalCannotReturn: localReturnValue + from: contextToReturnFrom ]. + "We must void the instructionPointer to stop it being updated if makeBaseFrameFor: cogs a method, which may cause a code compaction." - instructionPointer := 0. - thePage := self makeBaseFrameFor: contextToReturnTo. - theFP := thePage headFP. - theSP := thePage headSP]. + instructionPointer := 0. + thePage := self makeBaseFrameFor: contextToReturnTo. + theFP := thePage headFP. + theSP := thePage headSP ]. self setStackPageAndLimit: thePage. self assert: (stackPages stackPageFor: theFP) = stackPage. stackPointer := theSP. framePointer := theFP. - instructionPointer := self pointerForOop: self internalStackTop. - instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: - [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: - ["localIP in the cog method zone indicates a return to machine code." - ^self returnToMachineCodeFrame]. - instructionPointer := self pointerForOop: (self iframeSavedIP: framePointer)]. - self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer). + instructionPointer := self pointerForOop: self stackTop. + instructionPointer asUnsignedInteger < objectMemory startOfMemory + ifTrue: [ + instructionPointer asUnsignedInteger + ~= cogit ceReturnToInterpreterPC ifTrue: [ "localIP in the cog method zone indicates a return to machine code." + ^ self returnToMachineCodeFrame ]. + instructionPointer := self pointerForOop: + (self iframeSavedIP: framePointer) ]. + self assert: (self + checkIsStillMarriedContext: contextToReturnTo + currentFP: framePointer). self setMethod: (self iframeMethod: framePointer). - self internalStackTopPut: localReturnValue. - ^self fetchNextBytecode + self stackTopPut: localReturnValue. + ^ self fetchNextBytecode ] { #category : #hooks } @@ -2401,26 +2412,31 @@ CoInterpreter >> commenceCogCompiledCodeCompaction [ { #category : #'return bytecodes' } CoInterpreter >> commonCallerReturn [ + "Return to the previous context/frame (sender for method activations, caller for block activations)." + - | callersFPOrNull | + | callersFPOrNull | callersFPOrNull := self frameCallerFP: framePointer. - callersFPOrNull = 0 "baseFrame" ifTrue: - [self assert: framePointer = stackPage baseFP. - ^self baseFrameReturn]. + callersFPOrNull = 0 ifTrue: [ + self assert: framePointer = stackPage baseFP. + ^ self baseFrameReturn ]. "baseFrame" instructionPointer := self frameCallerSavedIP: framePointer. - stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer). + stackPointer := framePointer + + (self frameStackedReceiverOffset: framePointer). framePointer := callersFPOrNull. - instructionPointer asUnsignedInteger < objectMemory startOfMemory ifTrue: - [instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: - ["localIP in the cog method zone indicates a return to machine code." - ^self returnToMachineCodeFrame]. - instructionPointer := self pointerForOop: (self iframeSavedIP: framePointer)]. + instructionPointer asUnsignedInteger < objectMemory startOfMemory + ifTrue: [ + instructionPointer asUnsignedInteger + ~= cogit ceReturnToInterpreterPC ifTrue: [ "localIP in the cog method zone indicates a return to machine code." + ^ self returnToMachineCodeFrame ]. + instructionPointer := self pointerForOop: + (self iframeSavedIP: framePointer) ]. self setMethod: (self iframeMethod: framePointer). self fetchNextBytecode. - self internalStackTopPut: localReturnValue + self stackTopPut: localReturnValue ] { #category : #'send bytecodes' } @@ -2430,7 +2446,7 @@ CoInterpreter >> commonSendOrdinary [ the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." - self sendBreakpoint: messageSelector receiver: (self internalStackValue: argumentCount). + self sendBreakpoint: messageSelector receiver: (self stackValue: argumentCount). cogit recordSendTrace ifTrue: [self recordTrace: (objectMemory classForClassTag: lkupClassTag) thing: messageSelector @@ -2992,23 +3008,28 @@ CoInterpreter >> executeNewMethod [ { #category : #'stack bytecodes' } CoInterpreter >> extendedStoreBytecodePop: popBoolean [ + "Override to use itemporary:in:put:" - | descriptor variableType variableIndex value | + + | descriptor variableType variableIndex value | descriptor := self fetchByte. variableType := descriptor >> 6 bitAnd: 3. variableIndex := descriptor bitAnd: 63. - value := self internalStackTop. + value := self stackTop. popBoolean ifTrue: [ self pop: 1 ]. - variableType = 0 ifTrue: - [objectMemory storePointerImmutabilityCheck: variableIndex ofObject: self receiver withValue: value. - ^ self fetchNextBytecode.]. - variableType = 1 ifTrue: - [ self fetchNextBytecode. - ^self itemporary: variableIndex in: framePointer put: value]. - variableType = 3 ifTrue: - [self storeLiteralVariable: variableIndex withValue: value. - ^ self fetchNextBytecode.]. + variableType = 0 ifTrue: [ + objectMemory + storePointerImmutabilityCheck: variableIndex + ofObject: self receiver + withValue: value. + ^ self fetchNextBytecode ]. + variableType = 1 ifTrue: [ + self fetchNextBytecode. + ^ self itemporary: variableIndex in: framePointer put: value ]. + variableType = 3 ifTrue: [ + self storeLiteralVariable: variableIndex withValue: value. + ^ self fetchNextBytecode ]. self error: 'illegal store' ] @@ -3928,14 +3949,15 @@ CoInterpreter >> instructionPointerForFrame: spouseFP currentFP: currentFP curre { #category : #'message sending' } CoInterpreter >> internalActivateNewMethod [ - | methodHeader numTemps rcvr switched | - + + | methodHeader numTemps rcvr switched | methodHeader := self rawHeaderOf: newMethod. self assert: (self isCogMethodReference: methodHeader) not. numTemps := self temporaryCountOfMethodHeader: methodHeader. - self assert: argumentCount = (self argumentCountOfMethodHeader: methodHeader). - rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" + self assert: + argumentCount = (self argumentCountOfMethodHeader: methodHeader). + rcvr := self stackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. self push: instructionPointer. @@ -3945,37 +3967,44 @@ CoInterpreter >> internalActivateNewMethod [ self setMethod: newMethod methodHeader: methodHeader. self push: objectMemory nilObject. "FxThisContext field" self push: (self - encodeFrameFieldHasContext: false - isBlock: false - numArgs: (self argumentCountOfMethodHeader: methodHeader)). + encodeFrameFieldHasContext: false + isBlock: false + numArgs: (self argumentCountOfMethodHeader: methodHeader)). self push: 0. "FoxIFSavedIP" self push: rcvr. "Initialize temps..." - argumentCount + 1 to: numTemps do: - [:i | self push: objectMemory nilObject]. + argumentCount + 1 to: numTemps do: [ :i | + self push: objectMemory nilObject ]. "-1 to account for pre-increment in fetchNextBytecode" - instructionPointer := self pointerForOop: (self initialIPForHeader: methodHeader method: newMethod) - 1. + instructionPointer := self pointerForOop: + (self + initialIPForHeader: methodHeader + method: newMethod) - 1. - (self methodHeaderHasPrimitive: methodHeader) ifTrue: - ["Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts + (self methodHeaderHasPrimitive: methodHeader) ifTrue: [ "Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts with a long store temp. Strictly no need to skip the store because it's effectively a noop." - instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader). - primFailCode ~= 0 ifTrue: - [self reapAndResetErrorCodeTo: stackPointer header: methodHeader]]. + instructionPointer := instructionPointer + + + (self sizeOfCallPrimitiveBytecode: + methodHeader). + primFailCode ~= 0 ifTrue: [ + self reapAndResetErrorCodeTo: stackPointer header: methodHeader ] ]. self assert: (self frameNumArgs: framePointer) = argumentCount. self assert: (self frameIsBlockActivation: framePointer) not. self assert: (self frameHasContext: framePointer) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." - stackPointer < stackLimit ifTrue: - [self externalizeIPandSP. - switched := self handleStackOverflowOrEventAllowContextSwitch: - (self canContextSwitchIfActivating: newMethod header: methodHeader). - self returnToExecutive: true postContextSwitch: switched. - self internalizeIPandSP] + stackPointer < stackLimit ifTrue: [ + self externalizeIPandSP. + switched := self handleStackOverflowOrEventAllowContextSwitch: + (self + canContextSwitchIfActivating: newMethod + header: methodHeader). + self returnToExecutive: true postContextSwitch: switched. + self internalizeIPandSP ] ] { #category : #'message sending' } @@ -4261,11 +4290,13 @@ CoInterpreter >> longPushTemporaryVariableBytecode [ { #category : #'stack bytecodes' } CoInterpreter >> longStoreTemporaryVariableBytecode [ + "234 11101010 i i i i i i i i Store Temporary Variable #iiiiiiii" + | index | index := self fetchByte. self fetchNextBytecode. - self itemporary: index in: framePointer put: self internalStackTop + self itemporary: index in: framePointer put: self stackTop ] { #category : #simulation } @@ -5924,41 +5955,51 @@ CoInterpreter >> printSends [ { #category : #'stack bytecodes' } CoInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg compiledBlock: compiledBlock receiverIsOnStack: receiverIsOnStack ignoreContext: ignoreContext [ + "The compiler has pushed the values to be copied, if any. The receiver has been pushed on stack before if specified. Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure. Sets outerContext, compiledBlock, numArgs and receiver as specified.." + | numCopied newClosure context startIndex | "No need to record the pushed copied values in the outerContext." context := ignoreContext - ifTrue: [objectMemory nilObject ] - ifFalse: [self ensureFrameIsMarried: framePointer SP: stackPointer + (numCopiedArg * objectMemory bytesPerOop)]. + ifTrue: [ objectMemory nilObject ] + ifFalse: [ + self + ensureFrameIsMarried: framePointer + SP: + stackPointer + + (numCopiedArg * objectMemory bytesPerOop) ]. newClosure := self - fullClosureIn: context - numArgs: numArgs - numCopiedValues: numCopiedArg - compiledBlock: compiledBlock. - cogit recordSendTrace ifTrue: - [self recordTrace: TraceBlockCreation thing: newClosure source: TraceIsFromInterpreter]. + fullClosureIn: context + numArgs: numArgs + numCopiedValues: numCopiedArg + compiledBlock: compiledBlock. + cogit recordSendTrace ifTrue: [ + self + recordTrace: TraceBlockCreation + thing: newClosure + source: TraceIsFromInterpreter ]. receiverIsOnStack - ifFalse: - [ startIndex := FullClosureFirstCopiedValueIndex. - objectMemory storePointerUnchecked: FullClosureReceiverIndex + ifFalse: [ + startIndex := FullClosureFirstCopiedValueIndex. + objectMemory + storePointerUnchecked: FullClosureReceiverIndex ofObject: newClosure withValue: self receiver. numCopied := numCopiedArg ] - ifTrue: - [ startIndex := FullClosureReceiverIndex. + ifTrue: [ + startIndex := FullClosureReceiverIndex. numCopied := numCopiedArg + 1 ]. - numCopied > 0 ifTrue: - [0 to: numCopied - 1 do: - [ :i | - "Assume: have just allocated a new BlockClosure; it must be young. + numCopied > 0 ifTrue: [ + 0 to: numCopied - 1 do: [ :i | "Assume: have just allocated a new BlockClosure; it must be young. Thus, can use unchecked stores." - objectMemory storePointerUnchecked: i + startIndex + objectMemory + storePointerUnchecked: i + startIndex ofObject: newClosure - withValue: (self internalStackValue: numCopied - i - 1)]. - self pop: numCopied]. + withValue: (self stackValue: numCopied - i - 1) ]. + self pop: numCopied ]. self fetchNextBytecode. self push: newClosure ] @@ -6205,17 +6246,25 @@ CoInterpreter >> returnToExecutive: inInterpreter postContextSwitch: switchedCon { #category : #'return bytecodes' } CoInterpreter >> returnToMachineCodeFrame [ + "Return to the previous context/frame after assigning localIP, localSP and localFP." + cogit assertCStackWellAligned. - self assert: instructionPointer asUnsignedInteger < objectMemory startOfMemory. + self assert: + instructionPointer asUnsignedInteger < objectMemory startOfMemory. self assert: (self isMachineCodeFrame: framePointer). - self assertValidExecutionPointe: instructionPointer asUnsignedInteger r: framePointer s: stackPointer imbar: false line: #'__LINE__'. - self internalStackTopPut: instructionPointer. + self + assertValidExecutionPointe: instructionPointer asUnsignedInteger + r: framePointer + s: stackPointer + imbar: false + line: #__LINE__. + self stackTopPut: instructionPointer. self push: localReturnValue. self externalizeFPandSP. - self cCode: '' inSmalltalk: - [self maybeCheckStackDepth: 1 sp: stackPointer pc: instructionPointer]. + self cCode: '' inSmalltalk: [ + self maybeCheckStackDepth: 1 sp: stackPointer pc: instructionPointer ]. cogit ceEnterCogCodePopReceiverReg "NOTREACHED" ] @@ -6561,28 +6610,42 @@ CoInterpreter >> startPCOfMethodHeader: aCompiledMethodHeader [ { #category : #'stack bytecodes' } CoInterpreter >> storeAndPopTemporaryVariableBytecode [ + self - cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant" - [self fetchNextBytecode. - self itemporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. - self pop: 1] - inSmalltalk: "Interpreter version has fetchNextBytecode out of order" - [self itemporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. - self fetchNextBytecode. - self pop: 1] + cCode: [ "this bytecode will be expanded so that refs to currentBytecode below will be constant" + self fetchNextBytecode. + self + itemporary: (currentBytecode bitAnd: 7) + in: framePointer + put: self stackTop. + self pop: 1 ] + inSmalltalk: [ "Interpreter version has fetchNextBytecode out of order" + self + itemporary: (currentBytecode bitAnd: 7) + in: framePointer + put: self stackTop. + self fetchNextBytecode. + self pop: 1 ] ] { #category : #'stack bytecodes' } CoInterpreter >> storeRemoteTemp: index inVectorAt: tempVectorIndex [ + "Override to use itemporary:in:put:" + | tempVector | tempVector := self itemporary: tempVectorIndex in: framePointer. - TempVectReadBarrier - ifTrue: - [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. - objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop + TempVectReadBarrier ifTrue: [ + (objectMemory isForwarded: tempVector) ifTrue: [ + tempVector := self + unfollowTempVector: tempVector + atIndex: tempVectorIndex + in: framePointer ] ]. + objectMemory + storePointer: index + ofObject: tempVector + withValue: self stackTop ] { #category : #'process primitive support' } diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index 0f92fe06ec..b17171c58b 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -1500,7 +1500,7 @@ StackInterpreter class >> mustBeGlobal: var [ { #category : #translation } StackInterpreter class >> namesOfVariablesToLocalize [ - ^#(currentBytecode localFP localSP localReturnValue) + ^#(currentBytecode localReturnValue) ] { #category : #translation } @@ -2219,53 +2219,57 @@ StackInterpreter >> assertValidStackLimits: ln [ { #category : #'return bytecodes' } StackInterpreter >> baseFrameReturn [ + "Return from a baseFrame (the bottom frame in a stackPage). The context to return to (which may be married) is stored in the saved instruction pointer slot." + - | contextToReturnTo isAContext theFP theSP thePage frameAbove | + | contextToReturnTo isAContext theFP theSP thePage frameAbove | contextToReturnTo := self frameCallerContext: framePointer. isAContext := objectMemory isContext: contextToReturnTo. - (isAContext - and: [self isStillMarriedContext: contextToReturnTo]) - ifTrue: - [theFP := self frameOfMarriedContext: contextToReturnTo. - thePage := stackPages stackPageFor: theFP. - theFP = thePage headFP - ifTrue: - [theSP := thePage headSP. - stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows"] - ifFalse: - ["Returning to some interior frame, presumably because of a sender assignment. + (isAContext and: [ self isStillMarriedContext: contextToReturnTo ]) + ifTrue: [ + theFP := self frameOfMarriedContext: contextToReturnTo. + thePage := stackPages stackPageFor: theFP. + theFP = thePage headFP + ifTrue: [ + theSP := thePage headSP. + stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows" ] + ifFalse: [ "Returning to some interior frame, presumably because of a sender assignment. Move the frames above to another page (they may be in use, e.g. via coroutining). Make the interior frame the top frame." - frameAbove := self findFrameAbove: theFP inPage: thePage. - "Reuse the page we're exiting, which avoids allocating a new page and + frameAbove := self findFrameAbove: theFP inPage: thePage. + "Reuse the page we're exiting, which avoids allocating a new page and manipulating the page list to mark the page we're entering as least recently used (to avoid it being deallocated when allocating a new page)." - self moveFramesIn: thePage through: frameAbove toPage: stackPage. - theFP := thePage headFP. - theSP := thePage headSP]] - ifFalse: - [(isAContext - and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse: - [^self internalCannotReturn: localReturnValue]. - thePage := self makeBaseFrameFor: contextToReturnTo. - theFP := thePage headFP. - theSP := thePage headSP. - stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows"]. + self moveFramesIn: thePage through: frameAbove toPage: stackPage. + theFP := thePage headFP. + theSP := thePage headSP ] ] + ifFalse: [ + (isAContext and: [ + objectMemory isIntegerObject: (objectMemory + fetchPointer: InstructionPointerIndex + ofObject: contextToReturnTo) ]) ifFalse: [ + ^ self internalCannotReturn: localReturnValue ]. + thePage := self makeBaseFrameFor: contextToReturnTo. + theFP := thePage headFP. + theSP := thePage headSP. + stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows" ]. self setStackPageAndLimit: thePage. self assert: (stackPages stackPageFor: theFP) = stackPage. stackPointer := theSP. framePointer := theFP. self setMethod: (self frameMethod: framePointer). - instructionPointer := self pointerForOop: self internalStackTop. - self internalStackTopPut: localReturnValue. - self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer). - ^self fetchNextBytecode + instructionPointer := self pointerForOop: self stackTop. + self stackTopPut: localReturnValue. + self assert: (self + checkIsStillMarriedContext: contextToReturnTo + currentFP: framePointer). + ^ self fetchNextBytecode ] { #category : #'frame access' } @@ -2288,67 +2292,85 @@ StackInterpreter >> bereaveAllMarriedContextsForSnapshotFlushingExternalPrimitiv { #category : #'sista inline primitives - binary' } StackInterpreter >> binaryAtInlinePrimitive: primIndex [ + | result rec argIntAdjusted top | - rec := self internalStackValue: 1. - top := self internalStackTop. - self deny: ((objectMemory isOopForwarded: rec) or: [(objectMemory isImmediate: rec)]). + rec := self stackValue: 1. + top := self stackTop. + self deny: ((objectMemory isOopForwarded: rec) or: [ + objectMemory isImmediate: rec ]). self assert: (objectMemory isIntegerObject: top). argIntAdjusted := (objectMemory integerValueOf: top) - 1. self assert: argIntAdjusted >= 0. - primIndex caseOf: { - "2064 pointerAt: - Pointer object (Fixed sized or not) and not a context, Smi => (1-based, optimised if arg1 is a constant)" - [64] -> [self assert: (objectMemory isPointers: rec). - self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). - result := objectMemory fetchPointer: argIntAdjusted ofObject: rec.]. - "2065 maybeContextPointerAt: + primIndex caseOf: { + ([ 64 ] -> [ + self assert: (objectMemory isPointers: rec). + self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). + result := objectMemory fetchPointer: argIntAdjusted ofObject: rec ]). + "2065 maybeContextPointerAt: Pointer object (Fixed sized or not), Smi => (1-based, optimised if arg1 is a constant)" - [65] -> [ ((objectMemory isContextNonImm: rec) - and: [self isMarriedOrWidowedContext: rec]) - ifTrue: - [self externalizeIPandSP. - result := self externalInstVar: argIntAdjusted ofContext: rec. - self internalizeIPandSP] - ifFalse: [result := objectMemory fetchPointer: argIntAdjusted ofObject: rec] - ]. - "2066 byteAt: + ([ 65 ] -> [ + ((objectMemory isContextNonImm: rec) and: [ + self isMarriedOrWidowedContext: rec ]) + ifTrue: [ + self externalizeIPandSP. + result := self externalInstVar: argIntAdjusted ofContext: rec. + self internalizeIPandSP ] + ifFalse: [ + result := objectMemory fetchPointer: argIntAdjusted ofObject: rec ] ]). + "2066 byteAt: byte object, Smi => 8 bits unsigned Smi (1-based, optimised if arg1 is a constant)" - [66] -> [self assert: (objectMemory isBytes: rec). - self assert: argIntAdjusted < (objectMemory numBytesOf: rec). - result := objectMemory integerObjectOf: (objectMemory fetchByte: argIntAdjusted ofObject: rec)]. - "2067 shortAt: + ([ 66 ] -> [ + self assert: (objectMemory isBytes: rec). + self assert: argIntAdjusted < (objectMemory numBytesOf: rec). + result := objectMemory integerObjectOf: + (objectMemory fetchByte: argIntAdjusted ofObject: rec) ]). + "2067 shortAt: short object, Smi => 16 bits unsigned Smi (1-based, optimised if arg1 is a constant)" - [67] -> [self assert: (objectMemory isShorts: rec). - self assert: argIntAdjusted < (objectMemory num16BitUnitsOf: rec). - result := objectMemory integerObjectOf: (objectMemory fetchShort16: argIntAdjusted ofObject: rec)]. - "2068 wordAt: + ([ 67 ] -> [ + self assert: (objectMemory isShorts: rec). + self assert: argIntAdjusted < (objectMemory num16BitUnitsOf: rec). + result := objectMemory integerObjectOf: + (objectMemory + fetchShort16: argIntAdjusted + ofObject: rec) ]). + "2068 wordAt: word object, Smi => 32 bits unsigned Smi (1-based, optimised if arg1 is a constant)." - [68] -> [self assert: (objectMemory isWords: rec). - self assert: argIntAdjusted < (objectMemory num32BitUnitsOf: rec). - result := self positive32BitIntegerFor: (objectMemory fetchLong32: argIntAdjusted ofObject: rec)]. - "2069 doubleWordAt: + ([ 68 ] -> [ + self assert: (objectMemory isWords: rec). + self assert: argIntAdjusted < (objectMemory num32BitUnitsOf: rec). + result := self positive32BitIntegerFor: + (objectMemory fetchLong32: argIntAdjusted ofObject: rec) ]). + "2069 doubleWordAt: double word object, Smi => 64 bits unsigned Smi or LargePositiveInteger (1-based, optimised if arg1 is a constant)" - [69] -> [self assert: (objectMemory isLong64s: rec). - self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). - result := self positive64BitIntegerFor: (objectMemory fetchLong64: argIntAdjusted ofObject: rec)].}. - self pop: 1; internalStackTopPut: result + ([ 69 ] -> [ + self assert: (objectMemory isLong64s: rec). + self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). + result := self positive64BitIntegerFor: + (objectMemory fetchLong64: argIntAdjusted ofObject: rec) ]) }. + "2064 pointerAt: + Pointer object (Fixed sized or not) and not a context, Smi => (1-based, optimised if arg1 is a constant)" + self + pop: 1; + stackTopPut: result ] { #category : #'sista inline primitives - binary' } StackInterpreter >> binaryCompInlinePrimitive: primIndex [ + | result | self assert: (primIndex between: 38 and: 39). - primIndex caseOf: { - "2038 rawEqualsEquals: + primIndex caseOf: { + ([ 38 ] -> [ result := (self stackValue: 1) = self stackTop ]). + "2039 rawNotEqualsEquals: not a forwarder, not a forwarder => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)" - [38] -> [result := ((self internalStackValue: 1) = self internalStackTop).]. - "2039 rawNotEqualsEquals: + ([ 39 ] -> [ result := (self stackValue: 1) ~= self stackTop ]) }. + "2038 rawEqualsEquals: not a forwarder, not a forwarder => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)" - [39] -> [result := ((self internalStackValue: 1) ~= self internalStackTop)]. - }. - self pop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) + self + pop: 1; + stackTopPut: (objectMemory booleanObjectOf: result) ] { #category : #'sista inline primitives - binary' } @@ -2426,29 +2448,34 @@ StackInterpreter >> binaryInlinePrimitive: primIndex [ { #category : #'sista inline primitives - binary' } StackInterpreter >> binaryNewInlinePrimitive: primIndex [ + "2048 rawNew: literal which is a variable-sized behavior, Smi => instance of receiver, fields nilled/zeroed out (optimised if arg1 is a constant) 2049 rawNewNoInit: literal which is a variable-sized behavior, Smi => instance of receiver (Fields of returned value contain undefined data, optimised if arg1 is a constant) WARNING: In the interpreter version, fields are always initialized." + | classObj result size top | self assert: (primIndex between: 48 and: 49). - top := self internalStackTop. - classObj := self internalStackValue: 1. - self assert: ((objectMemory isNonImmediate: classObj) and: [self objCouldBeClassObj: classObj]). + top := self stackTop. + classObj := self stackValue: 1. + self assert: ((objectMemory isNonImmediate: classObj) and: [ + self objCouldBeClassObj: classObj ]). self assert: (objectMemory isIntegerObject: top). size := self positiveMachineIntegerValueOf: top. result := objectMemory instantiateClass: classObj indexableSize: size. - self pop: 1; internalStackTopPut: result + self + pop: 1; + stackTopPut: result ] { #category : #'sista inline primitives - binary' } StackInterpreter >> binarySmiArithmeticInlinePrimitive: primIndex [ | result recInt argInt rcvr top | - rcvr := self internalStackValue: 1. - top := self internalStackTop. + rcvr := self stackValue: 1. + top := self stackTop. self assert: primIndex <= 6. self assert: (objectMemory isIntegerObject: rcvr). self assert: (objectMemory isIntegerObject: top). @@ -2477,15 +2504,15 @@ StackInterpreter >> binarySmiArithmeticInlinePrimitive: primIndex [ Smi, Smi => Smi (no overflow, optimised if one operand is a constant)" [6] -> [result := self quot: recInt ient: argInt]. }. - self pop: 1; internalStackTopPutIntegerObjectOf: result + self pop: 1; stackTopPutIntegerObjectOf: result ] { #category : #'sista inline primitives - binary' } StackInterpreter >> binarySmiBitInlinePrimitive: primIndex [ | result recInt argInt rcvr top | - rcvr := self internalStackValue: 1. - top := self internalStackTop. + rcvr := self stackValue: 1. + top := self stackTop. self assert: (primIndex between: 16 and: 20). self assert: (objectMemory isIntegerObject: rcvr). self assert: (objectMemory isIntegerObject: top). @@ -2511,7 +2538,7 @@ StackInterpreter >> binarySmiBitInlinePrimitive: primIndex [ [20] -> [self assert: argInt >= 0. result := recInt >> argInt]. }. - self pop: 1; internalStackTopPutIntegerObjectOf: result + self pop: 1; stackTopPutIntegerObjectOf: result ] { #category : #'sista inline primitives - binary' } @@ -2519,8 +2546,8 @@ StackInterpreter >> binarySmiCompInlinePrimitive: primIndex [ | result top rcvr | self assert: (primIndex between: 32 and: 37). - rcvr := self internalStackValue: 1. - top := self internalStackTop. + rcvr := self stackValue: 1. + top := self stackTop. self assert: (objectMemory isIntegerObject: rcvr). self assert: (objectMemory isIntegerObject: top). primIndex caseOf: { @@ -2543,7 +2570,7 @@ StackInterpreter >> binarySmiCompInlinePrimitive: primIndex [ Smi, Smi => Boolean (optimised if one operand is a constant, Pipelined with ifTrue:ifFalse:)" [37] -> [result := (rcvr ~= top)]. }. - self pop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) + self pop: 1; stackTopPut: (objectMemory booleanObjectOf: result) ] { #category : #utilities } @@ -2729,8 +2756,8 @@ StackInterpreter >> booleanValueOf: obj [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimAdd [ | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg). (objectMemory isIntegerValue: result) ifTrue: @@ -2756,8 +2783,8 @@ StackInterpreter >> bytecodePrimAt [ is a compiled at: primitive method (which doesn't use the at: cache) the only way something can get installed in the atCache is here." | index rcvr result atIx | - index := self internalStackTop. - rcvr := self internalStackValue: 1. + index := self stackTop. + rcvr := self stackValue: 1. ((objectMemory isNonImmediate: rcvr) and: [objectMemory isIntegerObject: index]) ifTrue: [atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" @@ -2803,9 +2830,9 @@ StackInterpreter >> bytecodePrimAtPut [ is a compiled at:[put:] primitive method (which doesn't use the at: cache) the only way something can get installed in the atCache is here." | index rcvr atIx value correctRcvr | - value := self internalStackTop. - index := self internalStackValue: 1. - rcvr := self internalStackValue: 2. + value := self stackTop. + index := self stackValue: 1. + rcvr := self stackValue: 2. self cppIf: IMMUTABILITY ifTrue: [ correctRcvr := objectMemory isOopMutable: rcvr ] ifFalse: [ correctRcvr := objectMemory isNonImmediate: rcvr ]. @@ -2841,8 +2868,8 @@ StackInterpreter >> bytecodePrimAtPut [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimBitAnd [ | rcvr arg | - arg := self internalStackTop. - rcvr := self internalStackValue: 1. + arg := self stackTop. + rcvr := self stackValue: 1. ((objectMemory isIntegerObject: arg) and: [objectMemory isIntegerObject: rcvr]) ifTrue: [self pop: 2 thenPush: (arg bitAnd: rcvr). @@ -2863,8 +2890,8 @@ StackInterpreter >> bytecodePrimBitAnd [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimBitOr [ | rcvr arg | - arg := self internalStackTop. - rcvr := self internalStackValue: 1. + arg := self stackTop. + rcvr := self stackValue: 1. ((objectMemory isIntegerObject: arg) and: [objectMemory isIntegerObject: rcvr]) ifTrue: [self pop: 2 thenPush: (arg bitOr: rcvr). @@ -2898,11 +2925,12 @@ StackInterpreter >> bytecodePrimBitShift [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimClass [ + | rcvr | - rcvr := self internalStackTop. - (objectMemory isOopForwarded: rcvr) ifTrue: - [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. - self internalStackTopPut: (objectMemory fetchClassOf: rcvr). + rcvr := self stackTop. + (objectMemory isOopForwarded: rcvr) ifTrue: [ + rcvr := self handleSpecialSelectorSendFaultFor: rcvr ]. + self stackTopPut: (objectMemory fetchClassOf: rcvr). self fetchNextBytecode ] @@ -2910,7 +2938,7 @@ StackInterpreter >> bytecodePrimClass [ StackInterpreter >> bytecodePrimDiv [ | quotient | self initPrimCall. - quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). + quotient := self doPrimitiveDiv: (self stackValue: 1) by: (self stackValue: 0). self successful ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: quotient). ^ self fetchNextBytecode "success"]. @@ -2922,8 +2950,8 @@ StackInterpreter >> bytecodePrimDiv [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimDivide [ | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [rcvr := objectMemory integerValueOf: rcvr. arg := objectMemory integerValueOf: arg. @@ -2956,8 +2984,8 @@ StackInterpreter >> bytecodePrimDo [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimEqual [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg]. self initPrimCall. @@ -2972,8 +3000,8 @@ StackInterpreter >> bytecodePrimEqual [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimEqualSistaV1 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [^self booleanCheatSistaV1: rcvr = arg]. self initPrimCall. @@ -2988,8 +3016,8 @@ StackInterpreter >> bytecodePrimEqualSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimEqualV4 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [^self booleanCheatV4: rcvr = arg]. self initPrimCall. @@ -3004,8 +3032,8 @@ StackInterpreter >> bytecodePrimEqualV4 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimGreaterOrEqual [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3024,8 +3052,8 @@ StackInterpreter >> bytecodePrimGreaterOrEqual [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimGreaterOrEqualSistaV1 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3044,8 +3072,8 @@ StackInterpreter >> bytecodePrimGreaterOrEqualSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimGreaterOrEqualV4 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3064,8 +3092,8 @@ StackInterpreter >> bytecodePrimGreaterOrEqualV4 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimGreaterThan [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3084,8 +3112,8 @@ StackInterpreter >> bytecodePrimGreaterThan [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimGreaterThanSistaV1 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3104,8 +3132,8 @@ StackInterpreter >> bytecodePrimGreaterThanSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimGreaterThanV4 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3124,10 +3152,10 @@ StackInterpreter >> bytecodePrimGreaterThanV4 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimIdentical [ | rcvr arg | - rcvr := self internalStackValue: 1. + rcvr := self stackValue: 1. (objectMemory isOopForwarded: rcvr) ifTrue: [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. - arg := self internalStackValue: 0. + arg := self stackValue: 0. (objectMemory isOopForwarded: arg) ifTrue: [arg := self handleSpecialSelectorSendFaultFor: arg]. self booleanCheat: rcvr = arg @@ -3136,8 +3164,8 @@ StackInterpreter >> bytecodePrimIdentical [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimIdenticalSistaV1 [ | rcvr arg | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory isOopForwarded: rcvr) ifTrue: [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. (objectMemory isOopForwarded: arg) ifTrue: @@ -3148,8 +3176,8 @@ StackInterpreter >> bytecodePrimIdenticalSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimIdenticalV4 [ | rcvr arg | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory isOopForwarded: rcvr) ifTrue: [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. (objectMemory isOopForwarded: arg) ifTrue: @@ -3160,8 +3188,8 @@ StackInterpreter >> bytecodePrimIdenticalV4 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimLessOrEqual [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3180,8 +3208,8 @@ StackInterpreter >> bytecodePrimLessOrEqual [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimLessOrEqualSistaV1 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3200,8 +3228,8 @@ StackInterpreter >> bytecodePrimLessOrEqualSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimLessOrEqualV4 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3220,8 +3248,8 @@ StackInterpreter >> bytecodePrimLessOrEqualV4 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimLessThan [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3240,8 +3268,8 @@ StackInterpreter >> bytecodePrimLessThan [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimLessThanSistaV1 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3260,8 +3288,8 @@ StackInterpreter >> bytecodePrimLessThanSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimLessThanV4 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: ["The C code can avoid detagging since tagged integers are still signed. But this means the simulator must override to do detagging." @@ -3283,8 +3311,8 @@ StackInterpreter >> bytecodePrimMakePoint [ sp & fp, then internalizing and testign for primitive failure add much overhead. So simply inline the relatively small ammount of code directly." | rcvr arg pt | - rcvr := self internalStackValue: 1. - arg := self internalStackTop. + rcvr := self stackValue: 1. + arg := self stackTop. ((objectMemory isFloatOrInt: rcvr) and: [objectMemory isFloatOrInt: arg]) ifTrue: [pt := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) numSlots: YIndex + 1. @@ -3303,7 +3331,7 @@ StackInterpreter >> bytecodePrimMakePoint [ StackInterpreter >> bytecodePrimMod [ | mod | self initPrimCall. - mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). + mod := self doPrimitiveMod: (self stackValue: 1) by: (self stackValue: 0). self successful ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: mod). ^ self fetchNextBytecode "success"]. @@ -3316,8 +3344,8 @@ StackInterpreter >> bytecodePrimMod [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimMultiply [ | rcvr arg result overflow oop | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [rcvr := objectMemory integerValueOf: rcvr. arg := objectMemory integerValueOf: arg. @@ -3380,8 +3408,8 @@ StackInterpreter >> bytecodePrimNextPut [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimNotEqual [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr ~= arg]. self initPrimCall. @@ -3396,8 +3424,8 @@ StackInterpreter >> bytecodePrimNotEqual [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimNotEqualSistaV1 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [^self booleanCheatSistaV1: rcvr ~= arg]. self initPrimCall. @@ -3412,8 +3440,8 @@ StackInterpreter >> bytecodePrimNotEqualSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimNotEqualV4 [ | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [^self booleanCheatV4: rcvr ~= arg]. self initPrimCall. @@ -3428,10 +3456,10 @@ StackInterpreter >> bytecodePrimNotEqualV4 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimNotIdentical [ | rcvr arg | - rcvr := self internalStackValue: 1. + rcvr := self stackValue: 1. (objectMemory isOopForwarded: rcvr) ifTrue: [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. - arg := self internalStackValue: 0. + arg := self stackValue: 0. (objectMemory isOopForwarded: arg) ifTrue: [arg := self handleSpecialSelectorSendFaultFor: arg]. self booleanCheat: rcvr ~= arg @@ -3440,8 +3468,8 @@ StackInterpreter >> bytecodePrimNotIdentical [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimNotIdenticalSistaV1 [ | rcvr arg | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory isOopForwarded: rcvr) ifTrue: [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. (objectMemory isOopForwarded: arg) ifTrue: @@ -3452,8 +3480,8 @@ StackInterpreter >> bytecodePrimNotIdenticalSistaV1 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimNotIdenticalV4 [ | rcvr arg | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory isOopForwarded: rcvr) ifTrue: [rcvr := self handleSpecialSelectorSendFaultFor: rcvr]. (objectMemory isOopForwarded: arg) ifTrue: @@ -3466,11 +3494,11 @@ StackInterpreter >> bytecodePrimPointX [ | rcvr | self initPrimCall. - rcvr := self internalStackTop. + rcvr := self stackTop. self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint). - self successful ifTrue: - [self internalStackTopPut: (objectMemory fetchPointer: XIndex ofObject: rcvr). - ^self fetchNextBytecode "success"]. + self successful ifTrue: [ + self stackTopPut: (objectMemory fetchPointer: XIndex ofObject: rcvr). + ^ self fetchNextBytecode "success" ]. primFailCode := 0. messageSelector := self specialSelector: 30. @@ -3483,11 +3511,11 @@ StackInterpreter >> bytecodePrimPointY [ | rcvr | self initPrimCall. - rcvr := self internalStackTop. + rcvr := self stackTop. self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint). - self successful ifTrue: - [self internalStackTopPut: (objectMemory fetchPointer: YIndex ofObject: rcvr). - ^self fetchNextBytecode "success"]. + self successful ifTrue: [ + self stackTopPut: (objectMemory fetchPointer: YIndex ofObject: rcvr). + ^ self fetchNextBytecode "success" ]. primFailCode := 0. messageSelector := self specialSelector: 31. @@ -3497,23 +3525,24 @@ StackInterpreter >> bytecodePrimPointY [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimSize [ + | rcvr sz isString isArray | self initPrimCall. - rcvr := self internalStackTop. + rcvr := self stackTop. "Shortcut the mega-lookup for ByteString and Array, the two big consumers of cycles here. Both of these have compact class indices and neither has any added fields." - isString := self isInstanceOfClassByteString: rcvr. - isString ifTrue: - [sz := objectMemory lengthOf: rcvr. - self internalStackTopPut: (objectMemory integerObjectOf: sz). - ^self fetchNextBytecode]. - - isArray := self isInstanceOfClassArray: rcvr. - isArray ifTrue: - [sz := objectMemory lengthOf: rcvr. - self internalStackTopPut: (objectMemory integerObjectOf: sz). - ^self fetchNextBytecode]. + isString := self isInstanceOfClassByteString: rcvr. + isString ifTrue: [ + sz := objectMemory lengthOf: rcvr. + self stackTopPut: (objectMemory integerObjectOf: sz). + ^ self fetchNextBytecode ]. + + isArray := self isInstanceOfClassArray: rcvr. + isArray ifTrue: [ + sz := objectMemory lengthOf: rcvr. + self stackTopPut: (objectMemory integerObjectOf: sz). + ^ self fetchNextBytecode ]. messageSelector := self specialSelector: 18. argumentCount := 0. @@ -3531,8 +3560,8 @@ StackInterpreter >> bytecodePrimSpecialSelector24 [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimSubtract [ | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. + rcvr := self stackValue: 1. + arg := self stackValue: 0. (objectMemory areIntegers: rcvr and: arg) ifTrue: [result := (objectMemory integerValueOf: rcvr) - (objectMemory integerValueOf: arg). (objectMemory isIntegerValue: result) ifTrue: @@ -3551,18 +3580,18 @@ StackInterpreter >> bytecodePrimSubtract [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimValue [ + | rcvr isBlock | - rcvr := self internalStackTop. + rcvr := self stackTop. argumentCount := 0. isBlock := self isInstanceOfClassBlockClosure: rcvr. - isBlock ifTrue: - [self externalizeIPandSP. + isBlock ifTrue: [ + self externalizeIPandSP. self initPrimCall. self primitiveFullClosureValue. self internalizeIPandSP. - self successful ifTrue: - [^self fetchNextBytecode]. - primFailCode := 0]. + self successful ifTrue: [ ^ self fetchNextBytecode ]. + primFailCode := 0 ]. messageSelector := self specialSelector: 25. self normalSend ] @@ -3570,7 +3599,7 @@ StackInterpreter >> bytecodePrimValue [ { #category : #'common selector sends' } StackInterpreter >> bytecodePrimValueWithArg [ | rcvr isBlock | - rcvr := self internalStackValue: 1. + rcvr := self stackValue: 1. argumentCount := 1. isBlock := self isInstanceOfClassBlockClosure: rcvr. isBlock ifTrue: @@ -4552,40 +4581,43 @@ StackInterpreter >> commonAtPut: stringy [ { #category : #'return bytecodes' } StackInterpreter >> commonCallerReturn [ + "Return to the previous context/frame (sender for method activations, caller for block activations)." + - | callersFPOrNull | - + | callersFPOrNull | callersFPOrNull := self frameCallerFP: framePointer. - callersFPOrNull = 0 "baseFrame" ifTrue: - [self assert: framePointer = stackPage baseFP. - ^self baseFrameReturn]. + callersFPOrNull = 0 ifTrue: [ + self assert: framePointer = stackPage baseFP. + ^ self baseFrameReturn ]. "baseFrame" instructionPointer := self frameCallerSavedIP: framePointer. - stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer). + stackPointer := framePointer + + (self frameStackedReceiverOffset: framePointer). framePointer := callersFPOrNull. self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. - self internalStackTopPut: localReturnValue + self stackTopPut: localReturnValue ] { #category : #'return bytecodes' } StackInterpreter >> commonReturn [ + "Do an ^-return (return from method), checking for unwinds if this is a block activation. Note: Assumed to be inlined into the dispatch loop." - | closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage | + | closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage | + (self iframeIsBlockActivation: framePointer) ifFalse: [ + ^ self commonCallerReturn ]. "If this is a method simply return to the sender/caller." - (self iframeIsBlockActivation: framePointer) ifFalse: - [^self commonCallerReturn]. "Update the current page's headFrame pointers to enable the search for unwind protects below to identify widowed contexts correctly." @@ -4597,47 +4629,54 @@ StackInterpreter >> commonReturn [ home := nil. "avoid compiler warning" "Walk the closure's lexical chain to find the context or frame to return from (home). If home is missing (Sista closures) then throw cannotReturn rather than crash." - [closure ~= objectMemory nilObject] whileTrue: - [home := objectMemory followField: FullClosureOuterContextIndex ofObject: closure. - (objectMemory isContext: home) ifFalse: - [^self internalCannotReturn: localReturnValue]. - closure := objectMemory followField: ClosureIndex ofObject: home]. + [ closure ~= objectMemory nilObject ] whileTrue: [ + home := objectMemory + followField: FullClosureOuterContextIndex + ofObject: closure. + (objectMemory isContext: home) ifFalse: [ + ^ self internalCannotReturn: localReturnValue ]. + closure := objectMemory followField: ClosureIndex ofObject: home ]. "home is to be returned from provided there is no unwind-protect activation between this frame and home's sender. Search for an unwind. findUnwindThroughContext: will answer either the context for an unwind-protect activation or nilObj if the sender cannot be found or 0 if no unwind is found but the sender is." unwindContextOrNilOrZero := self findUnwindThroughContext: home. - unwindContextOrNilOrZero = objectMemory nilObject ifTrue: - ["error: can't find home on chain; cannot return" - ^self internalCannotReturn: localReturnValue]. - unwindContextOrNilOrZero ~= 0 ifTrue: - [^self internalAboutToReturn: localReturnValue through: unwindContextOrNilOrZero]. + unwindContextOrNilOrZero = objectMemory nilObject ifTrue: [ "error: can't find home on chain; cannot return" + ^ self internalCannotReturn: localReturnValue ]. + unwindContextOrNilOrZero ~= 0 ifTrue: [ + ^ self + internalAboutToReturn: localReturnValue + through: unwindContextOrNilOrZero ]. "Now we know home is on the sender chain. We could be returning to either a context or a frame. Find out which." contextToReturnTo := nil. (self isMarriedOrWidowedContext: home) - ifTrue: - [self assert: (self checkIsStillMarriedContext: home currentFP: framePointer). - theFP := self frameOfMarriedContext: home. - (self isBaseFrame: theFP) - ifTrue: - [contextToReturnTo := self frameCallerContext: theFP] - ifFalse: - [frameToReturnTo := self frameCallerFP: theFP]] - ifFalse: - [contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home. - ((objectMemory isContext: contextToReturnTo) - and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue: - [self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer). - frameToReturnTo := self frameOfMarriedContext: contextToReturnTo. - contextToReturnTo := nil]]. + ifTrue: [ + self assert: + (self checkIsStillMarriedContext: home currentFP: framePointer). + theFP := self frameOfMarriedContext: home. + (self isBaseFrame: theFP) + ifTrue: [ contextToReturnTo := self frameCallerContext: theFP ] + ifFalse: [ frameToReturnTo := self frameCallerFP: theFP ] ] + ifFalse: [ + contextToReturnTo := objectMemory + fetchPointer: SenderIndex + ofObject: home. + ((objectMemory isContext: contextToReturnTo) and: [ + self isMarriedOrWidowedContext: contextToReturnTo ]) ifTrue: [ + self assert: (self + checkIsStillMarriedContext: contextToReturnTo + currentFP: framePointer). + frameToReturnTo := self frameOfMarriedContext: contextToReturnTo. + contextToReturnTo := nil ] ]. "If returning to a context we must make a frame for it unless it is dead." - contextToReturnTo ~= nil ifTrue: - [frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo. - frameToReturnTo = 0 ifTrue: "error: home's sender is dead; cannot return" - [^self internalCannotReturn: localReturnValue]]. + contextToReturnTo ~= nil ifTrue: [ + frameToReturnTo := self establishFrameForContextToReturnTo: + contextToReturnTo. + frameToReturnTo = 0 ifTrue: [ "error: home's sender is dead; cannot return" + ^ self internalCannotReturn: localReturnValue ] ]. "Now we have a frame to return to. If it is on a different page we must free intervening pages and nil out intervening contexts. We must free intervening stack pages because if we leave the pages @@ -4646,46 +4685,55 @@ StackInterpreter >> commonReturn [ frame linked to because these may be in use, e.g. via co-routining (see baseFrameReturn)." self assert: stackPages pageListIsWellFormed. newPage := stackPages stackPageFor: frameToReturnTo. - newPage ~~ stackPage ifTrue: - [| currentCtx thePage nextCntx | - currentCtx := self frameCallerContext: stackPage baseFP. - stackPages freeStackPage: stackPage. - [self assert: (objectMemory isContext: currentCtx). - (self isMarriedOrWidowedContext: currentCtx) - and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse: - [(self isMarriedOrWidowedContext: currentCtx) - ifTrue: - [thePage := stackPages stackPageFor: theFP. - theFP ~= thePage headFP ifTrue: - ["Since we've just deallocated a page we know that newStackPage won't deallocate an existing one." - self moveFramesIn: thePage through: (self findFrameAbove: theFP inPage: thePage) toPage: stackPages newStackPage]. - currentCtx := self frameCallerContext: thePage baseFP. - stackPages freeStackPage: thePage] - ifFalse: - [nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx. - self markContextAsDead: currentCtx. - currentCtx := nextCntx]]. - self setStackPageAndLimit: newPage. - stackPointer := stackPage headSP. - framePointer := stackPage headFP]. + newPage ~~ stackPage ifTrue: [ + | currentCtx thePage nextCntx | + currentCtx := self frameCallerContext: stackPage baseFP. + stackPages freeStackPage: stackPage. + [ + self assert: (objectMemory isContext: currentCtx). + (self isMarriedOrWidowedContext: currentCtx) and: [ + (stackPages stackPageFor: + (theFP := self frameOfMarriedContext: currentCtx)) = newPage ] ] + whileFalse: [ + (self isMarriedOrWidowedContext: currentCtx) + ifTrue: [ + thePage := stackPages stackPageFor: theFP. + theFP ~= thePage headFP ifTrue: [ "Since we've just deallocated a page we know that newStackPage won't deallocate an existing one." + self + moveFramesIn: thePage + through: (self findFrameAbove: theFP inPage: thePage) + toPage: stackPages newStackPage ]. + currentCtx := self frameCallerContext: thePage baseFP. + stackPages freeStackPage: thePage ] + ifFalse: [ + nextCntx := objectMemory + fetchPointer: SenderIndex + ofObject: currentCtx. + self markContextAsDead: currentCtx. + currentCtx := nextCntx ] ]. + self setStackPageAndLimit: newPage. + stackPointer := stackPage headSP. + framePointer := stackPage headFP ]. "Two cases. Returning to the top frame on a new page or an interior frame on the current page. The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer in the caller frame. We need to peel back any frames on the page until we get to the correct frame." framePointer = frameToReturnTo - ifTrue: "pop the saved IP, push the return value and continue." - [instructionPointer := self pointerForOop: self internalStackTop] - ifFalse: - [[callerFP := framePointer. - framePointer := self frameCallerFP: framePointer. - framePointer ~~ frameToReturnTo] whileTrue. + ifTrue: [ "pop the saved IP, push the return value and continue." + instructionPointer := self pointerForOop: self stackTop ] + ifFalse: [ + [ + callerFP := framePointer. + framePointer := self frameCallerFP: framePointer. + framePointer ~~ frameToReturnTo ] whileTrue. instructionPointer := self frameCallerSavedIP: callerFP. - stackPointer := (self frameCallerSP: callerFP) - objectMemory wordSize]. + stackPointer := (self frameCallerSP: callerFP) + - objectMemory wordSize ]. self maybeReturnToMachineCodeFrame. self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. - self internalStackTopPut: localReturnValue + self stackTopPut: localReturnValue ] { #category : #'send bytecodes' } @@ -4695,7 +4743,7 @@ StackInterpreter >> commonSendOrdinary [ the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." - self sendBreakpoint: messageSelector receiver: (self internalStackValue: argumentCount). + self sendBreakpoint: messageSelector receiver: (self stackValue: argumentCount). self printSends ifTrue: [self printActivationNameForSelector: messageSelector startClass: (objectMemory classForClassTag: lkupClassTag); cr]. self internalFindNewMethodOrdinary. @@ -5238,8 +5286,7 @@ StackInterpreter >> dumpPrimTraceLog [ StackInterpreter >> duplicateTopBytecode [ self fetchNextBytecode. - self push: self internalStackTop. - + self push: self stackTop ] { #category : #'debug printing' } @@ -5327,9 +5374,9 @@ StackInterpreter >> ensureImageFormatIsUpToDate: swapBytes [ StackInterpreter >> ensureReceiverUnforwarded [ "To maintain the invariant that all receivers are unforwarded we need an explicit read barrier in the super send cases." - (objectMemory isOopForwarded: (self internalStackValue: argumentCount)) ifTrue: - [self internalStackValue: argumentCount - put: (objectMemory followForwarded: (self internalStackValue: argumentCount))] + (objectMemory isOopForwarded: (self stackValue: argumentCount)) ifTrue: + [self stackValue: argumentCount + put: (objectMemory followForwarded: (self stackValue: argumentCount))] ] { #category : #initialization } @@ -5543,12 +5590,14 @@ StackInterpreter >> extPushReceiverVariableBytecode [ { #category : #'return bytecodes' } StackInterpreter >> extReturnTopFromBlock [ + "218 11011010 Return Stack Top From Block [* return from enclosing block N, N = Extend A] If extA is zero, return to the caller of the current block activation. If extA is non-zero return to the caller of the Nth enclosing block activation." - extA = 0 ifTrue: - [localReturnValue := self internalStackTop. - ^self commonCallerReturn]. + + extA = 0 ifTrue: [ + localReturnValue := self stackTop. + ^ self commonCallerReturn ]. self shouldBeImplemented. extA := 0 ] @@ -5590,46 +5639,58 @@ StackInterpreter >> extSendSuperBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> extStoreAndPopLiteralVariableBytecode [ + "236 11101100 i i i i i i i i Pop and Store Literal Variable #iiiiiiii (+ Extend A * 256)" + | variableIndex value | variableIndex := self fetchByte + (extA << 8). - value := self internalStackTop. + value := self stackTop. self pop: 1. extA := 0. self storeLiteralVariable: variableIndex withValue: value. - self fetchNextBytecode. + self fetchNextBytecode ] { #category : #'stack bytecodes' } StackInterpreter >> extStoreAndPopReceiverVariableBytecode [ + "235 11101011 i i i i i i i i Pop and Store Receiver Variable #iiiiiii (+ Extend A * 256)" + | variableIndex value | variableIndex := self fetchByte + (extA << 8). extA := 0. - value := self internalStackTop. + value := self stackTop. self pop: 1. - self storeMaybeContextReceiverVariable: variableIndex withValue: value. - self fetchNextBytecode. + self + storeMaybeContextReceiverVariable: variableIndex + withValue: value. + self fetchNextBytecode ] { #category : #'stack bytecodes' } StackInterpreter >> extStoreLiteralVariableBytecode [ + "233 11101001 i i i i i i i i Store Literal Variable #iiiiiiii (+ Extend A * 256)" + | variableIndex | variableIndex := self fetchByte + (extA << 8). extA := 0. - self storeLiteralVariable: variableIndex withValue: self internalStackTop. - self fetchNextBytecode. + self storeLiteralVariable: variableIndex withValue: self stackTop. + self fetchNextBytecode ] { #category : #'stack bytecodes' } StackInterpreter >> extStoreReceiverVariableBytecode [ + "232 11101000 i i i i i i i i Store Receiver Variable #iiiiiii (+ Extend A * 256)" + | variableIndex | variableIndex := self fetchByte + (extA << 8). extA := 0. - self storeMaybeContextReceiverVariable: variableIndex withValue: self internalStackTop. - self fetchNextBytecode. + self + storeMaybeContextReceiverVariable: variableIndex + withValue: self stackTop. + self fetchNextBytecode ] { #category : #'jump bytecodes' } @@ -5677,25 +5738,28 @@ StackInterpreter >> extendedStoreBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> extendedStoreBytecodePop: popBoolean [ - | descriptor variableType variableIndex value | + + | descriptor variableType variableIndex value | descriptor := self fetchByte. variableType := descriptor >> 6 bitAnd: 3. variableIndex := descriptor bitAnd: 63. - value := self internalStackTop. + value := self stackTop. popBoolean ifTrue: [ self pop: 1 ]. - variableType = 0 ifTrue: - [objectMemory storePointerImmutabilityCheck: variableIndex ofObject: self receiver withValue: value. - ^ self fetchNextBytecode]. - variableType = 1 ifTrue: - [ self fetchNextBytecode. + variableType = 0 ifTrue: [ + objectMemory + storePointerImmutabilityCheck: variableIndex + ofObject: self receiver + withValue: value. + ^ self fetchNextBytecode ]. + variableType = 1 ifTrue: [ + self fetchNextBytecode. self temporary: variableIndex in: framePointer put: value. - ^ self "keep slang happy"]. - variableType = 3 ifTrue: - [self storeLiteralVariable: variableIndex withValue: value. - ^ self fetchNextBytecode]. + ^ self "keep slang happy" ]. + variableType = 3 ifTrue: [ + self storeLiteralVariable: variableIndex withValue: value. + ^ self fetchNextBytecode ]. self error: 'illegal store' - ] { #category : #'frame access' } @@ -8016,7 +8080,7 @@ StackInterpreter >> internalActivateNewMethod [ numTemps := self temporaryCountOfMethodHeader: methodHeader. self assert: argumentCount = (self argumentCountOfMethodHeader: methodHeader). - rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" + rcvr := self stackValue: argumentCount. "could new rcvr be set at point of send?" self assert: (objectMemory isOopForwarded: rcvr) not. self push: instructionPointer. @@ -8121,54 +8185,36 @@ StackInterpreter >> internalMustBeBoolean [ { #category : #'primitive support' } StackInterpreter >> internalQuickPrimitiveResponse [ + "Invoke a quick primitive. Called under the assumption that primFunctionPtr has been preloaded" - + | localPrimIndex | self assert: self isPrimitiveFunctionPointerAnIndex. - localPrimIndex := self cCoerceSimple: primitiveFunctionPointer to: #sqInt. - self assert: (localPrimIndex > 255 and: [localPrimIndex < 520]). + localPrimIndex := self + cCoerceSimple: primitiveFunctionPointer + to: #sqInt. + self assert: (localPrimIndex > 255 and: [ localPrimIndex < 520 ]). "Quick return inst vars" - localPrimIndex >= 264 ifTrue: - [self internalStackTopPut: (objectMemory fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop). - ^true]. + localPrimIndex >= 264 ifTrue: [ + self stackTopPut: (objectMemory + fetchPointer: localPrimIndex - 264 + ofObject: self stackTop). + ^ true ]. "Quick return constants" - localPrimIndex = 256 ifTrue: [^true "return self"]. - localPrimIndex = 257 ifTrue: [self internalStackTopPut: objectMemory trueObject. ^true]. - localPrimIndex = 258 ifTrue: [self internalStackTopPut: objectMemory falseObject. ^true]. - localPrimIndex = 259 ifTrue: [self internalStackTopPut: objectMemory nilObject. ^true]. - self internalStackTopPut: (objectMemory integerObjectOf: localPrimIndex - 261). - ^true -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalStackTop [ - - ^stackPages longAtPointer: stackPointer -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalStackTopPut: aValue [ - - ^stackPages longAtPointer: stackPointer put: aValue -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalStackTopPutIntegerObjectOf: aValue [ - - ^self internalStackTopPut: (objectMemory integerObjectOf: aValue) -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalStackValue: offset [ - "In the StackInterpreter stacks grow down." - ^stackPages longAtPointer: stackPointer + (offset * objectMemory bytesPerOop) -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalStackValue: offset put: aValue [ - "In the StackInterpreter stacks grow down." - ^stackPages longAtPointer: stackPointer + (offset * objectMemory bytesPerOop) put: aValue + localPrimIndex = 256 ifTrue: [ ^ true "return self" ]. + localPrimIndex = 257 ifTrue: [ + self stackTopPut: objectMemory trueObject. + ^ true ]. + localPrimIndex = 258 ifTrue: [ + self stackTopPut: objectMemory falseObject. + ^ true ]. + localPrimIndex = 259 ifTrue: [ + self stackTopPut: objectMemory nilObject. + ^ true ]. + self stackTopPut: + (objectMemory integerObjectOf: localPrimIndex - 261). + ^ true ] { #category : #utilities } @@ -8682,132 +8728,144 @@ StackInterpreter >> jump: offset [ { #category : #'sista bytecodes' } StackInterpreter >> jumpBinaryInlinePrimitive: primIndex [ + | test offset top | - top := self internalStackTop. + top := self stackTop. self assert: (objectMemory isIntegerObject: top). offset := objectMemory integerValueOf: top. - test := self internalStackValue: 1. + test := self stackValue: 1. self assert: offset >= 0. - primIndex caseOf: { - "7016 jumpIfWritable: + primIndex caseOf: { + ([ 16 ] -> [ + self deny: (objectMemory isOopForwarded: test). + self deny: (objectMemory isImmediate: test). + (objectMemory isImmutable: test) ifFalse: [ + instructionPointer := instructionPointer + offset ] ]). + "7017 jumpIfReadOnly: Not a forwarder, literal which is a Smi" - [16] -> [self deny: (objectMemory isOopForwarded: test). - self deny: (objectMemory isImmediate: test). - (objectMemory isImmutable: test) ifFalse: [instructionPointer := instructionPointer + offset]]. - "7017 jumpIfReadOnly: + ([ 17 ] -> [ + self deny: (objectMemory isOopForwarded: test). + self deny: (objectMemory isImmediate: test). + (objectMemory isImmutable: test) ifTrue: [ + instructionPointer := instructionPointer + offset ] ]). + "7018 jumpIfYoung: Not a forwarder, literal which is a Smi" - [17] -> [self deny: (objectMemory isOopForwarded: test). - self deny: (objectMemory isImmediate: test). - (objectMemory isImmutable: test) ifTrue: [instructionPointer := instructionPointer + offset]]. - "7018 jumpIfYoung: + ([ 18 ] -> [ + self deny: (objectMemory isOopForwarded: test). + self deny: (objectMemory isImmediate: test). + (objectMemory isYoungObject: test) ifTrue: [ + instructionPointer := instructionPointer + offset ] ]). + "7019 jumpIfOld: Not a forwarder, literal which is a Smi" - [18] -> [self deny: (objectMemory isOopForwarded: test). - self deny: (objectMemory isImmediate: test). - (objectMemory isYoungObject: test) ifTrue: [instructionPointer := instructionPointer + offset]]. - "7019 jumpIfOld: + ([ 19 ] -> [ + self deny: (objectMemory isOopForwarded: test). + self deny: (objectMemory isImmediate: test). + (objectMemory isYoungObject: test) ifFalse: [ + instructionPointer := instructionPointer + offset ] ]) }. + "7016 jumpIfWritable: Not a forwarder, literal which is a Smi" - [19] -> [self deny: (objectMemory isOopForwarded: test). - self deny: (objectMemory isImmediate: test). - (objectMemory isYoungObject: test) ifFalse: [instructionPointer := instructionPointer + offset]]. - }. instructionPointer := instructionPointer - 1. "we've already fetched, but we may have incorrectly fetched if jump" self fetchNextBytecode. - self pop: 2. - + self pop: 2 ] { #category : #'sista bytecodes' } StackInterpreter >> jumpTrinaryInlinePrimitive: primIndex [ - + "Note: those tests work with forwarders (wrong class index)" + + | test classObj offset classTag top | - top := self internalStackTop. + top := self stackTop. self assert: (objectMemory isIntegerObject: top). offset := objectMemory integerValueOf: top. self assert: offset >= 0. - test := self internalStackValue: 2. - classObj := self internalStackValue: 1. + test := self stackValue: 2. + classObj := self stackValue: 1. self assert: (objectMemory isNonImmediate: classObj). - primIndex caseOf: { - [0] -> ["8000 jumpIfInstanceOf:distance: + primIndex caseOf: { + ([ 0 ] -> [ "8000 jumpIfInstanceOf:distance: Anything, literal which is a Behavior, literal which is a Smi" self assert: (self objCouldBeClassObj: classObj). classTag := objectMemory fetchClassTagOf: test. - classTag = (objectMemory rawClassTagForClass: classObj) ifTrue: - [instructionPointer := instructionPointer + offset]]. - [1] -> ["8001 jumpIfNotInstanceOf:distance: + classTag = (objectMemory rawClassTagForClass: classObj) ifTrue: [ + instructionPointer := instructionPointer + offset ] ]). + ([ 1 ] -> [ "8001 jumpIfNotInstanceOf:distance: Anything, literal which is a Behavior, literal which is a Smi" self assert: (self objCouldBeClassObj: classObj). classTag := objectMemory fetchClassTagOf: test. - classTag = (objectMemory rawClassTagForClass: classObj) ifFalse: - [instructionPointer := instructionPointer + offset]]. - [2] -> ["8002 jumpIfInstanceOfOneOf:distance: + classTag = (objectMemory rawClassTagForClass: classObj) ifFalse: [ + instructionPointer := instructionPointer + offset ] ]). + ([ 2 ] -> [ "8002 jumpIfInstanceOfOneOf:distance: Anything, Array of behaviors, literal which is a Smi" self assert: (objectMemory isArrayNonImm: classObj). classTag := objectMemory fetchClassTagOf: test. - 0 to: (objectMemory numSlotsOf: classObj) asInteger - 1 do: - [:i | - classTag = (objectMemory rawClassTagForClass: (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: - [instructionPointer := instructionPointer + offset]]]. - [3] -> ["8003 jumpIfNotInstanceOfOneOf:distance: + 0 to: (objectMemory numSlotsOf: classObj) asInteger - 1 do: [ :i | + classTag = (objectMemory rawClassTagForClass: + (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: [ + instructionPointer := instructionPointer + offset ] ] ]). + ([ 3 ] -> [ "8003 jumpIfNotInstanceOfOneOf:distance: Anything, Array of behaviors, literal which is a Smi" self assert: (objectMemory isArrayNonImm: classObj). classTag := objectMemory fetchClassTagOf: test. - 0 to: (objectMemory numSlotsOf: classObj) asInteger - 1 do: - [:i | - classTag = (objectMemory rawClassTagForClass: (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: - [instructionPointer := instructionPointer - 1. - self fetchNextBytecode. - ^self pop: 3]]. - instructionPointer := instructionPointer + offset]. - }. + 0 to: (objectMemory numSlotsOf: classObj) asInteger - 1 do: [ :i | + classTag = (objectMemory rawClassTagForClass: + (objectMemory fetchPointer: i ofObject: classObj)) ifTrue: [ + instructionPointer := instructionPointer - 1. + self fetchNextBytecode. + ^ self pop: 3 ] ]. + instructionPointer := instructionPointer + offset ]) }. instructionPointer := instructionPointer - 1. "we've already fetched, but we may have incorrectly fetched if jump" self fetchNextBytecode. self pop: 3 - ] { #category : #'sista bytecodes' } StackInterpreter >> jumpUnaryInlinePrimitive: primIndex [ - + "6000 backjumpNoInterrupt literal which is a Smi" + + | top | - top := self internalStackTop. - primIndex = 0 ifTrue: - [self assert: (objectMemory isIntegerObject: top). - self assert: (objectMemory integerValueOf: top) < 0. + top := self stackTop. + primIndex = 0 ifTrue: [ + self assert: (objectMemory isIntegerObject: top). + self assert: (objectMemory integerValueOf: top) < 0. "We've already fetched next bytecode, so we add -1" - instructionPointer := instructionPointer + (objectMemory integerValueOf: top) - 1. - self fetchNextBytecode. - ^self pop: 1]. - ^ self unknownInlinePrimitive + instructionPointer := instructionPointer + + (objectMemory integerValueOf: top) - 1. + self fetchNextBytecode. + ^ self pop: 1 ]. + ^ self unknownInlinePrimitive ] { #category : #'jump bytecodes' } -StackInterpreter >> jumplfFalseBy: offset [ +StackInterpreter >> jumplfFalseBy: offset [ + | boolean | - boolean := self internalStackTop. + boolean := self stackTop. boolean = objectMemory falseObject - ifTrue: [self jump: offset] - ifFalse: - [boolean = objectMemory trueObject ifFalse: - [^self internalMustBeBoolean]. - self fetchNextBytecode]. + ifTrue: [ self jump: offset ] + ifFalse: [ + boolean = objectMemory trueObject ifFalse: [ + ^ self internalMustBeBoolean ]. + self fetchNextBytecode ]. self pop: 1 ] { #category : #'jump bytecodes' } -StackInterpreter >> jumplfTrueBy: offset [ +StackInterpreter >> jumplfTrueBy: offset [ + | boolean | - boolean := self internalStackTop. + boolean := self stackTop. boolean = objectMemory trueObject - ifTrue: [self jump: offset] - ifFalse: - [boolean = objectMemory falseObject ifFalse: - [^self internalMustBeBoolean]. - self fetchNextBytecode]. + ifTrue: [ self jump: offset ] + ifFalse: [ + boolean = objectMemory falseObject ifFalse: [ + ^ self internalMustBeBoolean ]. + self fetchNextBytecode ]. self pop: 1 ] @@ -9107,11 +9165,13 @@ StackInterpreter >> longStoreBytecodeForHeader: methodHeader [ { #category : #'stack bytecodes' } StackInterpreter >> longStoreTemporaryVariableBytecode [ + "234 11101010 i i i i i i i i Store Temporary Variable #iiiiiiii" + | index | index := self fetchByte. self fetchNextBytecode. - self temporary: index in: framePointer put: self internalStackTop + self temporary: index in: framePointer put: self stackTop ] { #category : #'jump bytecodes' } @@ -9591,14 +9651,15 @@ StackInterpreter >> mapVMRegisters [ { #category : #'sista bytecodes' } StackInterpreter >> mappedBackjumpAlwaysInterrupt [ + | top offset | - top := self internalStackTop. + top := self stackTop. self assert: (objectMemory isIntegerObject: top). offset := objectMemory integerObjectOf: top. instructionPointer := instructionPointer - offset. self pop: 1. "+1 since this instr is 3 bytes not 2" - self ifBackwardsCheckForEvents: 0 - offset + 1. + self ifBackwardsCheckForEvents: 0 - offset + 1. instructionPointer := instructionPointer - 1. self fetchNextBytecode ] @@ -9621,106 +9682,125 @@ StackInterpreter >> mappedDirectCall [ { #category : #'sista bytecodes' } StackInterpreter >> mappedEnsureEnoughWords [ + "50 EnsureEnoughWords literal which is a Smi => ret value is receiver" - | slots ok top | - top := self internalStackTop. - self assert: (objectMemory isIntegerObject: top). - slots := objectMemory integerValueOf: top. - self assert: slots >= 0. - ok := objectMemory checkForAvailableSlots: slots. - ok ifFalse: - [self externalizeIPandSP. - self checkForEventsMayContextSwitch: true. - self browserPluginReturnIfNeeded. - self internalizeIPandSP] + + | slots ok top | + top := self stackTop. + self assert: (objectMemory isIntegerObject: top). + slots := objectMemory integerValueOf: top. + self assert: slots >= 0. + ok := objectMemory checkForAvailableSlots: slots. + ok ifFalse: [ + self externalizeIPandSP. + self checkForEventsMayContextSwitch: true. + self browserPluginReturnIfNeeded. + self internalizeIPandSP ] ] { #category : #'sista bytecodes' } StackInterpreter >> mappedImmcheckDataAtPut: primIndex [ + | argIntAdjusted rec result arg1 | self assert: (primIndex between: 154 and: 157). - arg1 := self internalStackValue: 1. - rec := self internalStackValue: 2. - self deny: ((objectMemory isOopForwarded: rec) or: [(objectMemory isImmediate: rec)]). + arg1 := self stackValue: 1. + rec := self stackValue: 2. + self deny: ((objectMemory isOopForwarded: rec) or: [ + objectMemory isImmediate: rec ]). self assert: (objectMemory isIntegerObject: arg1). argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. self assert: argIntAdjusted >= 0. - result := self internalStackTop. - self pop: 2; internalStackTopPut: result. - (objectMemory isImmutable: rec) ifTrue: [^self cannotAssign: result to: rec withIndex: argIntAdjusted]. - - primIndex caseOf: { - "154 immCheckByteAt:put: - byte object, Smi, 8 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" - [154] -> [self assert: (objectMemory isBytes: rec). - self assert: argIntAdjusted < (objectMemory numBytesOf: rec). - self assert: (objectMemory isIntegerObject: result). - objectMemory - storeByte: argIntAdjusted - ofObject: rec - withValue: (objectMemory integerValueOf: result)]. - "155 immCheckShortAt:put: + result := self stackTop. + self + pop: 2; + stackTopPut: result. + (objectMemory isImmutable: rec) ifTrue: [ + ^ self cannotAssign: result to: rec withIndex: argIntAdjusted ]. + + primIndex caseOf: { + ([ 154 ] -> [ + self assert: (objectMemory isBytes: rec). + self assert: argIntAdjusted < (objectMemory numBytesOf: rec). + self assert: (objectMemory isIntegerObject: result). + objectMemory + storeByte: argIntAdjusted + ofObject: rec + withValue: (objectMemory integerValueOf: result) ]). + "155 immCheckShortAt:put: short object, Smi, 16 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" - [155] -> [self assert: (objectMemory isShorts: rec). - self assert: argIntAdjusted < (objectMemory num16BitUnitsOf: rec). - self assert: (objectMemory isIntegerObject: result). - objectMemory - storeShort16: argIntAdjusted - ofObject: rec - withValue: (objectMemory integerValueOf: result)]. - "156 immCheckWordAt:put: + ([ 155 ] -> [ + self assert: (objectMemory isShorts: rec). + self assert: argIntAdjusted < (objectMemory num16BitUnitsOf: rec). + self assert: (objectMemory isIntegerObject: result). + objectMemory + storeShort16: argIntAdjusted + ofObject: rec + withValue: (objectMemory integerValueOf: result) ]). + "156 immCheckWordAt:put: word object, Smi, 32 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" - [156] -> [self assert: (objectMemory isWords: rec). - self assert: argIntAdjusted < (objectMemory num32BitUnitsOf: rec). - objectMemory - storeLong32: argIntAdjusted - ofObject: rec - withValue: (objectMemory positive32BitValueOf: result)]. - "157 immCheckDoubleWordAt:put: + ([ 156 ] -> [ + self assert: (objectMemory isWords: rec). + self assert: argIntAdjusted < (objectMemory num32BitUnitsOf: rec). + objectMemory + storeLong32: argIntAdjusted + ofObject: rec + withValue: (objectMemory positive32BitValueOf: result) ]). + "157 immCheckDoubleWordAt:put: double word object, Smi, 64 bits unsigned Smi or LargePositiveInteger => arg2 (1-based, optimised if arg1 is a constant)" - [157] -> [self assert: (objectMemory isLong64s: rec). - self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). - objectMemory - storeLong64: argIntAdjusted - ofObject: rec - withValue: (objectMemory positive64BitValueOf: result)]}. - + ([ 157 ] -> [ + self assert: (objectMemory isLong64s: rec). + self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). + objectMemory + storeLong64: argIntAdjusted + ofObject: rec + withValue: (objectMemory positive64BitValueOf: result) ]) } + "154 immCheckByteAt:put: + byte object, Smi, 8 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" ] { #category : #'sista bytecodes' } StackInterpreter >> mappedImmcheckMaybeContextStoreCheckPointerAtPut [ + "153 immCheckMaybeContextStoreCheckPointerAt:put: pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" - |rec argIntAdjusted result arg1| - rec := self internalStackValue: 2. - arg1 := self internalStackValue: 1. + + | rec argIntAdjusted result arg1 | + rec := self stackValue: 2. + arg1 := self stackValue: 1. self assert: (objectMemory isIntegerObject: arg1). argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. - result := self internalStackTop. + result := self stackTop. self pop: 3. self push: result. - (self isWriteMediatedContextInstVarIndex: argIntAdjusted) - ifFalse: [objectMemory storePointerImmutabilityCheck: argIntAdjusted ofObject: rec withValue: result] - ifTrue: [self externalizeIPandSP. - self externalInstVar: argIntAdjusted ofContext: rec put: result. - self internalizeIPandSP] + (self isWriteMediatedContextInstVarIndex: argIntAdjusted) + ifFalse: [ + objectMemory + storePointerImmutabilityCheck: argIntAdjusted + ofObject: rec + withValue: result ] + ifTrue: [ + self externalizeIPandSP. + self externalInstVar: argIntAdjusted ofContext: rec put: result. + self internalizeIPandSP ] ] { #category : #'sista bytecodes' } StackInterpreter >> mappedImmcheckStoreCheckPointerAtPut [ + "151 immCheckStoreCheckPointerAt:put: pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" - |rec argIntAdjusted result arg1| - rec := self internalStackValue: 2. - arg1 := self internalStackValue: 1. + + | rec argIntAdjusted result arg1 | + rec := self stackValue: 2. + arg1 := self stackValue: 1. self assert: (objectMemory isPointers: rec). self assert: (objectMemory isIntegerObject: arg1). argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. self assert: argIntAdjusted >= 0. self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). - result := self internalStackTop. + result := self stackTop. self pop: 3. self push: result. objectMemory @@ -10628,7 +10708,7 @@ StackInterpreter >> normalSend [ "Note: This method is inlined into the interpreter dispatch loop." | rcvr | - rcvr := self internalStackValue: argumentCount. + rcvr := self stackValue: argumentCount. lkupClassTag := objectMemory fetchClassTagOf: rcvr. self assert: lkupClassTag ~= objectMemory nilObject. self commonSendOrdinary @@ -12572,7 +12652,7 @@ StackInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg c Thus, can use unchecked stores." objectMemory storePointerUnchecked: i + startIndex ofObject: newClosure - withValue: (self internalStackValue: numCopied - i - 1)]. + withValue: (self stackValue: numCopied - i - 1)]. self pop: numCopied]. self fetchNextBytecode. self push: newClosure @@ -12700,7 +12780,7 @@ StackInterpreter >> pushNewArrayBytecode [ [0 to: size - 1 do: [:i| "Assume: have just allocated a new Array; it must be young. Thus, can use unchecked stores." - objectMemory storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)]. + objectMemory storePointerUnchecked: i ofObject: array withValue: (self stackValue: size - i - 1)]. self pop: size] ifFalse: [0 to: size - 1 do: @@ -12887,11 +12967,11 @@ StackInterpreter >> quinaryInlinePrimitive: primIndex [ "0 is deprecated, now this can be handled at Scorch level" primIndex = 0 ifTrue: "Array copy, pointer variable object with no inst vars" - [dest := self internalStackValue: 4. - destIndex := (objectMemory integerValueOf: (self internalStackValue: 3)) - 1. - destLimit := (objectMemory integerValueOf: (self internalStackValue: 2)) - 1. - src := self internalStackValue: 1. - srcIndex := (objectMemory integerValueOf: (self internalStackValue: 0)) - 1. + [dest := self stackValue: 4. + destIndex := (objectMemory integerValueOf: (self stackValue: 3)) - 1. + destLimit := (objectMemory integerValueOf: (self stackValue: 2)) - 1. + src := self stackValue: 1. + srcIndex := (objectMemory integerValueOf: (self stackValue: 0)) - 1. self pop: 4. destLimit < destIndex ifTrue: [^self]. (objectMemory isYoung: dest) ifFalse: [objectMemory possibleRootStoreInto: dest]. @@ -13331,14 +13411,17 @@ StackInterpreter >> returnReceiver [ { #category : #'return bytecodes' } StackInterpreter >> returnTopFromBlock [ + "Return top-of-stack to the caller of the current block activation." - localReturnValue := self internalStackTop. + + localReturnValue := self stackTop. self commonCallerReturn ] { #category : #'return bytecodes' } StackInterpreter >> returnTopFromMethod [ - localReturnValue := self internalStackTop. + + localReturnValue := self stackTop. self commonReturn ] @@ -13523,7 +13606,7 @@ StackInterpreter >> sendLiteralSelector0ArgsBytecode [ | rcvr | messageSelector := self literal: (currentBytecode bitAnd: 16rF). argumentCount := 0. - rcvr := self internalStackValue: 0. + rcvr := self stackValue: 0. lkupClassTag := objectMemory fetchClassTagOf: rcvr. self assert: lkupClassTag ~= objectMemory nilObject. self commonSendOrdinary @@ -13535,7 +13618,7 @@ StackInterpreter >> sendLiteralSelector1ArgBytecode [ | rcvr | messageSelector := self literal: (currentBytecode bitAnd: 16rF). argumentCount := 1. - rcvr := self internalStackValue: 1. + rcvr := self stackValue: 1. lkupClassTag := objectMemory fetchClassTagOf: rcvr. self assert: lkupClassTag ~= objectMemory nilObject. self commonSendOrdinary @@ -13547,7 +13630,7 @@ StackInterpreter >> sendLiteralSelector2ArgsBytecode [ | rcvr | messageSelector := self literal: (currentBytecode bitAnd: 16rF). argumentCount := 2. - rcvr := self internalStackValue: 2. + rcvr := self stackValue: 2. lkupClassTag := objectMemory fetchClassTagOf: rcvr. self assert: lkupClassTag ~= objectMemory nilObject. self commonSendOrdinary @@ -14094,9 +14177,9 @@ StackInterpreter >> shuffleArgumentsAndStoreAbsentReceiver: theReceiver [ stackPointer := stackPointer - objectMemory bytesPerOop. "a.k.a. self internalPush: anything" 1 to: argumentCount do: [:i| | oop | - oop := self internalStackValue: i. - self internalStackValue: i - 1 put: oop]. - self internalStackValue: argumentCount put: theReceiver + oop := self stackValue: i. + self stackValue: i - 1 put: oop]. + self stackValue: argumentCount put: theReceiver ] { #category : #'primitive support' } @@ -14763,6 +14846,12 @@ StackInterpreter >> stackTopPut: aValue [ ^stackPages longAtPointer: stackPointer put: aValue ] +{ #category : #'internal interpreter access' } +StackInterpreter >> stackTopPutIntegerObjectOf: aValue [ + + ^ self stackTopPut: (objectMemory integerObjectOf: aValue) +] + { #category : #'stack access' } StackInterpreter >> stackValue: offset [ @@ -14794,16 +14883,17 @@ StackInterpreter >> startPCOfMethodHeader: methodHeader [ { #category : #'stack bytecodes' } StackInterpreter >> storeAndPopReceiverVariableBytecode [ + | rcvr top instVarIndex | rcvr := self receiver. - top := self internalStackTop. + top := self stackTop. instVarIndex := currentBytecode bitAnd: 7. self pop: 1. objectMemory storePointerImmutabilityCheck: instVarIndex ofObject: rcvr withValue: top. - self fetchNextBytecode. + self fetchNextBytecode ] { #category : #'stack bytecodes' } @@ -14814,16 +14904,23 @@ StackInterpreter >> storeAndPopRemoteTempLongBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> storeAndPopTemporaryVariableBytecode [ + self - cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant" - [self fetchNextBytecode. - self temporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. - self pop: 1] - inSmalltalk: "Interpreter version has fetchNextBytecode out of order" - [self temporary: (currentBytecode bitAnd: 7) in: framePointer put: self internalStackTop. - self fetchNextBytecode. - self pop: 1] + cCode: [ "this bytecode will be expanded so that refs to currentBytecode below will be constant" + self fetchNextBytecode. + self + temporary: (currentBytecode bitAnd: 7) + in: framePointer + put: self stackTop. + self pop: 1 ] + inSmalltalk: [ "Interpreter version has fetchNextBytecode out of order" + self + temporary: (currentBytecode bitAnd: 7) + in: framePointer + put: self stackTop. + self fetchNextBytecode. + self pop: 1 ] ] { #category : #utilities } @@ -14877,13 +14974,19 @@ StackInterpreter >> storeMaybeContextReceiverVariable: fieldIndex withValue: anO { #category : #'stack bytecodes' } StackInterpreter >> storeRemoteTemp: index inVectorAt: tempVectorIndex [ + | tempVector | tempVector := self temporary: tempVectorIndex in: framePointer. - TempVectReadBarrier - ifTrue: - [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. - objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop. + TempVectReadBarrier ifTrue: [ + (objectMemory isForwarded: tempVector) ifTrue: [ + tempVector := self + unfollowTempVector: tempVector + atIndex: tempVectorIndex + in: framePointer ] ]. + objectMemory + storePointer: index + ofObject: tempVector + withValue: self stackTop ] { #category : #'stack bytecodes' } @@ -15206,92 +15309,111 @@ StackInterpreter >> transferTo: newProc [ { #category : #'sista bytecodes' } StackInterpreter >> trinaryAtPutInlinePrimitive: primIndex [ + - | result rec argIntAdjusted arg1| - arg1 := self internalStackValue: 1. - rec := self internalStackValue: 2. - self deny: ((objectMemory isOopForwarded: rec) or: [(objectMemory isImmediate: rec)]). + | result rec argIntAdjusted arg1 | + arg1 := self stackValue: 1. + rec := self stackValue: 2. + self deny: ((objectMemory isOopForwarded: rec) or: [ + objectMemory isImmediate: rec ]). self assert: (objectMemory isIntegerObject: arg1). argIntAdjusted := (objectMemory integerValueOf: arg1) - 1. self assert: argIntAdjusted >= 0. - result := self internalStackTop. - - primIndex caseOf: { - "3000 pointerAt:put: - Mutable pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" - [0] -> [self assert: (objectMemory isPointers: rec). - self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). - objectMemory - storePointerUnchecked: argIntAdjusted - ofObject: rec - withValue: result.]. - "3001 storeCheckPointerAt:put: + result := self stackTop. + + primIndex caseOf: { + ([ 0 ] -> [ + self assert: (objectMemory isPointers: rec). + self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). + objectMemory + storePointerUnchecked: argIntAdjusted + ofObject: rec + withValue: result ]). + "3001 storeCheckPointerAt:put: Mutable pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" - [1] -> [self assert: (objectMemory isPointers: rec). - self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). - objectMemory - storePointer: argIntAdjusted - ofObject: rec - withValue: result]. - "3002 maybeContextPointerAt:put: + ([ 1 ] -> [ + self assert: (objectMemory isPointers: rec). + self assert: argIntAdjusted < (objectMemory numSlotsOfAny: rec). + objectMemory + storePointer: argIntAdjusted + ofObject: rec + withValue: result ]). + "3002 maybeContextPointerAt:put: Mutable pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" - [2] -> [((objectMemory isContextNonImm: rec) - and: [self isMarriedOrWidowedContext: rec]) - ifTrue: - [self externalizeIPandSP. - self externalInstVar: argIntAdjusted ofContext: rec put: result. - self internalizeIPandSP] - ifFalse: [objectMemory storePointer: argIntAdjusted ofObject: rec withValue: result]]. - "3003 maybeContextStoreCheckPointerAt:put: + ([ 2 ] -> [ + ((objectMemory isContextNonImm: rec) and: [ + self isMarriedOrWidowedContext: rec ]) + ifTrue: [ + self externalizeIPandSP. + self externalInstVar: argIntAdjusted ofContext: rec put: result. + self internalizeIPandSP ] + ifFalse: [ + objectMemory + storePointer: argIntAdjusted + ofObject: rec + withValue: result ] ]). + "3003 maybeContextStoreCheckPointerAt:put: Mutable pointer object (Fixed sized or not), Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" - [3] -> [((objectMemory isContextNonImm: rec) - and: [self isMarriedOrWidowedContext: rec]) - ifTrue: - [self externalizeIPandSP. - self externalInstVar: argIntAdjusted ofContext: rec put: result. - self internalizeIPandSP] - ifFalse: [objectMemory storePointer: argIntAdjusted ofObject: rec withValue: result]]. - "3004 byteAt:put: + ([ 3 ] -> [ + ((objectMemory isContextNonImm: rec) and: [ + self isMarriedOrWidowedContext: rec ]) + ifTrue: [ + self externalizeIPandSP. + self externalInstVar: argIntAdjusted ofContext: rec put: result. + self internalizeIPandSP ] + ifFalse: [ + objectMemory + storePointer: argIntAdjusted + ofObject: rec + withValue: result ] ]). + "3004 byteAt:put: Mutable byte object, Smi, 8 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" - [4] -> [self assert: (objectMemory isBytes: rec). - self assert: argIntAdjusted < (objectMemory numBytesOf: rec). - self assert: (objectMemory isIntegerObject: result). - objectMemory - storeByte: argIntAdjusted - ofObject: rec - withValue: (objectMemory integerValueOf: result).]. - "3005 shortAt:put: + ([ 4 ] -> [ + self assert: (objectMemory isBytes: rec). + self assert: argIntAdjusted < (objectMemory numBytesOf: rec). + self assert: (objectMemory isIntegerObject: result). + objectMemory + storeByte: argIntAdjusted + ofObject: rec + withValue: (objectMemory integerValueOf: result) ]). + "3005 shortAt:put: Mutable short object, Smi, 16 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" - [5] -> [self assert: (objectMemory isShorts: rec). - self assert: argIntAdjusted < (objectMemory num16BitUnitsOf: rec). - self assert: (objectMemory isIntegerObject: result). - objectMemory - storeShort16: argIntAdjusted - ofObject: rec - withValue: (objectMemory integerValueOf: result).]. - "3006 wordAt:put: + ([ 5 ] -> [ + self assert: (objectMemory isShorts: rec). + self assert: argIntAdjusted < (objectMemory num16BitUnitsOf: rec). + self assert: (objectMemory isIntegerObject: result). + objectMemory + storeShort16: argIntAdjusted + ofObject: rec + withValue: (objectMemory integerValueOf: result) ]). + "3006 wordAt:put: Mutable word object, Smi, 32 bits unsigned Smi => arg2 (1-based, optimised if arg1 is a constant)" - [6] -> [self assert: (objectMemory isWords: rec). - self assert: argIntAdjusted < (objectMemory num32BitUnitsOf: rec). - objectMemory - storeLong32: argIntAdjusted - ofObject: rec - withValue: (objectMemory positive32BitValueOf: result).]. - "3007 doubleWordAt:put: + ([ 6 ] -> [ + self assert: (objectMemory isWords: rec). + self assert: argIntAdjusted < (objectMemory num32BitUnitsOf: rec). + objectMemory + storeLong32: argIntAdjusted + ofObject: rec + withValue: (objectMemory positive32BitValueOf: result) ]). + "3007 doubleWordAt:put: Mutable double word object, Smi, 64 bits unsigned Smi or LargePositiveInteger => arg2 (1-based, optimised if arg1 is a constant)" - [7] -> [self assert: (objectMemory isLong64s: rec). - self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). - objectMemory - storeLong64: argIntAdjusted - ofObject: rec - withValue: (objectMemory positive64BitValueOf: result).]. - }. - self pop: 2; internalStackTopPut: result + ([ 7 ] -> [ + self assert: (objectMemory isLong64s: rec). + self assert: argIntAdjusted < (objectMemory num64BitUnitsOf: rec). + objectMemory + storeLong64: argIntAdjusted + ofObject: rec + withValue: (objectMemory positive64BitValueOf: result) ]) }. + "3000 pointerAt:put: + Mutable pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant)" + self + pop: 2; + stackTopPut: result ] { #category : #'sista bytecodes' } StackInterpreter >> trinaryInlinePrimitive: primIndex [ - + "Bulk comment, each sub method has its own comment 3000 pointerAt:put: Mutable pointer object (Fixed sized or not) and not a context, Smi, Anything => arg2 (1-based, optimised if arg1 is a constant) @@ -15310,19 +15432,30 @@ StackInterpreter >> trinaryInlinePrimitive: primIndex [ 3007 doubleWordAt:put: Mutable double word object, Smi, 64 bits unsigned Smi or LargePositiveInteger => arg2 (1-based, optimised if arg1 is a constant) 3021 is deprecated." - primIndex <= 7 ifTrue: [^self trinaryAtPutInlinePrimitive: primIndex]. + + + primIndex <= 7 ifTrue: [ + ^ self trinaryAtPutInlinePrimitive: primIndex ]. "21 is deprecated, now this can be handled at Scorch level" - primIndex = 21 ifTrue: - [ | str1 str2 word1 word2 len | - len := objectMemory integerValueOf: self internalStackTop. - len = 0 ifTrue: [^self pop: 2; internalStackTopPut: objectMemory trueObject]. - str1 := self internalStackValue: 2. - str2 := self internalStackValue: 1. - 0 to: len - 1 >> objectMemory shiftForWord do: [:i | + primIndex = 21 ifTrue: [ + | str1 str2 word1 word2 len | + len := objectMemory integerValueOf: self stackTop. + len = 0 ifTrue: [ + ^ self + pop: 2; + stackTopPut: objectMemory trueObject ]. + str1 := self stackValue: 2. + str2 := self stackValue: 1. + 0 to: len - 1 >> objectMemory shiftForWord do: [ :i | word1 := objectMemory fetchPointer: i ofObject: str1. - word2 := objectMemory fetchPointer: i ofObject: str2. - word1 = word2 ifFalse: [^self pop: 2; internalStackTopPut: objectMemory falseObject] ]. - ^self pop: 2; internalStackTopPut: objectMemory trueObject ]. + word2 := objectMemory fetchPointer: i ofObject: str2. + word1 = word2 ifFalse: [ + ^ self + pop: 2; + stackTopPut: objectMemory falseObject ] ]. + ^ self + pop: 2; + stackTopPut: objectMemory trueObject ]. self unknownInlinePrimitive ] @@ -15395,86 +15528,97 @@ StackInterpreter >> unPop: nItems [ { #category : #'sista inline primitives - unary' } StackInterpreter >> unaryClassPrimitive [ + | result top | "1000 rawClass not a forwarder => Behavior (Same as class special send, but receiver is not a forwarder)" - top := self internalStackTop. - self deny: (objectMemory isOopForwarded: top). - result := objectMemory fetchClassOf: top. - self internalStackTopPut: result + top := self stackTop. + self deny: (objectMemory isOopForwarded: top). + result := objectMemory fetchClassOf: top. + self stackTopPut: result ] { #category : #'sista inline primitives - unary' } StackInterpreter >> unaryConvertInlinePrimitive: primIndex [ + | result top | self assert: (primIndex between: 30 and: 32). - top := self internalStackTop. - primIndex caseOf: { - "1030 characterAsInteger - Character => 22 bits strictly positive Smi (Unicode)" - [30] -> [self assert: (objectMemory isImmediateCharacter: top). - result := objectMemory characterValueOf: top. - self assert: (result between: 1 and: "1 << 22 - 1" 4194303). - self internalStackTopPutIntegerObjectOf: result]. - "1031 smallFloatAsInteger + top := self stackTop. + primIndex caseOf: { + ([ 30 ] -> [ + self assert: (objectMemory isImmediateCharacter: top). + result := objectMemory characterValueOf: top. + self assert: (result between: 1 and: 4194303). "1 << 22 - 1" + self stackTopPutIntegerObjectOf: result ]). + "1031 smallFloatAsInteger SmallFloat => Smi" - [31] -> [objectMemory hasSixtyFourBitImmediates - ifTrue: "Needs to protect rotatedFloatBitsOf:" - [self assert: (objectMemory isImmediateFloat: top). - result := objectMemory rotatedFloatBitsOf: top. - self assert: (objectMemory isIntegerObject: result). - self internalStackTopPutIntegerObjectOf: result] - ifFalse: [self unknownInlinePrimitive]]. - "1032 smiAsFloat + ([ 31 ] -> [ + objectMemory hasSixtyFourBitImmediates + ifTrue: [ "Needs to protect rotatedFloatBitsOf:" + self assert: (objectMemory isImmediateFloat: top). + result := objectMemory rotatedFloatBitsOf: top. + self assert: (objectMemory isIntegerObject: result). + self stackTopPutIntegerObjectOf: result ] + ifFalse: [ self unknownInlinePrimitive ] ]). + "1032 smiAsFloat Smi => SmallFloat" - [32] -> [self assert: (objectMemory isIntegerObject: top). - self pop: 1 thenPushFloat: (objectMemory integerValueOf: top) asFloat]. - } + ([ 32 ] -> [ + self assert: (objectMemory isIntegerObject: top). + self + pop: 1 + thenPushFloat: (objectMemory integerValueOf: top) asFloat ]) } + "1030 characterAsInteger + Character => 22 bits strictly positive Smi (Unicode)" ] { #category : #'sista inline primitives - unary' } StackInterpreter >> unaryHashInlinePrimitive: primIndex [ + | result top | self assert: (primIndex between: 20 and: 23). - top := self internalStackTop. - primIndex caseOf: { - "1020 objectIdentityHash - non-immediate and non-behavior => 22 bits strictly positive Smi" - [20] -> [self deny: ((objectMemory isOopForwarded: top) - or: [(objectMemory isImmediate: top) - or: [objectMemory isInClassTable: top]]). - result := objectMemory hashBitsOf: top. - self assert: (result between: 1 and: "1 << 22 - 1" 4194303). - self internalStackTopPutIntegerObjectOf: result]. - "1021 smiIdentityHash + top := self stackTop. + primIndex caseOf: { + ([ 20 ] -> [ + self deny: ((objectMemory isOopForwarded: top) or: [ + (objectMemory isImmediate: top) or: [ + objectMemory isInClassTable: top ] ]). + result := objectMemory hashBitsOf: top. + self assert: (result between: 1 and: 4194303). "1 << 22 - 1" + self stackTopPutIntegerObjectOf: result ]). + "1021 smiIdentityHash Smi => Smi" - [21] -> [self assert: (objectMemory isIntegerObject: top). - "Don't do anything, Smi hash is the object itself"]. - "1022 charIdentityHash + ([ 21 ] -> [ + self assert: (objectMemory isIntegerObject: top) + "Don't do anything, Smi hash is the object itself" ]). + "1022 charIdentityHash Character => 22 bits strictly positive Smi" - [22] -> [self assert: (objectMemory isImmediateCharacter: top). - result := objectMemory integerObjectOfCharacterObject: top. - self assert: (result between: 1 and: "1 << 22 - 1" 4194303). - self internalStackTopPut: result]. - "1023 smallfloatIdentityHash + ([ 22 ] -> [ + self assert: (objectMemory isImmediateCharacter: top). + result := objectMemory integerObjectOfCharacterObject: top. + self assert: (result between: 1 and: 4194303). "1 << 22 - 1" + self stackTopPut: result ]). + "1023 smallfloatIdentityHash SmallFloat => Smi" - [23] -> [objectMemory hasSixtyFourBitImmediates - ifTrue: "Needs to protect rotatedFloatBitsOf:" - [self assert: (objectMemory isImmediateFloat: top). - result := objectMemory rotatedFloatBitsOf: top. - self assert: (objectMemory isIntegerObject: result). - self internalStackTopPutIntegerObjectOf: result] - ifFalse: [self unknownInlinePrimitive]]. - "1024 behaviorIdentityHash + ([ 23 ] -> [ + objectMemory hasSixtyFourBitImmediates + ifTrue: [ "Needs to protect rotatedFloatBitsOf:" + self assert: (objectMemory isImmediateFloat: top). + result := objectMemory rotatedFloatBitsOf: top. + self assert: (objectMemory isIntegerObject: result). + self stackTopPutIntegerObjectOf: result ] + ifFalse: [ self unknownInlinePrimitive ] ]). + "1024 behaviorIdentityHash Behavior => 22 bits strictly positive Smi" - [24] -> [self assert: ((objectMemory isNonImmediate: top) - and: [objectMemory objCouldBeClassObj: top]). - result := objectMemory ensureBehaviorHash: top. - self assert: (result between: 1 and: "1 << 22 - 1" 4194303). - self internalStackTopPutIntegerObjectOf: result]. - } + ([ 24 ] -> [ + self assert: ((objectMemory isNonImmediate: top) and: [ + objectMemory objCouldBeClassObj: top ]). + result := objectMemory ensureBehaviorHash: top. + self assert: (result between: 1 and: 4194303). "1 << 22 - 1" + self stackTopPutIntegerObjectOf: result ]) } + "1020 objectIdentityHash + non-immediate and non-behavior => 22 bits strictly positive Smi" ] { #category : #'sista inline primitives - unary' } @@ -15535,80 +15679,95 @@ StackInterpreter >> unaryInlinePrimitive: primIndex [ { #category : #'sista inline primitives - unary' } StackInterpreter >> unaryNewInlinePrimitive: primIndex [ + "1011 RawNew literal which is a fixed-sized behavior => instance of the receiver with fields nilled out 1012 RawNewNoInit literal which is a fixed-sized behavior => instance of the receiver (Fields of returned value contain undefined data) WARNING: In the interpreter version, fields are always initialized." + | classObj result | self assert: (primIndex between: 11 and: 12). - classObj := self internalStackTop. - self assert: ((objectMemory isNonImmediate: classObj) and: [self objCouldBeClassObj: classObj]). + classObj := self stackTop. + self assert: ((objectMemory isNonImmediate: classObj) and: [ + self objCouldBeClassObj: classObj ]). result := objectMemory instantiateClass: classObj. - self internalStackTopPut: result + self stackTopPut: result ] { #category : #'sista inline primitives - unary' } StackInterpreter >> unaryPossibleRootInlinePrimitive [ - + "1041 possibleRoot non-immediate, not a forwarder => receiver is returned (should be effect-only) (If old, becomes gray and remembered to allow many unchecked stores in a row afterwards)" + + | top | - top := self internalStackTop. + top := self stackTop. self deny: (objectMemory isImmediate: top). self deny: (objectMemory isOopForwarded: top). - (objectMemory isYoungObject: top) - ifFalse: [objectMemory possibleRootStoreInto: top] + (objectMemory isYoungObject: top) ifFalse: [ + objectMemory possibleRootStoreInto: top ] ] { #category : #'sista inline primitives - unary' } StackInterpreter >> unarySizeInlinePrimitive: primIndex [ + | result top | self assert: (primIndex between: 1 and: 6). - top := self internalStackTop. - primIndex caseOf: { - "1001 numSlots - pointer object => Smi between 0 and SmallInteger maxVal // 4 - 1 (Answers total size in pointer-sized slots)" - [1] -> [self assert: (objectMemory isPointers: top). - result := objectMemory numSlotsOfAny: top. - self assert: (result between: 0 and: objectMemory maxSmallInteger // 4 - 1)]. - "1002 numBytes + top := self stackTop. + primIndex caseOf: { + ([ 1 ] -> [ + self assert: (objectMemory isPointers: top). + result := objectMemory numSlotsOfAny: top. + self assert: + (result between: 0 and: objectMemory maxSmallInteger // 4 - 1) ]). + "1002 numBytes byte object => Smi between 0 and SmallInteger maxVal - 9 (Includes compiled code)" - [2] -> [self assert: (objectMemory isBytes: top). - result := objectMemory numBytesOf: top]. - "1003 numShorts + ([ 2 ] -> [ + self assert: (objectMemory isBytes: top). + result := objectMemory numBytesOf: top ]). + "1003 numShorts short object => Smi between 0 and SmallInteger maxVal - 9" - [3] -> [self assert: (objectMemory isShorts: top). - result := objectMemory num16BitUnitsOf: top]. - "1004 numWords + ([ 3 ] -> [ + self assert: (objectMemory isShorts: top). + result := objectMemory num16BitUnitsOf: top ]). + "1004 numWords word object => Smi between 0 and SmallInteger maxVal - 9" - [5] -> [self assert: (objectMemory isWords: top). - result := objectMemory num32BitUnitsOf: top]. - "1005 numDoubleWords + ([ 5 ] -> [ + self assert: (objectMemory isWords: top). + result := objectMemory num32BitUnitsOf: top ]). + "1005 numDoubleWords double word object => Smi between 0 and SmallInteger maxVal - 9" - [6] -> [self assert: (objectMemory isLong64s: top). - result := objectMemory num64BitUnitsOf: top]. - }. - self assert: (result between: 0 and: objectMemory maxSmallInteger - 9). - self internalStackTopPut: (objectMemory integerObjectOf: result) - + ([ 6 ] -> [ + self assert: (objectMemory isLong64s: top). + result := objectMemory num64BitUnitsOf: top ]) }. + "1001 numSlots + pointer object => Smi between 0 and SmallInteger maxVal // 4 - 1 (Answers total size in pointer-sized slots)" + self assert: + (result between: 0 and: objectMemory maxSmallInteger - 9). + self stackTopPut: (objectMemory integerObjectOf: result) ] { #category : #'sista inline primitives - unary' } StackInterpreter >> unaryUnforwardInlinePrimitive: primIndex [ - + "1039 unforwardNonImmediate non immediate => Not a forwarder 1040 unforward Anything => Not a forwarder" + "Only perf in jitted code matters, don't remove the immediate check" - | top | - top := self internalStackTop. - self assert: (primIndex = 40 or: [objectMemory isNonImmediate: top]). - (objectMemory isOopForwarded: top) ifTrue: - [self internalStackTopPut: (objectMemory followForwarded: top)] + + + | top | + top := self stackTop. + self assert: + (primIndex = 40 or: [ objectMemory isNonImmediate: top ]). + (objectMemory isOopForwarded: top) ifTrue: [ + self stackTopPut: (objectMemory followForwarded: top) ] ] { #category : #'sista bytecodes' } diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index 99a1ce85e2..3a9a9a0ed2 100644 --- a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st +++ b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st @@ -1199,16 +1199,6 @@ StackInterpreterSimulator >> loadNewPlugin: pluginString [ entry] ] -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localFP [ - ^framePointer -] - -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localSP [ - ^stackPointer -] - { #category : #'memory access' } StackInterpreterSimulator >> longAt: byteAddress [ self deprecated. diff --git a/smalltalksrc/VMMakerTests/StackBuilderTest.class.st b/smalltalksrc/VMMakerTests/StackBuilderTest.class.st index bc5b687228..659654dcee 100644 --- a/smalltalksrc/VMMakerTests/StackBuilderTest.class.st +++ b/smalltalksrc/VMMakerTests/StackBuilderTest.class.st @@ -260,27 +260,27 @@ StackBuilderTest >> testOrderArgument2InBaseFrame [ { #category : #'test-order' } StackBuilderTest >> testOrderContext [ - self assert: (interpreter internalStackValue: self offsetContext) + self assert: (interpreter stackValue: self offsetContext) equals: context ] { #category : #'test-order' } StackBuilderTest >> testOrderMethod [ - self assert: (interpreter internalStackValue: self offsetMethod) + self assert: (interpreter stackValue: self offsetMethod) equals: method ] { #category : #'test-order' } StackBuilderTest >> testOrderReceiver [ - self assert: (interpreter internalStackValue: self offsetReceiver) + self assert: (interpreter stackValue: self offsetReceiver) equals: receiver ] { #category : #'test-order' } StackBuilderTest >> testOrderStackElementIsReversed [ - self assert: (interpreter internalStackValue: self offsetStackElement1) + self assert: (interpreter stackValue: self offsetStackElement1) equals: stackElement1. - self assert: (interpreter internalStackValue: self offsetStackElement2) + self assert: (interpreter stackValue: self offsetStackElement2) equals: stackElement2. ] @@ -288,15 +288,15 @@ StackBuilderTest >> testOrderStackElementIsReversed [ StackBuilderTest >> testOrderStackTopOfSuspendedProcessIsInstructionPointer [ "When a process is suspended, the Instruction Pointer is pushed on the stack of the frame. It should be the last thing pushed, and therefore, be at the top. " - self assert: (interpreter internalStackValue: self offsetInstructionPointer) + self assert: (interpreter stackValue: self offsetInstructionPointer) equals: instructionPointer. ] { #category : #'test-order' } StackBuilderTest >> testOrderTempIsReversed [ - self assert: (interpreter internalStackValue: self offsetTemp1) + self assert: (interpreter stackValue: self offsetTemp1) equals: temp1. - self assert: (interpreter internalStackValue: self offsetTemp2) + self assert: (interpreter stackValue: self offsetTemp2) equals: temp2. ] From baa4c6e4ad16c1ff828187fe71a0197709a65d13 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 21 Dec 2021 11:24:52 +0100 Subject: [PATCH 27/75] Remove automatic localization hint --- smalltalksrc/VMMaker/StackInterpreter.class.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index b17171c58b..d5dd23e0a7 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -8228,7 +8228,7 @@ StackInterpreter >> interpret [ "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently." - + "" "If stacklimit is zero then the stack pages have not been initialized." stackLimit = 0 ifTrue: [^self initStackPagesAndInterpret]. From d4b6e376fc4fcea70edfb73932b87b0d1d39387c Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 21 Dec 2021 15:10:46 +0100 Subject: [PATCH 28/75] Replace cmacro by a normal perform --- .../VMMaker/StackInterpreter.class.st | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index d5dd23e0a7..a92226d15d 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -5099,13 +5099,17 @@ StackInterpreter >> directedSuperclassSend [ { #category : #'message sending' } StackInterpreter >> dispatchFunctionPointer: aFunctionPointer [ "In C aFunctionPointer is void (*aFunctionPointer)()" - - "In Smalltalk aFunctionPointer is a message selector symbol, except for - external primitives which are funkily encoded as integers >= 1000." - (aFunctionPointer isInteger - and: [aFunctionPointer >= 1000]) - ifTrue: [self callExternalPrimitive: aFunctionPointer] - ifFalse: [self perform: aFunctionPointer] + + self cCode: [ self perform: aFunctionPointer ] inSmalltalk: [ + "In Smalltalk aFunctionPointer is a message selector symbol, except for + external primitives which are funkily encoded as integers >= 1000." + (aFunctionPointer isInteger + and: [aFunctionPointer >= 1000]) + ifTrue: [self callExternalPrimitive: aFunctionPointer] + ifFalse: [self perform: aFunctionPointer] + ] + + ] { #category : #simulation } @@ -8228,7 +8232,7 @@ StackInterpreter >> interpret [ "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently." - "" + "If stacklimit is zero then the stack pages have not been initialized." stackLimit = 0 ifTrue: [^self initStackPagesAndInterpret]. From 96c0130d16f3ac0a71f50df15d79a46bdcc094a3 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 21 Dec 2021 17:47:33 +0100 Subject: [PATCH 29/75] Adding support for linearization of expressions --- .../MockLocalizationInterpreterMock.class.st | 70 ++- .../SlangBasicTranslationTest.class.st | 322 ++++++------- .../SlangLocalizationTestCase.class.st | 437 +++++++++++------- smalltalksrc/Slang/CCodeGenerator.class.st | 188 ++++---- smalltalksrc/Slang/SlangTyper.class.st | 4 +- smalltalksrc/Slang/TAssignmentNode.class.st | 4 +- smalltalksrc/Slang/TCaseStmtNode.class.st | 4 +- smalltalksrc/Slang/TExternalSendNode.class.st | 6 + smalltalksrc/Slang/TMethod.class.st | 57 ++- smalltalksrc/Slang/TParseNode.class.st | 39 +- smalltalksrc/Slang/TReturnNode.class.st | 7 + smalltalksrc/Slang/TSendNode.class.st | 8 +- ...e.class.st => TStatementListNode.class.st} | 99 ++-- smalltalksrc/Slang/TSwitchStmtNode.class.st | 4 +- smalltalksrc/Slang/TVariableNode.class.st | 6 + .../VMMaker/SmartSyntaxPluginTMethod.class.st | 6 +- .../VMMaker/StackInterpreter.class.st | 3 +- 17 files changed, 726 insertions(+), 538 deletions(-) rename smalltalksrc/Slang/{TStmtListNode.class.st => TStatementListNode.class.st} (81%) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index f2829fa670..81c16d21ae 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -102,23 +102,27 @@ MockLocalizationInterpreterMock class >> initializeWithInlinedMethodCall [ ] { #category : #initialization } -MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ +MockLocalizationInterpreterMock class >> initializeWithMacroCall [ BytecodeTable := Array new: 1. self table: BytecodeTable from: #( - ( 0 bytecodeUsingSafeExternalCall) + ( 0 bytecodeUsingMacro) ) ] -{ #category : #'interpreter shell' } -MockLocalizationInterpreterMock >> bytecodeInliningSharedMethod [ +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ - self sharedMethod + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingSafeExternalCall) + ) ] { #category : #'interpreter shell' } -MockLocalizationInterpreterMock >> bytecodeNotInliningSharedMethod [ +MockLocalizationInterpreterMock >> bytecodeInliningSharedMethod [ self sharedMethod ] @@ -148,6 +152,28 @@ MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariabl self foo: self nonInlinedMethodUsingAutolocalizedVariable ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment [ + + | foo | + foo := self foo: self nonInlinedMethodUsingAutolocalizedVariable. + ^ foo +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInReturn [ + + ^ self foo: self nonInlinedMethodUsingAutolocalizedVariable +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariableInNestedLexicalScope [ + + true ifTrue: [ + self foo: self nonInlinedMethodUsingAutolocalizedVariable + ] +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingInlinedCall [ @@ -160,7 +186,13 @@ MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ variableToLocalize := 42 ] -{ #category : #'as yet unclassified' } +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingMacro [ + + self macroMethod +] + +{ #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeUsingSafeExternalCall [ self nonInlinedMethodNotUsingAutolocalizedVariables: (autoLocalizedVariable := autoLocalizedVariable +1) @@ -197,7 +229,7 @@ MockLocalizationInterpreterMock >> bytecodeWithEscapingCallAsArgumentOfExternalC self foo: self nonInlinedMethodUsingAutolocalizedVariable1 ] -{ #category : #'as yet unclassified' } +{ #category : #'interpreter shell' } MockLocalizationInterpreterMock >> foo2 [ @@ -229,16 +261,6 @@ MockLocalizationInterpreterMock >> interpret [ self dispatchOn: 1 in: BytecodeTable ] -{ #category : #'interpreter shell' } -MockLocalizationInterpreterMock >> interpretWithConflict [ - - "This method should create a conflict with automatically inlined arguments" - | arg1 | - - - self dispatchOn: 1 in: BytecodeTable -] - { #category : #inline } MockLocalizationInterpreterMock >> interpretWithExternalCallBeforeDispatch [ @@ -289,6 +311,11 @@ MockLocalizationInterpreterMock >> interpretWithSeveralVariablesToLocalize [ self dispatchOn: 1 in: BytecodeTable ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> macroMethod [ + +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> methodAlsoSharedLocalizedVariableBeforeInlining [ @@ -301,13 +328,6 @@ MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ sharedVariableToLocalize := 17 ] -{ #category : #inline } -MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables [ - - - ^ 10 -] - { #category : #inline } MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables: anObject [ diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 27531bb622..357f7f2c05 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -142,7 +142,7 @@ SlangBasicTranslationTest >> testAssignementAsExpressionWithExpressionBlock [ expression: (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: - (TStmtListNode new setArguments: #( ) statements: { + (TStatementListNode new setArguments: #( ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) @@ -173,7 +173,7 @@ SlangBasicTranslationTest >> testAssignementAsExpressionWithExpressionBlockWithL expression: (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: - (TStmtListNode new setArguments: #( ) statements: { + (TStatementListNode new setArguments: #( ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) @@ -203,8 +203,8 @@ SlangBasicTranslationTest >> testBitShiftIfTrue [ receiver: (TVariableNode named: 'aBoolean') selector: #ifTrue:ifFalse: arguments: { - TStmtListNode statements: { TConstantNode value: 1 }. - TStmtListNode statements: { TConstantNode value: 2 }. + TStatementListNode statements: { TConstantNode value: 1 }. + TStatementListNode statements: { TConstantNode value: 2 }. } ) selector: #<< arguments: {TConstantNode value: 31}. @@ -227,7 +227,7 @@ SlangBasicTranslationTest >> testBlockValue [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -256,7 +256,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgument [ "In order to test the translation of a block as an argument, the block is given as condition of an if." | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new setArguments: #( ) statements: { + expression := TStatementListNode new setArguments: #( ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) @@ -272,7 +272,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgument [ translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSendNode new setSelector: #value receiver: expression arguments: {}) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -288,7 +288,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgument [ SlangBasicTranslationTest >> testBlockValueAsArgumentWithComment [ | translation expression | - expression := TStmtListNode new setArguments: #( ) statements: { + expression := TStatementListNode new setArguments: #( ) statements: { TLabeledCommentNode withComment: 'yes!'. TConstantNode value: 17. }. translation := self translate: (TAssignmentNode @@ -316,7 +316,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithConstantArgument [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new setArguments: #( i ) statements: { + expression := TStatementListNode new setArguments: #( i ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) @@ -332,7 +332,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithConstantArgument [ receiver: expression arguments: { (TConstantNode value: 4) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -355,7 +355,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithMultipleArguments [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new + expression := TStatementListNode new setArguments: #( i j ) statements: { (TSendNode new @@ -378,7 +378,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithMultipleArguments [ (TConstantNode value: 4). (TConstantNode value: 5) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -401,7 +401,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgument [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new setArguments: #( i ) statements: { + expression := TStatementListNode new setArguments: #( i ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) @@ -420,7 +420,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgument [ receiver: (TConstantNode value: 3) arguments: { (TConstantNode value: 4) }) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -443,7 +443,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgumentAndMulti | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new setArguments: #( i ) statements: { + expression := TStatementListNode new setArguments: #( i ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) @@ -462,7 +462,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgumentAndMulti receiver: (TConstantNode value: 3) arguments: { (TConstantNode value: 4) }) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -486,7 +486,7 @@ SlangBasicTranslationTest >> testBlockValueAssignment [ variable := TVariableNode new setName: 'var'. expression := TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -521,7 +521,7 @@ SlangBasicTranslationTest >> testBlockValueAssignmentIntoSameVariable [ variable := (TVariableNode new setName: 'var'). expression := TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -556,7 +556,7 @@ SlangBasicTranslationTest >> testBlockValueWithConstantArgument [ translation := self translate: (TSendNode new setSelector: #value: - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #(i) statements: { TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'i') @@ -578,7 +578,7 @@ SlangBasicTranslationTest >> testBlockValueWithNonLeafArgument [ | translation | translation := self translate: (TSendNode new setSelector: #value: - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') @@ -605,7 +605,7 @@ SlangBasicTranslationTest >> testBlockValueWithNonLeafArgumentAndMultipleUse [ translation := self translate: (TSendNode new setSelector: #value: receiver: - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -643,7 +643,7 @@ SlangBasicTranslationTest >> testBlockValueWithVariableAsLastExpression [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -898,7 +898,7 @@ SlangBasicTranslationTest >> testConstantsStatementsInBlockValueAreIgnored [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -1478,7 +1478,7 @@ SlangBasicTranslationTest >> testReturnBlockValueValueValue [ translation := self translate: (TReturnNode expression: (TSendNode new setSelector: #value:value:value: - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: { TVariableNode named: 'a'. TVariableNode named: 'b'. @@ -1550,8 +1550,8 @@ SlangBasicTranslationTest >> testReturnIfTrue [ receiver: (TVariableNode named: 'aBoolean') selector: #ifTrue:ifFalse: arguments: { - TStmtListNode statements: { TConstantNode value: 1 }. - TStmtListNode statements: { TConstantNode value: 2 }. + TStatementListNode statements: { TConstantNode value: 1 }. + TStatementListNode statements: { TConstantNode value: 2 }. } ). translation := self translate: ast. @@ -1600,16 +1600,16 @@ SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitch [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) }))). @@ -1634,10 +1634,10 @@ SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitchWithN expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; @@ -2142,7 +2142,7 @@ SlangBasicTranslationTest >> testSendCCodeAsArgumentWithBlock [ expression: (TSendNode new setSelector: #cCode: receiver: (TVariableNode new setName: 'self') - arguments: { TStmtListNode new setStatements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) arguments: { TConstantNode value: 2 }). (TVariableNode named: 'x') } }). + arguments: { TStatementListNode new setStatements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) arguments: { TConstantNode value: 2 }). (TVariableNode named: 'x') } }). translation := self translate: send. self assert: translation equals: 'y = (foo(1, 2), x)' @@ -2295,7 +2295,7 @@ SlangBasicTranslationTest >> testSendCppIfIfTrue [ receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2322,14 +2322,14 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIfFalse [ receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2391,7 +2391,7 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIfFalseAsArgumentIndentationInBl "A C preprocessor condition can be anywhere in code, even in an expression statement." | translation send | - send := TStmtListNode new setStatements: { (TAssignmentNode new + send := TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'y') expression: (TSendNode new setSelector: #ifTrue: @@ -2427,19 +2427,19 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIfFalseIndentationInBlock [ "[self cppIf: #FEATURE ifTrue: [ a := false. c := 1 ] ifFalse: [ a := true. c := 0 ]]" | translation send | - send := TStmtListNode new setStatements: { (TSendNode new + send := TStatementListNode new setStatements: { (TSendNode new setSelector: #cppIf:ifTrue:ifFalse: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2470,13 +2470,13 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIndentationInNestedBlocks [ "self cppIf: #FEATURE ifTrue: [ a := false. c := 1 ]" | translation send | - send := TStmtListNode new setStatements: - { (TStmtListNode new setStatements: { (TSendNode new + send := TStatementListNode new setStatements: + { (TStatementListNode new setStatements: { (TSendNode new setSelector: #cppIf:ifTrue: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2513,11 +2513,11 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSendIfTrueAsCondition [ setSelector: #ifTrue:ifFalse: receiver: (TConstantNode value: true) arguments: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: false) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: true) }) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2541,7 +2541,7 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSingleExpressionDoesNotAddsS receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)) }) }). @@ -2562,7 +2562,7 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSingleStatementAddsSeparator receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)) }) }. @@ -2696,7 +2696,7 @@ SlangBasicTranslationTest >> testSendIfFalse [ send := TSendNode new setSelector: #ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2720,7 +2720,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgument [ expression: (TSendNode new setSelector: #ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2746,7 +2746,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgumentWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2775,7 +2775,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgumentWithReceiverSendNot [ receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) arguments: { }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2797,14 +2797,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrue [ setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { (TAssignmentNode new + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: 1)) }) }. translation := self translate: send. @@ -2826,14 +2826,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgument [ expression: (TSendNode new setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2860,14 +2860,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgumentCollapseBothArmsOfCo receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2890,14 +2890,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgumentCollapseBothArmsOfCo setSelector: #ifFalse:ifTrue: receiver: (TVariableNode named: 'x') arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2920,7 +2920,7 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditional receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2928,7 +2928,7 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditional (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2953,7 +2953,7 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditionalW setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2961,7 +2961,7 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditionalW (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3005,7 +3005,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3028,7 +3028,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverFalseConstant [ send := TSendNode new setSelector: #ifFalse: receiver: (TConstantNode value: false) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3053,7 +3053,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverSendNot [ setSelector: #not receiver: (TVariableNode new setName: 'x') arguments: { }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3076,7 +3076,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverTrueConstant [ send := TSendNode new setSelector: #ifFalse: receiver: (TConstantNode value: true) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3099,7 +3099,7 @@ SlangBasicTranslationTest >> testSendIfNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3194,7 +3194,7 @@ SlangBasicTranslationTest >> testSendIfNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNil: receiver: (TConstantNode value: nil) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3220,14 +3220,14 @@ SlangBasicTranslationTest >> testSendIfNilifNotNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TConstantNode value: true)). @@ -3254,14 +3254,14 @@ SlangBasicTranslationTest >> testSendIfNilifNotNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNil:ifNotNil: receiver: (TConstantNode value: nil) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TConstantNode value: true)). @@ -3287,7 +3287,7 @@ SlangBasicTranslationTest >> testSendIfNotNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3347,14 +3347,14 @@ SlangBasicTranslationTest >> testSendIfNotNilIfNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TConstantNode value: true)). @@ -3442,14 +3442,14 @@ SlangBasicTranslationTest >> testSendIfNotNilIfNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNotNil:ifNil: receiver: (TConstantNode value: nil) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TConstantNode value: true)). @@ -3472,7 +3472,7 @@ SlangBasicTranslationTest >> testSendIfNotNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNotNil: receiver: (TConstantNode value: nil) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3491,7 +3491,7 @@ SlangBasicTranslationTest >> testSendIfTrue [ send := TSendNode new setSelector: #ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3515,7 +3515,7 @@ SlangBasicTranslationTest >> testSendIfTrueAsArgument [ expression: (TSendNode new setSelector: #ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3541,7 +3541,7 @@ SlangBasicTranslationTest >> testSendIfTrueAsArgumentWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3579,14 +3579,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalse [ setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { (TAssignmentNode new + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: 1)) }) }. translation := self translate: send. @@ -3608,14 +3608,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgument [ expression: (TSendNode new setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -3642,14 +3642,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgumentCollapseBothArmsOfCo receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3672,14 +3672,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgumentCollapseBothArmsOfCo setSelector: #ifTrue:ifFalse: receiver: (TVariableNode named: 'x') arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3702,7 +3702,7 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditional receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3710,7 +3710,7 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditional (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3735,7 +3735,7 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditionalW setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3743,7 +3743,7 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditionalW (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3783,11 +3783,11 @@ SlangBasicTranslationTest >> testSendIfTrueWithBlockReceiver [ | translation send | send := TSendNode new setSelector: #ifTrue: - receiver: (TStmtListNode new setStatements: { (TAssignmentNode new + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'y') expression: (TConstantNode value: false)). TVariableNode new setName: 'x' }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3812,7 +3812,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverBinaryOperation [ setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: { (TVariableNode new setName: 'b') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3835,7 +3835,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverFalseConstant [ send := TSendNode new setSelector: #ifTrue: receiver: (TConstantNode value: false) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3855,7 +3855,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverTrueConstant [ send := TSendNode new setSelector: #ifTrue: receiver: (TConstantNode value: true) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -4706,7 +4706,7 @@ SlangBasicTranslationTest >> testSendRepeat [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #repeat - receiver: (TStmtListNode new setStatements: + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression) }) @@ -4782,7 +4782,7 @@ SlangBasicTranslationTest >> testSendSequentialAndWithConstantReceiverTrue [ send := TSendNode new setSelector: #and: receiver: (TConstantNode value: true) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new setStatements: { (TSendNode new setSelector: #+ receiver: (TConstantNode value: 1) @@ -5165,7 +5165,7 @@ SlangBasicTranslationTest >> testSendTimesRepeat [ send := TSendNode new setSelector: #timesRepeat: receiver: (TConstantNode value: 5) - arguments: { (TStmtListNode new setStatements: + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5205,7 +5205,7 @@ SlangBasicTranslationTest >> testSendToByDo [ arguments: { (TConstantNode value: 10). (TConstantNode value: 2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5241,7 +5241,7 @@ SlangBasicTranslationTest >> testSendToByDoLimitExpressionHasSideEffect [ receiver: (TVariableNode new setName: 'var') arguments: { }). (TConstantNode value: 2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5274,7 +5274,7 @@ SlangBasicTranslationTest >> testSendToByDoWithNegativeStep [ arguments: { (TConstantNode value: 0). (TConstantNode value: -2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5311,7 +5311,7 @@ SlangBasicTranslationTest >> testSendToByDoWithOperationReceiver [ arguments: { (TConstantNode value: 10). (TConstantNode value: 2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5350,7 +5350,7 @@ SlangBasicTranslationTest >> testSendToByDoWithOperationUpdate [ setSelector: #foo receiver: (TConstantNode value: 1) arguments: { (TConstantNode value: 2) }) }). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5381,7 +5381,7 @@ SlangBasicTranslationTest >> testSendToDo [ receiver: (TConstantNode value: 1) arguments: { (TConstantNode value: 10). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5416,7 +5416,7 @@ SlangBasicTranslationTest >> testSendToDoAvoidUnderflowingOfLimitExpression [ receiver: (TVariableNode new setName: 'foo') arguments: { (TConstantNode value: 1) }). (TConstantNode value: 10). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5451,7 +5451,7 @@ SlangBasicTranslationTest >> testSendToDoLimitExpressionHasSideEffect [ setSelector: #foo receiver: (TVariableNode new setName: 'var') arguments: { }). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5488,7 +5488,7 @@ SlangBasicTranslationTest >> testSendToDoWithOperationReceiver [ arguments: { (TConstantNode value: 2) }) }) arguments: { (TConstantNode value: 10). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5527,7 +5527,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndAr arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileFalse: - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5536,7 +5536,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndAr receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) arguments: - { (TStmtListNode new setStatements: { (TAssignmentNode new + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TSendNode new setSelector: #\\ @@ -5565,11 +5565,11 @@ SlangBasicTranslationTest >> testSendWhileFalseWithOneStatementInReceiverBlock [ send := TSendNode new setSelector: #whileFalse: receiver: - (TStmtListNode new setStatements: { (TSendNode new + (TStatementListNode new setStatements: { (TSendNode new setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: {(TVariableNode new setName: 'b')}) }) - arguments: { (TStmtListNode new setStatements: + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5593,7 +5593,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileFalse - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5621,7 +5621,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithManyStatementsInReceiverAndArg arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue: - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5630,7 +5630,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithManyStatementsInReceiverAndArg receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) arguments: - { (TStmtListNode new setStatements: { (TAssignmentNode new + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TSendNode new setSelector: #\\ @@ -5658,7 +5658,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue: - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5667,7 +5667,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ receiver: (TVariableNode new setName: 'a') arguments: { (TVariableNode new setName: 'b') }) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TVariableNode new setName: 'nil') }) }. translation := self translate: send. @@ -5689,11 +5689,11 @@ SlangBasicTranslationTest >> testSendWhileTrueWithOneStatementInReceiverBlock [ send := TSendNode new setSelector: #whileTrue: receiver: - (TStmtListNode new setStatements: { (TSendNode new + (TStatementListNode new setStatements: { (TSendNode new setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: {(TVariableNode new setName: 'b')}) }) - arguments: { (TStmtListNode new setStatements: + arguments: { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5717,7 +5717,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5774,16 +5774,16 @@ SlangBasicTranslationTest >> testSwitchStatement [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) })). @@ -5811,22 +5811,22 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgument [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 1) }) }; cases: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 11)) }) }; yourself) otherwiseOrNil: nil) - arguments: { TStmtListNode new setStatements: { } }). + arguments: { TStatementListNode new setStatements: { } }). self assert: translation trimBoth equals: 'if (((x == 0) ? (foo = 10) @@ -5846,35 +5846,35 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgumentWithNastedCases [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 1) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 2) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 3) }) }; cases: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 1)) }) }; yourself) otherwiseOrNil: nil) - arguments: { TStmtListNode new setStatements: { } }). + arguments: { TStatementListNode new setStatements: { } }). self assert: translation trimBoth equals: 'if (((x == 0) ? (foo = 10) @@ -5899,22 +5899,22 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgumentWithSwitchVariable [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 1) }) }; cases: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 11)) }) }; yourself) otherwiseOrNil: nil) switchVariable: 'jinx') - arguments: { TStmtListNode new setStatements: { } }). + arguments: { TStatementListNode new setStatements: { } }). self assert: translation trimBoth equals: 'if ((((jinx = x) == 0) ? (foo = 10) @@ -5934,17 +5934,17 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) }))). @@ -5973,10 +5973,10 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') @@ -6007,10 +6007,10 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') @@ -6038,22 +6038,22 @@ SlangBasicTranslationTest >> testSwitchStatementWithNestedCase [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TConstantNode value: 1) }) }; cases: { - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: { })). + (TStatementListNode new setStatements: { })). self assert: translation trimBoth equals: 'switch (x) { case 0: @@ -6076,10 +6076,10 @@ SlangBasicTranslationTest >> testSwitchStatementWithNoDefaultStatement [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new setStatements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; @@ -6106,7 +6106,7 @@ SlangBasicTranslationTest >> testTranslateBlockAssignmentWithManyStatement [ variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new setStatements: { + expression := TStatementListNode new setStatements: { TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b'). @@ -6206,7 +6206,7 @@ SlangBasicTranslationTest >> testVariableStatementsInBlockValueAreIgnored [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index bde21f9876..919da49530 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -4,7 +4,41 @@ Class { #category : #'Slang-Tests' } -{ #category : #tests } +{ #category : #running } +SlangLocalizationTestCase >> applyLocalizationTo: interpreterSelector [ + + | interpretMethod autolocalizedVariables | + ccg addClass: MockLocalizationInterpreterMock. + ccg prepareMethods. + autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: + interpreterSelector. + ccg inlineDispatchesInMethodNamed: interpreterSelector. + ccg doBasicInlining: true. + ccg + autoLocalizationOfVariablesIn: interpreterSelector + withVariableBindings: autolocalizedVariables. + interpretMethod := ccg methodNamed: interpreterSelector. + ccg currentMethod: interpretMethod. + ^ interpretMethod +] + +{ #category : #running } +SlangLocalizationTestCase >> applyLocalizationToInterpretWith: initializationSelector [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + MockLocalizationInterpreterMock perform: initializationSelector. + ^ self applyLocalizationTo: #interpret +] + +{ #category : #running } +SlangLocalizationTestCase >> applyManyLocalizationsToInterpretWith: initializationSelector [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + MockLocalizationInterpreterMock perform: initializationSelector. + ^ self applyLocalizationTo: #interpretWithSeveralVariablesToLocalize +] + +{ #category : #running } SlangLocalizationTestCase >> externalizationOf: aVariableName [ ^ (TAssignmentNode @@ -12,7 +46,7 @@ SlangLocalizationTestCase >> externalizationOf: aVariableName [ expression: (TVariableNode named: #local_, aVariableName)) ] -{ #category : #tests } +{ #category : #running } SlangLocalizationTestCase >> internalizationOf: aVariableName [ ^ (TAssignmentNode @@ -20,14 +54,14 @@ SlangLocalizationTestCase >> internalizationOf: aVariableName [ expression: (TVariableNode named: aVariableName)) ] -{ #category : #tests } +{ #category : #running } SlangLocalizationTestCase >> setUp [ super setUp. MockLocalizationInterpreterMock initialize. ] -{ #category : #tests } +{ #category : #'tests - initialization' } SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -37,7 +71,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ self assert: ((ccg methodNamed: #interpret) locals includes: #local_autoLocalizedVariable) ] -{ #category : #tests } +{ #category : #'tests - initialization' } SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariableWhenNameConflict [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -46,7 +80,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariableWhen self assert: ((ccg methodNamed: #interpretWithLocalizedVariableConflict) locals includes: #local_autoLocalizedVariable1) ] -{ #category : #tests } +{ #category : #'tests - initialization' } SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -61,20 +95,13 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ - | externalizationStatement autolocalizedVariables | - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - - externalizationStatement := (ccg methodNamed: #interpret) statements last statements first. + | externalizationStatement interpretMethod | + interpretMethod := self applyLocalizationTo: #interpret. + externalizationStatement := interpretMethod statements last + statements first. - self - assert: (externalizationStatement - isSameAs: (self externalizationOf: #autoLocalizedVariable)) + self assert: (externalizationStatement isSameAs: + (self externalizationOf: #autoLocalizedVariable)) ] { #category : #tests } @@ -82,20 +109,11 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnRef "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod printedString autolocalizedVariables | - ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. - ccg inlineDispatchesInMethodNamed: - #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. - ccg autoLocalizationOfVariablesIn: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable withVariableBindings: autolocalizedVariables. - interpretMethod := ccg methodNamed: - #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. - ccg currentMethod: interpretMethod. + | interpretMethod printedString | + interpretMethod := self applyLocalizationTo: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. printedString := String streamContents: [ :str | (interpretMethod statements last asCASTIn: ccg) prettyPrintOn: str ]. - self assert: printedString equals: '{ autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable = local_autoLocalizedVariable; @@ -108,13 +126,9 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod autolocalizedVariables | - ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithReturnExpression. - ccg inlineDispatchesInMethodNamed: #interpretWithReturnExpression. - ccg autoLocalizationOfVariablesIn: #interpretWithReturnExpression withVariableBindings: autolocalizedVariables. - interpretMethod := ccg methodNamed: #interpretWithReturnExpression. + | interpretMethod | + interpretMethod := self applyLocalizationTo: #interpretWithReturnExpression. + self assert: interpretMethod statements last arguments first statements last statements last isReturn. @@ -132,14 +146,10 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning [ - | internalizationStatement autolocalizedVariables | - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - internalizationStatement := (ccg methodNamed: #interpret) statements first. + | internalizationStatement interpretMethod | + interpretMethod := self applyLocalizationTo: #interpret. + + internalizationStatement := interpretMethod statements first. self assert: (internalizationStatement isSameAs: (self internalizationOf: #autoLocalizedVariable)) @@ -149,16 +159,10 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod variableNode case autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithAutoLocalizedVariableOnly. - ccg addClass: MockLocalizationInterpreterMock. - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - + | interpretMethod variableNode case | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithAutoLocalizedVariableOnly. + "Fail if we find some node inside the case that uses the localized variable" - interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. variableNode := case statements second method statements first variable. @@ -166,21 +170,25 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ ] { #category : #tests } -SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendNodes [ +SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsMacros [ - | interpretMethod case inlinedMethod autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. + | interpretMethod case inlinedMethod | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithMacroCall. + + "Assert that the send node is preceded by variable externalization" + case := interpretMethod statements second cases first. + inlinedMethod := case statements second method. + self assert: inlinedMethod statements first isExternalSend +] +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendNodes [ + + | interpretMethod case inlinedMethod | + interpretMethod := self + applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. inlinedMethod := case statements second method. @@ -190,20 +198,10 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendN { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgument [ - | interpretMethod case externalCall cast printedString autolocalizedVariables inlinedMethod | - MockLocalizationInterpreterMock initializeWithEscapingCallAsArgument. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg doBasicInlining: true. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - + | interpretMethod case externalCall cast printedString inlinedMethod | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCallAsArgument. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. inlinedMethod := case statements second method. @@ -213,7 +211,7 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgument [ printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: 'autoLocalizedVariable = local_autoLocalizedVariable; -arg = foo2(); +r = foo2(); local_autoLocalizedVariable = autoLocalizedVariable; if (1 == r) { }' @@ -222,20 +220,10 @@ if (1 == r) { { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ - | interpretMethod case externalCall cast printedString autolocalizedVariables inlinedMethod | - MockLocalizationInterpreterMock initializeWithEscapingCallAsArgumentOfExternalCall. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. - ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. - ccg doBasicInlining: true. - ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. - + | interpretMethod case externalCall cast printedString inlinedMethod | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCallAsArgumentOfExternalCall. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. @@ -258,20 +246,10 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ - | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithInlinedMethodCall. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. - ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. - ccg doBasicInlining: true. - ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. - + | interpretMethod case inlinedMethod externalCall cast printedString | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithInlinedMethodCall. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. @@ -292,19 +270,10 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithEscapingCall. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - + | interpretMethod case inlinedMethod externalCall cast printedString | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. inlinedMethod := case statements second method. @@ -323,42 +292,18 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ - | interpretMethod autolocalizedVariables | - MockLocalizationInterpreterMock. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: - #interpretWithExternalCallBeforeDispatch. - ccg inlineDispatchesInMethodNamed: - #interpretWithExternalCallBeforeDispatch. - ccg - autoLocalizationOfVariablesIn: - #interpretWithExternalCallBeforeDispatch - withVariableBindings: autolocalizedVariables. - - interpretMethod := ccg methodNamed: - #interpretWithExternalCallBeforeDispatch. + | interpretMethod | + interpretMethod := self applyLocalizationTo: #interpretWithExternalCallBeforeDispatch. self assert: interpretMethod statements second isExternalSend ] { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ - | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithEscapingCall. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. - ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. - ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. - + | interpretMethod case inlinedMethod externalCall cast printedString | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. @@ -381,19 +326,10 @@ SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNe { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndInternalize [ - | interpretMethod case inlinedMethod autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - + | interpretMethod case inlinedMethod | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. inlinedMethod := case statements second method. @@ -403,21 +339,11 @@ SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndI { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpret. - ccg inlineDispatchesInMethodNamed: #interpret. - ccg doBasicInlining: true. - ccg autoLocalizationOfVariablesIn: #interpret withVariableBindings: autolocalizedVariables. - - + | interpretMethod case inlinedMethod externalCall cast printedString | + interpretMethod := self + applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpret. case := interpretMethod statements second cases first. inlinedMethod := case statements second method. @@ -433,7 +359,169 @@ SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternali }' ] -{ #category : #tests } +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ + + | methodToLinearize ifBlock | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableInNestedLexicalScope. + + ccg prepareMethods. + ccg linearizeExternalCallsIn: methodToLinearize. + + "Before it was + true ifTrue: [ + self foo: self nonInlinedMethodUsingAutolocalizedVariable + ] + After + true ifTrue: [ + | t0 t1 | + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0 + ] " + + ifBlock := methodToLinearize statements first arguments first. + + self assert: (ifBlock statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (ifBlock statements second + isSameAs: (TAssignmentNode + variableNamed: 't1' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' }))) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeNestedCalls [ + + | methodToLinearize | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpression. + + ccg prepareMethods. + ccg linearizeExternalCallsIn: methodToLinearize. + + "Before it was + self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0" + + self assert: (methodToLinearize statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (methodToLinearize statements second + isSameAs: (TAssignmentNode + variableNamed: 't1' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' }))) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ + + | methodToLinearize | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment. + + ccg prepareMethods. + ccg linearizeExternalCallsIn: methodToLinearize. + + "Before it was + foo := self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0. + foo := t1" + + self assert: (methodToLinearize statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (methodToLinearize statements second + isSameAs: (TAssignmentNode + variableNamed: 't1' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' }))). + self assert: (methodToLinearize statements third + isSameAs: (TAssignmentNode + variableNamed: 'foo' + expression: (TVariableNode named: 't1'))) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeNestedCallsWithReturn [ + + | methodToLinearize | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInReturn. + + ccg prepareMethods. + ccg linearizeExternalCallsIn: methodToLinearize. + + "Before it was + ^ self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0. + ^ t1" + + self assert: (methodToLinearize statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (methodToLinearize statements second + isSameAs: (TAssignmentNode + variableNamed: 't1' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' }))). + self assert: (methodToLinearize statements third + isSameAs: (TReturnNode expression: (TVariableNode named: 't1'))) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeSingleCalls [ + + | methodToLinearize | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingInlinedCall. + + ccg prepareMethods. + ccg linearizeExternalCallsIn: methodToLinearize. + + "Before it was + self inlinedMethodUsingExternalCall. + After + t0 := self inlinedMethodUsingExternalCall" + + self assert: (methodToLinearize statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #inlinedMethodUsingExternalCall))) +] + +{ #category : #'tests - old localization' } SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -448,7 +536,7 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFail [ self assert: error messageText equals: 'Cannot localize Shared Variables in the interpreter loop: sharedVariableToLocalize' ]. ] -{ #category : #tests } +{ #category : #'tests - old localization' } SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUsesAreNotInlined [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -470,7 +558,7 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUse self assert: error messageText equals: 'Cannot localize Shared Variables in the interpreter loop: sharedVariableToLocalizeBeforeInlining' ] ] -{ #category : #tests } +{ #category : #'tests - old localization' } SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAreInlined [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" @@ -488,19 +576,10 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAre { #category : #tests } SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ - | interpretMethod case inlinedMethod externalCall cast printedString autolocalizedVariables | - MockLocalizationInterpreterMock initializeWithSafeEscapingCall. - ccg addClass: MockLocalizationInterpreterMock. - - "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - ccg prepareMethods. - autolocalizedVariables := ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. - ccg inlineDispatchesInMethodNamed: #interpretWithSeveralVariablesToLocalize. - ccg autoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize withVariableBindings: autolocalizedVariables. - + | interpretMethod case inlinedMethod externalCall cast printedString | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithSafeEscapingCall. "Assert that the send node is preceded by variable externalization" - interpretMethod := ccg methodNamed: #interpretWithSeveralVariablesToLocalize. case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index cfd31588dc..7d98526f89 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -479,8 +479,11 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: | m | (m := self methodNamed: selector) ifNil: [ ^ self ]. (replacementDict isNil or: [ replacementDict isEmpty ]) ifTrue: [ ^ self ]. + + "self linearizeExternalCallsIn: m." "Wrap sends with externalization/internalization statements" self wrapExternalCallsIn: m withVariableBindings: replacementDict. + "Replace all localized variables by their localized versions" m parseTree bindVariablesIn: (replacementDict collect: [ :asso | @@ -488,15 +491,17 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: unless: [ :node | node isTMethod not and: [ node isReturn or: [ node isExternalSend ] ] ]. - "self lineariseExternalCallsIn: m." - self - externalizeAtReturnsIn: m - withVariablesToLocalize: replacementDict. - "Intitilize local versions with globals values at the beginning of the function." + + "Localize global values at the beginning of the function + AND externalize local values on each return" replacementDict do: [ :asso | m statements addFirst: (TAssignmentNode variable: (TVariableNode named: asso value) - expression: (TVariableNode named: asso key)) ] + expression: (TVariableNode named: asso key)) ]. + self + externalizeAtReturnsIn: m + withVariablesToLocalize: replacementDict. + ] { #category : #utilities } @@ -1308,7 +1313,7 @@ CCodeGenerator >> externalizeAtReturnsIn: aTMethod withVariablesToLocalize: vari replacementDictionary at: e put: - (TStmtListNode statements: + (TStatementListNode statements: (variablesReplacement collect: [ :each | TAssignmentNode variableNamed: each key @@ -1778,7 +1783,7 @@ CCodeGenerator >> generateCASTDivide: tast [ CCodeGenerator >> generateCASTDoWhile: boolean loop: tast [ | block cond| - block := (TStmtListNode new setStatements: + block := (TStatementListNode new setStatements: tast receiver statements allButLast) asCASTIn: self. cond := (tast receiver statements last asCASTExpressionIn: self). ^ CDoStatementNode @@ -2889,7 +2894,7 @@ CCodeGenerator >> generateCASTValue: tast [ to body with formals substituted for by actuals." | substitution substitutionDict newLabels castStatements | - self assert: tast receiver isStmtList. + self assert: tast receiver isStatementList. self assert: tast receiver args size = tast arguments size. castStatements := CCompoundStatementNode statements: OrderedCollection new. @@ -2924,7 +2929,7 @@ CCodeGenerator >> generateCASTValueAsArgument: tast [ to body with formals substituted for by actuals." | substitution substitutionDict newLabels | - self assert: tast receiver isStmtList. + self assert: tast receiver isStatementList. self assert: tast receiver args size = tast arguments size. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. @@ -2974,7 +2979,7 @@ CCodeGenerator >> generateCASTWhileForeverBreakIf: boolean loop: tast [ | block if cond | cond := (tast receiver statements last asCASTExpressionIn: self). if := CIfStatementNode if: (boolean ifTrue: [ cond ] ifFalse: [ CUnaryOperatorNode operator: #! expression: cond ]) then: (CBreakStatementNode new). - block := (TStmtListNode new setStatements: tast receiver statements allButLast) asCASTIn: self. + block := (TStatementListNode new setStatements: tast receiver statements allButLast) asCASTIn: self. block add: if. block addAll: (tast arguments first asCASTIn: self). @@ -3553,6 +3558,13 @@ CCodeGenerator >> isConstantNode: aNode valueInto: aBlock [ ^ false ] +{ #category : #utilities } +CCodeGenerator >> isDynamicCall: aNode [ + "Dynamic calls are calls to functions/methods determined at runtime. + It's important to know when we are doing a dynamic call because many optimizations do not apply in such cases" + ^ aNode isSend and: [ aNode selector beginsWith: 'perform:' ] +] + { #category : #inlining } CCodeGenerator >> isFloatingPointCType: aCType [ "" ^#('float' 'double' 'long double') includes: aCType asString @@ -3697,31 +3709,23 @@ CCodeGenerator >> isVoidPointer: aCType [ "" ] { #category : #'automatic-localization' } -CCodeGenerator >> lineariseExternalCallsIn: aTMethod [ +CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ - | replacementDictionary argumentAssignments newExternalSend | + "Should be applied after inlining. + Linearize all calls inside this method" + | replacementDictionary statementListsToLinearize | replacementDictionary := Dictionary new. - aTMethod nodesDo: [ :e | - e isExternalSend ifTrue: [ - argumentAssignments := e wrappedSendNode arguments collectWithIndex: [ :arg :index | | variableName | - variableName := aTMethod declareNonConflictingLocalNamedLike: 'arg', index asString. - TAssignmentNode - variable: (TVariableNode named: variableName) - expression: arg. - ]. - newExternalSend := TExternalSendNode - send: (TSendNode - receiver: e wrappedSendNode receiver - selector: e wrappedSendNode selector - arguments: (argumentAssignments collect: [ :ass | ass variable ])) - variableBindings: e variableBindings. - replacementDictionary - at: e - put: (TStmtListNode statements: argumentAssignments , { newExternalSend } ). - ]. - ]. - aTMethod replaceNodesIn: replacementDictionary + statementListsToLinearize := aTMethod parseTree select: [ :e | e isStatementList ]. + statementListsToLinearize do: [ :statementList | + statementList statements do: [ :statement | | replacement | + replacement := statement linearizeIn: self. + aTMethod replaceNodesIn: { statement -> replacement } asDictionary + ]. + aTMethod replaceNodesIn: { + statementList -> (TStatementListNode statements: statementList flattened) } asDictionary. + ]. + aTMethod flatten ] { #category : #utilities } @@ -3785,33 +3789,6 @@ CCodeGenerator >> localizeVariables: varsList inMethod: m [ variableDeclarations removeKey: varString ] ] ] -{ #category : #'automatic-localization' } -CCodeGenerator >> localizedVariablesReferences: variablesToLocalize inMethod: selector calledBy: caller withDictionary: associationDictionary [ - - "Return the references to global variables that are in variablesToLocalize in method selector." - - | currentMeth externalCalls globalReferences variablesReferences | - associationDictionary at: selector ifPresent: [ :vars | ^ vars ]. - currentMeth := self methodNamed: selector. - externalCalls := (currentMeth externalCallsIn: self) reject: [ :sel | - sel = selector or: [ sel = caller ] ]. - globalReferences := currentMeth freeVariableReferences. - variablesReferences := (variablesToLocalize select: [ :var | - globalReferences includes: var ]) asSet. - associationDictionary at: selector put: variablesReferences. - externalCalls ifEmpty: [ - ^ variablesReferences ]. - - externalCalls do: [ :s | - (associationDictionary includesKey: s) ifFalse: [ - (associationDictionary at: selector) addAll: (self - localizedVariablesReferences: variablesToLocalize - inMethod: s - calledBy: selector - withDictionary: associationDictionary) ] ]. - ^ variablesReferences -] - { #category : #utilities } CCodeGenerator >> logger [ ^logger @@ -4048,7 +4025,7 @@ CCodeGenerator >> nilOrBooleanConstantReceiverOf: aNode [ self isNilConstantReceiverOf: aNode ]) ifTrue: [ ^ aNode selector == #isNil ]. ((#( or: and: ) includes: aNode selector) and: [ - aNode arguments last isStmtList and: [ + aNode arguments last isStatementList and: [ aNode arguments last statements size = 1 ] ]) ifTrue: [ (self nilOrBooleanConstantReceiverOf: aNode receiver) ifNotNil: [ :rcvr | @@ -4512,6 +4489,41 @@ CCodeGenerator >> putDefineOf: aConstantNameString as: valueOrValueString on: aS cr ] +{ #category : #'automatic-localization' } +CCodeGenerator >> referencedVariablesIn: variablesToLocalize inSend: sendNode calledBy: caller withDictionary: associationDictionary [ + "Return the references to global variables that are in variablesToLocalize in method selector." + + | currentMeth externalCalls globalReferences variablesReferences | + associationDictionary at: sendNode selector ifPresent: [ :vars | ^ vars ]. + + "If it is a dynamic call, be conservative: assume all variables to localize may be touched" + (self isDynamicCall: sendNode) + ifTrue: [ ^ variablesToLocalize ]. + + currentMeth := self methodNamed: sendNode selector. + + "Otherwise, compute the subset of variablesToLocalize referenced in the method" + externalCalls := (currentMeth externalCallsIn: self) reject: [ :call | + call selector = sendNode selector or: [ call selector = caller ] ]. + globalReferences := currentMeth freeVariableReferences. + variablesReferences := (variablesToLocalize select: [ :var | + globalReferences includes: var ]) asSet. + associationDictionary at: sendNode selector put: variablesReferences. + externalCalls ifEmpty: [ + ^ variablesReferences ]. + + externalCalls do: [ :externalCall | + (associationDictionary includesKey: externalCall selector) ifFalse: [ + | subreferences | + subreferences := self + referencedVariablesIn: variablesToLocalize + inSend: externalCall + calledBy: sendNode selector + withDictionary: associationDictionary. + (associationDictionary at: sendNode selector) addAll: subreferences ] ]. + ^ variablesReferences +] + { #category : #inlining } CCodeGenerator >> removeAssertions [ "Remove all assertions in method bodies. This is for the benefit of inlining, which @@ -4520,15 +4532,10 @@ CCodeGenerator >> removeAssertions [ | newMethods | newMethods := Dictionary new. - 'Removing assertions...' - displayProgressAt: Sensor cursorPoint - from: 0 to: methods size - during: [ :bar | - methods doWithIndex: [ :m :i | - bar value: i. - m isAssertion ifFalse: [ - newMethods at: m selector put: m. - m removeAssertions]]]. + methods doWithIndex: [ :m :i | + m isAssertion ifFalse: [ + newMethods at: m selector put: m. + m removeAssertions]]. methods := newMethods. ] @@ -5438,35 +5445,34 @@ CCodeGenerator >> wordSize: aValue [ { #category : #'automatic-localization' } CCodeGenerator >> wrapExternalCallsIn: tMethod withVariableBindings: replacementDict [ - "Wrap external calls with TExternalSendNode." + "Wrap external calls with TExternalSendNode. + We should also wrap conservatively all macro methods, because they may contain calls" | sendReplacements methodsReferencesToVarsToLocalize variablesDict | variablesDict := (replacementDict collect: [ :asso | asso key -> (TVariableNode named: asso value) ]) asDictionary. - sendReplacements := Dictionary new. methodsReferencesToVarsToLocalize := Dictionary new. - tMethod parseTree - nodesDo: [ :node :parent | - (node isSend and: [ self isFunctionCall: node ]) ifTrue: [ - | externalVars | - externalVars := self - localizedVariablesReferences: - (replacementDict collect: [ :asso | asso key ]) - inMethod: node selector - calledBy: nil - withDictionary: methodsReferencesToVarsToLocalize. - - externalVars ifNotEmpty: [ - sendReplacements at: node put: (TExternalSendNode - send: node - variableBindings: - (externalVars collect: [ :var | - var -> (variablesDict at: var) ]) asDictionary) ] ] ] - parent: nil - unless: [ :e :parent | e isReturn ]. + "Apply externalization/localization of variables around + - static function calls + - dynamic function calls (perform & co)" + (tMethod externalCallsIn: self) do: [ :sendNode | + | variablesToExternalize | + "Optimization: only externalize/localize variables in usage in those methods" + variablesToExternalize := self + referencedVariablesIn: (replacementDict collect: [ :asso | asso key ]) + inSend: sendNode + calledBy: nil + withDictionary: methodsReferencesToVarsToLocalize. + + variablesToExternalize ifNotEmpty: [ + sendReplacements at: sendNode put: (TExternalSendNode + send: sendNode + variableBindings: + (variablesToExternalize collect: [ :var | + var -> (variablesDict at: var) ]) asDictionary) ] ]. sendReplacements ifNotEmpty: [ tMethod parseTree replaceNodesIn: sendReplacements ] ] diff --git a/smalltalksrc/Slang/SlangTyper.class.st b/smalltalksrc/Slang/SlangTyper.class.st index 7b8ad12b81..116aa24c7a 100644 --- a/smalltalksrc/Slang/SlangTyper.class.st +++ b/smalltalksrc/Slang/SlangTyper.class.st @@ -25,9 +25,9 @@ SlangTyper >> addTypesFor: node inMethod: method to: typeSet [ | expr | expr := node. - [ expr isAssignment or: [ expr isStmtList ] ] whileTrue: [ + [ expr isAssignment or: [ expr isStatementList ] ] whileTrue: [ expr isAssignment ifTrue: [ expr := expr variable ]. - expr isStmtList ifTrue: [ expr := expr statements last ] ]. + expr isStatementList ifTrue: [ expr := expr statements last ] ]. expr isSend ifTrue: [ (#( ifTrue: ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: ) includes: expr selector) ifTrue: [ diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index 5fc490de3a..e0eeb5b743 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -28,7 +28,7 @@ TAssignmentNode class >> variableNamed: aVariableName expression: anExpression [ { #category : #'C code generation' } TAssignmentNode >> asCASTExpressionIn: aCodeGen [ - (expression isStmtList and: [ expression statements size > 1 ]) + (expression isStatementList and: [ expression statements size > 1 ]) ifTrue: [ ^ self asCASTStatementListExpansionAsExpression: aCodeGen ]. ^ (self asCASTIn: aCodeGen) needsParentheses: true; @@ -65,7 +65,7 @@ TAssignmentNode >> asCASTIn: aBuilder [ lvalue: (CIdentifierNode name: variable name) rvalue: (CIdentifierNode name: 'aLiteralArray')) } ]. - (expression isStmtList and: [ expression statements size > 1 ]) + (expression isStatementList and: [ expression statements size > 1 ]) ifTrue: [ ^ expression copy assignLastExpressionTo: variable; diff --git a/smalltalksrc/Slang/TCaseStmtNode.class.st b/smalltalksrc/Slang/TCaseStmtNode.class.st index 9951c45503..712c7202aa 100644 --- a/smalltalksrc/Slang/TCaseStmtNode.class.st +++ b/smalltalksrc/Slang/TCaseStmtNode.class.st @@ -389,7 +389,7 @@ TCaseStmtNode >> setExpression: aNode selectors: selectorList arguments: anArray firsts add: firstInRun. lasts add: i - 2. stmt := TSendNode new setSelector: lastSel receiver: selfNode arguments: anArray. - cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)). + cases add: (TStatementListNode new setArguments: #() statements: (Array with: stmt)). lastSel := sel. firstInRun := i - 1. ]. @@ -397,5 +397,5 @@ TCaseStmtNode >> setExpression: aNode selectors: selectorList arguments: anArray firsts add: firstInRun. lasts add: selectorList size - 1. stmt := TSendNode new setSelector: lastSel receiver: selfNode arguments: anArray. - cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)). + cases add: (TStatementListNode new setArguments: #() statements: (Array with: stmt)). ] diff --git a/smalltalksrc/Slang/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st index 537bc89ec1..e4b0998648 100644 --- a/smalltalksrc/Slang/TExternalSendNode.class.st +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -127,6 +127,12 @@ TExternalSendNode >> nodesDo: aBlock parent: parent [ aBlock value: self value: parent ] +{ #category : #transformations } +TExternalSendNode >> printOn: aStream level: level [ + + wrappedSendNode printOn: aStream level: level +] + { #category : #asd } TExternalSendNode >> replaceNodesIn: aDictionary [ diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 3d5a69ee6d..0e5cbac560 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -161,7 +161,7 @@ TMethod >> allReferencedVariablesUsing: aCodeGen [ nodesWithParentsDo: [:node :parent| node isVariable ifTrue: [refs add: node name asString]. - node isStmtList ifTrue: [ node args ifNotNil: [ refs addAll: node args ]]. + node isStatementList ifTrue: [ node args ifNotNil: [ refs addAll: node args ]]. (node isSend and: [node selector value beginsWith: #cCode:]) ifTrue: [aCodeGen addVariablesInVerbatimCIn: node to: refs]] @@ -496,7 +496,7 @@ TMethod >> buildSwitchStmt: aSendNode parent: parentNode [ cases: aSendNode arguments first otherwiseOrNil: (aSendNode arguments at: 2 ifAbsent: [ nil ]). - (aSendNode receiver isVariable or: [ parentNode isStmtList ]) + (aSendNode receiver isVariable or: [ parentNode isStatementList ]) ifFalse: [ switch switchVariable: (locals add: (self extraVariableName: 'switch')) ]. @@ -666,11 +666,20 @@ TMethod >> declareNonConflictingLocalNamedLike: aString [ ^ newVarName ] +{ #category : #testing } +TMethod >> definedAsComplexMacro [ + ^properties notNil and: [(properties includesKey: #cmacro:)] +] + { #category : #testing } TMethod >> definedAsMacro [ - ^properties notNil - and: [(properties includesKey: #cmacro:) - or: [properties includesKey: #cmacro]] + ^self definedAsComplexMacro or: [ + self definedAsValueMacro ] +] + +{ #category : #testing } +TMethod >> definedAsValueMacro [ + ^properties notNil and: [(properties includesKey: #cmacro)] ] { #category : #accessing } @@ -909,9 +918,9 @@ TMethod >> exitVar: exitVar label: exitLabel [ "Now flatten any new statement lists..." parseTree nodesDo: [:node| | list | - (node isStmtList + (node isStatementList and: [node statements notEmpty - and: [node statements last isStmtList]]) ifTrue: + and: [node statements last isStatementList]]) ifTrue: [list := node statements last statements. node statements removeLast; addAllLast: list]]. ^labelUsed @@ -935,8 +944,8 @@ TMethod >> externalCallsIn: codeGenerator [ | calls | calls := Set new. parseTree nodesDo: [ :node | - (codeGenerator isFunctionCall: node) ifTrue: [ - calls add: node selector ] ]. + ((codeGenerator isFunctionCall: node) or: [ codeGenerator isDynamicCall: node ]) + ifTrue: [ calls add: node ] ]. ^ calls ] @@ -1113,7 +1122,7 @@ TMethod >> fixUpReturns: argCount postlog: postlog [ | newStmts | parseTree nodesDo: [:node | - node isStmtList ifTrue: [ + node isStatementList ifTrue: [ newStmts := OrderedCollection new: 100. node statements do: [:stmt | stmt isReturn @@ -1139,6 +1148,12 @@ TMethod >> fixUpReturns: argCount postlog: postlog [ ] +{ #category : #flattenning } +TMethod >> flatten [ + + parseTree := TStatementListNode statements: parseTree flattened +] + { #category : #utilities } TMethod >> freeVariableReferences [ "Answer a collection of variables referenced this method, excluding locals, arguments, and pseudovariables." @@ -1334,7 +1349,7 @@ TMethod >> inlineConditional: aSendNode in: aCodeGen [ where aSend is marked inline and always answers booleans." self assert: (self isInlineableConditional: aSendNode in: aCodeGen). - self assert: aSendNode arguments first isStmtList. + self assert: aSendNode arguments first isStatementList. ^ (aSendNode arguments first statements size = 1 and: [ aSendNode arguments first statements first isReturn ]) ifTrue: [ self inlineReturningConditional: aSendNode in: aCodeGen ] @@ -1424,7 +1439,7 @@ TMethod >> inlineGuardingConditional: aSendNode in: aCodeGen [ replacementTree comment: { ('inline ' , aSendNode receiver selector) }. self addVarsDeclarationsAndLabelsOf: method except: method args. - ^ TStmtListNode new setArguments: #( ) statements: (evaluateLabel + ^ TStatementListNode new setArguments: #( ) statements: (evaluateLabel ifNil: [ replacementTree statements , aSendNode arguments first statements , { skipLabel } ] @@ -1513,7 +1528,7 @@ TMethod >> inlineReturningConditional: aSendNode in: aCodeGen [ replacementTree comment: { ('inline ' , aSendNode receiver selector) }. ^ label ifNil: [ replacementTree ] ifNotNil: [ - TStmtListNode new setArguments: #( ) statements: { + TStatementListNode new setArguments: #( ) statements: { replacementTree. label } ] ] @@ -1720,7 +1735,7 @@ TMethod >> isConditionalToBeTransformedForAssignment: aSend in: aCodeGen [ and: [ aSend arguments anySatisfy: [ :arg | | stmt | - self assert: arg isStmtList. + self assert: arg isStatementList. arg statements size > 1 or: [ (stmt := arg statements first) isSwitch or: [ stmt isSend and: [ @@ -1817,7 +1832,7 @@ TMethod >> isNode: aNode substitutableFor: argName inMethod: targetMeth in: aCod "For now allow literal blocks to be substituted. They better be accessed only with value[:value:*] messages though!" - aNode isStmtList ifTrue: [^true]. + aNode isStatementList ifTrue: [^true]. "Don't inline expressions unless type-compatible," aNode isSend ifTrue: @@ -1904,7 +1919,7 @@ TMethod >> isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen [ "For now allow literal blocks to be substituted. They better be accessed only with value[:value:*] messages though!" - aNode isStmtList ifTrue: [^true]. + aNode isStatementList ifTrue: [^true]. (aNode isSend and: [aNode numArgs = 0 @@ -2613,7 +2628,7 @@ TMethod >> renameVariablesUsing: aDictionary [ nodesDo: [ :node | (node isVariable and: [ aDictionary includesKey: node name ]) ifTrue: [ node setName: (aDictionary at: node name) ]. - (node isStmtList and: [ node args size > 0 ]) + (node isStatementList and: [ node args size > 0 ]) ifTrue: [ node setArguments: (node args collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]) ] ] ] @@ -2759,7 +2774,7 @@ TMethod >> smalltalkSelector [ { #category : #accessing } TMethod >> statements [ - parseTree isStmtList + parseTree isStatementList ifFalse: [ self error: 'expected method parse tree to be a TStmtListNode' ]. ((parseTree args = nil) or: [parseTree args isEmpty]) ifFalse: [ self error: 'expected method parse tree to have no args' ]. @@ -2801,7 +2816,7 @@ TMethod >> statementsListsForInliningIn: aCodeGen [ | stmtLists | stmtLists := OrderedCollection new: 10. parseTree - nodesDo: [ :node | node isStmtList ifTrue: [ stmtLists add: node ] ] + nodesDo: [ :node | node isStatementList ifTrue: [ stmtLists add: node ] ] unless: [ :node | node isSend and: [ node selector == #cCode:inSmalltalk: or: [ @@ -2951,7 +2966,7 @@ TMethod >> transformReturnSubExpression: node toAssignmentOf: exitVar andGoto: e [replacement := replacement ifNil: [TGoToNode label: exitLabel] ifNotNil: - [TStmtListNode new + [TStatementListNode new setArguments: #() statements: {replacement. TGoToNode label: exitLabel}; @@ -2977,7 +2992,7 @@ TMethod >> transformReturns [ [returnType = #void ifTrue: [parent replaceChild: node - with: (TStmtListNode new + with: (TStatementListNode new setArguments: #() statements: {node expression. TReturnNode new diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index e091c409f7..ee4c1b9b34 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -159,6 +159,12 @@ TParseNode >> endsWithReturn [ ^false ] +{ #category : #flattenin } +TParseNode >> flattened [ + + ^ { self } +] + { #category : #testing } TParseNode >> hasExplicitReturn [ @@ -281,7 +287,7 @@ TParseNode >> isSend [ ] { #category : #testing } -TParseNode >> isStmtList [ +TParseNode >> isStatementList [ ^false ] @@ -307,6 +313,37 @@ TParseNode >> isVariable [ ^false ] +{ #category : #linearization } +TParseNode >> linearizeIn: aCodeGenerator [ + + "I am a statement. Linearize myself until I find a block." + + | replacementDictionary rewrittenStatement callsInStatement replacementBlock replacementsSoFar | + replacementDictionary := Dictionary new. + + callsInStatement := OrderedCollection new. + self + nodesDo: [ :node | + ((aCodeGenerator isFunctionCall: node) or: [ + aCodeGenerator isDynamicCall: node ]) + ifTrue: [ callsInStatement add: node ] ] + unless: [ :unlessNode | unlessNode isStatementList ]. + + replacementBlock := OrderedCollection new. + replacementsSoFar := Dictionary new. + callsInStatement do: [ :e | + | variableNode | + variableNode := TVariableNode named: + 't' , replacementBlock size asString. + replacementBlock add: (TAssignmentNode + variable: variableNode + expression: (e replaceNodesIn: replacementsSoFar)). + replacementsSoFar at: e put: variableNode ]. + rewrittenStatement := self replaceNodesIn: replacementsSoFar. + replacementBlock add: rewrittenStatement. + ^ TStatementListNode statements: replacementBlock +] + { #category : #accessing } TParseNode >> nameOrValue [ diff --git a/smalltalksrc/Slang/TReturnNode.class.st b/smalltalksrc/Slang/TReturnNode.class.st index e8c060a1b8..a7c46fc06e 100644 --- a/smalltalksrc/Slang/TReturnNode.class.st +++ b/smalltalksrc/Slang/TReturnNode.class.st @@ -116,6 +116,13 @@ TReturnNode >> isReturn [ ^true ] +{ #category : #comparing } +TReturnNode >> isSameAs: aTParseNode [ + + aTParseNode isReturn ifFalse: [ ^ false ]. + ^ expression isSameAs: aTParseNode expression +] + { #category : #enumerating } TReturnNode >> nodesDo: aBlock [ "Apply aBlock to all nodes in the receiver. diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index 4c32b6b748..a817414331 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -10,6 +10,12 @@ Class { #category : #'Slang-AST' } +{ #category : #'instance creation' } +TSendNode class >> receiver: aReceiverNode selector: aString [ + + ^ self receiver: aReceiverNode selector: aString arguments: #() +] + { #category : #'instance creation' } TSendNode class >> receiver: aReceiverNode selector: aString arguments: aCollection [ @@ -386,7 +392,7 @@ TSendNode >> isStructReference: varNode in: aCodeGen [ { #category : #testing } TSendNode >> isValueExpansion [ "Answer if the receiver is of the form literalBlock value[: arg]" - ^receiver isStmtList + ^receiver isStatementList and: [selector keywords allSatisfy: [:k| #('value' 'value:') includes: k]] ] diff --git a/smalltalksrc/Slang/TStmtListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st similarity index 81% rename from smalltalksrc/Slang/TStmtListNode.class.st rename to smalltalksrc/Slang/TStatementListNode.class.st index a96161a883..243e9a9c30 100644 --- a/smalltalksrc/Slang/TStmtListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -1,5 +1,5 @@ Class { - #name : #TStmtListNode, + #name : #TStatementListNode, #superclass : #TParseNode, #instVars : [ 'arguments', @@ -9,7 +9,7 @@ Class { } { #category : #'instance creation' } -TStmtListNode class >> statements: aCollection [ +TStatementListNode class >> statements: aCollection [ ^ self new setStatements: aCollection; @@ -17,10 +17,10 @@ TStmtListNode class >> statements: aCollection [ ] { #category : #comparing } -TStmtListNode >> = aNode [ +TStatementListNode >> = aNode [ super = aNode ifFalse: [ ^ false ]. - aNode isStmtList ifFalse: [ ^ false ]. + aNode isStatementList ifFalse: [ ^ false ]. statements size = aNode statements size ifFalse: [ ^ false ]. statements doWithIndex: [ :stmt :i | stmt = (aNode statements at: i) ifFalse: [ ^ false ] ]. @@ -28,7 +28,7 @@ TStmtListNode >> = aNode [ ] { #category : #utilities } -TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ +TStatementListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ "Add any variables in variables that are read before written to readBeforeAssigned. Add unconditional assignments to assigned. For convenience answer assigned." @@ -67,7 +67,7 @@ TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assig (#( ifTrue: ifFalse: ifNil: ifNotNil: ) intersection: node selector keywords) notEmpty ifTrue: [ "First find assignments in the expression..." - (TStmtListNode new + (TStatementListNode new setStatements: { node receiver }; yourself) addReadBeforeAssignedIn: variables @@ -77,7 +77,7 @@ TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assig "Now find read-before-written in each arm, and collect the assignments to spot those assigned in both arms" conditionalAssignments := node arguments collect: [ :block | - block isStmtList ifTrue: [ + block isStatementList ifTrue: [ block addReadBeforeAssignedIn: variables @@ -98,13 +98,13 @@ TStmtListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assig ] { #category : #accessing } -TStmtListNode >> args [ +TStatementListNode >> args [ ^arguments ] { #category : #tranforming } -TStmtListNode >> asCASTExpressionIn: aBuilder [ +TStatementListNode >> asCASTExpressionIn: aBuilder [ | expressionList | expressionList := CExpressionListNode new. @@ -117,13 +117,13 @@ TStmtListNode >> asCASTExpressionIn: aBuilder [ ] { #category : #tranforming } -TStmtListNode >> asCASTIn: aBuilder [ +TStatementListNode >> asCASTIn: aBuilder [ ^ self asCASTIn: aBuilder prependToEnd: nil ] { #category : #tranforming } -TStmtListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ +TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ | collect | collect := OrderedCollection new. @@ -142,7 +142,7 @@ TStmtListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ ] { #category : #transformations } -TStmtListNode >> asReturnNode [ +TStatementListNode >> asReturnNode [ self endsWithReturn ifTrue: [^self]. ^self class new @@ -152,7 +152,7 @@ TStmtListNode >> asReturnNode [ ] { #category : #transformations } -TStmtListNode >> assignLastExpressionTo: variableNode [ +TStatementListNode >> assignLastExpressionTo: variableNode [ "Destructively transform the receiver so that its last expression is assigned to the argument." | index | index := statements findLast: [:expr| (expr isGoTo or: [expr isLabel]) not]. @@ -164,13 +164,13 @@ TStmtListNode >> assignLastExpressionTo: variableNode [ ] { #category : #transformations } -TStmtListNode >> bindVariableUsesIn: aDictionary [ +TStatementListNode >> bindVariableUsesIn: aDictionary [ statements := statements collect: [ :s | s bindVariableUsesIn: aDictionary ]. ] { #category : #transformations } -TStmtListNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen [ +TStatementListNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen [ "Answer either the receiver, if it contains no references to the given variables, or a new node with the given variables rebound." | newStatements | newStatements := statements collect: [:s| s bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen]. @@ -183,26 +183,26 @@ TStmtListNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold ] { #category : #transformations } -TStmtListNode >> bindVariablesIn: aDictionary [ +TStatementListNode >> bindVariablesIn: aDictionary [ statements := statements collect: [ :s | s bindVariablesIn: aDictionary ]. ] { #category : #transformations } -TStmtListNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ +TStatementListNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ (cautionaryBlock value: self) ifTrue: [^self]. statements := statements collect: [ :s | s bindVariablesIn: aDictionary unless: cautionaryBlock]. ] { #category : #enumerating } -TStmtListNode >> children [ +TStatementListNode >> children [ ^ statements ] { #category : #transformations } -TStmtListNode >> copyWithoutReturn [ +TStatementListNode >> copyWithoutReturn [ self assert: self endsWithReturn. statements size = 1 ifTrue: [^statements last expression]. @@ -213,7 +213,7 @@ TStmtListNode >> copyWithoutReturn [ ] { #category : #testing } -TStmtListNode >> endsWithCloseBracket: aStream [ +TStatementListNode >> endsWithCloseBracket: aStream [ "Answer true if the given stream ends in a $} character." | ch pos | @@ -226,22 +226,29 @@ TStmtListNode >> endsWithCloseBracket: aStream [ ] { #category : #testing } -TStmtListNode >> endsWithReturn [ +TStatementListNode >> endsWithReturn [ "Answer true if the last statement of this lock is a return." ^statements notEmpty and: [statements last isReturn or: [statements last isReturningIf]] ] +{ #category : #flattening } +TStatementListNode >> flattened [ + + ^ statements flatCollect: [ :each | + each flattened ] +] + { #category : #accessing } -TStmtListNode >> initialize [ +TStatementListNode >> initialize [ super initialize. arguments := #() ] { #category : #testing } -TStmtListNode >> isNilStmtListNode [ +TStatementListNode >> isNilStmtListNode [ |stmt| statements size = 1 ifFalse: [^false]. @@ -250,8 +257,8 @@ TStmtListNode >> isNilStmtListNode [ ] { #category : #testing } -TStmtListNode >> isSameAs: aTParseNode [ - (aTParseNode isStmtList +TStatementListNode >> isSameAs: aTParseNode [ + (aTParseNode isStatementList and: [statements size = aTParseNode statements size]) ifFalse: [^false]. statements with: aTParseNode statements do: @@ -262,13 +269,13 @@ TStmtListNode >> isSameAs: aTParseNode [ ] { #category : #testing } -TStmtListNode >> isStmtList [ +TStatementListNode >> isStatementList [ ^true ] { #category : #enumerating } -TStmtListNode >> nodesDo: aBlock [ +TStatementListNode >> nodesDo: aBlock [ "Apply aBlock to all nodes in the receiver. N.B. This is assumed to be bottom-up, leaves first." statements do: [ :s | s nodesDo: aBlock ]. @@ -276,7 +283,7 @@ TStmtListNode >> nodesDo: aBlock [ ] { #category : #enumerating } -TStmtListNode >> nodesDo: aBlock parent: parent [ +TStatementListNode >> nodesDo: aBlock parent: parent [ "Apply aBlock to all nodes in the receiver with each node's parent. N.B. This is assumed to be bottom-up, leaves first." statements do: [:s| s nodesDo: aBlock parent: self]. @@ -284,7 +291,7 @@ TStmtListNode >> nodesDo: aBlock parent: parent [ ] { #category : #enumerating } -TStmtListNode >> nodesDo: aBlock parent: parent unless: cautionaryBlock [ +TStatementListNode >> nodesDo: aBlock parent: parent unless: cautionaryBlock [ (cautionaryBlock value: self value: parent) ifTrue: [^self]. statements do: [ :s | s nodesDo: aBlock parent: self unless: cautionaryBlock]. @@ -292,7 +299,7 @@ TStmtListNode >> nodesDo: aBlock parent: parent unless: cautionaryBlock [ ] { #category : #enumerating } -TStmtListNode >> nodesDo: aBlock unless: cautionaryBlock [ +TStatementListNode >> nodesDo: aBlock unless: cautionaryBlock [ (cautionaryBlock value: self) ifTrue: [^self]. statements do: [ :s | s nodesDo: aBlock unless: cautionaryBlock ]. @@ -300,7 +307,7 @@ TStmtListNode >> nodesDo: aBlock unless: cautionaryBlock [ ] { #category : #enumerating } -TStmtListNode >> nodesDo: aBlock value: parent [ +TStatementListNode >> nodesDo: aBlock value: parent [ "Apply aBlock to all nodes in the receiver with each node's parent. N.B. This is assumed to be bottom-up, leaves first." statements do: [:s| s nodesDo: aBlock parent: self.]. @@ -308,7 +315,7 @@ TStmtListNode >> nodesDo: aBlock value: parent [ ] { #category : #copying } -TStmtListNode >> postCopy [ +TStatementListNode >> postCopy [ 1haltIf: [ arguments isNil ]. arguments := arguments copy. @@ -316,7 +323,7 @@ TStmtListNode >> postCopy [ ] { #category : #printing } -TStmtListNode >> printOn: aStream level: level [ +TStatementListNode >> printOn: aStream level: level [ statements size > 1 ifTrue: [ aStream crtab: level + 1 ]. aStream nextPut: $[. @@ -328,7 +335,7 @@ TStmtListNode >> printOn: aStream level: level [ ] { #category : #printing } -TStmtListNode >> printStatementsOn: aStream level: level [ +TStatementListNode >> printStatementsOn: aStream level: level [ statements do: [:s| s printOn: aStream level: level] @@ -336,7 +343,7 @@ TStmtListNode >> printStatementsOn: aStream level: level [ ] { #category : #transformations } -TStmtListNode >> removeAssertions [ +TStatementListNode >> removeAssertions [ | newStatements | newStatements := OrderedCollection new: statements size. statements do: [ :stmt | @@ -348,7 +355,7 @@ TStmtListNode >> removeAssertions [ ] { #category : #'inlining support' } -TStmtListNode >> renameLabelsForInliningInto: aTMethod [ +TStatementListNode >> renameLabelsForInliningInto: aTMethod [ "TMethod already has a method for this; hijack it..." | labels | labels := OrderedCollection new. @@ -361,21 +368,21 @@ TStmtListNode >> renameLabelsForInliningInto: aTMethod [ ] { #category : #transformations } -TStmtListNode >> replaceChild: aNode with: bNode [ +TStatementListNode >> replaceChild: aNode with: bNode [ statements := Array streamContents: [:s| statements do: [:node| node == aNode ifTrue: - [bNode isStmtList + [bNode isStatementList ifTrue: [s nextPutAll: bNode statements] ifFalse: [s nextPut: bNode]] ifFalse: [s nextPut: node]]] ] { #category : #transformations } -TStmtListNode >> replaceNodesIn: aDictionary [ +TStatementListNode >> replaceNodesIn: aDictionary [ ^aDictionary at: self ifAbsent: [ statements := statements collect: [ :s | s replaceNodesIn: aDictionary ]. @@ -383,7 +390,7 @@ TStmtListNode >> replaceNodesIn: aDictionary [ ] { #category : #testing } -TStmtListNode >> returnsExpression [ +TStatementListNode >> returnsExpression [ "Answer true if the last statement of this block is a return of some expression, not merely self or nil." statements isEmpty ifTrue: @@ -397,14 +404,14 @@ TStmtListNode >> returnsExpression [ ] { #category : #accessing } -TStmtListNode >> setArguments: argList [ +TStatementListNode >> setArguments: argList [ 1haltIf: [ argList isNil ]. arguments := argList. ] { #category : #accessing } -TStmtListNode >> setArguments: argList statements: statementList [ +TStatementListNode >> setArguments: argList statements: statementList [ "Initialize this method using the given information." 1haltIf: [ argList isNil ]. @@ -413,24 +420,24 @@ TStmtListNode >> setArguments: argList statements: statementList [ ] { #category : #accessing } -TStmtListNode >> setStatements: stmtList [ +TStatementListNode >> setStatements: stmtList [ statements := stmtList asOrderedCollection. ] { #category : #inlining } -TStmtListNode >> shouldExpand [ +TStatementListNode >> shouldExpand [ ^(statements detect: [:stmt| stmt isInline]) shouldExpand ] { #category : #accessing } -TStmtListNode >> statements [ +TStatementListNode >> statements [ ^statements ] { #category : #'type inference' } -TStmtListNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ +TStatementListNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ ^statements isEmpty ifFalse: [statements last typeOrNilFrom: aCodeGenerator in: aTMethod] ] diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index 2f971c4b3c..882016430a 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -42,7 +42,7 @@ TSwitchStmtNode >> asCASTExpressionIn: aBuilder [ left: (var value: i) right: ((labels at: j) asCASTExpressionIn: aBuilder)) then: - ((TStmtListNode new + ((TStatementListNode new setArguments: #( ) statements: case statements) asCASTExpressionIn: aBuilder) @@ -66,7 +66,7 @@ TSwitchStmtNode >> asCASTExpressionIn: aBuilder [ left: (var value: i) right: ((labels at: j) asCASTExpressionIn: aBuilder)) then: - ((TStmtListNode new + ((TStatementListNode new setArguments: #( ) statements: case statements) asCASTExpressionIn: aBuilder) diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index 33dbc6d9de..3056446868 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -15,6 +15,12 @@ TVariableNode class >> named: aName [ yourself ] +{ #category : #'instance creation' } +TVariableNode class >> selfNode [ + + ^ self named: 'self' +] + { #category : #tranforming } TVariableNode >> asCASTIn: aBuilder [ diff --git a/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st b/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st index 68ecd1a622..b2fa1af5f4 100644 --- a/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st +++ b/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st @@ -148,7 +148,7 @@ SmartSyntaxPluginTMethod >> fixUpReturns [ "Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return." parseTree nodesDo: [:node | - node isStmtList ifTrue: [ + node isStatementList ifTrue: [ node setStatements: (Array streamContents: [:sStream | node statements do: @@ -502,9 +502,9 @@ SmartSyntaxPluginTMethod >> statementGuardedWithSuccess: aTParseNodeOrSequenceTh setSelector: #failed receiver: (TVariableNode new setName: 'interpreterProxy') arguments: #()) - arguments: {(aTParseNodeOrSequenceThereof isTParseNode and: [aTParseNodeOrSequenceThereof isStmtList]) + arguments: {(aTParseNodeOrSequenceThereof isTParseNode and: [aTParseNodeOrSequenceThereof isStatementList]) ifTrue: [aTParseNodeOrSequenceThereof] - ifFalse: [TStmtListNode new + ifFalse: [TStatementListNode new setArguments: #() statements: (aTParseNodeOrSequenceThereof isCollection ifTrue: [aTParseNodeOrSequenceThereof] diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st index a92226d15d..ee77fe869a 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -14736,8 +14736,7 @@ StackInterpreter >> stackPageFrameBytes [ slots in the StackInterpreter and 56 + 8 slots in the CoInterpreter. 256 slots gives from 4 to 36 frames in the StackInterpreter and from 4 to 42 in the CoInterpreter. Hence 2048 bytes in 32-bits and 4096 bytes in 64-bits; a compromise between overflow rate and latency in divorcing a page." - "Defining as a macro simplifies hand editing the C for experiments..." - + ^256 * objectMemory wordSize ] From 188f2babb67ddb987369205f0720bc779776f337 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 21 Dec 2021 17:51:29 +0100 Subject: [PATCH 30/75] Renames of isStmtNode --- .../RBAssignmentNode.extension.st | 4 ++-- .../VMMakerCompatibilityForPharo6/RBBlockNode.extension.st | 4 ++-- .../RBCascadeNode.extension.st | 2 +- .../RBMessageNode.extension.st | 6 +++--- .../VMMakerCompatibilityForPharo6/RBReturnNode.extension.st | 2 +- .../RBSequenceNode.extension.st | 4 ++-- 6 files changed, 11 insertions(+), 11 deletions(-) diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st index 37a98c6879..2371783f3b 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st @@ -17,7 +17,7 @@ RBAssignmentNode >> asTranslatorNodeIn: aTMethod [ | varNode valueNode | varNode := variable asTranslatorNodeIn: aTMethod. valueNode := value asTranslatorNodeIn: aTMethod. - valueNode isStmtList ifFalse: + valueNode isStatementList ifFalse: [^TAssignmentNode new setVariable: varNode expression: valueNode; @@ -27,7 +27,7 @@ RBAssignmentNode >> asTranslatorNodeIn: aTMethod [ [self error: 'haven''t implemented pushing down assignments into other than the last return']. "As of 6/25/2012 19:30 superExpansionNodeFor:args: elides the final return." self assert: valueNode statements last isReturn not. - ^TStmtListNode new + ^TStatementListNode new setStatements: valueNode statements allButLast, { TAssignmentNode new setVariable: varNode diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st index 476b9b4502..e35d28e0fb 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st @@ -9,13 +9,13 @@ RBBlockNode >> asTranslatorNodeIn: aTMethod [ [:s | | newS | newS := s asTranslatorNodeIn: aTMethod. "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" - newS isStmtList + newS isStatementList ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. statementList ifEmpty: [ statementList add: (TVariableNode new setName: 'nil'). ]. - ^TStmtListNode new + ^TStatementListNode new setArguments: (arguments asArray collect: [:arg | arg name]) statements: statementList; comment: self commentOrNil diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBCascadeNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBCascadeNode.extension.st index bc3862f145..678a2298e9 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBCascadeNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBCascadeNode.extension.st @@ -3,7 +3,7 @@ Extension { #name : #RBCascadeNode } { #category : #'*VMMakerCompatibilityForPharo6-C translation' } RBCascadeNode >> asTranslatorNodeIn: aTMethod [ "Answer a TParseNode subclass equivalent of me." - ^TStmtListNode new + ^TStatementListNode new setArguments: #() statements: (Array streamContents: diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st index 374ef47136..f39dacc641 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st @@ -65,7 +65,7 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ "If in the form of ifNil: [ :obj | ], replace that by an assignment and an ifFalse" ((usedSelector == #ifNotNil:) and: [ args first args notEmpty ]) ifTrue: [ - ^ TStmtListNode new + ^ TStatementListNode new setArguments: #(); setStatements: { TAssignmentNode new @@ -101,7 +101,7 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ "If there is a variable we should epand the message as a statement" blockWithPossibleArgument args notEmpty ifTrue: [ - ^ TStmtListNode new + ^ TStatementListNode new setArguments: #(); setStatements: { TAssignmentNode new @@ -139,7 +139,7 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ (args size > usedSelector numArgs and: [usedSelector ~~ #to:by:do:]) ifTrue: "to:by:do: has iLimiT hidden in last arg" ["prune the extra blocks left by ifTrue:, ifFalse:, and: & or:" self assert: args size - usedSelector numArgs = 1. - self assert: (args last isStmtList + self assert: (args last isStatementList and: [args last statements size = 1 and: [(args last statements first isVariable or: [args last statements first isConstant]) diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBReturnNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBReturnNode.extension.st index 5e884d333f..ff5ebe3d10 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBReturnNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBReturnNode.extension.st @@ -8,7 +8,7 @@ RBReturnNode >> asTranslatorNodeIn: aTMethod [ (value isMessage and: [value receiver isVariable and: [value receiver name = 'super' - and: [exprTranslation isStmtList]]]) ifTrue: + and: [exprTranslation isStatementList]]]) ifTrue: ["super expansions containing returns are fine, and (as of 6/25/2012 19:27) the last return is elided from the expansion by TMethod>>superExpansionNodeFor:args:. So we need to ensure the last expression is a return and simply reuse any other diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st index 03d050e965..a14027dc56 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st @@ -9,10 +9,10 @@ RBSequenceNode >> asTranslatorNodeIn: aTMethod [ [:s | | newS | newS := s asTranslatorNodeIn: aTMethod. "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" - newS isStmtList + newS isStatementList ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. - ^TStmtListNode new + ^TStatementListNode new setArguments: (parent isMethod ifTrue: [#()] ifFalse: [parent arguments asArray collect: [:arg | arg name]]) From 7d785fd81da4b5cf28e7cceea1ba592dcc016fb8 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 22 Dec 2021 15:26:39 +0100 Subject: [PATCH 31/75] Added visiting methods to the TAST and MLVMVariableAccessCollector to extract variables --- .../SlangLocalizationTestCase.class.st | 136 +++++++--------- smalltalksrc/Slang/CCodeGenerator.class.st | 87 ++++++---- .../MLVMVariableAccessCollector.class.st | 148 ++++++++++++++++++ smalltalksrc/Slang/TAssignmentNode.class.st | 12 ++ smalltalksrc/Slang/TCaseStmtNode.class.st | 12 ++ smalltalksrc/Slang/TConstantNode.class.st | 12 ++ smalltalksrc/Slang/TInlineNode.class.st | 12 ++ .../Slang/TLabeledCommentNode.class.st | 12 ++ smalltalksrc/Slang/TMethod.class.st | 29 ++++ smalltalksrc/Slang/TParseNode.class.st | 39 ++++- smalltalksrc/Slang/TReturnNode.class.st | 12 ++ smalltalksrc/Slang/TSendNode.class.st | 12 ++ .../Slang/TStatementListNode.class.st | 16 +- smalltalksrc/Slang/TVariableNode.class.st | 12 ++ .../VMMaker-Tools/TParseNode.extension.st | 21 +++ .../VMMASTTranslationTest.class.st | 10 +- 16 files changed, 462 insertions(+), 120 deletions(-) create mode 100644 smalltalksrc/Slang/MLVMVariableAccessCollector.class.st create mode 100644 smalltalksrc/VMMaker-Tools/TParseNode.extension.st diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 919da49530..6a6973484c 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -115,8 +115,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnRef (interpretMethod statements last asCASTIn: ccg) prettyPrintOn: str ]. self assert: printedString equals: '{ - autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; return (autoLocalizedVariable += 1); }' ] @@ -126,21 +126,19 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" - | interpretMethod | + | interpretMethod sendNode | interpretMethod := self applyLocalizationTo: #interpretWithReturnExpression. - self assert: - interpretMethod statements last arguments first statements last statements last - isReturn. + sendNode := interpretMethod statements last statements second. + self assert: sendNode arguments first statements last statements last isReturn. self - assert: (interpretMethod statements last arguments first statements last statements first - isSameAs: (self externalizationOf: #autoLocalizedVariable)). - self assert: - interpretMethod statements last arguments second statements first statements last - isReturn. + assert: (sendNode arguments first statements last statements first + isSameAs: (self externalizationOf: #autoLocalizedVariable)). + + self assert: sendNode arguments second statements last statements last isReturn. self - assert: (interpretMethod statements last arguments second statements first statements first - isSameAs: (self externalizationOf: #autoLocalizedVariable)) + assert: (sendNode arguments second statements last statements first + isSameAs: (self externalizationOf: #autoLocalizedVariable)). ] { #category : #tests } @@ -169,51 +167,29 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). ] -{ #category : #tests } -SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsMacros [ - - | interpretMethod case inlinedMethod | - interpretMethod := self applyLocalizationToInterpretWith: #initializeWithMacroCall. - - "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - - self assert: inlinedMethod statements first isExternalSend -] - -{ #category : #tests } -SlangLocalizationTestCase >> testAutoLocalizeVariableWrapsSendsWithExternalSendNodes [ - - | interpretMethod case inlinedMethod | - interpretMethod := self - applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. - "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - - self assert: inlinedMethod statements first isExternalSend -] - { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgument [ - | interpretMethod case externalCall cast printedString inlinedMethod | + | interpretMethod case cast printedString inlinedMethod | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCallAsArgument. "Assert that the send node is preceded by variable externalization" case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. + cast := inlinedMethod parseTree asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: 'autoLocalizedVariable = local_autoLocalizedVariable; -r = foo2(); -local_autoLocalizedVariable = autoLocalizedVariable; -if (1 == r) { + self assert: printedString equals: +'{ + { + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = foo2(); + local_autoLocalizedVariable = autoLocalizedVariable; + } + if (1 == t0) { + } }' ] @@ -228,17 +204,26 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ inlinedMethod := case statements second method. externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. - + cast := externalCall asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ autoLocalizedVariable1 = local_autoLocalizedVariable1; + t0 = nonInlinedMethodUsingAutolocalizedVariable1(); + local_autoLocalizedVariable1 = autoLocalizedVariable1; +}'. + + externalCall := inlinedMethod statements second. + cast := externalCall asCASTIn: ccg. + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: '{ autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable2 = local_autoLocalizedVariable2; - foo(nonInlinedMethodUsingAutolocalizedVariable1()); - local_autoLocalizedVariable1 = autoLocalizedVariable1; + t1 = foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; }' ] @@ -259,11 +244,11 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ - autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable = local_autoLocalizedVariable; - foo2(); - local_autoLocalizedVariable1 = autoLocalizedVariable1; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + t0 = foo2(); local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; }' ] @@ -284,58 +269,36 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE self assert: printedString equals: '{ autoLocalizedVariable = local_autoLocalizedVariable; - foo((autoLocalizedVariable += 1)); + t0 = foo((local_autoLocalizedVariable += 1)); local_autoLocalizedVariable = autoLocalizedVariable; }' ] -{ #category : #tests } -SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalizationOutOfDispatch [ - - | interpretMethod | - interpretMethod := self applyLocalizationTo: #interpretWithExternalCallBeforeDispatch. - self assert: interpretMethod statements second isExternalSend -] - { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ | interpretMethod case inlinedMethod externalCall cast printedString | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements first. cast := externalCall asCASTIn: ccg. - + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable2 = local_autoLocalizedVariable2; - foo((autoLocalizedVariable += 1)); - local_autoLocalizedVariable1 = autoLocalizedVariable1; + t0 = foo((local_autoLocalizedVariable += 1)); local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; }' ] -{ #category : #tests } -SlangLocalizationTestCase >> testExternalSendNodeKnowsVariablesToExternalizeAndInternalize [ - - | interpretMethod case inlinedMethod | - interpretMethod := self applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. - - "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - - self assert: (inlinedMethod statements first localizedVariables includes: #autoLocalizedVariable) -] - { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ @@ -349,12 +312,21 @@ SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternali externalCall := inlinedMethod statements first. cast := externalCall asCASTIn: ccg. + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + self assert: printedString equals: '{ + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = nonInlinedMethodUsingAutolocalizedVariable(); + local_autoLocalizedVariable = autoLocalizedVariable; +}'. + + externalCall := inlinedMethod statements second. + cast := externalCall asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ autoLocalizedVariable = local_autoLocalizedVariable; - foo(nonInlinedMethodUsingAutolocalizedVariable()); + t1 = foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; }' ] @@ -588,5 +560,5 @@ SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: 'nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' + self assert: printedString equals: 't0 = nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' ] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 7d98526f89..d2f0c161c3 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -480,10 +480,6 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: (m := self methodNamed: selector) ifNil: [ ^ self ]. (replacementDict isNil or: [ replacementDict isEmpty ]) ifTrue: [ ^ self ]. - "self linearizeExternalCallsIn: m." - "Wrap sends with externalization/internalization statements" - self wrapExternalCallsIn: m withVariableBindings: replacementDict. - "Replace all localized variables by their localized versions" m parseTree bindVariablesIn: (replacementDict collect: [ :asso | @@ -491,16 +487,21 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: unless: [ :node | node isTMethod not and: [ node isReturn or: [ node isExternalSend ] ] ]. - + + self linearizeExternalCallsIn: m. + + "Wrap sends with externalization/internalization statements" + self wrapStatements: m withVariableBindings: replacementDict. + "Localize global values at the beginning of the function AND externalize local values on each return" replacementDict do: [ :asso | m statements addFirst: (TAssignmentNode variable: (TVariableNode named: asso value) expression: (TVariableNode named: asso key)) ]. - self + "self externalizeAtReturnsIn: m - withVariablesToLocalize: replacementDict. + withVariablesToLocalize: replacementDict." ] @@ -1299,6 +1300,14 @@ CCodeGenerator >> exportedPrimitiveNames [ ] +{ #category : #'automatic-localization' } +CCodeGenerator >> externalizationOf: aVariableName [ + + ^ (TAssignmentNode + variableNamed: aVariableName + expression: (TVariableNode named: #local_, aVariableName)) +] + { #category : #'automatic-localization' } CCodeGenerator >> externalizeAtReturnsIn: aTMethod withVariablesToLocalize: variablesReplacement [ @@ -3463,6 +3472,14 @@ CCodeGenerator >> instVarNamesForClass: aClass [ ] +{ #category : #'automatic-localization' } +CCodeGenerator >> internalizationOf: aVariableName [ + + ^ (TAssignmentNode + variableNamed: #local_, aVariableName + expression: (TVariableNode named: aVariableName)) +] + { #category : #'C translation' } CCodeGenerator >> is32Bit [ ^ self wordSize = 4 @@ -5443,36 +5460,48 @@ CCodeGenerator >> wordSize: aValue [ ] { #category : #'automatic-localization' } -CCodeGenerator >> wrapExternalCallsIn: tMethod withVariableBindings: replacementDict [ +CCodeGenerator >> wrapStatementWithExternalizationAndLocalizations: statement ofLocalizedVariables: localizedVariables [ + + | collector variablesToExternalize replacementStatements | + + "Optimization: only externalize/localize variables used by the statement's called functions" + collector := MLVMVariableAccessCollector + inCodeGenerator: self + fromGlobals: localizedVariables. + statement accept: collector. + + "Sorted to guarantee determinism in the output" + variablesToExternalize := collector accessedVariables sorted. + variablesToExternalize ifEmpty: [ ^ statement ]. + + "Wrap the statement with externalization/localizations" + replacementStatements := OrderedCollection new. + replacementStatements addAll: (variablesToExternalize collect: [ :e | self externalizationOf: e ]). + replacementStatements add: statement. + statement isReturn ifFalse: [ + replacementStatements addAll: (variablesToExternalize collect: [ :e | self internalizationOf: e ]) ]. + ^ TStatementListNode statements: replacementStatements +] + +{ #category : #'automatic-localization' } +CCodeGenerator >> wrapStatements: tMethod withVariableBindings: replacementDict [ - "Wrap external calls with TExternalSendNode. - We should also wrap conservatively all macro methods, because they may contain calls" + "Wrap statements with external calls with TExternalSendNode" - | sendReplacements methodsReferencesToVarsToLocalize variablesDict | + | methodsReferencesToVarsToLocalize variablesDict | variablesDict := (replacementDict collect: [ :asso | asso key -> (TVariableNode named: asso value) ]) asDictionary. - sendReplacements := Dictionary new. methodsReferencesToVarsToLocalize := Dictionary new. "Apply externalization/localization of variables around - static function calls - dynamic function calls (perform & co)" - (tMethod externalCallsIn: self) do: [ :sendNode | - | variablesToExternalize | - "Optimization: only externalize/localize variables in usage in those methods" - variablesToExternalize := self - referencedVariablesIn: (replacementDict collect: [ :asso | asso key ]) - inSend: sendNode - calledBy: nil - withDictionary: methodsReferencesToVarsToLocalize. - - variablesToExternalize ifNotEmpty: [ - sendReplacements at: sendNode put: (TExternalSendNode - send: sendNode - variableBindings: - (variablesToExternalize collect: [ :var | - var -> (variablesDict at: var) ]) asDictionary) ] ]. - sendReplacements ifNotEmpty: [ - tMethod parseTree replaceNodesIn: sendReplacements ] + + tMethod allStatements do: [ :statement | | replacement | + replacement := self + wrapStatementWithExternalizationAndLocalizations: statement + ofLocalizedVariables: (replacementDict collect: [ :asso | asso key ]). + tMethod replaceNodesIn: { statement -> replacement } asDictionary + ]. ] diff --git a/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st new file mode 100644 index 0000000000..30049f8ac3 --- /dev/null +++ b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st @@ -0,0 +1,148 @@ +Class { + #name : #MLVMVariableAccessCollector, + #superclass : #Object, + #instVars : [ + 'codeGenerator', + 'variableSubset', + 'alreadyVisited', + 'accessedVariables' + ], + #category : #'Slang-CodeGeneration' +} + +{ #category : #'instance creation' } +MLVMVariableAccessCollector class >> inCodeGenerator: aCodeGenerator fromGlobals: aCollection [ + + ^ self new + codeGenerator: aCodeGenerator; + variableSubset: aCollection; + yourself +] + +{ #category : #accessing } +MLVMVariableAccessCollector >> accessedVariables [ + ^ accessedVariables +] + +{ #category : #callgraph } +MLVMVariableAccessCollector >> analyzeCallGraphFromMessageSend: aTMessageSend [ + + | method | + method := codeGenerator methodNamed: aTMessageSend selector. + + "The method could be nil if not found in the list of methods to translate. + This could be because the selector is either + - a special selector (+, /, perform: ...) + - a C selector (str:cpy:_:_:) + - or a selector that was inlined and removed by some other pass..." + method ifNil: [ ^ self ]. + + self analyzeCallGraphFromMethod: method +] + +{ #category : #callgraph } +MLVMVariableAccessCollector >> analyzeCallGraphFromMethod: aTMethod [ + + (alreadyVisited includes: aTMethod) + ifTrue: [ ^ self ]. + alreadyVisited add: aTMethod. + + accessedVariables addAll: (aTMethod freeVariableReferences intersection: variableSubset). + (aTMethod externalCallsIn: codeGenerator) do: [ :aTSendNode | + self analyzeCallGraphFromMessageSend: aTSendNode + ] +] + +{ #category : #accessing } +MLVMVariableAccessCollector >> codeGenerator [ + + ^ codeGenerator +] + +{ #category : #accessing } +MLVMVariableAccessCollector >> codeGenerator: anObject [ + + codeGenerator := anObject +] + +{ #category : #initialization } +MLVMVariableAccessCollector >> initialize [ + + super initialize. + accessedVariables := Set new. + alreadyVisited := Set new. +] + +{ #category : #accessing } +MLVMVariableAccessCollector >> variableSubset [ + + ^ variableSubset +] + +{ #category : #accessing } +MLVMVariableAccessCollector >> variableSubset: anObject [ + + variableSubset := anObject +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitAssignmentNode: aTAssignmentNode [ + + aTAssignmentNode variable accept: self. + aTAssignmentNode expression accept: self. +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitCastStatementNode: aTCaseStmtNode [ + + "Do not recurse on children of a case statement. + Children will be recursed as separate statements" + aTCaseStmtNode expression accept: self +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitConstantNode: aTConstantNode [ + + "Nothing for constants" +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitInlineNode: aTInlineNode [ + + "Do not recurse on children of an inline statement. + Children will be recursed as separate statements" +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitLabeledCommentNode: aTLabeledCommentNode [ + + "Nothing for now?" +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitReturnNode: aTReturnNode [ + + "If we are doing a return node, we should externalize everything" + accessedVariables addAll: variableSubset +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitSendNode: aTSendNode [ + + aTSendNode receiver accept: self. + aTSendNode arguments do: [ :argument | argument accept: self ]. + self analyzeCallGraphFromMessageSend: aTSendNode +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitStatementListNode: aTStatementListNode [ + + aTStatementListNode statements do: [ :e | e accept: self ] +] + +{ #category : #visiting } +MLVMVariableAccessCollector >> visitVariableNode: aTVariableNode [ + + (variableSubset includes: aTVariableNode name) + ifTrue: [ accessedVariables add: aTVariableNode name ] +] diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index e0eeb5b743..70e8fd9bd2 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -25,6 +25,12 @@ TAssignmentNode class >> variableNamed: aVariableName expression: anExpression [ yourself ] +{ #category : #visiting } +TAssignmentNode >> accept: aVisitor [ + + ^ aVisitor visitAssignmentNode: self +] + { #category : #'C code generation' } TAssignmentNode >> asCASTExpressionIn: aCodeGen [ @@ -166,6 +172,12 @@ TAssignmentNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. ] +{ #category : #accessing } +TAssignmentNode >> children [ + + ^ { variable . expression } +] + { #category : #accessing } TAssignmentNode >> expression [ diff --git a/smalltalksrc/Slang/TCaseStmtNode.class.st b/smalltalksrc/Slang/TCaseStmtNode.class.st index 712c7202aa..a4950f5eda 100644 --- a/smalltalksrc/Slang/TCaseStmtNode.class.st +++ b/smalltalksrc/Slang/TCaseStmtNode.class.st @@ -32,6 +32,12 @@ TCaseStmtNode class >> newWithExpression: anExpression selectors: aCollectionOfS yourself ] +{ #category : #visiting } +TCaseStmtNode >> accept: aVisitor [ + + ^ aVisitor visitCastStatementNode: self +] + { #category : #tranforming } TCaseStmtNode >> asCASTIn: aBuilder [ @@ -147,6 +153,12 @@ TCaseStmtNode >> cases [ ^cases ] +{ #category : #accessing } +TCaseStmtNode >> children [ + + ^ { expression }, cases +] + { #category : #transformations } TCaseStmtNode >> customizeCase: caseParseTree forVar: varName from: firstIndex to: lastIndex in: codeGen method: aTMethod expandedCases: seen [ "Return a collection of copies of the given parse tree, each of which has the value of the case index substituted for the given variable." diff --git a/smalltalksrc/Slang/TConstantNode.class.st b/smalltalksrc/Slang/TConstantNode.class.st index 7b9ad382dc..43d79f69d4 100644 --- a/smalltalksrc/Slang/TConstantNode.class.st +++ b/smalltalksrc/Slang/TConstantNode.class.st @@ -21,6 +21,12 @@ TConstantNode >> = aNode [ ^ aNode isConstant and: [ value = aNode value ] ] +{ #category : #visiting } +TConstantNode >> accept: aVisitor [ + + ^ aVisitor visitConstantNode: self +] + { #category : #tranforming } TConstantNode >> asCASTIn: aBuilder [ @@ -35,6 +41,12 @@ TConstantNode >> asPrintfFormatStringNode [ yourself ] +{ #category : #accessing } +TConstantNode >> children [ + + ^ #() +] + { #category : #accessing } TConstantNode >> constantNumbericValueIfAtAllPossibleOrNilIn: aCCodeGen [ "This is a version of constantNumbericValueOrNil for type checking rather than code generation. diff --git a/smalltalksrc/Slang/TInlineNode.class.st b/smalltalksrc/Slang/TInlineNode.class.st index 3d0d2ff657..294fa73230 100644 --- a/smalltalksrc/Slang/TInlineNode.class.st +++ b/smalltalksrc/Slang/TInlineNode.class.st @@ -7,6 +7,12 @@ Class { #category : #'Slang-AST' } +{ #category : #visiting } +TInlineNode >> accept: aVisitor [ + + ^ aVisitor visitInlineNode: self +] + { #category : #tranforming } TInlineNode >> asCASTIn: aBuilder [ @@ -46,6 +52,12 @@ TInlineNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ ] +{ #category : #accessing } +TInlineNode >> children [ + + ^ { method } +] + { #category : #testing } TInlineNode >> isInline [ ^true diff --git a/smalltalksrc/Slang/TLabeledCommentNode.class.st b/smalltalksrc/Slang/TLabeledCommentNode.class.st index f532b9bb7d..e5ee72fc17 100644 --- a/smalltalksrc/Slang/TLabeledCommentNode.class.st +++ b/smalltalksrc/Slang/TLabeledCommentNode.class.st @@ -27,6 +27,12 @@ TLabeledCommentNode class >> withComment: aComment [ yourself ] +{ #category : #visiting } +TLabeledCommentNode >> accept: aVisitor [ + + ^ aVisitor visitLabeledCommentNode: self +] + { #category : #tranforming } TLabeledCommentNode >> asCASTIn: aBuilder [ @@ -71,6 +77,12 @@ TLabeledCommentNode >> asmLabel: labelString [ asmLabel := labelString ] +{ #category : #accessing } +TLabeledCommentNode >> children [ + + ^ #() +] + { #category : #testing } TLabeledCommentNode >> isComment [ "Answer true if the receiver is just a comment (i.e., it has no label)." diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 0e5cbac560..faa789e377 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -173,6 +173,22 @@ TMethod >> allReferencedVariablesUsing: aCodeGen [ ^refs ] +{ #category : #accessing } +TMethod >> allStatements [ + + | statements | + statements := OrderedCollection new. + self allStatementsDo: [ :statement | statements add: statement ]. + ^ statements +] + +{ #category : #accessing } +TMethod >> allStatementsDo: aFullBlockClosure [ + + "Iterate all statements in the tree with a block closure" + parseTree allStatementsDo: aFullBlockClosure +] + { #category : #inlining } TMethod >> argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeGen [ @@ -565,6 +581,12 @@ TMethod >> checkedDeclarationAt: aVariableName put: aDeclaration in: aCCodeGen [ ^self declarationAt: aVariableName "" put: aDeclaration ] +{ #category : #accessing } +TMethod >> children [ + + ^ { parseTree } +] + { #category : #accessing } TMethod >> clearReferencesToGlobalStruct [ globalStructureBuildMethodHasFoo := false @@ -1662,6 +1684,13 @@ TMethod >> inlineableSend: aNode in: aCodeGen [ or: [m checkForRequiredInlinability]]]] ] +{ #category : #accessing } +TMethod >> inspectionTree [ + + + ^ parseTree inspectionTree +] + { #category : #'primitive compilation' } TMethod >> instVarGetExprFor: varName offset: instIndex [ "Return the parse tree for an expression that fetches and converts the value of the instance variable at the given offset." diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index ee4c1b9b34..ec59f29954 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -10,6 +10,12 @@ Class { #category : #'Slang-AST' } +{ #category : #visiting } +TParseNode >> accept: aVisitor [ + + self subclassResponsibility +] + { #category : #utilities } TParseNode >> allCalls [ "Answer a collection of selectors for the messages sent in this parse tree." @@ -39,6 +45,12 @@ TParseNode >> allSatisfy: aBlock unless: cautionaryBlock [ ^true ] +{ #category : #enumerating } +TParseNode >> allStatementsDo: aFullBlockClosure [ + + self children do: [ :child | child allStatementsDo: aFullBlockClosure ] +] + { #category : #enumerating } TParseNode >> anySatisfy: aBlock [ self nodesDo: [:n| (aBlock value: n) ifTrue: [^true]]. @@ -112,9 +124,8 @@ TParseNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ { #category : #enumerating } TParseNode >> collect: aBlock [ | nodes | - self halt. "This is a misnomer; should be deleted" nodes := OrderedCollection new. - self nodesDo: [:n| (aBlock value: n) ifTrue: [nodes add: n]]. + self nodesDo: [:n| nodes add: (aBlock value: n) ]. ^nodes ] @@ -316,8 +327,30 @@ TParseNode >> isVariable [ { #category : #linearization } TParseNode >> linearizeIn: aCodeGenerator [ - "I am a statement. Linearize myself until I find a block." + "I am a statement. Linearize all calls in myself until I find a block. + For example, I transform statements of the form: + + > self foo: self nonInlinedMethodUsingAutolocalizedVariable + + into + + > t0 := self nonInlinedMethodUsingAutolocalizedVariable + > t1 := self foo: t0 + + Such localization happens on a per-block basis: + + > someExpression ifTrue: [ + > self foo: self nonInlinedMethodUsingAutolocalizedVariable + > ] + into + + > someExpression ifTrue: [ + > | t0 t1 | + > t0 := self nonInlinedMethodUsingAutolocalizedVariable. + > t1 := self foo: t0 + > ] + " | replacementDictionary rewrittenStatement callsInStatement replacementBlock replacementsSoFar | replacementDictionary := Dictionary new. diff --git a/smalltalksrc/Slang/TReturnNode.class.st b/smalltalksrc/Slang/TReturnNode.class.st index a7c46fc06e..37186cf3fe 100644 --- a/smalltalksrc/Slang/TReturnNode.class.st +++ b/smalltalksrc/Slang/TReturnNode.class.st @@ -24,6 +24,12 @@ TReturnNode >> = aNode [ ^ true ] +{ #category : #visiting } +TReturnNode >> accept: aVisitor [ + + ^ aVisitor visitReturnNode: self +] + { #category : #tranforming } TReturnNode >> asCASTIn: aBuilder [ @@ -93,6 +99,12 @@ TReturnNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. ] +{ #category : #accessing } +TReturnNode >> children [ + + ^ { expression } +] + { #category : #transformations } TReturnNode >> copyWithoutReturn [ ^expression diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index a817414331..06307e251e 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -39,6 +39,12 @@ TSendNode >> = aNode [ ^ true ] +{ #category : #visiting } +TSendNode >> accept: aVisitor [ + + ^ aVisitor visitSendNode: self +] + { #category : #accessing } TSendNode >> args [ @@ -257,6 +263,12 @@ TSendNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ arguments := arguments collect: [ :a | a bindVariablesIn: aDictionary unless: cautionaryBlock]. ] +{ #category : #accessing } +TSendNode >> children [ + + ^ { receiver }, arguments +] + { #category : #accessing } TSendNode >> constantNumbericValueIfAtAllPossibleOrNilIn: aCCodeGen [ "This is a version of constantNumbericValueOrNil for type checking rather than code generation. diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 243e9a9c30..d245b6d407 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -27,6 +27,12 @@ TStatementListNode >> = aNode [ ^ true ] +{ #category : #visiting } +TStatementListNode >> accept: aVisitor [ + + ^ aVisitor visitStatementListNode: self +] + { #category : #utilities } TStatementListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned assignments: assigned in: aCodeGen [ @@ -97,6 +103,14 @@ TStatementListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned ^ assigned ] +{ #category : #enumerating } +TStatementListNode >> allStatementsDo: aFullBlockClosure [ + + statements do: [ :statement | + aFullBlockClosure value: statement. + statement allStatementsDo: aFullBlockClosure ]. +] + { #category : #accessing } TStatementListNode >> args [ @@ -235,7 +249,7 @@ TStatementListNode >> endsWithReturn [ { #category : #flattening } TStatementListNode >> flattened [ - + ^ statements flatCollect: [ :each | each flattened ] ] diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index 3056446868..750ea3f513 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -21,6 +21,12 @@ TVariableNode class >> selfNode [ ^ self named: 'self' ] +{ #category : #visiting } +TVariableNode >> accept: aVisitor [ + + ^ aVisitor visitVariableNode: self +] + { #category : #tranforming } TVariableNode >> asCASTIn: aBuilder [ @@ -55,6 +61,12 @@ TVariableNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ ^ (aDictionary at: name ifAbsent: [^ self]) copy ] +{ #category : #accessing } +TVariableNode >> children [ + + ^ #() +] + { #category : #testing } TVariableNode >> hasSideEffect [ "Answer if the parse tree rooted at this node has a side-effect or not." diff --git a/smalltalksrc/VMMaker-Tools/TParseNode.extension.st b/smalltalksrc/VMMaker-Tools/TParseNode.extension.st new file mode 100644 index 0000000000..0bfcb470bf --- /dev/null +++ b/smalltalksrc/VMMaker-Tools/TParseNode.extension.st @@ -0,0 +1,21 @@ +Extension { #name : #TParseNode } + +{ #category : #'*VMMaker-Tools' } +TParseNode >> inspectionTree [ + + + ^ SpTreePresenter new + roots: { self }; + children: [ :aNode | aNode children ]; + display: [ :each | + String + streamContents: [ :stream | + stream + nextPutAll: each class name; + nextPut: $(; + nextPutAll: ((each asString truncateTo: 50) copyReplaceAll: String cr with: String space); + nextPut: $) + ] ]; + expandAll; + yourself +] diff --git a/smalltalksrc/VMMakerTests/VMMASTTranslationTest.class.st b/smalltalksrc/VMMakerTests/VMMASTTranslationTest.class.st index 3d47524d09..047332478f 100644 --- a/smalltalksrc/VMMakerTests/VMMASTTranslationTest.class.st +++ b/smalltalksrc/VMMakerTests/VMMASTTranslationTest.class.st @@ -138,8 +138,8 @@ VMMASTTranslationTest >> testComplexIfNilIfNotNilWithArgument [ conditional := translation parseTree statements second. self assert: conditional isSend. self assert: conditional selector equals: #ifTrue:ifFalse:. - self assert: conditional args first isStmtList. - self assert: conditional args second isStmtList. + self assert: conditional args first isStatementList. + self assert: conditional args second isStatementList. self assert: conditional args first args isEmpty. self assert: conditional args second args notEmpty. @@ -170,8 +170,8 @@ VMMASTTranslationTest >> testComplexIfNotNilIfNilWithArgument [ conditional := translation parseTree statements second. self assert: conditional isSend. self assert: conditional selector equals: #ifTrue:ifFalse:. - self assert: conditional args first isStmtList. - self assert: conditional args second isStmtList. + self assert: conditional args first isStatementList. + self assert: conditional args second isStatementList. self assert: conditional args first args isEmpty. self assert: conditional args second args notEmpty. @@ -199,7 +199,7 @@ VMMASTTranslationTest >> testComplexIfNotNilWithArgument [ conditional := translation parseTree statements second. self assert: conditional isSend. self assert: conditional selector equals: #ifFalse:. - self assert: conditional args first isStmtList. + self assert: conditional args first isStatementList. self assert: conditional args first args notEmpty. condition := conditional receiver. From 246d497f19e800b05ef199ab9c7cd490df35ce60 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:48:14 +0100 Subject: [PATCH 32/75] Introducing node parents to be able to do O(1) replacement --- smalltalksrc/Slang/TAssignmentNode.class.st | 63 ++++++-- smalltalksrc/Slang/TBraceCaseNode.class.st | 37 +++-- smalltalksrc/Slang/TCaseStmtNode.class.st | 102 ++++++------ smalltalksrc/Slang/TGoToNode.class.st | 12 ++ smalltalksrc/Slang/TInlineNode.class.st | 6 + smalltalksrc/Slang/TMethod.class.st | 145 +++++++++--------- smalltalksrc/Slang/TParseNode.class.st | 25 +++ smalltalksrc/Slang/TSendNode.class.st | 29 ++-- .../Slang/TStatementListNode.class.st | 76 ++++++--- smalltalksrc/Slang/TSwitchStmtNode.class.st | 10 +- 10 files changed, 316 insertions(+), 189 deletions(-) diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index 70e8fd9bd2..eed1e6f0ec 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -140,7 +140,7 @@ TAssignmentNode >> asCASTValueExpansionIn: aCodeGen [ TAssignmentNode >> bindVariableUsesIn: aDictionary [ "Do NOT bind the variable on the left-hand-side of an assignment statement." "was bindVariablesIn:" - expression := expression bindVariableUsesIn: aDictionary. + self expression: (expression bindVariableUsesIn: aDictionary). ] @@ -160,16 +160,16 @@ TAssignmentNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFo { #category : #transformations } TAssignmentNode >> bindVariablesIn: aDictionary [ - variable := variable bindVariablesIn: aDictionary. - expression := expression bindVariablesIn: aDictionary. + self variable: (variable bindVariablesIn: aDictionary). + self expression: (expression bindVariablesIn: aDictionary). ] { #category : #transformations } TAssignmentNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ (cautionaryBlock value: self) ifTrue: [^self]. - variable := variable bindVariablesIn: aDictionary unless: cautionaryBlock. - expression := expression bindVariablesIn: aDictionary unless: cautionaryBlock. + self variable: (variable bindVariablesIn: aDictionary unless: cautionaryBlock). + self expression: (expression bindVariablesIn: aDictionary unless: cautionaryBlock). ] { #category : #accessing } @@ -184,6 +184,19 @@ TAssignmentNode >> expression [ ^expression ] +{ #category : #accessing } +TAssignmentNode >> expression: anExpression [ + + | oldExpression | + oldExpression := expression. + expression := anExpression. + expression parent: self. + + oldExpression ifNil: [ ^ self ]. + oldExpression ~= variable + ifTrue: [ oldExpression parent: nil ] +] + { #category : #testing } TAssignmentNode >> isAssignment [ @@ -249,8 +262,8 @@ TAssignmentNode >> nodesDo: aBlock unless: cautionaryBlock [ { #category : #copying } TAssignmentNode >> postCopy [ - variable := variable copy. - expression := expression copy + self variable: variable copy. + self expression: expression copy ] { #category : #'C code generation' } @@ -279,25 +292,28 @@ TAssignmentNode >> removeAssertions [ ] { #category : #transformations } -TAssignmentNode >> replaceNodesIn: aDictionary [ +TAssignmentNode >> replaceChild: aNode with: aReplacementNode [ - ^aDictionary at: self ifAbsent: [ - variable := variable replaceNodesIn: aDictionary. - expression := expression replaceNodesIn: aDictionary. - self] + variable == aNode ifTrue: [ + self variable: aReplacementNode ]. + expression == aNode ifTrue: [ + self expression: aReplacementNode ] ] -{ #category : #accessing } -TAssignmentNode >> setExpression: expressionNode [ +{ #category : #transformations } +TAssignmentNode >> replaceNodesIn: aDictionary [ - expression := expressionNode + ^aDictionary at: self ifAbsent: [ + self variable: (variable replaceNodesIn: aDictionary). + self expression: (expression replaceNodesIn: aDictionary). + self] ] { #category : #accessing } TAssignmentNode >> setVariable: varNode expression: expressionNode [ self assert: (expressionNode isGoTo or: [expressionNode isLabel]) not. - variable := varNode. - expression := expressionNode. + self variable: varNode. + self expression: expressionNode. ] { #category : #testing } @@ -321,6 +337,19 @@ TAssignmentNode >> variable [ ^variable ] +{ #category : #accessing } +TAssignmentNode >> variable: anObject [ + + | oldVariable | + oldVariable := variable. + variable := anObject. + variable parent: self. + + oldVariable ifNil: [ ^ self ]. + oldVariable ~= variable + ifTrue: [ oldVariable parent: nil ] +] + { #category : #accessing } TAssignmentNode >> variableNameOrNil [ ^variable variableNameOrNil diff --git a/smalltalksrc/Slang/TBraceCaseNode.class.st b/smalltalksrc/Slang/TBraceCaseNode.class.st index 803c748389..6e5cb28ebd 100644 --- a/smalltalksrc/Slang/TBraceCaseNode.class.st +++ b/smalltalksrc/Slang/TBraceCaseNode.class.st @@ -3,7 +3,8 @@ Class { #superclass : #TParseNode, #instVars : [ 'caseLabels', - 'cases' + 'cases', + 'oldCases' ], #category : #'Slang-AST' } @@ -11,8 +12,8 @@ Class { { #category : #transformations } TBraceCaseNode >> bindVariableUsesIn: aDictionary [ - caseLabels := caseLabels collect: [:node| node bindVariableUsesIn: aDictionary]. - cases := cases collect: [:node| node bindVariableUsesIn: aDictionary] + self caseLabels: (caseLabels collect: [:node| node bindVariableUsesIn: aDictionary]). + self cases: (cases collect: [:node| node bindVariableUsesIn: aDictionary]) ] { #category : #transformations } @@ -33,16 +34,16 @@ TBraceCaseNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFol { #category : #transformations } TBraceCaseNode >> bindVariablesIn: aDictionary [ - caseLabels := caseLabels collect: [:node| node bindVariablesIn: aDictionary]. - cases := cases collect: [:node| node bindVariablesIn: aDictionary] + self caseLabels: (caseLabels collect: [:node| node bindVariablesIn: aDictionary]). + self cases: (cases collect: [:node| node bindVariablesIn: aDictionary]) ] { #category : #transformations } TBraceCaseNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ (cautionaryBlock value: self) ifTrue: [^self]. - caseLabels := caseLabels collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock]. - cases := cases collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock] + self caseLabels: (caseLabels collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock]). + self cases: (cases collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock]) ] { #category : #accessing } @@ -56,7 +57,14 @@ TBraceCaseNode >> caseLabels [ TBraceCaseNode >> caseLabels: anObject [ "Set the value of caseLabels" - caseLabels := anObject + | oldLabels | + oldLabels := caseLabels. + caseLabels := anObject. + caseLabels do: [ :e | e parent: self ]. + + oldLabels ifNil: [ ^ self ]. + (oldLabels difference: caseLabels) + do: [ :e | e parent: nil ] ] { #category : #accessing } @@ -70,7 +78,14 @@ TBraceCaseNode >> cases [ TBraceCaseNode >> cases: anObject [ "Set the value of cases" - cases := anObject + oldCases := cases. + cases := anObject. + + cases do: [ :e | e parent: self ]. + + oldCases ifNil: [ ^ self ]. + (oldCases difference: cases) + do: [ :e | e parent: nil ]. ] { #category : #enumerating } @@ -121,8 +136,8 @@ TBraceCaseNode >> nodesDo: aBlock unless: cautionaryBlock [ TBraceCaseNode >> replaceNodesIn: aDictionary [ ^aDictionary at: self ifAbsent: [ - caseLabels := caseLabels collect: [:node| node replaceNodesIn: aDictionary]. - cases := cases collect: [:node| node replaceNodesIn: aDictionary]. + self caseLabels: (caseLabels collect: [:node| node replaceNodesIn: aDictionary]). + self cases: (cases collect: [:node| node replaceNodesIn: aDictionary]). self] ] diff --git a/smalltalksrc/Slang/TCaseStmtNode.class.st b/smalltalksrc/Slang/TCaseStmtNode.class.st index a4950f5eda..c254bbfc8d 100644 --- a/smalltalksrc/Slang/TCaseStmtNode.class.st +++ b/smalltalksrc/Slang/TCaseStmtNode.class.st @@ -298,67 +298,67 @@ TCaseStmtNode >> printOn: aStream level: level [ { #category : #transformations } TCaseStmtNode >> processSharedCodeBlocks: caseTree forCase: caseIndex in: codeGen method: aTMethod expandedCases: seen [ + "Process any shared code blocks in the case parse tree for the given case, either inlining them or making them a 'goto sharedLabel'." + | caseMethod map meth sharedNode exitLabel | exitLabel := nil. "caseTree is expected to be a TStmtListNode whose first element is a comment and whose second element is a TInlineNode for a method." caseMethod := caseTree statements second method. - [sharedNode := nil. - map := IdentityDictionary new. - caseTree nodesDo: - [:node| - (sharedNode isNil - and: [node isSend - and:[(meth := codeGen methodNamed: node selector) notNil - and:[meth sharedCase notNil]]]) ifTrue: - [(meth sharedCase = (meth sharedCase isSymbol - ifTrue: [caseMethod selector] - ifFalse: [caseIndex]) - and: [(seen includes: meth sharedLabel) not]) - ifTrue: - ["If the bytecode (the caseMethod) ends with a message that has a lastCase (and lastLabel) then + [ + sharedNode := nil. + map := IdentityDictionary new. + caseTree nodesDo: [ :node | + (sharedNode isNil and: [ + node isSend and: [ + (meth := codeGen methodNamed: node selector) notNil and: [ + meth sharedCase notNil ] ] ]) ifTrue: [ + (meth sharedCase = (meth sharedCase isSymbol + ifTrue: [ caseMethod selector ] + ifFalse: [ caseIndex ]) and: [ + (seen includes: meth sharedLabel) not ]) + ifTrue: [ "If the bytecode (the caseMethod) ends with a message that has a lastCase (and lastLabel) then that will be converted into a goto and control will continue to that code, If the bytecode does /not/ end with a message that has a lastCase (and lastLabel) then control should not continue to that shared case. expandViaFallThrough captures this, true for the former, false for the latter." - | expandViaFallThrough | - expandViaFallThrough := false. - caseMethod statements last isSend ifTrue: - [(codeGen methodNamed: caseMethod statements last selector) ifNotNil: - [:m| expandViaFallThrough := m sharedCase notNil]]. - seen add: meth sharedLabel. - map - at: node - put: (expandViaFallThrough - ifTrue: [sharedNode := meth. - TLabeledCommentNode new setComment: 'goto ', meth sharedLabel] - ifFalse: ["Still need recursive expansjon to continue but don't want + | expandViaFallThrough | + expandViaFallThrough := false. + caseMethod statements last isSend ifTrue: [ + (codeGen methodNamed: caseMethod statements last selector) + ifNotNil: [ :m | expandViaFallThrough := m sharedCase notNil ] ]. + seen add: meth sharedLabel. + map at: node put: (expandViaFallThrough + ifTrue: [ + sharedNode := meth. + TLabeledCommentNode new setComment: + 'goto ' , meth sharedLabel ] + ifFalse: [ "Still need recursive expansjon to continue but don't want to duplicate the node, so substitue an empty method." - sharedNode := TLabeledCommentNode new setComment: 'null '. - meth copy - renameLabelsForInliningInto: aTMethod; - addLabelsTo: aTMethod; - asInlineNode])] - ifFalse: - [map at: node put: (TGoToNode label: meth sharedLabel)]]]. - caseTree replaceNodesIn: map. - "recursively expand" - sharedNode notNil] - whileTrue: - [sharedNode isTMethod ifTrue: - [meth := sharedNode copy. - meth hasReturn ifTrue: - [exitLabel ifNil: - [exitLabel := aTMethod unusedLabelForInliningInto: aTMethod. - aTMethod labels add: exitLabel]. - meth exitVar: nil label: exitLabel]. - meth - renameLabelsForInliningInto: aTMethod; - addLabelsTo: aTMethod. - caseTree setStatements: (caseTree statements copyWith: meth asInlineNode)]]. - exitLabel ifNotNil: - [caseTree setStatements: (caseTree statements copyWith: - (TLabeledCommentNode new setLabel: exitLabel comment: 'end case'))] + sharedNode := TLabeledCommentNode new setComment: 'null '. + meth copy + renameLabelsForInliningInto: aTMethod; + addLabelsTo: aTMethod; + asInlineNode ]) ] + ifFalse: [ map at: node put: (TGoToNode label: meth sharedLabel) ] ] ]. + caseTree replaceNodesIn: map. + "recursively expand" + sharedNode notNil ] whileTrue: [ + sharedNode isTMethod ifTrue: [ + meth := sharedNode copy. + meth hasReturn ifTrue: [ + exitLabel ifNil: [ + exitLabel := aTMethod unusedLabelForInliningInto: aTMethod. + aTMethod labels add: exitLabel ]. + meth exitVar: nil label: exitLabel ]. + meth + renameLabelsForInliningInto: aTMethod; + addLabelsTo: aTMethod. + caseTree statements: + (caseTree statements copyWith: meth asInlineNode) ] ]. + exitLabel ifNotNil: [ + caseTree statements: (caseTree statements copyWith: + (TLabeledCommentNode new setLabel: exitLabel comment: 'end case')) ] ] { #category : #transformations } diff --git a/smalltalksrc/Slang/TGoToNode.class.st b/smalltalksrc/Slang/TGoToNode.class.st index 510f324262..4ef8843b1c 100644 --- a/smalltalksrc/Slang/TGoToNode.class.st +++ b/smalltalksrc/Slang/TGoToNode.class.st @@ -15,6 +15,12 @@ TGoToNode class >> label: aLabel [ yourself ] +{ #category : #visiting } +TGoToNode >> accept: aVisitor [ + + ^ aVisitor visitGoToNode: self +] + { #category : #tranforming } TGoToNode >> asCASTIn: aCCodeGenerator [ ^ CGotoStatementNode identifier: label @@ -25,6 +31,12 @@ TGoToNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ ^ self asCASTExpressionIn: aBuilder ] +{ #category : #accessing } +TGoToNode >> children [ + + ^ #() +] + { #category : #testing } TGoToNode >> isGoTo [ diff --git a/smalltalksrc/Slang/TInlineNode.class.st b/smalltalksrc/Slang/TInlineNode.class.st index 294fa73230..d657fac2f8 100644 --- a/smalltalksrc/Slang/TInlineNode.class.st +++ b/smalltalksrc/Slang/TInlineNode.class.st @@ -132,3 +132,9 @@ TInlineNode >> shouldExpand [ TInlineNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ ^method returnType ] + +{ #category : #comparing } +TInlineNode >> whoNotSameAs: aTParseNode [ + + ^ method parseTree whoNotSameAs: aTParseNode method parseTree +] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index faa789e377..5a4c355905 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -731,17 +731,18 @@ TMethod >> determineTypeFor: aNode in: aCodeGen [ { #category : #transformations } TMethod >> elideAnyFinalReturn [ + "For super expansions we need to eliminate any final return to prevent premature exit. Anything meaningful in the returned expression must be retained." | stmtList expr | stmtList := parseTree statements asOrderedCollection. - stmtList last isReturn ifTrue: - [expr := stmtList last expression. - (expr isVariable and: [expr name = 'self']) - ifTrue: [stmtList := stmtList allButLast] - ifFalse: [stmtList at: stmtList size put: expr]. - parseTree setStatements: stmtList] + stmtList last isReturn ifTrue: [ + expr := stmtList last expression. + (expr isVariable and: [ expr name = 'self' ]) + ifTrue: [ stmtList := stmtList allButLast ] + ifFalse: [ stmtList at: stmtList size put: expr ]. + parseTree statements: stmtList ] ] { #category : #'C code generation' } @@ -1492,7 +1493,7 @@ TMethod >> inlineMethod: meth inCaseStatement: stmtNode [ addFirst: meth asInlineNode; addFirst: (TLabeledCommentNode new setComment: meth selector). - stmtNode setStatements: newStatements. + stmtNode statements: newStatements ] { #category : #inlining } @@ -2090,7 +2091,7 @@ TMethod >> newCascadeTempFor: aTParseNode [ [:node| (node isAssignment and: [node variable name = varName]) ifTrue: - [node setExpression: (TSendNode new + [node expression: (TSendNode new setSelector: #addressOf: receiver: (TVariableNode new setName: 'self') arguments: {node expression})]]]. @@ -2410,6 +2411,7 @@ TMethod >> readsVariable: variableName [ { #category : #transformations } TMethod >> recordDeclarationsIn: aCCodeGen [ + "Record C type declarations of the forms @@ -2421,56 +2423,50 @@ TMethod >> recordDeclarationsIn: aCCodeGen [ and remove the declarations from the method body." | newStatements | - properties pragmas notEmpty - ifTrue: [ properties pragmas - do: [ :pragma | - pragma selector == #var:declareC: - ifTrue: [ self - checkedDeclarationAt: pragma arguments first asString - put: pragma arguments last - in: aCCodeGen ]. - pragma selector == #var:type: - ifTrue: [ | varName varType | - varName := pragma arguments first asString. - varType := aCCodeGen - conventionalTypeForType: pragma arguments last. - varType last == $* - ifFalse: [ varType := varType , ' ' ]. - self - checkedDeclarationAt: varName - put: varType , varName - in: aCCodeGen ]. - pragma selector = #returnTypeC: - ifTrue: [ self returnType: pragma arguments last ]. - pragma selector = #doNotGenerate: - ifTrue: [ locals remove: pragma arguments last ] ]. - ^ self ]. + properties pragmas notEmpty ifTrue: [ + properties pragmas do: [ :pragma | + pragma selector == #var:declareC: ifTrue: [ + self + checkedDeclarationAt: pragma arguments first asString + put: pragma arguments last + in: aCCodeGen ]. + pragma selector == #var:type: ifTrue: [ + | varName varType | + varName := pragma arguments first asString. + varType := aCCodeGen conventionalTypeForType: + pragma arguments last. + varType last == $* ifFalse: [ varType := varType , ' ' ]. + self + checkedDeclarationAt: varName + put: varType , varName + in: aCCodeGen ]. + pragma selector = #returnTypeC: ifTrue: [ + self returnType: pragma arguments last ]. + pragma selector = #doNotGenerate: ifTrue: [ + locals remove: pragma arguments last ] ]. + ^ self ]. newStatements := OrderedCollection new: parseTree statements size. - parseTree statements - do: [ :stmt | - | isDeclaration | - isDeclaration := false. - stmt isSend - ifTrue: [ stmt selector == #var:declareC: - ifTrue: [ isDeclaration := true. - self - declarationAt: stmt args first value asString - put: stmt args last value ]. - stmt selector == #var:type: - ifTrue: [ | varName varType | - isDeclaration := true. - varName := stmt args first value asString. - varType := aCCodeGen - conventionalTypeForType: stmt args last value. - varType last == $* - ifFalse: [ varType := varType , ' ' ]. - self declarationAt: varName put: varType , varName ]. - stmt selector = #returnTypeC: - ifTrue: [ isDeclaration := true. - returnType := stmt args last value ] ]. - isDeclaration - ifFalse: [ newStatements add: stmt ] ]. - parseTree setStatements: newStatements asArray + parseTree statements do: [ :stmt | + | isDeclaration | + isDeclaration := false. + stmt isSend ifTrue: [ + stmt selector == #var:declareC: ifTrue: [ + isDeclaration := true. + self + declarationAt: stmt args first value asString + put: stmt args last value ]. + stmt selector == #var:type: ifTrue: [ + | varName varType | + isDeclaration := true. + varName := stmt args first value asString. + varType := aCCodeGen conventionalTypeForType: stmt args last value. + varType last == $* ifFalse: [ varType := varType , ' ' ]. + self declarationAt: varName put: varType , varName ]. + stmt selector = #returnTypeC: ifTrue: [ + isDeclaration := true. + returnType := stmt args last value ] ]. + isDeclaration ifFalse: [ newStatements add: stmt ] ]. + parseTree statements: newStatements asArray ] { #category : #accessing } @@ -2490,6 +2486,7 @@ TMethod >> removeAssertions [ { #category : #transformations } TMethod >> removeFinalSelfReturnIn: aCodeGenOrNil [ + "The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since in most VMMaker classes (except struct classes) the generated code has no notion of 'self' anyway. @@ -2498,19 +2495,23 @@ TMethod >> removeFinalSelfReturnIn: aCodeGenOrNil [ return type accordingly." | lastStmt | - parseTree statements isEmpty ifTrue: [^self]. - ((lastStmt := parseTree statements last) isReturn - and: [lastStmt expression isVariable - and: ['self' = lastStmt expression name]]) ifTrue: - [| tokens | - tokens := Scanner new scanTokens: (definingClass sourceCodeAt: selector ifAbsent: ['']). - (tokens size < 2 - or: [(tokens last: 2) ~= #(#'^' 'self')]) ifTrue: - [parseTree setStatements: parseTree statements allButLast. - (returnType isNil - and: [aCodeGenOrNil notNil - and: [parseTree noneSatisfy: [:node| node isReturn and: [node expression isVariable not or: [node expression name ~= 'self']]]]]) ifTrue: - [self returnType: (aCodeGenOrNil implicitReturnTypeFor: selector)]]] + parseTree statements isEmpty ifTrue: [ ^ self ]. + ((lastStmt := parseTree statements last) isReturn and: [ + lastStmt expression isVariable and: [ + 'self' = lastStmt expression name ] ]) ifTrue: [ + | tokens | + tokens := Scanner new scanTokens: + (definingClass sourceCodeAt: selector ifAbsent: [ '' ]). + (tokens size < 2 or: [ (tokens last: 2) ~= #( #'^' 'self' ) ]) + ifTrue: [ + parseTree statements: parseTree statements allButLast. + (returnType isNil and: [ + aCodeGenOrNil notNil and: [ + parseTree noneSatisfy: [ :node | + node isReturn and: [ + node expression isVariable not or: [ + node expression name ~= 'self' ] ] ] ] ]) ifTrue: [ + self returnType: (aCodeGenOrNil implicitReturnTypeFor: selector) ] ] ] ] { #category : #utilities } @@ -3117,6 +3118,8 @@ TMethod >> tryToInlineMethodStatementsIn: aCodeGen statementListsInto: aBlock [ stmtLists do: [ :stmtList | newStatements := OrderedCollection new: stmtList statements size. stmtList statements do: [ :stmt | + 1 haltIf: [ + stmt isSend and: [ stmt selector = #initStackPagesAndInterpret ] ]. (self inlineCodeOrNilForStatement: stmt returningNodes: returningNodes @@ -3125,7 +3128,7 @@ TMethod >> tryToInlineMethodStatementsIn: aCodeGen statementListsInto: aBlock [ ifNotNil: [ :inlinedStmts | didSomething := true. newStatements addAllLast: inlinedStmts ] ]. - stmtList setStatements: newStatements asArray ]. + stmtList statements: newStatements asArray ]. "This is a hack; forgive me. The inlining above tends to keep return statements in statement lists. In the case of returning ifs we don't want the returns in case the returning if is generated as an expression." diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index ec59f29954..68f67338a2 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -5,6 +5,7 @@ Class { #name : #TParseNode, #superclass : #Object, #instVars : [ + 'parent', 'comment' ], #category : #'Slang-AST' @@ -480,6 +481,18 @@ TParseNode >> occurrencesOf: aNode [ ^count ] +{ #category : #accessing } +TParseNode >> parent [ + + ^ parent +] + +{ #category : #accessing } +TParseNode >> parent: anObject [ + + parent := anObject +] + { #category : #printing } TParseNode >> printOn: aStream [ "Append a description of the receiver onto the given stream." @@ -499,6 +512,18 @@ TParseNode >> removeAssertions [ "default: do nothing" ] +{ #category : #transformations } +TParseNode >> replaceBy: aNode [ + + self parent replaceChild: self with: aNode +] + +{ #category : #transformations } +TParseNode >> replaceChild: aNode with: aReplacementNode [ + + self subclassResponsibility +] + { #category : #transformations } TParseNode >> replaceNodesIn: aDictionary [ diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index 06307e251e..f2cbd5ed8d 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -184,8 +184,8 @@ TSendNode >> asTransformedConstantPerform [ { #category : #transformations } TSendNode >> bindVariableUsesIn: aDictionary [ - receiver := receiver bindVariableUsesIn: aDictionary. - arguments := arguments collect: [ :a | a bindVariableUsesIn: aDictionary ]. + self receiver: (receiver bindVariableUsesIn: aDictionary). + self arguments: (arguments collect: [ :a | a bindVariableUsesIn: aDictionary ]). ] { #category : #transformations } @@ -251,16 +251,16 @@ TSendNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: { #category : #transformations } TSendNode >> bindVariablesIn: aDictionary [ - receiver := receiver bindVariablesIn: aDictionary. - arguments := arguments collect: [ :a | a bindVariablesIn: aDictionary ]. + self receiver: (receiver bindVariablesIn: aDictionary). + self arguments: (arguments collect: [ :a | a bindVariablesIn: aDictionary ]). ] { #category : #transformations } TSendNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ (cautionaryBlock value: self) ifTrue: [^self]. - receiver := receiver bindVariablesIn: aDictionary unless: cautionaryBlock. - arguments := arguments collect: [ :a | a bindVariablesIn: aDictionary unless: cautionaryBlock]. + self receiver: (receiver bindVariablesIn: aDictionary unless: cautionaryBlock). + self arguments: (arguments collect: [ :a | a bindVariablesIn: aDictionary unless: cautionaryBlock]). ] { #category : #accessing } @@ -467,8 +467,8 @@ TSendNode >> numArgs [ { #category : #copying } TSendNode >> postCopy [ - receiver := receiver copy. - arguments := (arguments collect: [ :arg | arg copy ]) + self receiver: receiver copy. + self arguments: (arguments collect: [ :arg | arg copy ]) ] { #category : #printing } @@ -519,8 +519,8 @@ TSendNode >> removeAssertions [ TSendNode >> replaceNodesIn: aDictionary [ ^aDictionary at: self ifAbsent: [ - receiver := receiver replaceNodesIn: aDictionary. - arguments := arguments collect: [ :a | a replaceNodesIn: aDictionary ]. + self receiver: (receiver replaceNodesIn: aDictionary). + self arguments: (arguments collect: [ :a | a replaceNodesIn: aDictionary ]). self] ] @@ -538,18 +538,15 @@ TSendNode >> selector: aSymbol [ { #category : #accessing } TSendNode >> setSelector: aSymbol receiver: rcvrNode arguments: argList [ - selector := aSymbol. - receiver := rcvrNode. - arguments := argList asArray. - isBuiltinOperator := false. + ^ self setSelector: aSymbol receiver: rcvrNode arguments: argList isBuiltInOp: false ] { #category : #accessing } TSendNode >> setSelector: aSymbol receiver: rcvrNode arguments: argList isBuiltInOp: builtinFlag [ selector := aSymbol. - receiver := rcvrNode. - arguments := argList asArray. + self receiver: rcvrNode. + self arguments: argList asArray. isBuiltinOperator := builtinFlag. ] diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index d245b6d407..6d6fd4a5a6 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -8,11 +8,19 @@ Class { #category : #'Slang-AST' } +{ #category : #'instance creation' } +TStatementListNode class >> parameters: parameters statements: statementList [ + + ^ self new + setArguments: parameters statements: statementList + yourself +] + { #category : #'instance creation' } TStatementListNode class >> statements: aCollection [ ^ self new - setStatements: aCollection; + statements: aCollection; yourself ] @@ -74,7 +82,7 @@ TStatementListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned node selector keywords) notEmpty ifTrue: [ "First find assignments in the expression..." (TStatementListNode new - setStatements: { node receiver }; + statements: { node receiver }; yourself) addReadBeforeAssignedIn: variables to: readBeforeAssigned @@ -180,33 +188,39 @@ TStatementListNode >> assignLastExpressionTo: variableNode [ { #category : #transformations } TStatementListNode >> bindVariableUsesIn: aDictionary [ - statements := statements collect: [ :s | s bindVariableUsesIn: aDictionary ]. + self statements: (statements collect: [ :s | s bindVariableUsesIn: aDictionary ]). ] { #category : #transformations } TStatementListNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen [ + "Answer either the receiver, if it contains no references to the given variables, or a new node with the given variables rebound." + | newStatements | - newStatements := statements collect: [:s| s bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold in: codeGen]. - ^newStatements = statements - ifTrue: [self] - ifFalse: - [self shallowCopy - setStatements: newStatements; - yourself] + newStatements := statements collect: [ :s | + s + bindVariableUsesIn: aDictionary + andConstantFoldIf: constantFold + in: codeGen ]. + ^ newStatements = statements + ifTrue: [ self ] + ifFalse: [ + self shallowCopy + statements: newStatements; + yourself ] ] { #category : #transformations } TStatementListNode >> bindVariablesIn: aDictionary [ - statements := statements collect: [ :s | s bindVariablesIn: aDictionary ]. + self statements: (statements collect: [ :s | s bindVariablesIn: aDictionary ]). ] { #category : #transformations } TStatementListNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ (cautionaryBlock value: self) ifTrue: [^self]. - statements := statements collect: [ :s | s bindVariablesIn: aDictionary unless: cautionaryBlock]. + self statements: (statements collect: [ :s | s bindVariablesIn: aDictionary unless: cautionaryBlock]). ] { #category : #enumerating } @@ -328,12 +342,17 @@ TStatementListNode >> nodesDo: aBlock value: parent [ aBlock value: self value: parent ] +{ #category : #accessing } +TStatementListNode >> parameterNames [ + + ^ arguments +] + { #category : #copying } TStatementListNode >> postCopy [ -1haltIf: [ arguments isNil ]. arguments := arguments copy. - statements := statements collect: [ :s | s copy ] + self statements: (statements collect: [ :s | s copy ]) ] { #category : #printing } @@ -383,7 +402,7 @@ TStatementListNode >> renameLabelsForInliningInto: aTMethod [ { #category : #transformations } TStatementListNode >> replaceChild: aNode with: bNode [ - statements := Array streamContents: + self statements: (Array streamContents: [:s| statements do: [:node| @@ -392,14 +411,14 @@ TStatementListNode >> replaceChild: aNode with: bNode [ [bNode isStatementList ifTrue: [s nextPutAll: bNode statements] ifFalse: [s nextPut: bNode]] - ifFalse: [s nextPut: node]]] + ifFalse: [s nextPut: node]]]) ] { #category : #transformations } TStatementListNode >> replaceNodesIn: aDictionary [ ^aDictionary at: self ifAbsent: [ - statements := statements collect: [ :s | s replaceNodesIn: aDictionary ]. + self statements: (statements collect: [ :s | s replaceNodesIn: aDictionary ]). self] ] @@ -420,23 +439,23 @@ TStatementListNode >> returnsExpression [ { #category : #accessing } TStatementListNode >> setArguments: argList [ -1haltIf: [ argList isNil ]. arguments := argList. ] { #category : #accessing } TStatementListNode >> setArguments: argList statements: statementList [ "Initialize this method using the given information." - -1haltIf: [ argList isNil ]. arguments := argList. - statements := statementList. + self statements: statementList. ] { #category : #accessing } TStatementListNode >> setStatements: stmtList [ - statements := stmtList asOrderedCollection. + self + deprecated: 'Call statements: pliz' + transformWith: '`@receiver setStatements: `@arg' -> '`@receiver statements: `@arg'. + self statements: stmtList. ] { #category : #inlining } @@ -450,6 +469,19 @@ TStatementListNode >> statements [ ^statements ] +{ #category : #accessing } +TStatementListNode >> statements: anObject [ + + | oldStatements | + oldStatements := statements. + statements := anObject asOrderedCollection. + statements do: [ :e | e parent: self ]. + + oldStatements ifNil: [ ^ self ]. + (oldStatements difference: statements) + do: [ :e | e parent: nil ]. +] + { #category : #'type inference' } TStatementListNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ ^statements isEmpty ifFalse: diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index 882016430a..45337c6d2d 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -157,7 +157,7 @@ TSwitchStmtNode >> asCASTIn: aBuilder addToEndOfCases: aNodeToPrependOrNil [ defaultExpr. (TConstantNode value: type) } ]. statements add: - ((aNodeToPrependOrNil copy setExpression: defaultExpr) asCASTIn: + ((aNodeToPrependOrNil copy expression: defaultExpr) asCASTIn: aBuilder) ]. ^ CSwitchStatementNode if: (expression asCASTExpressionIn: aBuilder) @@ -236,6 +236,14 @@ TSwitchStmtNode >> cases: anObject [ cases := anObject ] +{ #category : #accessing } +TSwitchStmtNode >> children [ + + ^ { expression }, + cases flattened, + (otherwiseOrNil ifNil: [ #() ] ifNotNil: [ {otherwiseOrNil} ]) +] + { #category : #'instance initialization' } TSwitchStmtNode >> createCasesFromBraceNode: aTBraceNode [ "Answer a sequence of tuples of { labels. case } for a TBraceNode, making From 7eb848347ee0c89ec89792842e47742bf27fc382 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:49:11 +0100 Subject: [PATCH 33/75] Extending visitor to switch --- .../Slang/MLVMVariableAccessCollector.class.st | 14 ++++++++++++++ smalltalksrc/Slang/TSwitchStmtNode.class.st | 6 ++++++ 2 files changed, 20 insertions(+) diff --git a/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st index 30049f8ac3..5e5be10185 100644 --- a/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st +++ b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st @@ -106,6 +106,12 @@ MLVMVariableAccessCollector >> visitConstantNode: aTConstantNode [ "Nothing for constants" ] +{ #category : #visiting } +MLVMVariableAccessCollector >> visitGoToNode: aTGoToNode [ + + "Nothing" +] + { #category : #visiting } MLVMVariableAccessCollector >> visitInlineNode: aTInlineNode [ @@ -140,6 +146,14 @@ MLVMVariableAccessCollector >> visitStatementListNode: aTStatementListNode [ aTStatementListNode statements do: [ :e | e accept: self ] ] +{ #category : #visiting } +MLVMVariableAccessCollector >> visitSwitchStatementNode: aTSwitchStmtNode [ + + "Do not recurse on children of a case statement. + Children will be recursed as separate statements" + aTSwitchStmtNode expression accept: self +] + { #category : #visiting } MLVMVariableAccessCollector >> visitVariableNode: aTVariableNode [ diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index 45337c6d2d..bc1d15510e 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -15,6 +15,12 @@ Class { #category : #'Slang-AST' } +{ #category : #visiting } +TSwitchStmtNode >> accept: aVisitor [ + + ^ aVisitor visitSwitchStatementNode: self +] + { #category : #transforming } TSwitchStmtNode >> asCASTExpressionIn: aBuilder [ From 56ae36c4a18c7e353377429adb7b3e9fab21aa05 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:50:17 +0100 Subject: [PATCH 34/75] Cleanups in StatementList instantiation --- smalltalksrc/Slang/CCodeGenerator.class.st | 4 ++-- .../RBAssignmentNode.extension.st | 6 ++---- .../RBMessageNode.extension.st | 18 ++++++++---------- 3 files changed, 12 insertions(+), 16 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index d2f0c161c3..de27e687e1 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -2594,7 +2594,7 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ finalNode := CBinaryOperatorNode operator: #<< left: leftNode - right: (arg asCASTIn: self). + right: (arg asCASTExpressionIn: self). mustCastBackToSign := typeIsUnsigned not. mustCastBackToSign ifTrue: [ | promotedType | @@ -2633,7 +2633,7 @@ CCodeGenerator >> generateCASTShiftRight: tast [ ^ CBinaryOperatorNode operator: #>> left: rcvr - right: (tast arguments first asCASTIn: self) + right: (tast arguments first asCASTExpressionIn: self) ] { #category : #'CAST translation' } diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st index 2371783f3b..cd96487a70 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st @@ -27,11 +27,9 @@ RBAssignmentNode >> asTranslatorNodeIn: aTMethod [ [self error: 'haven''t implemented pushing down assignments into other than the last return']. "As of 6/25/2012 19:30 superExpansionNodeFor:args: elides the final return." self assert: valueNode statements last isReturn not. - ^TStatementListNode new - setStatements: valueNode statements allButLast, + ^TStatementListNode statements: valueNode statements allButLast, { TAssignmentNode new setVariable: varNode expression: valueNode statements last; - comment: self commentOrNil }; - yourself + comment: self commentOrNil } ] diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st index f39dacc641..2d39838e93 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st @@ -65,9 +65,9 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ "If in the form of ifNil: [ :obj | ], replace that by an assignment and an ifFalse" ((usedSelector == #ifNotNil:) and: [ args first args notEmpty ]) ifTrue: [ - ^ TStatementListNode new - setArguments: #(); - setStatements: { + ^ TStatementListNode + parameters: #() + statements: { TAssignmentNode new setVariable: (TVariableNode new setName: args first args first) expression: rcvrOrNil. @@ -80,8 +80,7 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ arguments: {(TVariableNode new setName: 'nil')}; yourself) arguments: {args first} - }; - yourself ]. + } ]. (#(#ifNotNil:ifNil: #ifNil:ifNotNil:) includes: usedSelector) ifTrue: [ | comparand expression blockWithPossibleArgument | "We turn it always to an ifTrueIfFalse" @@ -101,9 +100,9 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ "If there is a variable we should epand the message as a statement" blockWithPossibleArgument args notEmpty ifTrue: [ - ^ TStatementListNode new - setArguments: #(); - setStatements: { + ^ TStatementListNode + parameters: #() + statements: { TAssignmentNode new setVariable: (TVariableNode new setName: blockWithPossibleArgument args first) expression: expression. @@ -112,8 +111,7 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ setSelector: usedSelector receiver: rcvrOrNil arguments: args - }; - yourself + } ] ]. (usedSelector == #ifNil:ifNotNil:) ifTrue: [ From 058941c352dfc755fcc667ed711e0eb52b6baba7 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:50:52 +0100 Subject: [PATCH 35/75] More cleanups in statement list instantiation --- smalltalksrc/Slang/CCodeGenerator.class.st | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index de27e687e1..f6d15b3be9 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -1792,7 +1792,7 @@ CCodeGenerator >> generateCASTDivide: tast [ CCodeGenerator >> generateCASTDoWhile: boolean loop: tast [ | block cond| - block := (TStatementListNode new setStatements: + block := (TStatementListNode statements: tast receiver statements allButLast) asCASTIn: self. cond := (tast receiver statements last asCASTExpressionIn: self). ^ CDoStatementNode @@ -2988,7 +2988,7 @@ CCodeGenerator >> generateCASTWhileForeverBreakIf: boolean loop: tast [ | block if cond | cond := (tast receiver statements last asCASTExpressionIn: self). if := CIfStatementNode if: (boolean ifTrue: [ cond ] ifFalse: [ CUnaryOperatorNode operator: #! expression: cond ]) then: (CBreakStatementNode new). - block := (TStatementListNode new setStatements: tast receiver statements allButLast) asCASTIn: self. + block := (TStatementListNode statements: tast receiver statements allButLast) asCASTIn: self. block add: if. block addAll: (tast arguments first asCASTIn: self). From 7f5afcaa8b09ca6f5e1bc3e630a3391114a76000 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:51:36 +0100 Subject: [PATCH 36/75] Extending isSameAs: for more types --- smalltalksrc/Slang/TCaseStmtNode.class.st | 16 ++++++++++++++++ smalltalksrc/Slang/TDefineNode.class.st | 4 +--- smalltalksrc/Slang/TGoToNode.class.st | 7 +++++++ smalltalksrc/Slang/TInlineNode.class.st | 8 ++++++++ .../Slang/TLabeledCommentNode.class.st | 7 +++++++ smalltalksrc/Slang/TParseNode.class.st | 2 +- smalltalksrc/Slang/TSwitchStmtNode.class.st | 19 +++++++++++++++++++ 7 files changed, 59 insertions(+), 4 deletions(-) diff --git a/smalltalksrc/Slang/TCaseStmtNode.class.st b/smalltalksrc/Slang/TCaseStmtNode.class.st index c254bbfc8d..148cbb7fbe 100644 --- a/smalltalksrc/Slang/TCaseStmtNode.class.st +++ b/smalltalksrc/Slang/TCaseStmtNode.class.st @@ -232,6 +232,22 @@ TCaseStmtNode >> isCaseStmt [ ^true ] +{ #category : #comparing } +TCaseStmtNode >> isSameAs: anotherNode [ + + anotherNode isCaseStmt ifFalse: [ ^ false ]. + (expression isSameAs: anotherNode expression) + ifFalse: [ ^ false ]. + + cases size ~= anotherNode cases size ifTrue: [ ^ false ]. + cases with: anotherNode cases collect: [ :case1 :case2 | + (case1 isSameAs: case2) + ]. + + "Apparently it went ok after all this" + ^ true +] + { #category : #enumerating } TCaseStmtNode >> nodesDo: aBlock [ "Apply aBlock to all nodes in the receiver. diff --git a/smalltalksrc/Slang/TDefineNode.class.st b/smalltalksrc/Slang/TDefineNode.class.st index 88f19443a4..9c9f76df99 100644 --- a/smalltalksrc/Slang/TDefineNode.class.st +++ b/smalltalksrc/Slang/TDefineNode.class.st @@ -36,9 +36,7 @@ TDefineNode >> isDefine [ { #category : #comparing } TDefineNode >> isSameAs: aTParseNode [ ^self class == aTParseNode class - and: [value class == aTParseNode value class - and: [value = aTParseNode value - and: [name = aTParseNode nameOrValue]]] + and: [name = aTParseNode nameOrValue] ] { #category : #accessing } diff --git a/smalltalksrc/Slang/TGoToNode.class.st b/smalltalksrc/Slang/TGoToNode.class.st index 4ef8843b1c..ea3f678354 100644 --- a/smalltalksrc/Slang/TGoToNode.class.st +++ b/smalltalksrc/Slang/TGoToNode.class.st @@ -43,6 +43,13 @@ TGoToNode >> isGoTo [ ^true ] +{ #category : #comparing } +TGoToNode >> isSameAs: aTGoToNode [ + + ^ aTGoToNode isGoTo + and: [ label = aTGoToNode label ] +] + { #category : #accessing } TGoToNode >> label [ diff --git a/smalltalksrc/Slang/TInlineNode.class.st b/smalltalksrc/Slang/TInlineNode.class.st index d657fac2f8..58bc686c97 100644 --- a/smalltalksrc/Slang/TInlineNode.class.st +++ b/smalltalksrc/Slang/TInlineNode.class.st @@ -63,6 +63,14 @@ TInlineNode >> isInline [ ^true ] +{ #category : #comparing } +TInlineNode >> isSameAs: anotherNode [ + + ^ anotherNode isInline + and: [ method selector = anotherNode method selector + and: [ method parseTree isSameAs: anotherNode method parseTree ] ] +] + { #category : #accessing } TInlineNode >> method [ ^method diff --git a/smalltalksrc/Slang/TLabeledCommentNode.class.st b/smalltalksrc/Slang/TLabeledCommentNode.class.st index e5ee72fc17..e04e8c66da 100644 --- a/smalltalksrc/Slang/TLabeledCommentNode.class.st +++ b/smalltalksrc/Slang/TLabeledCommentNode.class.st @@ -102,6 +102,13 @@ TLabeledCommentNode >> isLeaf [ ^true ] +{ #category : #comparing } +TLabeledCommentNode >> isSameAs: anotherNode [ + + ^anotherNode isLabel + and: [comment = anotherNode comment] +] + { #category : #accessing } TLabeledCommentNode >> label [ diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index 68f67338a2..de629a71dd 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -289,7 +289,7 @@ TParseNode >> isReturningIf [ TParseNode >> isSameAs: aTParseNode [ "Answer if the ParseTree rooted at this node is the same as aTParseNode. By default answer false and have subclasses override as appropriate." - ^false + ^ self subclassResponsibility ] { #category : #testing } diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index bc1d15510e..5d317090c2 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -294,6 +294,25 @@ TSwitchStmtNode >> expression: expr cases: aTBraceNode otherwiseOrNil: otherwise self otherwiseOrNil: otherwiseOrNilNode ] +{ #category : #comparing } +TSwitchStmtNode >> isSameAs: anotherNode [ + + anotherNode isSwitch ifFalse: [ ^ false ]. + (expression isSameAs: anotherNode expression) + ifFalse: [ ^ false ]. + + cases size ~= anotherNode cases size ifTrue: [ ^ false ]. + cases with: anotherNode cases do: [ :case1 :case2 | + case1 first = case2 first + ifFalse: [ ^ false ]. + (case1 second isSameAs: case2 second) + ifFalse: [ ^ false ] + ]. + + "Apparently it went ok after all this" + ^ true +] + { #category : #testing } TSwitchStmtNode >> isSwitch [ ^true From 89f0f97099e0d6de3bdd853d8f21f0cd5d1579df Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:52:26 +0100 Subject: [PATCH 37/75] Using replaceBy: to replace without the need of iterating --- smalltalksrc/Slang/CCodeGenerator.class.st | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index f6d15b3be9..b73c81847e 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3737,12 +3737,10 @@ CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ statementListsToLinearize do: [ :statementList | statementList statements do: [ :statement | | replacement | replacement := statement linearizeIn: self. - aTMethod replaceNodesIn: { statement -> replacement } asDictionary + aTMethod localizeVariables: replacement parameterNames. + statement replaceBy: replacement ]. - aTMethod replaceNodesIn: { - statementList -> (TStatementListNode statements: statementList flattened) } asDictionary. - ]. - aTMethod flatten + ] ] { #category : #utilities } @@ -5502,6 +5500,6 @@ CCodeGenerator >> wrapStatements: tMethod withVariableBindings: replacementDict replacement := self wrapStatementWithExternalizationAndLocalizations: statement ofLocalizedVariables: (replacementDict collect: [ :asso | asso key ]). - tMethod replaceNodesIn: { statement -> replacement } asDictionary + statement replaceBy: replacement. ]. ] From e36c9021b95a2f99db7b734124f89e161d67d7ff Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 00:53:05 +0100 Subject: [PATCH 38/75] Hoist new variables during linearization --- smalltalksrc/Slang/TParseNode.class.st | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index de629a71dd..242498dc06 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -352,7 +352,7 @@ TParseNode >> linearizeIn: aCodeGenerator [ > t1 := self foo: t0 > ] " - | replacementDictionary rewrittenStatement callsInStatement replacementBlock replacementsSoFar | + | replacementDictionary rewrittenStatement callsInStatement replacementBlock replacementsSoFar variables | replacementDictionary := Dictionary new. callsInStatement := OrderedCollection new. @@ -364,18 +364,20 @@ TParseNode >> linearizeIn: aCodeGenerator [ unless: [ :unlessNode | unlessNode isStatementList ]. replacementBlock := OrderedCollection new. + variables := OrderedCollection new. replacementsSoFar := Dictionary new. callsInStatement do: [ :e | | variableNode | - variableNode := TVariableNode named: - 't' , replacementBlock size asString. + variableNode := TVariableNode named: 't' , replacementBlock size asString. + variables add: variableNode name. replacementBlock add: (TAssignmentNode variable: variableNode expression: (e replaceNodesIn: replacementsSoFar)). replacementsSoFar at: e put: variableNode ]. rewrittenStatement := self replaceNodesIn: replacementsSoFar. replacementBlock add: rewrittenStatement. - ^ TStatementListNode statements: replacementBlock + + ^ TStatementListNode parameters: variables statements: replacementBlock ] { #category : #accessing } From e5edcff022c423c25b9ee94ec490737204853195 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 01:19:17 +0100 Subject: [PATCH 39/75] Making tests green for now --- .../SlangBasicTranslationTest.class.st | 791 ++++++++++-------- .../SlangLocalizationTestCase.class.st | 200 +++-- 2 files changed, 541 insertions(+), 450 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 357f7f2c05..fdbe71f814 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -253,29 +253,37 @@ SlangBasicTranslationTest >> testBlockValueAsArgument [ "Case: [ 1 foo: 2. 3 foo: 4. 5 foo: 6 ] value ifTrue: [ a := b ]" + "In order to test the translation of a block as an argument, the block is given as condition of an if." + | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStatementListNode new setArguments: #( ) statements: { - (TSendNode new - setSelector: #foo - receiver: (TConstantNode value: 1) - arguments: { (TConstantNode value: 2) }). - (TSendNode new - setSelector: #foo - receiver: (TConstantNode value: 3) - arguments: { (TConstantNode value: 4) }). - (TSendNode new - setSelector: #foo - receiver: (TConstantNode value: 5) - arguments: { (TConstantNode value: 6) }) }. + expression := TStatementListNode new + setArguments: #( ) + statements: { + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 1) + arguments: { (TConstantNode value: 2) }). + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 3) + arguments: { (TConstantNode value: 4) }). + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 5) + arguments: { (TConstantNode value: 6) }) }. translation := self translate: (TSendNode new setSelector: #ifTrue: - receiver: (TSendNode new setSelector: #value receiver: expression arguments: {}) - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TVariableNode new setName: 'b')) }) }). + receiver: (TSendNode new + setSelector: #value + receiver: expression + arguments: { }) + arguments: + { (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TVariableNode new setName: 'b')) }) }). self assert: translation trimBoth @@ -316,15 +324,17 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithConstantArgument [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStatementListNode new setArguments: #( i ) statements: { - (TSendNode new - setSelector: #foo - receiver: (TConstantNode value: 1) - arguments: { (TConstantNode value: 2) }). - (TSendNode new - setSelector: #= - receiver: (TVariableNode named: 'i') - arguments: { (TConstantNode value: 4) }) }. + expression := TStatementListNode new + setArguments: #( i ) + statements: { + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 1) + arguments: { (TConstantNode value: 2) }). + (TSendNode new + setSelector: #= + receiver: (TVariableNode named: 'i') + arguments: { (TConstantNode value: 4) }) }. translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSendNode new @@ -332,7 +342,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithConstantArgument [ receiver: expression arguments: { (TConstantNode value: 4) }) arguments: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -361,7 +371,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithMultipleArguments [ (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) - arguments: { TConstantNode value: 2 }). + arguments: { (TConstantNode value: 2) }). (TSendNode new setSelector: #= receiver: (TSendNode new @@ -378,7 +388,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithMultipleArguments [ (TConstantNode value: 4). (TConstantNode value: 5) }) arguments: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -401,15 +411,17 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgument [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStatementListNode new setArguments: #( i ) statements: { - (TSendNode new - setSelector: #foo - receiver: (TConstantNode value: 1) - arguments: { (TConstantNode value: 2) }). - (TSendNode new - setSelector: #= - receiver: (TVariableNode named: 'i') - arguments: { (TConstantNode value: 4) }) }. + expression := TStatementListNode new + setArguments: #( i ) + statements: { + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 1) + arguments: { (TConstantNode value: 2) }). + (TSendNode new + setSelector: #= + receiver: (TVariableNode named: 'i') + arguments: { (TConstantNode value: 4) }) }. translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSendNode new @@ -420,7 +432,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgument [ receiver: (TConstantNode value: 3) arguments: { (TConstantNode value: 4) }) }) arguments: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -443,15 +455,17 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgumentAndMulti | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStatementListNode new setArguments: #( i ) statements: { - (TSendNode new - setSelector: #foo - receiver: (TConstantNode value: 1) - arguments: { (TVariableNode named: 'i') }). - (TSendNode new - setSelector: #= - receiver: (TVariableNode named: 'i') - arguments: { (TConstantNode value: 4) }) }. + expression := TStatementListNode new + setArguments: #( i ) + statements: { + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 1) + arguments: { (TVariableNode named: 'i') }). + (TSendNode new + setSelector: #= + receiver: (TVariableNode named: 'i') + arguments: { (TConstantNode value: 4) }) }. translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSendNode new @@ -462,7 +476,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgumentAndMulti receiver: (TConstantNode value: 3) arguments: { (TConstantNode value: 4) }) }) arguments: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -1596,23 +1610,25 @@ return;' SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitch [ | translation | - translation := self translate: (TReturnNode expression: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: - { (TStatementListNode new setStatements: - { (TConstantNode value: 0) }) }; - cases: - { (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }) }; - yourself) - otherwiseOrNil: - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 0)) }))). + translation := self translate: + (TReturnNode expression: (TSwitchStmtNode new + expression: (TVariableNode named: 'x') + cases: (TBraceCaseNode new + caseLabels: + { (TStatementListNode new statements: + { (TConstantNode value: 0) }) }; + cases: + { (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }) }; + yourself) + otherwiseOrNil: + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: (TVariableNode named: 'foo') + expression: (TConstantNode value: 0)) }))). self assert: translation trimBoth equals: 'switch (x) { case 0: @@ -1630,19 +1646,21 @@ SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitch [ SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitchWithNoDefaultStatement [ | translation | - translation := self translate: (TReturnNode expression: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: - { (TStatementListNode new setStatements: - { (TConstantNode value: 0) }) }; - cases: - { (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }) }; - yourself) - otherwiseOrNil: nil)). + translation := self translate: + (TReturnNode expression: (TSwitchStmtNode new + expression: (TVariableNode named: 'x') + cases: (TBraceCaseNode new + caseLabels: + { (TStatementListNode new statements: + { (TConstantNode value: 0) }) }; + cases: + { (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }) }; + yourself) + otherwiseOrNil: nil)). self assert: translation trimBoth equals: 'switch (x) { case 0: @@ -2142,7 +2160,12 @@ SlangBasicTranslationTest >> testSendCCodeAsArgumentWithBlock [ expression: (TSendNode new setSelector: #cCode: receiver: (TVariableNode new setName: 'self') - arguments: { TStatementListNode new setStatements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) arguments: { TConstantNode value: 2 }). (TVariableNode named: 'x') } }). + arguments: { (TStatementListNode new statements: { + (TSendNode new + setSelector: #foo + receiver: (TConstantNode value: 1) + arguments: { (TConstantNode value: 2) }). + (TVariableNode named: 'x') }) }). translation := self translate: send. self assert: translation equals: 'y = (foo(1, 2), x)' @@ -2289,13 +2312,14 @@ SlangBasicTranslationTest >> testSendCCoerceVariableToFloat [ SlangBasicTranslationTest >> testSendCppIfIfTrue [ "self cppIf: #FEATURE ifTrue: [ a := false. c := 1 ]" + | translation send | send := TSendNode new setSelector: #cppIf:ifTrue: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2316,20 +2340,21 @@ SlangBasicTranslationTest >> testSendCppIfIfTrue [ SlangBasicTranslationTest >> testSendCppIfIfTrueIfFalse [ "self cppIf: #FEATURE ifTrue: [ a := false. c := 1 ] ifFalse: [ a := true. c := 0 ]" + | translation send | send := TSendNode new setSelector: #cppIf:ifTrue:ifFalse: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2391,7 +2416,7 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIfFalseAsArgumentIndentationInBl "A C preprocessor condition can be anywhere in code, even in an expression statement." | translation send | - send := TStatementListNode new setStatements: { (TAssignmentNode new + send := TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'y') expression: (TSendNode new setSelector: #ifTrue: @@ -2427,19 +2452,19 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIfFalseIndentationInBlock [ "[self cppIf: #FEATURE ifTrue: [ a := false. c := 1 ] ifFalse: [ a := true. c := 0 ]]" | translation send | - send := TStatementListNode new setStatements: { (TSendNode new + send := TStatementListNode new statements: { (TSendNode new setSelector: #cppIf:ifTrue:ifFalse: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2470,13 +2495,13 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueIndentationInNestedBlocks [ "self cppIf: #FEATURE ifTrue: [ a := false. c := 1 ]" | translation send | - send := TStatementListNode new setStatements: - { (TStatementListNode new setStatements: { (TSendNode new + send := TStatementListNode new statements: + { (TStatementListNode new statements: { (TSendNode new setSelector: #cppIf:ifTrue: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2513,11 +2538,11 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSendIfTrueAsCondition [ setSelector: #ifTrue:ifFalse: receiver: (TConstantNode value: true) arguments: { - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: false) }). - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: true) }) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2537,14 +2562,14 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSingleExpressionDoesNotAddsS | translation send | send := TReturnNode expression: (TSendNode new - setSelector: #cppIf:ifTrue: - receiver: (TVariableNode new setName: 'self') - arguments: { - (TConstantNode value: #FEATURE). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)) }) }). + setSelector: #cppIf:ifTrue: + receiver: (TVariableNode new setName: 'self') + arguments: { + (TConstantNode value: #FEATURE). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)) }) }). translation := self translate: send. self assert: translation trimBoth equals: 'return @@ -2561,11 +2586,11 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSingleStatementAddsSeparator setSelector: #cppIf:ifTrue: receiver: (TVariableNode new setName: 'self') arguments: { - (TConstantNode value: #FEATURE). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)) }) }. + (TConstantNode value: #FEATURE). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)) }) }. translation := self translate: send. self assert: translation trimBoth equals: '#if FEATURE @@ -2696,7 +2721,7 @@ SlangBasicTranslationTest >> testSendIfFalse [ send := TSendNode new setSelector: #ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2720,7 +2745,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgument [ expression: (TSendNode new setSelector: #ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2746,7 +2771,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgumentWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2775,7 +2800,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgumentWithReceiverSendNot [ receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) arguments: { }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2797,14 +2822,15 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrue [ setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { (TAssignmentNode new + (TStatementListNode new statements: + { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: 1)) }) }. translation := self translate: send. @@ -2826,20 +2852,21 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgument [ expression: (TSendNode new setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: true)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 0)) }) }). + arguments: { + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }). + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: true)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 0)) }) }). translation := self translate: send. self assert: translation trimBoth equals: 'y = ((x) @@ -2860,14 +2887,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgumentCollapseBothArmsOfCo receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2890,14 +2917,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgumentCollapseBothArmsOfCo setSelector: #ifFalse:ifTrue: receiver: (TVariableNode named: 'x') arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2920,19 +2947,19 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditional receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }) }. @@ -2953,19 +2980,19 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditionalW setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }) }. @@ -3002,10 +3029,10 @@ SlangBasicTranslationTest >> testSendIfFalseWithNonLeafReceiver [ send := TSendNode new setSelector: #ifFalse: receiver: (TSendNode new - setSelector: #& - receiver: (TVariableNode new setName: 'x') - arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStatementListNode new setStatements: { + setSelector: #& + receiver: (TVariableNode new setName: 'x') + arguments: { (TVariableNode new setName: 'y') }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3028,7 +3055,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverFalseConstant [ send := TSendNode new setSelector: #ifFalse: receiver: (TConstantNode value: false) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3053,7 +3080,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverSendNot [ setSelector: #not receiver: (TVariableNode new setName: 'x') arguments: { }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3076,7 +3103,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverTrueConstant [ send := TSendNode new setSelector: #ifFalse: receiver: (TConstantNode value: true) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3099,7 +3126,7 @@ SlangBasicTranslationTest >> testSendIfNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3194,7 +3221,7 @@ SlangBasicTranslationTest >> testSendIfNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNil: receiver: (TConstantNode value: nil) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3213,6 +3240,7 @@ SlangBasicTranslationTest >> testSendIfNilWithNilConstantReceiver [ SlangBasicTranslationTest >> testSendIfNilifNotNil [ "(self foo: x) ifNil: [ a:= true. c = 1 ] ifNotNil: [ b := false. c := 7 ]" + | translation send | send := TSendNode new setSelector: #ifNil:ifNotNil: @@ -3220,20 +3248,21 @@ SlangBasicTranslationTest >> testSendIfNilifNotNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'b') - expression: (TConstantNode value: true)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 7)) }) }. + arguments: { + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }). + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'b') + expression: (TConstantNode value: true)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 7)) }) }. translation := self translate: send. self assert: translation trimBoth equals: 'if (foo(x)) { @@ -3247,27 +3276,29 @@ SlangBasicTranslationTest >> testSendIfNilifNotNil [ { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendIfNilifNotNilWithNilConstantReceiver [ - + "nil ifNil: [ a:= true. c = 1 ] ifNotNil: [ b := false. c := 7 ]" + | translation send | generator generateDeadCode: false. send := TSendNode new setSelector: #ifNil:ifNotNil: receiver: (TConstantNode value: nil) - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'b') - expression: (TConstantNode value: true)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 7)) }) }. + arguments: { + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }). + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'b') + expression: (TConstantNode value: true)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 7)) }) }. translation := self translate: send. self assert: translation trimBoth equals: '{ @@ -3287,7 +3318,7 @@ SlangBasicTranslationTest >> testSendIfNotNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3340,6 +3371,7 @@ SlangBasicTranslationTest >> testSendIfNotNilAsArgumentWithNilConstantReceiver [ SlangBasicTranslationTest >> testSendIfNotNilIfNil [ "(self foo: x) ifNotNil: [ a:= true. c = 1 ] ifNil: [ b := false. c := 7 ]" + | translation send | send := TSendNode new setSelector: #ifNotNil:ifNil: @@ -3347,20 +3379,21 @@ SlangBasicTranslationTest >> testSendIfNotNilIfNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'b') - expression: (TConstantNode value: true)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 7)) }) }. + arguments: { + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }). + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'b') + expression: (TConstantNode value: true)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 7)) }) }. translation := self translate: send. self assert: translation trimBoth equals: 'if (foo(x)) { @@ -3437,25 +3470,27 @@ SlangBasicTranslationTest >> testSendIfNotNilIfNilAsArgumentWithNonLeafReceiver SlangBasicTranslationTest >> testSendIfNotNilIfNilWithNilConstantReceiver [ "nil ifNotNil: [ a:= true. c = 1 ] ifNil: [ b := false. c := 7 ]" + | translation send | generator generateDeadCode: false. send := TSendNode new setSelector: #ifNotNil:ifNil: receiver: (TConstantNode value: nil) - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'b') - expression: (TConstantNode value: true)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 7)) }) }. + arguments: { + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }). + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'b') + expression: (TConstantNode value: true)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 7)) }) }. translation := self translate: send. self assert: translation trimBoth equals: '{ @@ -3472,7 +3507,7 @@ SlangBasicTranslationTest >> testSendIfNotNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNotNil: receiver: (TConstantNode value: nil) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3491,7 +3526,7 @@ SlangBasicTranslationTest >> testSendIfTrue [ send := TSendNode new setSelector: #ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3515,7 +3550,7 @@ SlangBasicTranslationTest >> testSendIfTrueAsArgument [ expression: (TSendNode new setSelector: #ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3541,7 +3576,7 @@ SlangBasicTranslationTest >> testSendIfTrueAsArgumentWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3579,14 +3614,15 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalse [ setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { (TAssignmentNode new + (TStatementListNode new statements: + { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: 1)) }) }. translation := self translate: send. @@ -3608,20 +3644,21 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgument [ expression: (TSendNode new setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: false)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TConstantNode value: true)). - (TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 0)) }) }). + arguments: { + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: false)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }). + (TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TConstantNode value: true)). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 0)) }) }). translation := self translate: send. self assert: translation trimBoth equals: 'y = ((x) @@ -3642,14 +3679,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgumentCollapseBothArmsOfCo receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3672,14 +3709,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgumentCollapseBothArmsOfCo setSelector: #ifTrue:ifFalse: receiver: (TVariableNode named: 'x') arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3702,19 +3739,19 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditional receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }) }. @@ -3735,19 +3772,19 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditionalW setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') arguments: { - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }). - (TStatementListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). - + (TAssignmentNode new setVariable: (TVariableNode new setName: 'c') expression: (TConstantNode value: 1)) }) }. @@ -3783,11 +3820,12 @@ SlangBasicTranslationTest >> testSendIfTrueWithBlockReceiver [ | translation send | send := TSendNode new setSelector: #ifTrue: - receiver: (TStatementListNode new setStatements: { (TAssignmentNode new + receiver: (TStatementListNode new statements: { + (TAssignmentNode new setVariable: (TVariableNode new setName: 'y') expression: (TConstantNode value: false)). - TVariableNode new setName: 'x' }) - arguments: { (TStatementListNode new setStatements: { + (TVariableNode new setName: 'x') }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3812,7 +3850,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverBinaryOperation [ setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: { (TVariableNode new setName: 'b') }) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3835,7 +3873,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverFalseConstant [ send := TSendNode new setSelector: #ifTrue: receiver: (TConstantNode value: false) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3855,7 +3893,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverTrueConstant [ send := TSendNode new setSelector: #ifTrue: receiver: (TConstantNode value: true) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -4697,6 +4735,7 @@ SlangBasicTranslationTest >> testSendRaisedTo [ SlangBasicTranslationTest >> testSendRepeat [ " [ var := var - 7 ] repeat" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -4706,7 +4745,7 @@ SlangBasicTranslationTest >> testSendRepeat [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #repeat - receiver: (TStatementListNode new setStatements: + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) @@ -4782,11 +4821,11 @@ SlangBasicTranslationTest >> testSendSequentialAndWithConstantReceiverTrue [ send := TSendNode new setSelector: #and: receiver: (TConstantNode value: true) - arguments: { (TStatementListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TSendNode new setSelector: #+ receiver: (TConstantNode value: 1) - arguments: {(TConstantNode value: 2)}). + arguments: { (TConstantNode value: 2) }). (TSendNode new setSelector: #= receiver: (TVariableNode new setName: 'a') @@ -5155,6 +5194,7 @@ SlangBasicTranslationTest >> testSendTimes [ SlangBasicTranslationTest >> testSendTimesRepeat [ "5 timesRepeat: [ var := var - 7 ]" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5165,7 +5205,7 @@ SlangBasicTranslationTest >> testSendTimesRepeat [ send := TSendNode new setSelector: #timesRepeat: receiver: (TConstantNode value: 5) - arguments: { (TStatementListNode new setStatements: + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5518,6 +5558,7 @@ SlangBasicTranslationTest >> testSendTruncateTo [ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndArgument [ "[ var := var - 7. var >= 21 ] whileFalse: [ b := var \\ 3 ]" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5527,7 +5568,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndAr arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileFalse: - receiver: (TStatementListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5536,12 +5577,13 @@ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndAr receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) arguments: - { (TStatementListNode new setStatements: { (TAssignmentNode new + { (TStatementListNode new statements: + { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TSendNode new setSelector: #\\ receiver: (TVariableNode new setName: 'var') - arguments: {(TConstantNode value: 3)})) }) }. + arguments: { (TConstantNode value: 3) })) }) }. translation := self translate: send. self assert: translation trimBoth equals: 'while (1) { @@ -5565,11 +5607,11 @@ SlangBasicTranslationTest >> testSendWhileFalseWithOneStatementInReceiverBlock [ send := TSendNode new setSelector: #whileFalse: receiver: - (TStatementListNode new setStatements: { (TSendNode new + (TStatementListNode new statements: { (TSendNode new setSelector: #& receiver: (TVariableNode new setName: 'a') - arguments: {(TVariableNode new setName: 'b')}) }) - arguments: { (TStatementListNode new setStatements: + arguments: { (TVariableNode new setName: 'b') }) }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5584,6 +5626,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithOneStatementInReceiverBlock [ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ "[ var := var - 7. var >= 21 ] whileFalse" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5593,7 +5636,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileFalse - receiver: (TStatementListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5601,7 +5644,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ setSelector: #>= receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) - arguments: {}. + arguments: { }. translation := self translate: send. self assert: translation trimBoth equals: 'do{ @@ -5621,7 +5664,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithManyStatementsInReceiverAndArg arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue: - receiver: (TStatementListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5630,12 +5673,13 @@ SlangBasicTranslationTest >> testSendWhileTrueWithManyStatementsInReceiverAndArg receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) arguments: - { (TStatementListNode new setStatements: { (TAssignmentNode new + { (TStatementListNode new statements: + { (TAssignmentNode new setVariable: (TVariableNode new setName: 'b') expression: (TSendNode new setSelector: #\\ receiver: (TVariableNode new setName: 'var') - arguments: {(TConstantNode value: 3)})) }) }. + arguments: { (TConstantNode value: 3) })) }) }. translation := self translate: send. self assert: translation trimBoth equals: 'while (1) { @@ -5658,7 +5702,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue: - receiver: (TStatementListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5666,9 +5710,8 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: { (TVariableNode new setName: 'b') }) }) - arguments: - { (TStatementListNode new setStatements: - { (TVariableNode new setName: 'nil') }) }. + arguments: { (TStatementListNode new statements: + { (TVariableNode new setName: 'nil') }) }. translation := self translate: send. self assert: translation trimBoth equals: 'do{ @@ -5689,11 +5732,11 @@ SlangBasicTranslationTest >> testSendWhileTrueWithOneStatementInReceiverBlock [ send := TSendNode new setSelector: #whileTrue: receiver: - (TStatementListNode new setStatements: { (TSendNode new + (TStatementListNode new statements: { (TSendNode new setSelector: #& receiver: (TVariableNode new setName: 'a') - arguments: {(TVariableNode new setName: 'b')}) }) - arguments: { (TStatementListNode new setStatements: + arguments: { (TVariableNode new setName: 'b') }) }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5708,6 +5751,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithOneStatementInReceiverBlock [ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ "[ var := var - 7. var >= 21 ] whileTrue" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5717,7 +5761,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue - receiver: (TStatementListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5725,7 +5769,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ setSelector: #>= receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) - arguments: {}. + arguments: { }. translation := self translate: send. self assert: translation trimBoth equals: 'do{ @@ -5774,16 +5818,16 @@ SlangBasicTranslationTest >> testSwitchStatement [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) })). @@ -5808,25 +5852,28 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgument [ translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: { - (TStatementListNode new setStatements: - { (TConstantNode value: 0) }). - (TStatementListNode new setStatements: - { (TConstantNode value: 1) }) }; - cases: { - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 11)) }) }; - yourself) - otherwiseOrNil: nil) - arguments: { TStatementListNode new setStatements: { } }). + expression: (TVariableNode named: 'x') + cases: (TBraceCaseNode new + caseLabels: { + (TStatementListNode new statements: + { (TConstantNode value: 0) }). + (TStatementListNode new statements: + { (TConstantNode value: 1) }) }; + cases: { + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 11)) }) }; + yourself) + otherwiseOrNil: nil) + arguments: + { (TStatementListNode new statements: { }) }). self assert: translation trimBoth equals: 'if (((x == 0) ? (foo = 10) @@ -5843,38 +5890,42 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgumentWithNastedCases [ translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: { - (TStatementListNode new setStatements: - { (TConstantNode value: 0) }). - (TStatementListNode new setStatements: - { (TConstantNode value: 1) }). - (TStatementListNode new setStatements: - { (TConstantNode value: 2) }). - (TStatementListNode new setStatements: - { (TConstantNode value: 3) }) }; - cases: { - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 1)) }) - }; - yourself) - otherwiseOrNil: nil) - arguments: { TStatementListNode new setStatements: { } }). + expression: (TVariableNode named: 'x') + cases: (TBraceCaseNode new + caseLabels: { + (TStatementListNode new statements: + { (TConstantNode value: 0) }). + (TStatementListNode new statements: + { (TConstantNode value: 1) }). + (TStatementListNode new statements: + { (TConstantNode value: 2) }). + (TStatementListNode new statements: + { (TConstantNode value: 3) }) }; + cases: { + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 1)) }) }; + yourself) + otherwiseOrNil: nil) + arguments: + { (TStatementListNode new statements: { }) }). self assert: translation trimBoth equals: 'if (((x == 0) ? (foo = 10) @@ -5892,29 +5943,33 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgumentWithNastedCases [ SlangBasicTranslationTest >> testSwitchStatementAsArgumentWithSwitchVariable [ "A temporary variable can be used as switch variable, here the variable 'jinx'." + | translation | translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: ((TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: { - (TStatementListNode new setStatements: - { (TConstantNode value: 0) }). - (TStatementListNode new setStatements: - { (TConstantNode value: 1) }) }; - cases: { - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStatementListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 11)) }) }; - yourself) - otherwiseOrNil: nil) switchVariable: 'jinx') - arguments: { TStatementListNode new setStatements: { } }). + expression: (TVariableNode named: 'x') + cases: (TBraceCaseNode new + caseLabels: { + (TStatementListNode new statements: + { (TConstantNode value: 0) }). + (TStatementListNode new statements: + { (TConstantNode value: 1) }) }; + cases: { + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 10)) }). + (TStatementListNode new statements: + { (TAssignmentNode new + setVariable: + (TVariableNode named: 'foo') + expression: (TConstantNode value: 11)) }) }; + yourself) + otherwiseOrNil: nil) switchVariable: 'jinx') + arguments: + { (TStatementListNode new statements: { }) }). self assert: translation trimBoth equals: 'if ((((jinx = x) == 0) ? (foo = 10) @@ -5934,17 +5989,17 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) }))). @@ -5973,10 +6028,10 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') @@ -6007,10 +6062,10 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') @@ -6038,22 +6093,22 @@ SlangBasicTranslationTest >> testSwitchStatementWithNestedCase [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: { - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: 0) }). - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: 1) }) }; cases: { - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStatementListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStatementListNode new setStatements: { })). + (TStatementListNode new statements: { })). self assert: translation trimBoth equals: 'switch (x) { case 0: @@ -6076,10 +6131,10 @@ SlangBasicTranslationTest >> testSwitchStatementWithNoDefaultStatement [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStatementListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; @@ -6101,23 +6156,21 @@ SlangBasicTranslationTest >> testSwitchStatementWithNoDefaultStatement [ SlangBasicTranslationTest >> testTranslateBlockAssignmentWithManyStatement [ | translation variable expression | - " var := [ a := b . c := 1 ]." - variable := TVariableNode new setName: 'var'. - expression := TStatementListNode new setStatements: { - TAssignmentNode new - setVariable: (TVariableNode new setName: 'a') - expression: (TVariableNode new setName: 'b'). - TAssignmentNode new - setVariable: (TVariableNode new setName: 'c') - expression: (TConstantNode value: 1). - }. - - translation := self translate: (TAssignmentNode new - setVariable: variable - expression: expression). + expression := TStatementListNode new statements: { + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TVariableNode new setName: 'b')). + (TAssignmentNode new + setVariable: (TVariableNode new setName: 'c') + expression: (TConstantNode value: 1)) }. + + translation := self translate: + (TAssignmentNode new + setVariable: variable + expression: expression). self assert: translation trimBoth equals: '{ a = b; diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 6a6973484c..635e9aef42 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -97,8 +97,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ | externalizationStatement interpretMethod | interpretMethod := self applyLocalizationTo: #interpret. - externalizationStatement := interpretMethod statements last - statements first. + externalizationStatement := (interpretMethod statements last: 2) first. self assert: (externalizationStatement isSameAs: (self externalizationOf: #autoLocalizedVariable)) @@ -112,7 +111,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnRef | interpretMethod printedString | interpretMethod := self applyLocalizationTo: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. printedString := String streamContents: [ :str | - (interpretMethod statements last asCASTIn: ccg) + ((TStatementListNode statements: (interpretMethod statements last: 3)) asCASTIn: ccg) prettyPrintOn: str ]. self assert: printedString equals: '{ autoLocalizedVariable = local_autoLocalizedVariable; @@ -129,15 +128,15 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ | interpretMethod sendNode | interpretMethod := self applyLocalizationTo: #interpretWithReturnExpression. - sendNode := interpretMethod statements last statements second. - self assert: sendNode arguments first statements last statements last isReturn. + sendNode := interpretMethod statements fourth. + self assert: sendNode arguments first statements last isReturn. self - assert: (sendNode arguments first statements last statements first + assert: (sendNode arguments first statements first isSameAs: (self externalizationOf: #autoLocalizedVariable)). - self assert: sendNode arguments second statements last statements last isReturn. + self assert: sendNode arguments second statements last isReturn. self - assert: (sendNode arguments second statements last statements first + assert: (sendNode arguments second statements first isSameAs: (self externalizationOf: #autoLocalizedVariable)). ] @@ -183,11 +182,9 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgument [ self assert: printedString equals: '{ - { - autoLocalizedVariable = local_autoLocalizedVariable; - t0 = foo2(); - local_autoLocalizedVariable = autoLocalizedVariable; - } + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = foo2(); + local_autoLocalizedVariable = autoLocalizedVariable; if (1 == t0) { } }' @@ -203,75 +200,88 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. - printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - - self assert: printedString equals: '{ - autoLocalizedVariable1 = local_autoLocalizedVariable1; - t0 = nonInlinedMethodUsingAutolocalizedVariable1(); - local_autoLocalizedVariable1 = autoLocalizedVariable1; -}'. - - externalCall := inlinedMethod statements second. - cast := externalCall asCASTIn: ccg. + cast := inlinedMethod asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - autoLocalizedVariable1 = local_autoLocalizedVariable1; - autoLocalizedVariable2 = local_autoLocalizedVariable2; - t1 = foo(t0); - local_autoLocalizedVariable = autoLocalizedVariable; - local_autoLocalizedVariable1 = autoLocalizedVariable1; - local_autoLocalizedVariable2 = autoLocalizedVariable2; -}' + self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeWithEscapingCallAsArgumentOfExternalCall */ +static sqInt +bytecodeWithEscapingCallAsArgumentOfExternalCall(void) +{ + { + autoLocalizedVariable1 = local_autoLocalizedVariable1; + t0 = nonInlinedMethodUsingAutolocalizedVariable1(); + local_autoLocalizedVariable1 = autoLocalizedVariable1; + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + t1 = foo(t0); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable2 = autoLocalizedVariable2; + } + return 0; +} +'. ] { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod case inlinedMethod cast printedString | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithInlinedMethodCall. "Assert that the send node is preceded by variable externalization" case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements second. - cast := externalCall asCASTIn: ccg. + cast := inlinedMethod asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - autoLocalizedVariable1 = local_autoLocalizedVariable1; - t0 = foo2(); - local_autoLocalizedVariable = autoLocalizedVariable; - local_autoLocalizedVariable1 = autoLocalizedVariable1; -}' + self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeUsingInlinedCall */ +static sqInt +bytecodeUsingInlinedCall(void) +{ + { + /* begin inlinedMethodUsingExternalCall */ + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + t0 = foo2(); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; + } + return 0; +} +' ] { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod case inlinedMethod cast printedString | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. + cast := inlinedMethod asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - t0 = foo((local_autoLocalizedVariable += 1)); - local_autoLocalizedVariable = autoLocalizedVariable; -}' + self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeWithEscapingCall */ +static sqInt +bytecodeWithEscapingCall(void) +{ + { + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = foo((local_autoLocalizedVariable += 1)); + local_autoLocalizedVariable = autoLocalizedVariable; + } + return 0; +} +' ] { #category : #tests } @@ -284,25 +294,31 @@ SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNe "Assert that the send node is preceded by variable externalization" case := interpretMethod statements sixth cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. + cast := inlinedMethod asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - autoLocalizedVariable1 = local_autoLocalizedVariable1; - autoLocalizedVariable2 = local_autoLocalizedVariable2; - t0 = foo((local_autoLocalizedVariable += 1)); - local_autoLocalizedVariable = autoLocalizedVariable; - local_autoLocalizedVariable1 = autoLocalizedVariable1; - local_autoLocalizedVariable2 = autoLocalizedVariable2; -}' + self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeWithEscapingCall */ +static sqInt +bytecodeWithEscapingCall(void) +{ + { + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + t0 = foo((local_autoLocalizedVariable += 1)); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable2 = autoLocalizedVariable2; + } + return 0; +} +' ] { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod case inlinedMethod cast printedString | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. @@ -310,25 +326,24 @@ SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternali case := interpretMethod statements second cases first. inlinedMethod := case statements second method. - externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. + cast := inlinedMethod asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - t0 = nonInlinedMethodUsingAutolocalizedVariable(); - local_autoLocalizedVariable = autoLocalizedVariable; -}'. - - externalCall := inlinedMethod statements second. - cast := externalCall asCASTIn: ccg. - printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - - self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - t1 = foo(t0); - local_autoLocalizedVariable = autoLocalizedVariable; -}' + self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeUsingExternalizedAutoLocalizedVariableAsExpression */ +static sqInt +bytecodeUsingExternalizedAutoLocalizedVariableAsExpression(void) +{ + { + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = nonInlinedMethodUsingAutolocalizedVariable(); + local_autoLocalizedVariable = autoLocalizedVariable; + autoLocalizedVariable = local_autoLocalizedVariable; + t1 = foo(t0); + local_autoLocalizedVariable = autoLocalizedVariable; + } + return 0; +} +' ] { #category : #'tests - linearization' } @@ -400,6 +415,29 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ arguments: { TVariableNode named: 't0' }))) ] +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeNestedCallsDefinesIntermediateVariables [ + + | methodToLinearize | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment. + + ccg prepareMethods. + ccg linearizeExternalCallsIn: methodToLinearize. + + "Before it was + self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0 + + => both t0 and t1 should be defined in the method" + + self assert: (methodToLinearize locals includes: 't0'). + self assert: (methodToLinearize locals includes: 't1') + +] + { #category : #'tests - linearization' } SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ From 768c97c9af7f65057ea81a76d88d3995fe122835 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 01:20:18 +0100 Subject: [PATCH 40/75] Correct node replacement --- smalltalksrc/Slang/CCodeGenerator.class.st | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index b73c81847e..b3c58c74d1 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3735,10 +3735,13 @@ CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ statementListsToLinearize := aTMethod parseTree select: [ :e | e isStatementList ]. statementListsToLinearize do: [ :statementList | - statementList statements do: [ :statement | | replacement | + statementList statements do: [ :statement | | replacement previousParent | + previousParent := statement parent. replacement := statement linearizeIn: self. aTMethod localizeVariables: replacement parameterNames. - statement replaceBy: replacement + + "Do not ask the child to replace itself, as it may have been already moved" + previousParent replaceChild: statement with: replacement. ]. ] ] @@ -5496,10 +5499,11 @@ CCodeGenerator >> wrapStatements: tMethod withVariableBindings: replacementDict - static function calls - dynamic function calls (perform & co)" - tMethod allStatements do: [ :statement | | replacement | + tMethod allStatements do: [ :statement | | replacement oldParent | + oldParent := statement parent. replacement := self wrapStatementWithExternalizationAndLocalizations: statement ofLocalizedVariables: (replacementDict collect: [ :asso | asso key ]). - statement replaceBy: replacement. + oldParent replaceChild: statement with: replacement. ]. ] From bbde1bc0687b55154669ccba2878135d9ba0130a Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 01:20:34 +0100 Subject: [PATCH 41/75] Fix wrong rename --- smalltalksrc/Slang/TSwitchStmtNode.class.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index 5d317090c2..12ad0ac40e 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -163,7 +163,7 @@ TSwitchStmtNode >> asCASTIn: aBuilder addToEndOfCases: aNodeToPrependOrNil [ defaultExpr. (TConstantNode value: type) } ]. statements add: - ((aNodeToPrependOrNil copy expression: defaultExpr) asCASTIn: + ((aNodeToPrependOrNil copy setExpression: defaultExpr) asCASTIn: aBuilder) ]. ^ CSwitchStatementNode if: (expression asCASTExpressionIn: aBuilder) From dc0c853b16435485c92774b43d7e8f05ce36abfe Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 29 Dec 2021 01:21:04 +0100 Subject: [PATCH 42/75] Fix automatic deprecations --- smalltalksrc/Slang/CCodeGenerator.class.st | 14 ++++++++------ smalltalksrc/Slang/TAssignmentNode.class.st | 10 +++++----- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index b3c58c74d1..7bbbea1755 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -2177,7 +2177,7 @@ CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ self noteVariableUsageInString: aTSendNode arguments first value. ^ CRawCodeNode code: aTSendNode arguments first value ]. - ^ aTSendNode args first asCASTIn: self + ^ aTSendNode arguments first asCASTIn: self ] { #category : #'CAST translation' } @@ -2192,7 +2192,7 @@ CCodeGenerator >> generateCASTInlineCCodeAsArgument: aTSendNode [ self noteVariableUsageInString: aTSendNode arguments first value. ^ CRawCodeNode code: aTSendNode arguments first value ]. - ^ aTSendNode args first asCASTExpressionIn: self + ^ aTSendNode arguments first asCASTExpressionIn: self ] { #category : #'CAST translation' } @@ -2846,15 +2846,17 @@ CCodeGenerator >> generateCASTToByDoUntil: limitExpr iterativeVariable: itVar ne CCodeGenerator >> generateCASTToDo: tast [ | iterationVar init until step | - (tast args last args size = 1) ifFalse: [ - self error: 'wrong number of block arguments'. - ]. + tast arguments last args size = 1 ifFalse: [ + self error: 'wrong number of block arguments' ]. iterationVar := tast arguments last args first. init := CAssignmentNode lvalue: (CIdentifierNode name: iterationVar) rvalue: (tast receiver asCASTExpressionIn: self). self noteUsedVariableName: iterationVar. - until := self generateCASTToByDoUntil: tast arguments first iterativeVariable: iterationVar negative: false. + until := self + generateCASTToByDoUntil: tast arguments first + iterativeVariable: iterationVar + negative: false. step := CIncrementNode object: (CIdentifierNode name: iterationVar). ^ CForStatementNode init: { init } diff --git a/smalltalksrc/Slang/TAssignmentNode.class.st b/smalltalksrc/Slang/TAssignmentNode.class.st index eed1e6f0ec..f4745ad260 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -45,17 +45,17 @@ TAssignmentNode >> asCASTExpressionIn: aCodeGen [ TAssignmentNode >> asCASTIn: aBuilder [ | type | - expression isSwitch ifTrue: - [ ^ expression asCASTIn: aBuilder addToEndOfCases: self ]. + expression isSwitch ifTrue: [ + ^ expression asCASTIn: aBuilder addToEndOfCases: self ]. expression isLiteralArrayDeclaration ifTrue: [ - |literalArrayNode | - type := expression args last value. + | literalArrayNode | + type := expression arguments last value. self assert: type last = $*. "Transform the literal array declaration to a C block containing: - a static literal array declaration - an assigment from this literal array to the assigned variable " - literalArrayNode := expression args first value collect: [ :e | + literalArrayNode := expression arguments first value collect: [ :e | CConstantNode value: e ]. ^ CCompoundStatementNode declarations: { (CDeclarationNode From e0f5687d994015cf078abb30a972df87219b85e8 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Thu, 30 Dec 2021 23:49:31 +0100 Subject: [PATCH 43/75] Rename setExpression: -> expression: --- smalltalksrc/Slang/TSwitchStmtNode.class.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/smalltalksrc/Slang/TSwitchStmtNode.class.st b/smalltalksrc/Slang/TSwitchStmtNode.class.st index 12ad0ac40e..5d317090c2 100644 --- a/smalltalksrc/Slang/TSwitchStmtNode.class.st +++ b/smalltalksrc/Slang/TSwitchStmtNode.class.st @@ -163,7 +163,7 @@ TSwitchStmtNode >> asCASTIn: aBuilder addToEndOfCases: aNodeToPrependOrNil [ defaultExpr. (TConstantNode value: type) } ]. statements add: - ((aNodeToPrependOrNil copy setExpression: defaultExpr) asCASTIn: + ((aNodeToPrependOrNil copy expression: defaultExpr) asCASTIn: aBuilder) ]. ^ CSwitchStatementNode if: (expression asCASTExpressionIn: aBuilder) From c4c09612570c5a8c67f1c67e78d5ea58205c7141 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 14:53:15 +0100 Subject: [PATCH 44/75] Making locals belong to statement list instead of method encapsulate accesses to locals locals -> allLocals testing variable declarations --- .../MLPluginAccessorDepthCalculator.class.st | 2 +- .../Melchor/VMPluginCodeGenerator.class.st | 2 +- .../SLBasicTestDeclarationClass.class.st | 33 +++ .../Slang-Tests/SLTestDeclarations.class.st | 69 +++++ smalltalksrc/Slang/CCodeGenerator.class.st | 34 +-- .../Slang/ManifestVMMakerSlang.class.st | 5 + smalltalksrc/Slang/SlangTyper.class.st | 8 +- smalltalksrc/Slang/TMethod.class.st | 260 +++++++++--------- .../Slang/TStatementListNode.class.st | 14 + smalltalksrc/Slang/TVariableNode.class.st | 2 +- smalltalksrc/VMMaker/Object.extension.st | 5 - .../VMMaker/SmartSyntaxPluginTMethod.class.st | 45 +-- .../RBBlockNode.extension.st | 19 +- .../RBMessageNode.extension.st | 4 - .../RBMethodNode.extension.st | 2 +- .../RBSequenceNode.extension.st | 1 + .../RBVariableNode.extension.st | 5 - 17 files changed, 297 insertions(+), 213 deletions(-) create mode 100644 smalltalksrc/Slang-Tests/SLBasicTestDeclarationClass.class.st create mode 100644 smalltalksrc/Slang-Tests/SLTestDeclarations.class.st diff --git a/smalltalksrc/Melchor/MLPluginAccessorDepthCalculator.class.st b/smalltalksrc/Melchor/MLPluginAccessorDepthCalculator.class.st index 151a056dca..c1365b0b9d 100644 --- a/smalltalksrc/Melchor/MLPluginAccessorDepthCalculator.class.st +++ b/smalltalksrc/Melchor/MLPluginAccessorDepthCalculator.class.st @@ -32,7 +32,7 @@ MLPluginAccessorDepthCalculator >> accessorsAndAssignmentsForSubMethodNamed: sel [^nil]. map := Dictionary new. method args do: [:var| map at: var put: depth asString, var]. - method locals do: [:var| map at: var put: depth asString, var]. + method allLocals do: [:var| map at: var put: depth asString, var]. ^self accessorsAndAssignmentsForMethod: (method copy renameVariablesUsing: map) actuals: actualParameters depth: depth + 1 diff --git a/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st b/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st index 082380428f..40055b0b65 100644 --- a/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st +++ b/smalltalksrc/Melchor/VMPluginCodeGenerator.class.st @@ -578,7 +578,7 @@ VMPluginCodeGenerator >> structTargetKindForDeclaration: decl [ "" VMPluginCodeGenerator >> typeFor: aNode in: aTMethod [ "Override to provide the type for InterpreterProxy's implicit stack variable." aNode isVariable ifTrue: - [^(aTMethod typeFor: aNode in: self) ifNil: + [^(aTMethod typeFor: aNode name in: self) ifNil: [aNode name = 'stack' ifTrue: [#'sqInt *'] ifFalse: [#sqInt]]]. diff --git a/smalltalksrc/Slang-Tests/SLBasicTestDeclarationClass.class.st b/smalltalksrc/Slang-Tests/SLBasicTestDeclarationClass.class.st new file mode 100644 index 0000000000..46405a7010 --- /dev/null +++ b/smalltalksrc/Slang-Tests/SLBasicTestDeclarationClass.class.st @@ -0,0 +1,33 @@ +Class { + #name : #SLBasicTestDeclarationClass, + #superclass : #SlangClass, + #category : #'Slang-Tests' +} + +{ #category : #'as yet unclassified' } +SLBasicTestDeclarationClass >> methodWithBlockLocalDeclaration [ + + "var does not exist" + + [ | var | 1+2 ] value +] + +{ #category : #'as yet unclassified' } +SLBasicTestDeclarationClass >> methodWithLocal [ + + | var | +] + +{ #category : #'as yet unclassified' } +SLBasicTestDeclarationClass >> methodWithLocalWithDeclaration [ + + + | var | +] + +{ #category : #'as yet unclassified' } +SLBasicTestDeclarationClass >> methodWithNonExistingLocalDeclaration [ + + "var does not exist" + +] diff --git a/smalltalksrc/Slang-Tests/SLTestDeclarations.class.st b/smalltalksrc/Slang-Tests/SLTestDeclarations.class.st new file mode 100644 index 0000000000..c4ac004113 --- /dev/null +++ b/smalltalksrc/Slang-Tests/SLTestDeclarations.class.st @@ -0,0 +1,69 @@ +Class { + #name : #SLTestDeclarations, + #superclass : #SlangAbstractTestCase, + #category : #'Slang-Tests' +} + +{ #category : #running } +SLTestDeclarations >> setUp [ + super setUp. + ccg addClass: SLBasicTestDeclarationClass +] + +{ #category : #tests } +SLTestDeclarations >> testAllLocalsReturnsBlockLocals [ + + self + assertCollection: (ccg methodNamed: #methodWithBlockLocalDeclaration) allLocals + hasSameElements: #( var ) +] + +{ #category : #tests } +SLTestDeclarations >> testDefaultTypeOfVariableNotInScope [ + + self assert: (ccg typeOfVariable: #var) isNil +] + +{ #category : #tests } +SLTestDeclarations >> testDefineGlobalVariable [ + + ccg var: 'var' declareC: 'int var'. + self assert: (ccg typeOfVariable: #var) equals: 'int' +] + +{ #category : #tests } +SLTestDeclarations >> testLocalVariableWithDeclaration [ + + | type method | + method := ccg methodNamed: #methodWithLocalWithDeclaration. + method recordDeclarationsIn: ccg. + ccg + pushScope: method + while: [ + type := ccg typeOfVariable: #var ]. + self assert: type equals: 'toto' +] + +{ #category : #tests } +SLTestDeclarations >> testLocalVariableWithoutDeclaration [ + + | type | + ccg + pushScope: (ccg methodNamed: #methodWithLocal) + while: [ type := ccg typeOfVariable: #var ]. + self assert: type isNil +] + +{ #category : #tests } +SLTestDeclarations >> testLocalsDoesNotReturnBlockLocals [ + + self assert: (ccg methodNamed: #methodWithBlockLocalDeclaration) locals isEmpty +] + +{ #category : #tests } +SLTestDeclarations >> testLocalsReturnsDirectLocals [ + + self + assertCollection: (ccg methodNamed: #methodWithLocal) locals + hasSameElements: #( 'var' ) +] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 7bbbea1755..75745da368 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -784,7 +784,7 @@ CCodeGenerator >> checkForGlobalUsage: vars in: aTMethod [ [(globalVariableUsage at: var ifAbsentPut: [Set new]) add: aTMethod selector]]. aTMethod clearReferencesToGlobalStruct. - (aTMethod locals select: [:l| self reservedWords includes: l]) do: + (aTMethod allLocals select: [:l| self reservedWords includes: l]) do: [:l| | em | em := aTMethod definingClass name, '>>', aTMethod smalltalkSelector, ' has variable that is a C reserved word: ', l. self error: em. @@ -864,22 +864,14 @@ CCodeGenerator >> compileTimeOptions: aCollection [ { #category : #utilities } CCodeGenerator >> compileToTMethodSelector: selector in: aClass [ + "Compile a method to a TMethod" - ^(aClass >> selector) asTranslationMethodOfClass: self translationMethodClass forCodeGenerator: self. - - "was: - | implementingClass | - implementingClass := aClass. - ^(Compiler new - parse: ([aClass sourceCodeAt: selector] - on: KeyNotFound - do: [:ex| ""Quick hack for simulating Pharo images..."" - (PharoVM and: [aClass == String class and: [selector == #findSubstringViaPrimitive:in:startingAt:matchTable:]]) ifFalse: - [ex pass]. - (implementingClass := ByteString) sourceCodeAt: #findSubstring:in:startingAt:matchTable:]) - in: implementingClass - notifying: nil) - asTranslationMethodOfClass: self translationMethodClass" + + ^ (aClass >> selector + asTranslationMethodOfClass: self translationMethodClass + forCodeGenerator: self) + expandSuperSendsIn: self; + yourself ] { #category : #public } @@ -4272,7 +4264,7 @@ CCodeGenerator >> prepareMethods [ globals addAll: variables. methods do: [:m | - m locals, m args do: + m allLocals, m args do: [:var | (globals includes: var) ifTrue: [self error: 'Local variable ''', var, ''' may mask global when inlining ', m selector]. @@ -4352,7 +4344,7 @@ CCodeGenerator >> printUnboundVariableReferenceWarnings [ methods do: [ :m | | knownVars | knownVars := globalVars copy. m args do: [ :var | knownVars add: var ]. - m locals do: [ :var | knownVars add: var ]. + m allLocals do: [ :var | knownVars add: var ]. m freeVariableReferences do: [ :varName | (knownVars includes: varName) ifFalse: [ (undefinedRefs includesKey: varName) @@ -5192,11 +5184,11 @@ CCodeGenerator >> typeForDereference: sendNode in: aTMethod [ CCodeGenerator >> typeOfVariable: varName [ "" self assert: varName isString. scopeStack reverseDo: - [:dict| - (dict includesKey: varName) ifTrue: + [:scope| + (scope declarations includesKey: varName) ifTrue: [^self extractTypeFor: varName - fromDeclaration: (dict at: varName)]]. + fromDeclaration: (scope declarations at: varName)]]. (variableDeclarations at: varName ifAbsent: diff --git a/smalltalksrc/Slang/ManifestVMMakerSlang.class.st b/smalltalksrc/Slang/ManifestVMMakerSlang.class.st index 35373115c3..2d9d228835 100644 --- a/smalltalksrc/Slang/ManifestVMMakerSlang.class.st +++ b/smalltalksrc/Slang/ManifestVMMakerSlang.class.st @@ -11,3 +11,8 @@ Class { ManifestVMMakerSlang class >> manuallyResolvedDependencies [ ^ #(#'FileSystem-Core' #'Collections-Abstract') ] + +{ #category : #'code-critics' } +ManifestVMMakerSlang class >> ruleStringConcatenationRuleV1FalsePositive [ + ^ #(#(#(#RGPackageDefinition #(#Slang)) #'2022-01-03T12:05:51.106983+01:00') ) +] diff --git a/smalltalksrc/Slang/SlangTyper.class.st b/smalltalksrc/Slang/SlangTyper.class.st index 116aa24c7a..4d45bcf249 100644 --- a/smalltalksrc/Slang/SlangTyper.class.st +++ b/smalltalksrc/Slang/SlangTyper.class.st @@ -85,7 +85,7 @@ SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [ codeGenerator maybeBreakForTestToInline: aMethod selector in: aMethod. aMethod returnType ifNotNil: [ ^ self ]. codeGenerator - pushScope: aMethod declarations + pushScope: aMethod while: [| hasReturn returnTypes | hasReturn := false. @@ -209,7 +209,7 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ alreadyExplicitlyTypedOrNotToBeTyped := aMethod declarations keys asSet. - asYetUntyped := aMethod locals copyWithoutAll: + asYetUntyped := aMethod allLocals copyWithoutAll: alreadyExplicitlyTypedOrNotToBeTyped. mustBeSigned := Set new. newDeclarations := Dictionary new. @@ -218,7 +218,7 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ | type var | "If there is something of the form i >= 0, then i should be signed, not unsigned." (node isSend and: [ - (aMethod locals includes: (var := node receiver variableNameOrNil)) + (aMethod allLocals includes: (var := node receiver variableNameOrNil)) and: [ (#( <= < >= > ) includes: node selector) and: [ node arguments first isConstant and: [ @@ -228,7 +228,7 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ "if an assignment to an untyped local of a known type, set the local's type to that type. Only observe known sends (methods in the current set) and typed local variables." (node isAssignment and: [ - (aMethod locals includes: (var := node variable name)) and: [ + (aMethod allLocals includes: (var := node variable name)) and: [ (alreadyExplicitlyTypedOrNotToBeTyped includes: var) not ] ]) ifTrue: [ "don't be fooled by previously inferred types" type := self diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 5a4c355905..137cb1cc7b 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -15,7 +15,6 @@ Class { 'globalStructureBuildMethodHasFoo', 'inline', 'labels', - 'locals', 'parseTree', 'primitive', 'properties', @@ -26,7 +25,8 @@ Class { 'static', 'writtenToGlobalVarsCache', 'functionAttributes', - 'usedVariablesCache' + 'usedVariablesCache', + 'cachedLocals' ], #classVars : [ 'CaseStatements' @@ -82,8 +82,8 @@ TMethod >> addCASTLocalsIn: aCASTBlock generator: aCodeGen [ maybeExternFunctions := (declarations select: [ :decl | decl beginsWith: 'extern' ]) keys. - (locals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ - (aCodeGen sortStrings: locals , maybeExternFunctions) do: [ :var | + (self allLocals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ + (aCodeGen sortStrings: self allLocals , maybeExternFunctions) do: [ :var | | decl | decl := self declarationAt: var @@ -124,9 +124,10 @@ TMethod >> addTypeForSelf [ TMethod >> addVarsDeclarationsAndLabelsOf: methodToBeInlined except: doNotRename [ "Prepare to inline the body of the given method into the receiver by making the args and locals of the argument to the receiver be locals of the receiver. Record any type declarations for these variables. Record labels. Assumes that the variables have already be renamed to avoid name clashes." - locals + self locals: (self locals addAll: (methodToBeInlined args reject: [ :v | doNotRename includes: v]); - addAll: (methodToBeInlined locals reject: [ :v | doNotRename includes: v]). + addAll: (methodToBeInlined locals reject: [ :v | doNotRename includes: v]); + yourself). methodToBeInlined declarations keysAndValuesDo: [ :v :decl | (doNotRename includes: v) ifFalse: @@ -146,8 +147,15 @@ TMethod >> allCalls [ TMethod >> allLocals [ "The merge of locals and declarations (don't ask)" - ^(declarations keys asSet reject: [:k| (declarations at: k) == #implicit]) - addAll: locals; yourself + | allLocals | + cachedLocals ifNotNil: [ ^ cachedLocals ]. + + allLocals := Set new. + allLocals addAll: (declarations keys asSet reject: [:k| (declarations at: k) == #implicit]). + allLocals addAll: self locals. + self nodesDo: [ :node | + node isStatementList ifTrue: [ allLocals addAll: node locals ] ]. + ^ cachedLocals := allLocals ] { #category : #accessing } @@ -215,9 +223,12 @@ TMethod >> argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeG typeCompatibleWith: argName inliningInto: meth in: self). - locals + + cachedLocals := nil. + self locals remove: argName - ifAbsent: [ self assert: (argName beginsWith: 'self_in_') ]. + ifAbsent: [ self assert: (argName beginsWith: 'self_in_') + ]. declarations removeKey: argName ifAbsent: nil ] ifFalse: [ "Add an assignment for anything except an unused self_in_foo argument" (elidedArgs includes: argName) ifFalse: [ @@ -379,7 +390,7 @@ TMethod >> asCASTIn: aCodeGen [ isPrototype: false. functionDefinition body: CCompoundStatementNode new. aCodeGen - pushScope: declarations + pushScope: self while: [ body := (parseTree asCASTIn: aCodeGen) ]. "Generation will note used variables in usedVariablesCache" self addCASTLocalsIn: functionDefinition body generator: aCodeGen. functionDefinition body add: body. @@ -398,14 +409,14 @@ TMethod >> asCASTInlinedIn: aBuilder [ self removeUnusedTempsAndNilIfRequiredIn: aBuilder. compoundStatement := CCompoundStatementNode new. - locals isEmpty ifFalse: [ - (aBuilder sortStrings: locals) do: [ :var | + self locals ifNotEmpty: [ + (aBuilder sortStrings: self locals) do: [ :var | compoundStatement add: (CRawCodeNode code: (self declarationAt: var ifAbsent: [ aBuilder defaultType , ' ' , var ])) ] ]. compoundStatement add: (aBuilder asmLabelNodeFor: selector ). aBuilder - pushScope: declarations + pushScope: self while: [ body := (parseTree asCASTIn: aBuilder) ]. compoundStatement add: body. @@ -514,8 +525,9 @@ TMethod >> buildSwitchStmt: aSendNode parent: parentNode [ (aSendNode arguments at: 2 ifAbsent: [ nil ]). (aSendNode receiver isVariable or: [ parentNode isStatementList ]) ifFalse: [ + cachedLocals := nil. switch switchVariable: - (locals add: (self extraVariableName: 'switch')) ]. + (self locals add: (self extraVariableName: 'switch')) ]. ^ switch ] @@ -567,20 +579,6 @@ TMethod >> checkSuccessExpr [ varName: '' ] -{ #category : #accessing } -TMethod >> checkedDeclarationAt: aVariableName put: aDeclaration in: aCCodeGen [ - ((args includes: aVariableName) - or: [(locals includes: aVariableName) - or: [(definingClass instVarIndexFor: aVariableName asString ifAbsent: nil) notNil - or: [aDeclaration beginsWith: 'extern ']]]) ifFalse: - [| msg | - msg := definingClass name, '>>', selector, ' contains declaration for non-existent variable ', aVariableName. - aCCodeGen - ifNotNil: [aCCodeGen logger show: msg; cr] - ifNil: [self error: msg]]. - ^self declarationAt: aVariableName "" put: aDeclaration -] - { #category : #accessing } TMethod >> children [ @@ -635,7 +633,7 @@ TMethod >> computePossibleSideEffectsInto: writtenToVars visited: visitedSelecto parseTree nodesDo: [ :node | (node isAssignment - and: [(locals includes: node variable name) not]) + and: [(self allLocals includes: node variable name) not]) ifTrue: [writtenToVars add: node variable name]. (node isSend @@ -677,14 +675,15 @@ TMethod >> declarations [ TMethod >> declareNonConflictingLocalNamedLike: aString [ | definedVariables n newVarName | - definedVariables := (locals , args) asSet. + definedVariables := (self allLocals, args) asSet. n := 1. newVarName := aString. [ definedVariables includes: newVarName ] whileTrue: [ newVarName := aString , n printString. n := n + 1 ]. - - locals add: newVarName. + + cachedLocals := nil. + self locals add: newVarName. ^ newVarName ] @@ -858,12 +857,14 @@ TMethod >> ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen [ node arguments size = 4 ifTrue: [ hasSideEffects - ifTrue: [ locals add: node arguments last name ] + ifTrue: [ + cachedLocals := nil. + self locals add: node arguments last name ] ifFalse: [ node arguments: node arguments allButLast ] ] ifFalse: [ "If the expression is complex but as yet there is no limit variable, add it" hasSideEffects ifTrue: [ | var | - var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: locals. "N.B. adds it to locals!!" + var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: self locals. "N.B. adds it to locals!!" node arguments: node arguments , { (TVariableNode new setName: var; yourself) }. @@ -949,6 +950,16 @@ TMethod >> exitVar: exitVar label: exitLabel [ ^labelUsed ] +{ #category : #transformation } +TMethod >> expandSuperSendsIn: aCCodeGeneratorGlobalStructure [ + + self nodesDo: [ :e | + (e isSend and: [ e receiver isVariable + and: [ e receiver name = 'super' ]]) ifTrue: [ + e replaceBy: (self superExpansionNodeFor: e selector args: e arguments) ] ] + +] + { #category : #accessing } TMethod >> export [ @@ -1187,7 +1198,7 @@ TMethod >> freeVariableReferences [ node isVariable ifTrue: [ refs add: node name asString ]. ]. args do: [ :var | refs remove: var asString ifAbsent: [] ]. - locals do: [ :var | refs remove: var asString ifAbsent: [] ]. + self allLocals do: [ :var | refs remove: var asString ifAbsent: [] ]. #('self' 'nil' 'true' 'false') do: [ :var | refs remove: var ifAbsent: [] ]. ^refs ] @@ -1409,8 +1420,9 @@ TMethod >> inlineFunctionCall: aSendNode in: aCodeGen [ meth args with: argsForInlining do: [ :argName :exprNode | substitutionDict at: argName put: exprNode. - (doNotRename includes: argName) ifFalse: - [locals remove: argName]]. + (doNotRename includes: argName) ifFalse: [ + cachedLocals := nil. + self locals remove: argName]]. meth parseTree bindVariablesIn: substitutionDict. ^meth parseTree endsWithReturn ifTrue: [meth parseTree copyWithoutReturn] @@ -1601,8 +1613,9 @@ TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: "Propagate any unusual argument types to untyped argument variables" methArgs with: aSendNode arguments do: [ :formal :actual | - (meth declarationAt: formal ifAbsent: nil) ifNil: [ - (self typeFor: actual in: aCodeGen) ifNotNil: [ :type | + (meth declarationAt: formal ifAbsent: nil) ifNil: [ | type | + (actual isVariable and: [ (type := self typeFor: actual name in: aCodeGen) notNil ]) + ifTrue: [ type ~= #sqInt ifTrue: [ meth declarationAt: formal put: (type last = $* ifTrue: [ type , formal ] @@ -1834,7 +1847,7 @@ TMethod >> isNode: aNode substitutableFor: argName inMethod: targetMeth in: aCod aNode isConstant ifTrue: [^true]. aNode isVariable ifTrue: - [((locals includes: aNode name) + [((self locals includes: aNode name) or: [(args includes: aNode name) or: [#('self' 'true' 'false' 'nil') includes: aNode name]]) ifTrue: [^true]. "We can substitute any variable provided it is only read in the method being inlined, @@ -1886,7 +1899,7 @@ TMethod >> isNode: aNode substitutableFor: argName inMethod: targetMeth in: aCod [node isVariable ifTrue: [(aCodeGen isNonArgumentImplicitReceiverVariableName: node name) ifFalse: [constantExpression := false. - ((locals includes: node name) + ((self locals includes: node name) or: [(args includes: node name) or: [(#('self' 'true' 'false' 'nil') includes: node name) or: [targetMeth maySubstituteGlobal: node name in: aCodeGen]]]) ifFalse: [^false]]] ifFalse: @@ -1942,7 +1955,7 @@ TMethod >> isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen [ aNode isVariable ifTrue: [ var := aNode name. - ((locals includes: var) or: [args includes: var]) ifTrue: [ ^ true ]. + ((self locals includes: var) or: [args includes: var]) ifTrue: [ ^ true ]. (#(self true false nil) includes: var) ifTrue: [ ^ true ]. (targetMeth maySubstituteGlobal: var in: aCodeGen) ifTrue: [ ^ true ]. ]. @@ -1965,7 +1978,7 @@ TMethod >> isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen [ ]. node isVariable ifTrue: [ var := node name. - ((locals includes: var) or: + ((self locals includes: var) or: [(args includes: var) or: [(#(self true false nil) includes: var) or: [targetMeth maySubstituteGlobal: var in: aCodeGen]]]) ifFalse: [ ^ false ]. @@ -1997,16 +2010,25 @@ TMethod >> labels: aCollection [ TMethod >> localizeVariables: localizationCandidates [ | definedVariables | - definedVariables := (locals , args) asSet. + definedVariables := (self allLocals , args) asSet. "make local versions of the given globals" - locals addAll: (localizationCandidates reject: [ :var | definedVariables includes: var ]) + cachedLocals := nil. + self locals addAll: (localizationCandidates reject: [ :var | definedVariables includes: var ]) ] { #category : #accessing } TMethod >> locals [ + "The local variables of the body of this method" + + ^ parseTree locals +] + +{ #category : #accessing } +TMethod >> locals: aCollection [ "The local variables of this method." - ^locals + cachedLocals := nil. + parseTree locals: aCollection ] { #category : #transformations } @@ -2126,15 +2148,6 @@ TMethod >> noteUsedVariableName: token [ [usedVariablesCache add: token] ] -{ #category : #private } -TMethod >> oopVariable: aString [ - - (locals includes: aString) ifFalse: - [locals add: aString. - self declarationAt: aString put: 'sqInt ', aString]. - ^TVariableNode new setName: aString -] - { #category : #'C code generation' } TMethod >> outputConditionalDefineFor: compileTimeOptionPragmas on: aStream [ aStream nextPutAll: '#if '. @@ -2174,7 +2187,7 @@ TMethod >> popArgsExpr: argCount [ { #category : #copying } TMethod >> postCopy [ args := args copy. - locals := locals copy. + self locals: self locals copy. declarations := declarations copy. parseTree := parseTree copy. labels := labels copy @@ -2192,11 +2205,12 @@ TMethod >> prepareMethodIn: aCodeGen [ [:varName :decl| decl isBlock ifTrue: [self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]). - locals add: varName. + cachedLocals := nil. + self locals add: varName. self declarationAt: varName put: (decl value: self value: aCodeGen), ' ', varName]]]. aCodeGen - pushScope: declarations + pushScope: self while:"N.B. nodesWithParentsDo: is bottom-up, hence replacement is destructive and conserved." [parseTree nodesWithParentsDo: [:node :parent| @@ -2285,15 +2299,18 @@ Undeclared variables are taken to be integers and will be converted from Smallta 1 to: instVarList size do: [:varIndex | varName := instVarList at: varIndex. (instVarsUsed includes: varName) ifTrue: [ - locals add: varName. + cachedLocals := nil. + self locals add: varName. prolog addAll: (self instVarGetExprFor: varName offset: varIndex - 1). (varsAssignedTo includes: varName) ifTrue: [ postlog addAll: (self instVarPutExprFor: varName offset: varIndex - 1)]]]. prolog addAll: self checkSuccessExpr. - ((locals includes: 'rcvr') or: [(locals intersection: args) notEmpty]) ifTrue: + ((self locals includes: 'rcvr') or: [(self locals intersection: args) notEmpty]) ifTrue: [self error: 'local name conflicts with instance variable name']. - locals add: 'rcvr'; addAll: args. + + cachedLocals := nil. + self locals add: 'rcvr'; addAll: args. args := args class new. endsWithReturn := self endsWithReturn. self fixUpReturns: primArgCount postlog: postlog. @@ -2421,52 +2438,22 @@ TMethod >> recordDeclarationsIn: aCCodeGen [ self var: #foo declareC: 'float foo' self var: #foo type:'float'. and remove the declarations from the method body." - - | newStatements | - properties pragmas notEmpty ifTrue: [ - properties pragmas do: [ :pragma | - pragma selector == #var:declareC: ifTrue: [ - self - checkedDeclarationAt: pragma arguments first asString - put: pragma arguments last - in: aCCodeGen ]. - pragma selector == #var:type: ifTrue: [ - | varName varType | - varName := pragma arguments first asString. - varType := aCCodeGen conventionalTypeForType: - pragma arguments last. - varType last == $* ifFalse: [ varType := varType , ' ' ]. - self - checkedDeclarationAt: varName - put: varType , varName - in: aCCodeGen ]. - pragma selector = #returnTypeC: ifTrue: [ - self returnType: pragma arguments last ]. - pragma selector = #doNotGenerate: ifTrue: [ - locals remove: pragma arguments last ] ]. - ^ self ]. - newStatements := OrderedCollection new: parseTree statements size. - parseTree statements do: [ :stmt | - | isDeclaration | - isDeclaration := false. - stmt isSend ifTrue: [ - stmt selector == #var:declareC: ifTrue: [ - isDeclaration := true. - self - declarationAt: stmt args first value asString - put: stmt args last value ]. - stmt selector == #var:type: ifTrue: [ - | varName varType | - isDeclaration := true. - varName := stmt args first value asString. - varType := aCCodeGen conventionalTypeForType: stmt args last value. - varType last == $* ifFalse: [ varType := varType , ' ' ]. - self declarationAt: varName put: varType , varName ]. - stmt selector = #returnTypeC: ifTrue: [ - isDeclaration := true. - returnType := stmt args last value ] ]. - isDeclaration ifFalse: [ newStatements add: stmt ] ]. - parseTree statements: newStatements asArray + properties pragmas do: [ :pragma | + pragma selector == #var:declareC: ifTrue: [ + self + declarationAt: pragma arguments first asString + put: pragma arguments last ]. + pragma selector == #var:type: ifTrue: [ + | varName varType | + varName := pragma arguments first asString. + varType := aCCodeGen conventionalTypeForType: + pragma arguments last. + varType last == $* ifFalse: [ varType := varType , ' ' ]. + self + declarationAt: varName + put: varType , varName ]. + pragma selector = #returnTypeC: ifTrue: [ + self returnType: pragma arguments last ] ] ] { #category : #accessing } @@ -2522,11 +2509,12 @@ TMethod >> removeUnusedTempsAndNilIfRequiredIn: aCodeGen [ | refs readBeforeAssigned simplyTypedLocals | refs := self removeUnusedTempsIn: aCodeGen. "reset the locals to be only those still referred to" - locals := locals select: [:e| refs includes: e]. - (locals notEmpty + cachedLocals := nil. + self locals: (self locals select: [:e| refs includes: e]). + (self locals notEmpty and: [aCodeGen - pushScope: declarations - while: [simplyTypedLocals := locals select: + pushScope: self + while: [simplyTypedLocals := self locals select: [:var| declarations at: var @@ -2561,13 +2549,15 @@ TMethod >> removeUnusedTempsIn: aCodeGen [ | usedVariables | usedVariables := self allReferencedVariablesUsing: aCodeGen. "reset the locals to be only those still referred to" - locals do: + self locals copy do: [:local| (usedVariables includes: local) ifFalse: [(((declarations at: local ifAbsent: ['']) includesSubstring: 'static') or: [(declarations at: local ifAbsent: ['']) includesSubstring: 'extern']) ifFalse: - [locals remove: local. + [ + cachedLocals := nil. + self locals remove: local. declarations removeKey: local ifAbsent: []] ifTrue: [usedVariables add: local "In case this is a function declaration, e.g. amInVMThread in ownVM:"]]]. @@ -2619,7 +2609,9 @@ TMethod >> renameVariablesUsing: aDictionary [ "map args and locals" args := args collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]. - locals := locals collect: [ :v | aDictionary at: v ifAbsent: [ v ] ]. + + cachedLocals := nil. + self locals: (self locals collect: [ :v | aDictionary at: v ifAbsent: [ v ] ]). "map declarations" newDecls := declarations species new. @@ -2672,9 +2664,9 @@ TMethod >> renameVarsForInliningInto: destMethod except: doNotRename in: aCodeGe destVars addAll: destMethod locals. destVars addAll: destMethod args. usedVars := destVars copy. "keeps track of names in use" - usedVars addAll: args; addAll: locals. + usedVars addAll: args; addAll: self locals. varMap := Dictionary new: 100. - locals, args do: + self locals, args do: [ :v | ((doNotRename includes: v) not and: [destVars includes: v]) ifTrue: @@ -2755,16 +2747,17 @@ TMethod >> setSelector: sel definingClass: class args: argList locals: localList selector := sel. definingClass := class. - args := argList asOrderedCollection collect: [:arg | arg key]. - locals := (localList collect: [:arg | arg key]) asSet. + args := argList asOrderedCollection collect: [:arg | arg name]. + + parseTree := aBlockNode. "hack; allows nodes to find their parent, etc" + parseTree := aBlockNode asTranslatorNodeIn: self. + declarations := Dictionary new. self addTypeForSelf. primitive := aNumber. properties := methodProperties. comment := aComment. labels := Set new. - parseTree := aBlockNode. "hack; allows nodes to find their parent, etc" - parseTree := aBlockNode asTranslatorNodeIn: self. complete := false. "set to true when all possible inlining has been done" export := self extractExportDirective. static := self extractStaticDirective. @@ -2904,8 +2897,8 @@ TMethod >> superExpansionNodeFor: aSelector args: argumentNodes [ ifNotNil: [:superMethod| | superTMethod commonVars varMap | superTMethod := superMethod asTranslationMethodOfClass: self class. - ((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode]) - and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse: + ((argumentNodes allSatisfy: [:parseNode| parseNode isVariable]) + and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode name]) = superTMethod args]) ifFalse: [self error: definingClass name, '>>',selector, ' args ~= ', superTMethod definingClass name, '>>', aSelector, (String with: $. with: Character cr), @@ -2917,7 +2910,8 @@ TMethod >> superExpansionNodeFor: aSelector args: argumentNodes [ superTMethod renameVariablesUsing: varMap]. self mergePropertiesOfSuperMethod: superTMethod. self assert: (superTMethod locals allSatisfy: [:var| (self locals includes: var) not]). - locals addAll: superTMethod locals. + cachedLocals := nil. + self locals addAll: superTMethod locals. superTMethod declarations keysAndValuesDo: [:var :decl| self declarationAt: var put: decl]. @@ -3073,7 +3067,7 @@ TMethod >> tryToInlineMethodExpressionsIn: aCodeGen [ | sendsToInline | sendsToInline := Dictionary new: 100. aCodeGen - pushScope: declarations + pushScope: self while: [parseTree nodesDo: [:node| @@ -3176,23 +3170,21 @@ TMethod >> tryToInlineMethodsIn: aCodeGen [ ] { #category : #utilities } -TMethod >> typeFor: aVariable in: aCodeGen [ +TMethod >> typeFor: aVariableName in: aCodeGen [ "Answer the type for aVariable, deferring to aCodeGen (which defers to the vmClass) if no type is found and the variable is global (not an arg or a local). Expect the cCodeGen to answer nil for variables without types. nil for typelessness is required by the type propagation logic in inlineSend:directReturn:exitVar:in:." - | varName | - varName := aVariable asString. ^(declarations - at: varName + at: aVariableName ifAbsent: - [(args includes: varName) "arg types default to default integer type" - ifTrue: [aCodeGen defaultType, ' ', varName] + [(args includes: aVariableName) "arg types default to default integer type" + ifTrue: [aCodeGen defaultType, ' ', aVariableName] ifFalse: - [(locals includes: varName) ifFalse: "don't provide type for locals" - [aCodeGen typeOfVariable: varName]]]) ifNotNil: + [(self locals includes: aVariableName) ifFalse: "don't provide type for locals" + [aCodeGen typeOfVariable: aVariableName]]]) ifNotNil: [:decl| - aCodeGen extractTypeFor: varName fromDeclaration: decl] + aCodeGen extractTypeFor: aVariableName fromDeclaration: decl] ] { #category : #utilities } diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 6d6fd4a5a6..8ec8739d4f 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -2,6 +2,7 @@ Class { #name : #TStatementListNode, #superclass : #TParseNode, #instVars : [ + 'locals', 'arguments', 'statements' ], @@ -272,6 +273,7 @@ TStatementListNode >> flattened [ TStatementListNode >> initialize [ super initialize. + locals := #(). arguments := #() ] @@ -302,6 +304,18 @@ TStatementListNode >> isStatementList [ ^true ] +{ #category : #accessing } +TStatementListNode >> locals [ + + ^ locals +] + +{ #category : #accessing } +TStatementListNode >> locals: anObject [ + + locals := anObject +] + { #category : #enumerating } TStatementListNode >> nodesDo: aBlock [ "Apply aBlock to all nodes in the receiver. diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index 750ea3f513..b9b15a3a5e 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -132,7 +132,7 @@ TVariableNode >> structTargetKindIn: aCodeGen [ { #category : #'type inference' } TVariableNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ - ^aTMethod typeFor: self in: aCodeGenerator + ^aTMethod typeFor: self name in: aCodeGenerator ] { #category : #accessing } diff --git a/smalltalksrc/VMMaker/Object.extension.st b/smalltalksrc/VMMaker/Object.extension.st index 49fcef5b08..645e14bb05 100644 --- a/smalltalksrc/VMMaker/Object.extension.st +++ b/smalltalksrc/VMMaker/Object.extension.st @@ -182,11 +182,6 @@ Object >> touch: something [ "For translation only; eliminated by CCodeGenerator. Used to squash unused varable warnings." ] -{ #category : #'*VMMaker-translation support' } -Object >> var: varSymbol declareC: declString [ - "For translation only; noop when running in Smalltalk." -] - { #category : #'*VMMaker-translation support' } Object >> var: varSymbol type: typeString [ "For translation only; noop when running in Smalltalk." diff --git a/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st b/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st index b2fa1af5f4..f20baada65 100644 --- a/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st +++ b/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st @@ -38,8 +38,8 @@ SmartSyntaxPluginTMethod >> emitCLocalsOn: aStream generator: aCodeGen [ "Emit a C function header for this method onto the given stream." aStream newLine. - locals isEmpty ifFalse: - [(aCodeGen sortStrings: locals) do: + self locals isEmpty ifFalse: + [(aCodeGen sortStrings: self locals) do: [ :var | aStream tab; @@ -172,7 +172,8 @@ SmartSyntaxPluginTMethod >> handlePrimitiveDirective: aStmt on: sStream [ isPrimitive := true. fullArgs := args. - locals addAll: args. + cachedLocals := nil. + self locals addAll: args. args := OrderedCollection new. fullArgs with: parmSpecs do: [:argName :spec | @@ -274,6 +275,17 @@ SmartSyntaxPluginTMethod >> nullReturnExpr [ setExpression: (TVariableNode new setName: 'null') ] +{ #category : #private } +SmartSyntaxPluginTMethod >> oopVariable: aString [ + + (self locals includes: aString) ifFalse: + [ + cachedLocals := nil. + self locals add: aString. + self declarationAt: aString put: 'sqInt ', aString]. + ^TVariableNode new setName: aString +] + { #category : #accessing } SmartSyntaxPluginTMethod >> parmSpecs [ @@ -335,12 +347,12 @@ SmartSyntaxPluginTMethod >> primitiveDirectiveWasHandled: stmt on: sStream [ SmartSyntaxPluginTMethod >> printTempsAndVar: varName on: aStream [ "add the required temps and the varname to the stream" aStream nextPut: $|; space. - (#('rcvr' 'stackPointer' 'interpreterProxy') reject: [:each | locals includes: each]) do: + (#('rcvr' 'stackPointer' 'interpreterProxy') reject: [:each | self locals includes: each]) do: [:each | aStream nextPutAll: each; space]. - (locals reject: [:each | each first = $_]) do: + (self locals reject: [:each | each first = $_]) do: [:each | aStream nextPutAll: each; space]. "don't add varName twice. Probably a deeper reason for this, but WTH. TPR" - (locals includes: varName) ifFalse: + (self locals includes: varName) ifFalse: [aStream nextPutAll: varName; space]. aStream nextPut: $|; newLine ] @@ -370,9 +382,8 @@ SmartSyntaxPluginTMethod >> recordDeclarationsIn: aCCodeGen [ properties pragmas do: [ :pragma | pragma key == #var:declareC: ifTrue: [ self - checkedDeclarationAt: pragma arguments first asString - put: pragma arguments last - in: aCCodeGen ]. + declarationAt: pragma arguments first asString + put: pragma arguments last ]. pragma key == #var:type: ifTrue: [ | varName varType | varName := pragma arguments first asString. @@ -380,9 +391,8 @@ SmartSyntaxPluginTMethod >> recordDeclarationsIn: aCCodeGen [ pragma arguments last. varType last == $* ifFalse: [ varType := varType , ' ' ]. self - checkedDeclarationAt: varName - put: varType , varName - in: aCCodeGen ]. + declarationAt: varName + put: varType , varName ]. pragma key == #var:as: ifTrue: [ | theClass | theClass := Smalltalk @@ -391,14 +401,11 @@ SmartSyntaxPluginTMethod >> recordDeclarationsIn: aCCodeGen [ theClass isBehavior ifFalse: [ ^ self error: 'declarator must be a Behavior' ]. self - checkedDeclarationAt: pragma arguments first value asString + declarationAt: pragma arguments first value asString put: - (theClass ccgDeclareCForVar: pragma arguments first asString) - in: aCCodeGen ]. + (theClass ccgDeclareCForVar: pragma arguments first asString) ]. pragma key == #returnTypeC: ifTrue: [ - self returnType: pragma arguments last ]. - pragma key = #doNotGenerate: ifTrue: [ - locals removeKey: pragma arguments last ] ]. + self returnType: pragma arguments last ]]. ^ self ]. newStatements := OrderedCollection new: parseTree statements size. parseTree statements do: [ :stmt | @@ -470,7 +477,7 @@ SmartSyntaxPluginTMethod >> setSelector: sel definingClass: class args: argList definingClass := class. returnType := #sqInt. "assume return type is sqInt for now" args := argList asOrderedCollection collect: [:arg | arg key]. - locals := (localList collect: [:arg | arg key]) asSet. + self locals: (localList collect: [:arg | arg key]) asSet. declarations := Dictionary new. primitive := aNumber. properties := methodProperties. diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st index e35d28e0fb..65ff2ffc83 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st @@ -2,23 +2,8 @@ Extension { #name : #RBBlockNode } { #category : #'*VMMakerCompatibilityForPharo6-C translation' } RBBlockNode >> asTranslatorNodeIn: aTMethod [ - "Answer a TParseNode subclass equivalent of me" - | statementList | - statementList := OrderedCollection new. - body statements do: - [:s | | newS | - newS := s asTranslatorNodeIn: aTMethod. - "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" - newS isStatementList - ifTrue: [statementList addAll: newS statements] - ifFalse: [statementList add: newS]]. - statementList ifEmpty: [ - statementList add: (TVariableNode new setName: 'nil'). - ]. - ^TStatementListNode new - setArguments: (arguments asArray collect: [:arg | arg name]) - statements: statementList; - comment: self commentOrNil + + ^ body asTranslatorNodeIn: aTMethod ] { #category : #'*VMMakerCompatibilityForPharo6-testing' } diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st index 2d39838e93..4fdfbc1b3b 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st @@ -13,10 +13,6 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ | usedSelector rcvrOrNil args | usedSelector := selector value. rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod]. - (rcvrOrNil notNil - and: [rcvrOrNil isVariable - and: [rcvrOrNil name = 'super']]) ifTrue: - [^aTMethod superExpansionNodeFor: usedSelector args: arguments]. usedSelector == #halt ifTrue: [^rcvrOrNil]. (usedSelector == #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block." or: [usedSelector == #cCode:]) ifTrue: diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st index 92d58f4e24..79e68d1e3d 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st @@ -58,7 +58,7 @@ RBMethodNode >> asTranslationMethodOfClass: aTMethodClass forCodeGenerator: aCod setSelector: selector definingClass: compilationContext getClass args: arguments - locals: ((self allDefinedVariables copyWithoutAll: (arguments collect: #name)) collect: [:string| string -> string]) + locals: #() block: (body lastIsReturn ifTrue: [body] ifFalse: [body shallowCopy diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st index a14027dc56..8bf5838a20 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st @@ -13,6 +13,7 @@ RBSequenceNode >> asTranslatorNodeIn: aTMethod [ ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. ^TStatementListNode new + locals: (self temporaries collect: [:e | e name ]); setArguments: (parent isMethod ifTrue: [#()] ifFalse: [parent arguments asArray collect: [:arg | arg name]]) diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBVariableNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBVariableNode.extension.st index df9003a5f4..026913c2f5 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBVariableNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBVariableNode.extension.st @@ -12,8 +12,3 @@ RBVariableNode >> asTranslatorNodeIn: aTMethod [ RBVariableNode >> isVariableNode [ ^true ] - -{ #category : #'*VMMakerCompatibilityForPharo6-accessing' } -RBVariableNode >> key [ - ^name -] From 75b7ff6f10a03b7405c6f75c703a6bdd3656fd5a Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 15:41:34 +0100 Subject: [PATCH 45/75] Extracting common methods --- smalltalksrc/Slang/CCodeGenerator.class.st | 37 +--------- smalltalksrc/Slang/TMethod.class.st | 78 +++++++++++----------- 2 files changed, 41 insertions(+), 74 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 75745da368..91dd107710 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3765,7 +3765,7 @@ CCodeGenerator >> localizeGlobalVariables [ (procedure isRealMethod and: [self shouldGenerateMethod: procedure]) ifTrue: [(localized at: name ifAbsentPut: [SortedCollection new]) add: key. - elected add: (procedure locals add: key). + elected add: (procedure addLocal: key). newDeclaration := variableDeclarations at: key ifAbsent: ['sqInt ', key]. (self initializerForInstVar: key inStartClass: procedure definingClass) ifNotNil: [:initializerNode| @@ -4501,41 +4501,6 @@ CCodeGenerator >> putDefineOf: aConstantNameString as: valueOrValueString on: aS cr ] -{ #category : #'automatic-localization' } -CCodeGenerator >> referencedVariablesIn: variablesToLocalize inSend: sendNode calledBy: caller withDictionary: associationDictionary [ - "Return the references to global variables that are in variablesToLocalize in method selector." - - | currentMeth externalCalls globalReferences variablesReferences | - associationDictionary at: sendNode selector ifPresent: [ :vars | ^ vars ]. - - "If it is a dynamic call, be conservative: assume all variables to localize may be touched" - (self isDynamicCall: sendNode) - ifTrue: [ ^ variablesToLocalize ]. - - currentMeth := self methodNamed: sendNode selector. - - "Otherwise, compute the subset of variablesToLocalize referenced in the method" - externalCalls := (currentMeth externalCallsIn: self) reject: [ :call | - call selector = sendNode selector or: [ call selector = caller ] ]. - globalReferences := currentMeth freeVariableReferences. - variablesReferences := (variablesToLocalize select: [ :var | - globalReferences includes: var ]) asSet. - associationDictionary at: sendNode selector put: variablesReferences. - externalCalls ifEmpty: [ - ^ variablesReferences ]. - - externalCalls do: [ :externalCall | - (associationDictionary includesKey: externalCall selector) ifFalse: [ - | subreferences | - subreferences := self - referencedVariablesIn: variablesToLocalize - inSend: externalCall - calledBy: sendNode selector - withDictionary: associationDictionary. - (associationDictionary at: sendNode selector) addAll: subreferences ] ]. - ^ variablesReferences -] - { #category : #inlining } CCodeGenerator >> removeAssertions [ "Remove all assertions in method bodies. This is for the benefit of inlining, which diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 137cb1cc7b..9360222c72 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -108,6 +108,13 @@ TMethod >> addLabelsTo: aTMethod [ aTMethod labels addAll: labels ] +{ #category : #accessing } +TMethod >> addLocal: aString [ + + cachedLocals := nil. + self locals add: aString +] + { #category : #initialization } TMethod >> addTypeForSelf [ "If self should be typed then add a suitable type declaration. @@ -223,12 +230,8 @@ TMethod >> argAssignmentsFor: meth send: aSendNode except: elidedArgs in: aCodeG typeCompatibleWith: argName inliningInto: meth in: self). - - cachedLocals := nil. - self locals - remove: argName - ifAbsent: [ self assert: (argName beginsWith: 'self_in_') - ]. + + self removeLocal: argName. declarations removeKey: argName ifAbsent: nil ] ifFalse: [ "Add an assignment for anything except an unused self_in_foo argument" (elidedArgs includes: argName) ifFalse: [ @@ -1392,6 +1395,7 @@ TMethod >> inlineConditional: aSendNode in: aCodeGen [ { #category : #inlining } TMethod >> inlineFunctionCall: aSendNode in: aCodeGen [ + "Answer the body of the called function, substituting the actual parameters for the formal argument variables in the method body. Assume caller has established that: @@ -1401,32 +1405,28 @@ TMethod >> inlineFunctionCall: aSendNode in: aCodeGen [ | sel meth doNotRename argsForInlining substitutionDict | sel := aSendNode selector. meth := (aCodeGen methodNamed: sel) copy. - meth ifNil: - [^self inlineBuiltin: aSendNode in: aCodeGen]. + meth ifNil: [ ^ self inlineBuiltin: aSendNode in: aCodeGen ]. doNotRename := Set withAll: args. - argsForInlining := aSendNode argumentsForInliningCodeGenerator: aCodeGen. - meth args with: argsForInlining do: - [ :argName :exprNode | - exprNode isLeaf ifTrue: - [doNotRename add: argName]]. - (meth statements size = 2 - and: [meth statements first isSend - and: [meth statements first selector == #flag:]]) ifTrue: - [meth statements removeFirst]. + argsForInlining := aSendNode argumentsForInliningCodeGenerator: + aCodeGen. + meth args with: argsForInlining do: [ :argName :exprNode | + exprNode isLeaf ifTrue: [ doNotRename add: argName ] ]. + (meth statements size = 2 and: [ + meth statements first isSend and: [ + meth statements first selector == #flag: ] ]) ifTrue: [ + meth statements removeFirst ]. meth renameVarsForInliningInto: self except: doNotRename in: aCodeGen. meth renameLabelsForInliningInto: self. self addVarsDeclarationsAndLabelsOf: meth except: doNotRename. substitutionDict := Dictionary new: meth args size * 2. - meth args with: argsForInlining do: - [ :argName :exprNode | + meth args with: argsForInlining do: [ :argName :exprNode | substitutionDict at: argName put: exprNode. - (doNotRename includes: argName) ifFalse: [ - cachedLocals := nil. - self locals remove: argName]]. + (doNotRename includes: argName) ifFalse: [ + self removeLocal: argName ] ]. meth parseTree bindVariablesIn: substitutionDict. - ^meth parseTree endsWithReturn - ifTrue: [meth parseTree copyWithoutReturn] - ifFalse: [meth parseTree] + ^ meth parseTree endsWithReturn + ifTrue: [ meth parseTree copyWithoutReturn ] + ifFalse: [ meth parseTree ] ] { #category : #inlining } @@ -2542,26 +2542,28 @@ TMethod >> removeUnusedTempsAndNilIfRequiredIn: aCodeGen [ { #category : #utilities } TMethod >> removeUnusedTempsIn: aCodeGen [ + "Remove all of the unused temps in this method. Answer a set of the references." + "After inlining some variable references are now obsolete, we could fix them there but the code seems a bit complicated, the other choice to to rebuild the locals before extruding. This is done here" + | usedVariables | usedVariables := self allReferencedVariablesUsing: aCodeGen. "reset the locals to be only those still referred to" - self locals copy do: - [:local| - (usedVariables includes: local) ifFalse: - [(((declarations at: local ifAbsent: ['']) includesSubstring: 'static') - or: [(declarations at: local ifAbsent: ['']) includesSubstring: 'extern']) - ifFalse: - [ - cachedLocals := nil. - self locals remove: local. - declarations removeKey: local ifAbsent: []] - ifTrue: - [usedVariables add: local "In case this is a function declaration, e.g. amInVMThread in ownVM:"]]]. - ^usedVariables + self locals copy do: [ :local | + (usedVariables includes: local) ifFalse: [ + (((declarations at: local ifAbsent: [ '' ]) includesSubstring: + 'static') or: [ + (declarations at: local ifAbsent: [ '' ]) includesSubstring: + 'extern' ]) + ifFalse: [ + self removeLocal: local. + declarations removeKey: local ifAbsent: [ ] ] + ifTrue: [ + usedVariables add: local "In case this is a function declaration, e.g. amInVMThread in ownVM:" ] ] ]. + ^ usedVariables ] { #category : #'inlining support' } From 24afe96cfd5fd6f7af6681cc6fdc3dfa2c0b144c Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 15:44:04 +0100 Subject: [PATCH 46/75] Add missing method --- smalltalksrc/Slang/TMethod.class.st | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 9360222c72..f2aa5e3a9c 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -2501,6 +2501,13 @@ TMethod >> removeFinalSelfReturnIn: aCodeGenOrNil [ self returnType: (aCodeGenOrNil implicitReturnTypeFor: selector) ] ] ] ] +{ #category : #utilities } +TMethod >> removeLocal: local [ + + cachedLocals := nil. + self locals remove: local +] + { #category : #utilities } TMethod >> removeUnusedTempsAndNilIfRequiredIn: aCodeGen [ "Remove all of the unused temps in this method. Answer a set of the references. From cd555eeae1538c90e3109747c8953e7bb1137a06 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 16:14:48 +0100 Subject: [PATCH 47/75] Avoid creating unused variables --- .../SlangLocalizationTestCase.class.st | 51 ++++++++----------- smalltalksrc/Slang/TParseNode.class.st | 28 ++++++---- 2 files changed, 41 insertions(+), 38 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 635e9aef42..984eb943cd 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -193,7 +193,7 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgument [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ - | interpretMethod case externalCall cast printedString inlinedMethod | + | interpretMethod case cast printedString inlinedMethod | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCallAsArgumentOfExternalCall. "Assert that the send node is preceded by variable externalization" @@ -214,7 +214,7 @@ bytecodeWithEscapingCallAsArgumentOfExternalCall(void) autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable2 = local_autoLocalizedVariable2; - t1 = foo(t0); + foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; @@ -246,7 +246,7 @@ bytecodeUsingInlinedCall(void) /* begin inlinedMethodUsingExternalCall */ autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; - t0 = foo2(); + foo2(); local_autoLocalizedVariable = autoLocalizedVariable; local_autoLocalizedVariable1 = autoLocalizedVariable1; } @@ -276,7 +276,7 @@ bytecodeWithEscapingCall(void) { { autoLocalizedVariable = local_autoLocalizedVariable; - t0 = foo((local_autoLocalizedVariable += 1)); + foo((local_autoLocalizedVariable += 1)); local_autoLocalizedVariable = autoLocalizedVariable; } return 0; @@ -287,7 +287,7 @@ bytecodeWithEscapingCall(void) { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod case inlinedMethod cast printedString | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCall. @@ -305,7 +305,7 @@ bytecodeWithEscapingCall(void) autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable2 = local_autoLocalizedVariable2; - t0 = foo((local_autoLocalizedVariable += 1)); + foo((local_autoLocalizedVariable += 1)); local_autoLocalizedVariable = autoLocalizedVariable; local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; @@ -338,7 +338,7 @@ bytecodeUsingExternalizedAutoLocalizedVariableAsExpression(void) t0 = nonInlinedMethodUsingAutolocalizedVariable(); local_autoLocalizedVariable = autoLocalizedVariable; autoLocalizedVariable = local_autoLocalizedVariable; - t1 = foo(t0); + foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; } return 0; @@ -362,9 +362,9 @@ SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ ] After true ifTrue: [ - | t0 t1 | + | t0 | t0 := self nonInlinedMethodUsingAutolocalizedVariable. - t1 := self foo: t0 + self foo: t0 ] " ifBlock := methodToLinearize statements first arguments first. @@ -376,12 +376,10 @@ SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ receiver: TVariableNode selfNode selector: #nonInlinedMethodUsingAutolocalizedVariable))). self assert: (ifBlock statements second - isSameAs: (TAssignmentNode - variableNamed: 't1' - expression: (TSendNode + isSameAs: (TSendNode receiver: TVariableNode selfNode selector: #foo: - arguments: { TVariableNode named: 't0' }))) + arguments: { TVariableNode named: 't0' })) ] { #category : #'tests - linearization' } @@ -398,7 +396,7 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ self foo: self nonInlinedMethodUsingAutolocalizedVariable. After t0 := self nonInlinedMethodUsingAutolocalizedVariable. - t1 := self foo: t0" + self foo: t0" self assert: (methodToLinearize statements first isSameAs: (TAssignmentNode @@ -407,12 +405,11 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ receiver: TVariableNode selfNode selector: #nonInlinedMethodUsingAutolocalizedVariable))). self assert: (methodToLinearize statements second - isSameAs: (TAssignmentNode - variableNamed: 't1' - expression: (TSendNode + isSameAs: (TSendNode receiver: TVariableNode selfNode selector: #foo: - arguments: { TVariableNode named: 't0' }))) + arguments: { TVariableNode named: 't0' })). + self assert: methodToLinearize statements size equals: 3. ] { #category : #'tests - linearization' } @@ -429,16 +426,14 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsDefinesIntermediateVariable self foo: self nonInlinedMethodUsingAutolocalizedVariable. After t0 := self nonInlinedMethodUsingAutolocalizedVariable. - t1 := self foo: t0 + self foo: t0 - => both t0 and t1 should be defined in the method" + => t0 should be defined in the method" self assert: (methodToLinearize locals includes: 't0'). - self assert: (methodToLinearize locals includes: 't1') - ] -{ #category : #'tests - linearization' } +{ #category : #'tests - initialization' } SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ | methodToLinearize | @@ -521,14 +516,12 @@ SlangLocalizationTestCase >> testLinearizeSingleCalls [ "Before it was self inlinedMethodUsingExternalCall. After - t0 := self inlinedMethodUsingExternalCall" + self inlinedMethodUsingExternalCall" self assert: (methodToLinearize statements first - isSameAs: (TAssignmentNode - variableNamed: 't0' - expression: (TSendNode + isSameAs: (TSendNode receiver: TVariableNode selfNode - selector: #inlinedMethodUsingExternalCall))) + selector: #inlinedMethodUsingExternalCall)) ] { #category : #'tests - old localization' } @@ -598,5 +591,5 @@ SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: 't0 = nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' + self assert: printedString equals: 'nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' ] diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index 242498dc06..51fd7f0e30 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -328,7 +328,13 @@ TParseNode >> isVariable [ { #category : #linearization } TParseNode >> linearizeIn: aCodeGenerator [ - "I am a statement. Linearize all calls in myself until I find a block. + "Remove a linearized version of myself where calls become statements + and nested calls are assigned to variables. + I stop on receiver/arguments that are blocks. + Remove unused variables locally. + + Precondition: I am a statement. + For example, I transform statements of the form: > self foo: self nonInlinedMethodUsingAutolocalizedVariable @@ -366,14 +372,18 @@ TParseNode >> linearizeIn: aCodeGenerator [ replacementBlock := OrderedCollection new. variables := OrderedCollection new. replacementsSoFar := Dictionary new. - callsInStatement do: [ :e | - | variableNode | - variableNode := TVariableNode named: 't' , replacementBlock size asString. - variables add: variableNode name. - replacementBlock add: (TAssignmentNode - variable: variableNode - expression: (e replaceNodesIn: replacementsSoFar)). - replacementsSoFar at: e put: variableNode ]. + + "Apply linearization to all nodes except itself" + callsInStatement + select: [ :e | e ~= self ] + thenDo: [ :e | + | variableNode | + variableNode := TVariableNode named: 't' , replacementBlock size asString. + variables add: variableNode name. + replacementBlock add: (TAssignmentNode + variable: variableNode + expression: (e replaceNodesIn: replacementsSoFar)). + replacementsSoFar at: e put: variableNode ]. rewrittenStatement := self replaceNodesIn: replacementsSoFar. replacementBlock add: rewrittenStatement. From 26440de8deef67d1907022f1998a8fd857d84eb8 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 17:33:26 +0100 Subject: [PATCH 48/75] Making tests pass --- .../SlangLocalizationTestCase.class.st | 191 +++++++++--------- smalltalksrc/Slang/CCodeGenerator.class.st | 3 + .../Slang/TStatementListNode.class.st | 29 ++- 3 files changed, 108 insertions(+), 115 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 984eb943cd..6211980c37 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -97,7 +97,7 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ | externalizationStatement interpretMethod | interpretMethod := self applyLocalizationTo: #interpret. - externalizationStatement := (interpretMethod statements last: 2) first. + externalizationStatement := interpretMethod statements last first first. self assert: (externalizationStatement isSameAs: (self externalizationOf: #autoLocalizedVariable)) @@ -111,12 +111,16 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnRef | interpretMethod printedString | interpretMethod := self applyLocalizationTo: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. printedString := String streamContents: [ :str | - ((TStatementListNode statements: (interpretMethod statements last: 3)) asCASTIn: ccg) + ((TStatementListNode statements: interpretMethod statements last) asCASTIn: ccg) prettyPrintOn: str ]. self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - autoLocalizedVariable1 = local_autoLocalizedVariable1; - return (autoLocalizedVariable += 1); + { + { + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + return (autoLocalizedVariable += 1); + } + } }' ] @@ -128,15 +132,15 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ | interpretMethod sendNode | interpretMethod := self applyLocalizationTo: #interpretWithReturnExpression. - sendNode := interpretMethod statements fourth. - self assert: sendNode arguments first statements last isReturn. + sendNode := interpretMethod statements last statements first statements second.. + self assert: sendNode arguments first statements first statements first statements last isReturn. self - assert: (sendNode arguments first statements first + assert: (sendNode arguments first statements first statements first statements first isSameAs: (self externalizationOf: #autoLocalizedVariable)). - self assert: sendNode arguments second statements last isReturn. + self assert: sendNode arguments second statements first statements first statements last isReturn. self - assert: (sendNode arguments second statements first + assert: (sendNode arguments second statements first statements first statements first isSameAs: (self externalizationOf: #autoLocalizedVariable)). ] @@ -160,8 +164,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ interpretMethod := self applyLocalizationToInterpretWith: #initializeWithAutoLocalizedVariableOnly. "Fail if we find some node inside the case that uses the localized variable" - case := interpretMethod statements second cases first. - variableNode := case statements second method statements first variable. + case := interpretMethod statements second statements first cases first. + variableNode := case statements second statements first method statements first statements first variable. self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). ] @@ -169,22 +173,24 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgument [ - | interpretMethod case cast printedString inlinedMethod | + | interpretMethod case cast printedString inlinedMethod linearizedBlock | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCallAsArgument. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - - cast := inlinedMethod parseTree asCASTIn: ccg. + case := interpretMethod statements second statements first cases first. + inlinedMethod := case statements second statements first method. + linearizedBlock := inlinedMethod statements first. + cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ - autoLocalizedVariable = local_autoLocalizedVariable; - t0 = foo2(); - local_autoLocalizedVariable = autoLocalizedVariable; + { + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = foo2(); + local_autoLocalizedVariable = autoLocalizedVariable; + } if (1 == t0) { } }' @@ -193,24 +199,24 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgument [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ - | interpretMethod case cast printedString inlinedMethod | + | interpretMethod case cast printedString inlinedMethod linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCallAsArgumentOfExternalCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth cases first. - inlinedMethod := case statements second method. + case := interpretMethod statements sixth statements first cases first. + inlinedMethod := case statements second statements first method. + linearizedBlock := inlinedMethod statements first. + cast := linearizedBlock asCASTIn: ccg. - cast := inlinedMethod asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeWithEscapingCallAsArgumentOfExternalCall */ -static sqInt -bytecodeWithEscapingCallAsArgumentOfExternalCall(void) -{ + self assert: printedString equals: '{ { autoLocalizedVariable1 = local_autoLocalizedVariable1; t0 = nonInlinedMethodUsingAutolocalizedVariable1(); local_autoLocalizedVariable1 = autoLocalizedVariable1; + } + { autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable2 = local_autoLocalizedVariable2; @@ -219,88 +225,73 @@ bytecodeWithEscapingCallAsArgumentOfExternalCall(void) local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; } - return 0; -} -'. +}'. ] { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ - | interpretMethod case inlinedMethod cast printedString | + | interpretMethod case inlinedMethod cast printedString linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithInlinedMethodCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth cases first. - inlinedMethod := case statements second method. - - cast := inlinedMethod asCASTIn: ccg. + case := interpretMethod statements sixth statements first cases first. + inlinedMethod := case statements second statements first method. + linearizedBlock := inlinedMethod statements second. + cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeUsingInlinedCall */ -static sqInt -bytecodeUsingInlinedCall(void) -{ + self assert: printedString equals: '{ { - /* begin inlinedMethodUsingExternalCall */ autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; foo2(); local_autoLocalizedVariable = autoLocalizedVariable; local_autoLocalizedVariable1 = autoLocalizedVariable1; } - return 0; -} -' +}' ] { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod cast printedString | + | interpretMethod case inlinedMethod cast printedString linearizedBlock | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. + case := interpretMethod statements second statements first cases first. + inlinedMethod := case statements second statements first method. + linearizedBlock := inlinedMethod statements first. + cast := linearizedBlock asCASTIn: ccg. - cast := inlinedMethod asCASTIn: ccg. - printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeWithEscapingCall */ -static sqInt -bytecodeWithEscapingCall(void) -{ + self assert: printedString equals: '{ { autoLocalizedVariable = local_autoLocalizedVariable; foo((local_autoLocalizedVariable += 1)); local_autoLocalizedVariable = autoLocalizedVariable; } - return 0; -} -' +}' ] { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ - | interpretMethod case inlinedMethod cast printedString | + | interpretMethod case inlinedMethod cast printedString linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth cases first. - inlinedMethod := case statements second method. - cast := inlinedMethod asCASTIn: ccg. + case := interpretMethod statements sixth statements first cases first. + inlinedMethod := case statements second statements first method. + linearizedBlock := inlinedMethod statements first. + cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeWithEscapingCall */ -static sqInt -bytecodeWithEscapingCall(void) -{ + self assert: printedString equals: '{ { autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; @@ -310,40 +301,36 @@ bytecodeWithEscapingCall(void) local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; } - return 0; -} -' +}' ] { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod cast printedString | + | interpretMethod case inlinedMethod cast printedString linearizedBlock | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second cases first. - inlinedMethod := case statements second method. - - cast := inlinedMethod asCASTIn: ccg. + case := interpretMethod statements second statements first cases first. + inlinedMethod := case statements second statements first method. + linearizedBlock := inlinedMethod statements first. + + cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '/* MockLocalizationInterpreterMock>>#bytecodeUsingExternalizedAutoLocalizedVariableAsExpression */ -static sqInt -bytecodeUsingExternalizedAutoLocalizedVariableAsExpression(void) -{ + self assert: printedString equals: '{ { autoLocalizedVariable = local_autoLocalizedVariable; t0 = nonInlinedMethodUsingAutolocalizedVariable(); local_autoLocalizedVariable = autoLocalizedVariable; + } + { autoLocalizedVariable = local_autoLocalizedVariable; foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; } - return 0; -} -' +}' ] { #category : #'tests - linearization' } @@ -367,7 +354,7 @@ SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ self foo: t0 ] " - ifBlock := methodToLinearize statements first arguments first. + ifBlock := methodToLinearize statements first statements first arguments first statements first. self assert: (ifBlock statements first isSameAs: (TAssignmentNode @@ -385,7 +372,7 @@ SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ { #category : #'tests - linearization' } SlangLocalizationTestCase >> testLinearizeNestedCalls [ - | methodToLinearize | + | methodToLinearize replacementBlock | ccg addClass: MockLocalizationInterpreterMock. methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpression. @@ -398,18 +385,19 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ t0 := self nonInlinedMethodUsingAutolocalizedVariable. self foo: t0" - self assert: (methodToLinearize statements first + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first isSameAs: (TAssignmentNode variableNamed: 't0' expression: (TSendNode receiver: TVariableNode selfNode selector: #nonInlinedMethodUsingAutolocalizedVariable))). - self assert: (methodToLinearize statements second + self assert: (replacementBlock statements second isSameAs: (TSendNode receiver: TVariableNode selfNode selector: #foo: arguments: { TVariableNode named: 't0' })). - self assert: methodToLinearize statements size equals: 3. + self assert: replacementBlock statements size equals: 2. ] { #category : #'tests - linearization' } @@ -436,7 +424,7 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsDefinesIntermediateVariable { #category : #'tests - initialization' } SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ - | methodToLinearize | + | methodToLinearize replacementBlock | ccg addClass: MockLocalizationInterpreterMock. methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment. @@ -449,21 +437,22 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ t0 := self nonInlinedMethodUsingAutolocalizedVariable. t1 := self foo: t0. foo := t1" - - self assert: (methodToLinearize statements first + + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first isSameAs: (TAssignmentNode variableNamed: 't0' expression: (TSendNode receiver: TVariableNode selfNode selector: #nonInlinedMethodUsingAutolocalizedVariable))). - self assert: (methodToLinearize statements second + self assert: (replacementBlock statements second isSameAs: (TAssignmentNode variableNamed: 't1' expression: (TSendNode receiver: TVariableNode selfNode selector: #foo: arguments: { TVariableNode named: 't0' }))). - self assert: (methodToLinearize statements third + self assert: (replacementBlock statements third isSameAs: (TAssignmentNode variableNamed: 'foo' expression: (TVariableNode named: 't1'))) @@ -472,7 +461,7 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ { #category : #'tests - linearization' } SlangLocalizationTestCase >> testLinearizeNestedCallsWithReturn [ - | methodToLinearize | + | methodToLinearize replacementBlock | ccg addClass: MockLocalizationInterpreterMock. methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInReturn. @@ -485,28 +474,29 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithReturn [ t0 := self nonInlinedMethodUsingAutolocalizedVariable. t1 := self foo: t0. ^ t1" - - self assert: (methodToLinearize statements first + + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first isSameAs: (TAssignmentNode variableNamed: 't0' expression: (TSendNode receiver: TVariableNode selfNode selector: #nonInlinedMethodUsingAutolocalizedVariable))). - self assert: (methodToLinearize statements second + self assert: (replacementBlock statements second isSameAs: (TAssignmentNode variableNamed: 't1' expression: (TSendNode receiver: TVariableNode selfNode selector: #foo: arguments: { TVariableNode named: 't0' }))). - self assert: (methodToLinearize statements third + self assert: (replacementBlock statements third isSameAs: (TReturnNode expression: (TVariableNode named: 't1'))) ] { #category : #'tests - linearization' } SlangLocalizationTestCase >> testLinearizeSingleCalls [ - | methodToLinearize | + | methodToLinearize replacementBlock | ccg addClass: MockLocalizationInterpreterMock. methodToLinearize := ccg methodNamed: #bytecodeUsingInlinedCall. @@ -518,7 +508,8 @@ SlangLocalizationTestCase >> testLinearizeSingleCalls [ After self inlinedMethodUsingExternalCall" - self assert: (methodToLinearize statements first + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first isSameAs: (TSendNode receiver: TVariableNode selfNode selector: #inlinedMethodUsingExternalCall)) @@ -583,13 +574,15 @@ SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithSafeEscapingCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth cases first. - inlinedMethod := case statements second method. + case := interpretMethod statements sixth statements first cases first. + inlinedMethod := case statements second statements first method. externalCall := inlinedMethod statements first. cast := externalCall asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: 'nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' + self assert: printedString equals: '{ + nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1)); +}' ] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 91dd107710..92d45230dd 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -5424,6 +5424,9 @@ CCodeGenerator >> wrapStatementWithExternalizationAndLocalizations: statement of | collector variablesToExternalize replacementStatements | + "If the statement to wrap is already a statement list, do not wrap it, we are going to wrap its children" + statement isStatementList ifTrue: [ ^ statement ]. + "Optimization: only externalize/localize variables used by the statement's called functions" collector := MLVMVariableAccessCollector inCodeGenerator: self diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 8ec8739d4f..4034b717d7 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -262,6 +262,12 @@ TStatementListNode >> endsWithReturn [ and: [statements last isReturn or: [statements last isReturningIf]] ] +{ #category : #accessing } +TStatementListNode >> first [ + + ^ self statements first +] + { #category : #flattening } TStatementListNode >> flattened [ @@ -415,17 +421,12 @@ TStatementListNode >> renameLabelsForInliningInto: aTMethod [ ] { #category : #transformations } -TStatementListNode >> replaceChild: aNode with: bNode [ - self statements: (Array streamContents: - [:s| - statements do: - [:node| - node == aNode - ifTrue: - [bNode isStatementList - ifTrue: [s nextPutAll: bNode statements] - ifFalse: [s nextPut: bNode]] - ifFalse: [s nextPut: node]]]) +TStatementListNode >> replaceChild: aNode with: bNode [ + + self statements: (statements collect: [ :node | + node == aNode + ifTrue: [ bNode ] + ifFalse: [ node ] ]) ] { #category : #transformations } @@ -489,11 +490,7 @@ TStatementListNode >> statements: anObject [ | oldStatements | oldStatements := statements. statements := anObject asOrderedCollection. - statements do: [ :e | e parent: self ]. - - oldStatements ifNil: [ ^ self ]. - (oldStatements difference: statements) - do: [ :e | e parent: nil ]. + statements do: [ :e | e parent: self ] ] { #category : #'type inference' } From 1a5d8439e9a3b1451238a323d049c7ef17595b28 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 17:44:27 +0100 Subject: [PATCH 49/75] add locals --- smalltalksrc/Slang/TStatementListNode.class.st | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 4034b717d7..50d1bcca90 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -148,9 +148,15 @@ TStatementListNode >> asCASTIn: aBuilder [ { #category : #tranforming } TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ - | collect | + | declarations collect | + declarations := OrderedCollection new. collect := OrderedCollection new. + self locals do: [ :var | + declarations add: (CRawCodeNode code: (aBuilder currentMethod + declarationAt: var + ifAbsent: [ aBuilder defaultType , ' ' , var ])) ]. + statements doWithIndex: [ :e :index | (e isLeaf and: [ e isLabel not and: [ @@ -161,7 +167,7 @@ TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ collect add: (e asCASTIn: aBuilder prependToEnd: aNodeOrNil) ] ifFalse: [ collect add: (e asCASTIn: aBuilder) ] ] ifTrue: [ CEmptyStatementNode new ] ]. - ^ CCompoundStatementNode statements: collect + ^ CCompoundStatementNode declarations: declarations statements: collect ] { #category : #transformations } From 620005c01c817276fa0dfa1ee45252e861505e63 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 18:02:13 +0100 Subject: [PATCH 50/75] Adding declarations on C code --- smalltalksrc/Slang/CCodeGenerator.class.st | 6 +++ smalltalksrc/Slang/TParseNode.class.st | 16 ++++---- .../Slang/TStatementListNode.class.st | 40 +++++++++++++++++-- 3 files changed, 51 insertions(+), 11 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 92d45230dd..036dd030f9 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -918,6 +918,12 @@ CCodeGenerator >> currentMethod: aTMethod [ currentMethod := aTMethod ] +{ #category : #declarations } +CCodeGenerator >> declarationAt: aString ifAbsent: aFullBlockClosure [ + + ^ (self typeOfVariable: aString) ifNil: aFullBlockClosure +] + { #category : #public } CCodeGenerator >> declareModuleName: nameString [ "add the declaration of a module name, version and local/external tag" diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index 51fd7f0e30..f4fe7bd8a3 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -358,7 +358,7 @@ TParseNode >> linearizeIn: aCodeGenerator [ > t1 := self foo: t0 > ] " - | replacementDictionary rewrittenStatement callsInStatement replacementBlock replacementsSoFar variables | + | replacementDictionary rewrittenStatement callsInStatement replacementBlock replacementsSoFar declarations | replacementDictionary := Dictionary new. callsInStatement := OrderedCollection new. @@ -370,24 +370,26 @@ TParseNode >> linearizeIn: aCodeGenerator [ unless: [ :unlessNode | unlessNode isStatementList ]. replacementBlock := OrderedCollection new. - variables := OrderedCollection new. + declarations := Dictionary new. replacementsSoFar := Dictionary new. "Apply linearization to all nodes except itself" callsInStatement select: [ :e | e ~= self ] thenDo: [ :e | - | variableNode | + | variableNode valueNode | variableNode := TVariableNode named: 't' , replacementBlock size asString. - variables add: variableNode name. - replacementBlock add: (TAssignmentNode + valueNode := TAssignmentNode variable: variableNode - expression: (e replaceNodesIn: replacementsSoFar)). + expression: (e replaceNodesIn: replacementsSoFar). + declarations at: variableNode name put: (aCodeGenerator typeFor: valueNode in: aCodeGenerator currentMethod). + replacementBlock add: valueNode. + replacementsSoFar at: e put: variableNode ]. rewrittenStatement := self replaceNodesIn: replacementsSoFar. replacementBlock add: rewrittenStatement. - ^ TStatementListNode parameters: variables statements: replacementBlock + ^ TStatementListNode declarations: declarations statements: replacementBlock ] { #category : #accessing } diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 50d1bcca90..fb74d121d0 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -3,12 +3,32 @@ Class { #superclass : #TParseNode, #instVars : [ 'locals', + 'declarations', 'arguments', 'statements' ], #category : #'Slang-AST' } +{ #category : #'instance creation' } +TStatementListNode class >> declarations: declarations statements: aCollection [ + + ^ self new + declarations: declarations; + locals: declarations keys; + statements: aCollection; + yourself +] + +{ #category : #'instance creation' } +TStatementListNode class >> locals: locals statements: aCollection [ + + ^ self new + locals: locals; + statements: aCollection; + yourself +] + { #category : #'instance creation' } TStatementListNode class >> parameters: parameters statements: statementList [ @@ -148,12 +168,12 @@ TStatementListNode >> asCASTIn: aBuilder [ { #category : #tranforming } TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ - | declarations collect | - declarations := OrderedCollection new. + | cDeclarations collect | + cDeclarations := OrderedCollection new. collect := OrderedCollection new. self locals do: [ :var | - declarations add: (CRawCodeNode code: (aBuilder currentMethod + cDeclarations add: (CRawCodeNode code: (aBuilder declarationAt: var ifAbsent: [ aBuilder defaultType , ' ' , var ])) ]. @@ -167,7 +187,7 @@ TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ collect add: (e asCASTIn: aBuilder prependToEnd: aNodeOrNil) ] ifFalse: [ collect add: (e asCASTIn: aBuilder) ] ] ifTrue: [ CEmptyStatementNode new ] ]. - ^ CCompoundStatementNode declarations: declarations statements: collect + ^ CCompoundStatementNode declarations: cDeclarations statements: collect ] { #category : #transformations } @@ -247,6 +267,18 @@ TStatementListNode >> copyWithoutReturn [ yourself ] +{ #category : #accessing } +TStatementListNode >> declarations [ + + ^ declarations +] + +{ #category : #accessing } +TStatementListNode >> declarations: anObject [ + + declarations := anObject +] + { #category : #testing } TStatementListNode >> endsWithCloseBracket: aStream [ "Answer true if the given stream ends in a $} character." From 5f23c473d8d10dc6f989997aa66924935ba9556a Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 18:19:21 +0100 Subject: [PATCH 51/75] Using declared types when output --- smalltalksrc/Slang/CCodeGenerator.class.st | 5 ++++- smalltalksrc/Slang/TParseNode.class.st | 1 - smalltalksrc/Slang/TStatementListNode.class.st | 6 ++++-- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 036dd030f9..4b703bd69d 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -921,7 +921,10 @@ CCodeGenerator >> currentMethod: aTMethod [ { #category : #declarations } CCodeGenerator >> declarationAt: aString ifAbsent: aFullBlockClosure [ - ^ (self typeOfVariable: aString) ifNil: aFullBlockClosure + | type | + type := (self typeOfVariable: aString) ifNil: [ + ^ aFullBlockClosure value ]. + ^ type , ' ', aString ] { #category : #public } diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index f4fe7bd8a3..b03330666f 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -384,7 +384,6 @@ TParseNode >> linearizeIn: aCodeGenerator [ expression: (e replaceNodesIn: replacementsSoFar). declarations at: variableNode name put: (aCodeGenerator typeFor: valueNode in: aCodeGenerator currentMethod). replacementBlock add: valueNode. - replacementsSoFar at: e put: variableNode ]. rewrittenStatement := self replaceNodesIn: replacementsSoFar. replacementBlock add: rewrittenStatement. diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index fb74d121d0..634c591c00 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -162,7 +162,9 @@ TStatementListNode >> asCASTExpressionIn: aBuilder [ { #category : #tranforming } TStatementListNode >> asCASTIn: aBuilder [ - ^ self asCASTIn: aBuilder prependToEnd: nil + ^ aBuilder + pushScope: self + while: [ self asCASTIn: aBuilder prependToEnd: nil ] ] { #category : #tranforming } @@ -270,7 +272,7 @@ TStatementListNode >> copyWithoutReturn [ { #category : #accessing } TStatementListNode >> declarations [ - ^ declarations + ^ declarations ifNil: [ declarations := Dictionary new ] ] { #category : #accessing } From dcbf9e0bf592c400ca3460ff62de1943fbeb3775 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 22:13:22 +0100 Subject: [PATCH 52/75] Adding iterator variable locally --- smalltalksrc/Slang/CCodeGenerator.class.st | 12 ++++++++---- smalltalksrc/Slang/TMethod.class.st | 2 +- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 4b703bd69d..810749a5f6 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -2809,11 +2809,13 @@ CCodeGenerator >> generateCASTToByDo: tast [ lvalue: (CIdentifierNode name: iterationVar) operator: '+=' rvalue: (tast arguments second asCASTExpressionIn: self). - ^ CForStatementNode + ^ CCompoundStatementNode + declarations: {(CRawCodeNode code: self defaultType, ' ', iterationVar)} + statements: { CForStatementNode init: inits until: until step: { step } - statement: (blockExpr asCASTIn: self) + statement: (blockExpr asCASTIn: self) } ] { #category : #'CAST translation' } @@ -2859,11 +2861,13 @@ CCodeGenerator >> generateCASTToDo: tast [ iterativeVariable: iterationVar negative: false. step := CIncrementNode object: (CIdentifierNode name: iterationVar). - ^ CForStatementNode + ^ CCompoundStatementNode + declarations: {(CRawCodeNode code: self defaultType, ' ', iterationVar)} + statements: { CForStatementNode init: { init } until: until step: { step } - statement: (tast arguments last asCASTIn: self) + statement: (tast arguments last asCASTIn: self) } ] { #category : #'CAST translation' } diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index f2aa5e3a9c..57cf05e2a1 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -862,7 +862,7 @@ TMethod >> ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen [ hasSideEffects ifTrue: [ cachedLocals := nil. - self locals add: node arguments last name ] + self addLocal: node arguments last name ] ifFalse: [ node arguments: node arguments allButLast ] ] ifFalse: [ "If the expression is complex but as yet there is no limit variable, add it" hasSideEffects ifTrue: [ From 8c6874a99420f6e2b8c4ee0a415567641c43b3b8 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 22:30:04 +0100 Subject: [PATCH 53/75] Do not linearize assertions --- smalltalksrc/Slang/CCodeGenerator.class.st | 1 - smalltalksrc/Slang/TSendNode.class.st | 10 ++++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 810749a5f6..5d38290d07 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3745,7 +3745,6 @@ CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ statementList statements do: [ :statement | | replacement previousParent | previousParent := statement parent. replacement := statement linearizeIn: self. - aTMethod localizeVariables: replacement parameterNames. "Do not ask the child to replace itself, as it may have been already moved" previousParent replaceChild: statement with: replacement. diff --git a/smalltalksrc/Slang/TSendNode.class.st b/smalltalksrc/Slang/TSendNode.class.st index f2cbd5ed8d..7261e1d6de 100644 --- a/smalltalksrc/Slang/TSendNode.class.st +++ b/smalltalksrc/Slang/TSendNode.class.st @@ -408,6 +408,16 @@ TSendNode >> isValueExpansion [ and: [selector keywords allSatisfy: [:k| #('value' 'value:') includes: k]] ] +{ #category : #linearization } +TSendNode >> linearizeIn: aCodeGenerator [ + + "Do not linearize assert calls, otherwise this may change the semantics" + (aCodeGenerator isAssertSelector: selector) + ifTrue: [ ^ self ]. + + ^ super linearizeIn: aCodeGenerator +] + { #category : #accessing } TSendNode >> name [ From 1b252bac6b8e2a9c23c89e5ecc281d6c760376c3 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 22:37:37 +0100 Subject: [PATCH 54/75] Update tabbing --- smalltalksrc/Slang/Gnuifier.class.st | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/smalltalksrc/Slang/Gnuifier.class.st b/smalltalksrc/Slang/Gnuifier.class.st index a2444c0ecd..4b57783031 100644 --- a/smalltalksrc/Slang/Gnuifier.class.st +++ b/smalltalksrc/Slang/Gnuifier.class.st @@ -129,12 +129,12 @@ Gnuifier >> gnuifyFrom: inputFile to: outFileStream [ (inLine findString: 'register struct foo * foo = &fum;') > 0 ifTrue: [ outLine := 'register struct foo * foo FOO_REG = &fum;' ]. - (inLine findString: ' localIP;') > 0 ifTrue: [ - outLine := ' register char* localIP IP_REG;' ]. - (inLine findString: ' localFP;') > 0 ifTrue: [ - outLine := ' register char* localFP FP_REG;' ]. - (inLine findString: ' localSP;') > 0 ifTrue: [ - outLine := ' register char* localSP SP_REG;' ]. + (inLine findString: ' local_instructionPointer;') > 0 ifTrue: [ + outLine := ' register char* local_instructionPointer IP_REG;' ]. + (inLine findString: ' local_framePointer;') > 0 ifTrue: [ + outLine := ' register char* local_framePointer FP_REG;' ]. + (inLine findString: ' local_stackPointer;') > 0 ifTrue: [ + outLine := ' register char* local_stackPointer SP_REG;' ]. (inLine findString: ' currentBytecode;') > 0 ifTrue: [ outLine := ' register sqInt currentBytecode CB_REG;' ]. inLine isEmpty ifTrue: [ "reached end of variables" @@ -146,15 +146,15 @@ Gnuifier >> gnuifyFrom: inputFile to: outFileStream [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" - (inLine beginsWith: ' case ') ifTrue: [ + (inLine beginsWith: ' case ') ifTrue: [ | tokens | tokens := inLine findTokens: ' :'. - outLine := ' CASE(' , tokens second , ')'. + outLine := ' CASE(' , tokens second , ')'. tokens size > 2 ifTrue: [ (tokens allButFirst: 2) do: [ :token | outLine := outLine , ' ' , token ] ] ]. - inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. + inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. inLine = '}' ifTrue: [ "all finished with interpret()" inInterpret := false ] ] ifFalse: [ From 5e84cb9b9a808f0f279ed1cc6c73d07f832032ab Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 22:45:42 +0100 Subject: [PATCH 55/75] only write locals --- smalltalksrc/Slang/TMethod.class.st | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 57cf05e2a1..5322585a28 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -81,9 +81,9 @@ TMethod >> addCASTLocalsIn: aCASTBlock generator: aCodeGen [ ifFalse: [ 'DECL_MAYBE_SQ_GLOBAL_STRUCT' ])) ]. maybeExternFunctions := (declarations select: [ :decl | decl beginsWith: 'extern' ]) keys. - - (self allLocals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ - (aCodeGen sortStrings: self allLocals , maybeExternFunctions) do: [ :var | + + (self locals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ + (aCodeGen sortStrings: self locals , maybeExternFunctions) do: [ :var | | decl | decl := self declarationAt: var From e44a871901bda2f9792fce7133c1db276257ba00 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 23:16:18 +0100 Subject: [PATCH 56/75] Do not linearize blocks in expressions (and, iftrue...) for now, nor blocks without parent (inline methods!). --- smalltalksrc/Slang/CCodeGenerator.class.st | 6 +++++- smalltalksrc/Slang/TStatementListNode.class.st | 10 +--------- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 5d38290d07..5e6d29a9c4 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -3740,7 +3740,11 @@ CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ | replacementDictionary statementListsToLinearize | replacementDictionary := Dictionary new. - statementListsToLinearize := aTMethod parseTree select: [ :e | e isStatementList ]. + statementListsToLinearize := aTMethod parseTree select: [ :e | + e isStatementList and: [ + e parent notNil and: [ + e parent isSend not + or: [ e parent parent isStatementList ] ]] ]. statementListsToLinearize do: [ :statementList | statementList statements do: [ :statement | | replacement previousParent | previousParent := statement parent. diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 634c591c00..cfe338c6cc 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -20,15 +20,6 @@ TStatementListNode class >> declarations: declarations statements: aCollection [ yourself ] -{ #category : #'instance creation' } -TStatementListNode class >> locals: locals statements: aCollection [ - - ^ self new - locals: locals; - statements: aCollection; - yourself -] - { #category : #'instance creation' } TStatementListNode class >> parameters: parameters statements: statementList [ @@ -319,6 +310,7 @@ TStatementListNode >> flattened [ TStatementListNode >> initialize [ super initialize. + declarations := Dictionary new. locals := #(). arguments := #() ] From 513b6746842872757243b59dfa1d171e25e54114 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 23:19:59 +0100 Subject: [PATCH 57/75] Fixing back tabbing --- smalltalksrc/Slang/Gnuifier.class.st | 66 ++++++++++++++-------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/smalltalksrc/Slang/Gnuifier.class.st b/smalltalksrc/Slang/Gnuifier.class.st index 4b57783031..c82826d1e6 100644 --- a/smalltalksrc/Slang/Gnuifier.class.st +++ b/smalltalksrc/Slang/Gnuifier.class.st @@ -146,46 +146,46 @@ Gnuifier >> gnuifyFrom: inputFile to: outFileStream [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" - (inLine beginsWith: ' case ') ifTrue: [ - | tokens | - - tokens := inLine findTokens: ' :'. - outLine := ' CASE(' , tokens second , ')'. - tokens size > 2 ifTrue: [ - (tokens allButFirst: 2) do: [ :token | - outLine := outLine , ' ' , token ] ] ]. - inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. - inLine = '}' ifTrue: [ "all finished with interpret()" - inInterpret := false ] ] + (inLine beginsWith: ' case ') ifTrue: [ + | tokens | + + tokens := inLine findTokens: ' :'. + outLine := ' CASE(' , tokens second , ')'. + tokens size > 2 ifTrue: [ + (tokens allButFirst: 2) do: [ :token | + outLine := outLine , ' ' , token ] ] ]. + inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. + inLine = '}' ifTrue: [ "all finished with interpret()" + inInterpret := false ] ] + ifFalse: [ + beforePrimitiveResponse + ifTrue: [ + (inLine beginsWith: 'primitiveResponse(') ifTrue: [ "into primitiveResponse we go" + beforePrimitiveResponse := false. + inPrimitiveResponse := true. + extraOutLine := ' PRIM_TABLE;' ] ] ifFalse: [ - beforePrimitiveResponse - ifTrue: [ - (inLine beginsWith: 'primitiveResponse(') ifTrue: [ "into primitiveResponse we go" - beforePrimitiveResponse := false. - inPrimitiveResponse := true. - extraOutLine := ' PRIM_TABLE;' ] ] - ifFalse: [ - inPrimitiveResponse ifTrue: [ - 1halt. - inLine = ' switch (primitiveIndex) {' ifTrue: [ - extraOutLine := outLine. - outLine := ' PRIM_DISPATCH;' ]. - inLine = ' switch (GIV(primitiveIndex)) {' ifTrue: [ - extraOutLine := outLine. - outLine := ' PRIM_DISPATCH;' ]. - (inLine beginsWith: ' case ') ifTrue: [ - | caseLabel | - caseLabel := (inLine findTokens: ' :') second. - outLine := ' CASE(' , caseLabel , ')' ]. - inLine = '}' ifTrue: [ inPrimitiveResponse := false ] ] ] ] ] ]. + inPrimitiveResponse ifTrue: [ + 1halt. + inLine = ' switch (primitiveIndex) {' ifTrue: [ + extraOutLine := outLine. + outLine := ' PRIM_DISPATCH;' ]. + inLine = ' switch (GIV(primitiveIndex)) {' ifTrue: [ + extraOutLine := outLine. + outLine := ' PRIM_DISPATCH;' ]. + (inLine beginsWith: ' case ') ifTrue: [ + | caseLabel | + caseLabel := (inLine findTokens: ' :') second. + outLine := ' CASE(' , caseLabel , ')' ]. + inLine = '}' ifTrue: [ inPrimitiveResponse := false ] ] ] ] ] ]. outFileStream nextPutAll: outLine; cr. extraOutLine ifNotNil: [ outFileStream - nextPutAll: extraOutLine; - cr ] ] ]. + nextPutAll: extraOutLine; + cr ] ] ]. outFileStream close ] From 33dcd74a82d4af37de76742bb55d3ea81a2ad726 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 23:36:34 +0100 Subject: [PATCH 58/75] Deprecating args --- smalltalksrc/Slang/CCodeGenerator.class.st | 41 +-- smalltalksrc/Slang/TMethod.class.st | 117 ++++---- .../Slang/TStatementListNode.class.st | 13 +- .../RBMessageNode.extension.st | 279 ++++++++++-------- 4 files changed, 238 insertions(+), 212 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 5e6d29a9c4..4c9e098ba0 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -2784,10 +2784,10 @@ CCodeGenerator >> generateCASTToByDo: tast [ | blockExpr iterationVar until step mayHaveSideEffects inits limitVar limitExpr | blockExpr := tast arguments third. - blockExpr args size = 1 ifFalse: [ + blockExpr arguments size = 1 ifFalse: [ self error: 'wrong number of block arguments' ]. inits := OrderedCollection new. - iterationVar := blockExpr args first. + iterationVar := blockExpr arguments first. limitExpr := tast arguments first. inits add: (CAssignmentNode lvalue: (CIdentifierNode name: iterationVar) @@ -2810,12 +2810,13 @@ CCodeGenerator >> generateCASTToByDo: tast [ operator: '+=' rvalue: (tast arguments second asCASTExpressionIn: self). ^ CCompoundStatementNode - declarations: {(CRawCodeNode code: self defaultType, ' ', iterationVar)} - statements: { CForStatementNode - init: inits - until: until - step: { step } - statement: (blockExpr asCASTIn: self) } + declarations: + { (CRawCodeNode code: self defaultType , ' ' , iterationVar) } + statements: { (CForStatementNode + init: inits + until: until + step: { step } + statement: (blockExpr asCASTIn: self)) } ] { #category : #'CAST translation' } @@ -2911,21 +2912,23 @@ CCodeGenerator >> generateCASTValue: tast [ | substitution substitutionDict newLabels castStatements | self assert: tast receiver isStatementList. - self assert: tast receiver args size = tast arguments size. + self assert: tast receiver arguments size = tast arguments size. castStatements := CCompoundStatementNode statements: OrderedCollection new. castStatements needsBrackets: false. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. substitutionDict := Dictionary new: tast arguments size * 2. - tast receiver args with: tast arguments do: [ :argName :exprNode | - exprNode isLeaf - ifTrue: [ substitutionDict at: argName put: exprNode ] - ifFalse: [ - castStatements add: (CAssignmentNode - lvalue: (CIdentifierNode name: argName) - rvalue: (exprNode asCASTExpressionIn: self)). - self noteUsedVariableName: argName ] ]. + tast receiver arguments + with: tast arguments + do: [ :argName :exprNode | + exprNode isLeaf + ifTrue: [ substitutionDict at: argName put: exprNode ] + ifFalse: [ + castStatements add: (CAssignmentNode + lvalue: (CIdentifierNode name: argName) + rvalue: (exprNode asCASTExpressionIn: self)). + self noteUsedVariableName: argName ] ]. substitution bindVariablesIn: substitutionDict. castStatements add: (substitution asCASTIn: self). newLabels := Set withAll: currentMethod labels. @@ -2946,11 +2949,11 @@ CCodeGenerator >> generateCASTValueAsArgument: tast [ | substitution substitutionDict newLabels | self assert: tast receiver isStatementList. - self assert: tast receiver args size = tast arguments size. + self assert: tast receiver arguments size = tast arguments size. substitution := tast receiver copy. substitution renameLabelsForInliningInto: currentMethod. substitutionDict := Dictionary new: tast arguments size * 2. - tast receiver args + tast receiver arguments with: tast arguments do: [ :argName :exprNode | substitutionDict at: argName put: exprNode ]. diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 5322585a28..9ac5a36a84 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -167,25 +167,25 @@ TMethod >> allLocals [ { #category : #accessing } TMethod >> allReferencedVariablesUsing: aCodeGen [ + "Answer the set of all variables referenced in the receiver." + | refs | refs := Set new. "Find all the variable names referenced in this method. Don't descend into conditionals that won't be generated." parseTree - nodesWithParentsDo: - [:node :parent| - node isVariable ifTrue: [refs add: node name asString]. - node isStatementList ifTrue: [ node args ifNotNil: [ refs addAll: node args ]]. - (node isSend - and: [node selector value beginsWith: #cCode:]) ifTrue: - [aCodeGen addVariablesInVerbatimCIn: node to: refs]] - unless: - [:node :parent| - parent notNil - and: [parent isSend - and: [aCodeGen nodeIsDeadCode: node withParent: parent]]]. - ^refs + nodesWithParentsDo: [ :node :parent | + node isVariable ifTrue: [ refs add: node name asString ]. + node isStatementList ifTrue: [ + node arguments ifNotNil: [ refs addAll: node arguments ] ]. + (node isSend and: [ node selector value beginsWith: #cCode: ]) + ifTrue: [ aCodeGen addVariablesInVerbatimCIn: node to: refs ] ] + unless: [ :node :parent | + parent notNil and: [ + parent isSend and: [ + aCodeGen nodeIsDeadCode: node withParent: parent ] ] ]. + ^ refs ] { #category : #accessing } @@ -867,18 +867,21 @@ TMethod >> ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen [ ifFalse: [ "If the expression is complex but as yet there is no limit variable, add it" hasSideEffects ifTrue: [ | var | - var := self unusedNamePrefixedBy: 'toDoLimit' avoiding: self locals. "N.B. adds it to locals!!" + var := self + unusedNamePrefixedBy: 'toDoLimit' + avoiding: self locals. "N.B. adds it to locals!!" node arguments: node arguments , { (TVariableNode new setName: var; yourself) }. declarations - at: node arguments third args first + at: node arguments third arguments first ifPresent: [ :decl | self declarationAt: var put: - (self typeFor: node arguments third args first in: aCodeGen) - , ' ' , var ] ] ] + (self + typeFor: node arguments third arguments first + in: aCodeGen) , ' ' , var ] ] ] ] { #category : #inlining } @@ -2609,59 +2612,53 @@ TMethod >> renameLabelsUsing: aDictionary [ { #category : #'inlining support' } TMethod >> renameVariablesUsing: aDictionary [ + "Rename all variables according to old->new mappings of the given dictionary." | newDecls newProperties | - aDictionary isEmpty - ifTrue: [ ^ self ]. + aDictionary isEmpty ifTrue: [ ^ self ]. "map args and locals" - args := args - collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]. - + args := args collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]. + cachedLocals := nil. - self locals: (self locals collect: [ :v | aDictionary at: v ifAbsent: [ v ] ]). + self locals: + (self locals collect: [ :v | aDictionary at: v ifAbsent: [ v ] ]). "map declarations" newDecls := declarations species new. - declarations - keysAndValuesDo: [ :oldName :decl | - (aDictionary at: oldName ifAbsent: nil) - ifNotNil: [ :newName | - | index | - index := decl indexOfWord: oldName. - newDecls - at: newName - put: - (index ~= 0 - ifTrue: [ decl - copyReplaceFrom: index - to: index + oldName size - 1 - with: newName ] - ifFalse: [ decl ]) ] - ifNil: [ newDecls at: oldName put: decl ] ]. + declarations keysAndValuesDo: [ :oldName :decl | + (aDictionary at: oldName ifAbsent: nil) + ifNotNil: [ :newName | + | index | + index := decl indexOfWord: oldName. + newDecls at: newName put: (index ~= 0 + ifTrue: [ + decl + copyReplaceFrom: index + to: index + oldName size - 1 + with: newName ] + ifFalse: [ decl ]) ] + ifNil: [ newDecls at: oldName put: decl ] ]. self newDeclarations: newDecls. newProperties := properties copy. - newProperties pragmas - do: [ :pragma | - | mappedArgs | - mappedArgs := pragma arguments - collect: [ :arg | - arg isString - ifTrue: [ aDictionary at: arg ifAbsent: arg ] - ifFalse: [ arg ] ]. - mappedArgs ~= pragma arguments - ifTrue: [ pragma arguments: mappedArgs ] ]. + newProperties pragmas do: [ :pragma | + | mappedArgs | + mappedArgs := pragma arguments collect: [ :arg | + arg isString + ifTrue: [ aDictionary at: arg ifAbsent: arg ] + ifFalse: [ arg ] ]. + mappedArgs ~= pragma arguments ifTrue: [ + pragma arguments: mappedArgs ] ]. self properties: newProperties. "map variable names in parse tree" - parseTree - nodesDo: [ :node | - (node isVariable and: [ aDictionary includesKey: node name ]) - ifTrue: [ node setName: (aDictionary at: node name) ]. - (node isStatementList and: [ node args size > 0 ]) - ifTrue: [ node - setArguments: (node args collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]) ] ] + parseTree nodesDo: [ :node | + (node isVariable and: [ aDictionary includesKey: node name ]) + ifTrue: [ node setName: (aDictionary at: node name) ]. + (node isStatementList and: [ node arguments size > 0 ]) ifTrue: [ + node setArguments: (node arguments collect: [ :arg | + aDictionary at: arg ifAbsent: [ arg ] ]) ] ] ] { #category : #'inlining support' } @@ -2806,12 +2803,12 @@ TMethod >> smalltalkSelector [ { #category : #accessing } TMethod >> statements [ - parseTree isStatementList - ifFalse: [ self error: 'expected method parse tree to be a TStmtListNode' ]. - ((parseTree args = nil) or: [parseTree args isEmpty]) + parseTree isStatementList ifFalse: [ + self error: 'expected method parse tree to be a TStmtListNode' ]. + (parseTree arguments = nil or: [ parseTree arguments isEmpty ]) ifFalse: [ self error: 'expected method parse tree to have no args' ]. - ^parseTree statements + ^ parseTree statements ] { #category : #'primitive compilation' } diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index cfe338c6cc..29629579d4 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -78,14 +78,15 @@ TStatementListNode >> addReadBeforeAssignedIn: variables to: readBeforeAssigned node isSend ifTrue: [ "First deal with implicit assignments..." node isValueExpansion ifTrue: [ - assigned addAll: node receiver args ]. + assigned addAll: node receiver arguments ]. (#( #memcpy:_:_: #memmove:_:_: ) includes: node selector) ifTrue: [ assigned add: (node arguments first detect: [ :subnode | subnode isVariable ]) name ]. (#( #to:do: #to:by:do: ) includes: node selector) ifTrue: [ - assigned addAll: (node arguments at: node selector numArgs) args. + assigned addAll: + (node arguments at: node selector numArgs) arguments. mayHaveSideEffects := node arguments size = 4. "See TMethod>>prepareMethodIn:" mayHaveSideEffects ifTrue: [ assigned add: node arguments last name ] ]. @@ -133,6 +134,14 @@ TStatementListNode >> allStatementsDo: aFullBlockClosure [ { #category : #accessing } TStatementListNode >> args [ + self + deprecated: 'use #arguments instead' + transformWith: '`@rec args' -> '`@rec arguments'. + ^arguments +] + +{ #category : #accessing } +TStatementListNode >> arguments [ ^arguments ] diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st index 4fdfbc1b3b..b4589f62b7 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMessageNode.extension.st @@ -2,7 +2,9 @@ Extension { #name : #RBMessageNode } { #category : #'*VMMakerCompatibilityForPharo6-C translation' } RBMessageNode >> asTranslatorNodeIn: aTMethod [ + "Answer a TParseNode subclass equivalent of me" + "selector is sometimes a Symbol, sometimes a SelectorNode! On top of this, numArgs is needed due to the (truly grody) use of arguments as a place to store the extra expressions needed to generate @@ -10,142 +12,157 @@ RBMessageNode >> asTranslatorNodeIn: aTMethod [ Expand super nodes in place. Elide sends of halt so that halts can be sprinkled through the simulator but will be eliminated from the generated C." + | usedSelector rcvrOrNil args | usedSelector := selector value. - rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod]. - usedSelector == #halt ifTrue: [^rcvrOrNil]. - (usedSelector == #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block." - or: [usedSelector == #cCode:]) ifTrue: - [arguments first isBlockNode ifTrue: - [| block | - ^(block := arguments first asTranslatorNodeIn: aTMethod) statements size = 1 - ifTrue: [block statements first] - ifFalse: [block]]. - (arguments first isLiteralNode - and: [arguments first value isString - and: [arguments first value isEmpty]]) ifTrue: - [^arguments first asTranslatorNodeIn: aTMethod]]. - args := arguments collect: [:arg| arg asTranslatorNodeIn: aTMethod]. - - (usedSelector == #to:do:) ifTrue: [ | block | + rcvrOrNil := receiver ifNotNil: [ + receiver asTranslatorNodeIn: aTMethod ]. + usedSelector == #halt ifTrue: [ ^ rcvrOrNil ]. + (usedSelector == #cCode:inSmalltalk: or: [ usedSelector == #cCode: ]) + ifTrue: [ + arguments first isBlockNode ifTrue: [ + | block | + ^ (block := arguments first asTranslatorNodeIn: aTMethod) + statements size = 1 + ifTrue: [ block statements first ] + ifFalse: [ block ] ]. + (arguments first isLiteralNode and: [ + arguments first value isString and: [ + arguments first value isEmpty ] ]) ifTrue: [ + ^ arguments first asTranslatorNodeIn: aTMethod ] ]. "extracting here rather than in translation allows inlining in the block." + args := arguments collect: [ :arg | arg asTranslatorNodeIn: aTMethod ]. + + usedSelector == #to:do: ifTrue: [ + | block | usedSelector := #to:by:do:. block := args second. - arguments first isLiteralNode ifTrue: [ - args := OrderedCollection - with: args first - with: (TConstantNode value: 1) - with: args second - with: (TAssignmentNode new - setVariable: (arguments first asTranslatorNodeIn: aTMethod) - expression: (TConstantNode value: 1); - yourself) - with: (TSendNode new - setSelector: #<= - receiver: (TVariableNode new setName: block args first) - arguments: { receiver asTranslatorNodeIn: aTMethod }) - with: (TAssignmentNode new - setVariable: (TVariableNode new setName: block args first) - expression: (TSendNode new - setSelector: #+ - receiver: (TVariableNode new setName: block args first) - arguments: { TConstantNode value: 1 }); - yourself) - ] ifFalse: [ - args := OrderedCollection - with: args first - with: (TConstantNode value: 1) - with: args second - with: (TVariableNode new setName: 'iLimiT') - ] - ]. - + arguments first isLiteralNode + ifTrue: [ + args := OrderedCollection + with: args first + with: (TConstantNode value: 1) + with: args second + with: (TAssignmentNode new + setVariable: + (arguments first asTranslatorNodeIn: aTMethod) + expression: (TConstantNode value: 1); + yourself) + with: (TSendNode new + setSelector: #<= + receiver: + (TVariableNode new setName: block arguments first) + arguments: { (receiver asTranslatorNodeIn: aTMethod) }) + with: (TAssignmentNode new + setVariable: + (TVariableNode new setName: block arguments first) + expression: (TSendNode new + setSelector: #+ + receiver: + (TVariableNode new setName: block arguments first) + arguments: { (TConstantNode value: 1) }); + yourself) ] + ifFalse: [ + args := OrderedCollection + with: args first + with: (TConstantNode value: 1) + with: args second + with: (TVariableNode new setName: 'iLimiT') ] ]. + "If in the form of ifNil: [ :obj | ], replace that by an assignment and an ifFalse" - ((usedSelector == #ifNotNil:) and: [ args first args notEmpty ]) ifTrue: [ - ^ TStatementListNode - parameters: #() - statements: { - TAssignmentNode new - setVariable: (TVariableNode new setName: args first args first) - expression: rcvrOrNil. - - TSendNode new - setSelector: #ifFalse: - receiver: (TSendNode new - setSelector: #== - receiver: (TVariableNode new setName: args first args first) - arguments: {(TVariableNode new setName: 'nil')}; - yourself) - arguments: {args first} - } ]. - - (#(#ifNotNil:ifNil: #ifNil:ifNotNil:) includes: usedSelector) ifTrue: [ | comparand expression blockWithPossibleArgument | - "We turn it always to an ifTrueIfFalse" - usedSelector = #ifNotNil:ifNil: - ifTrue: [ args := args reversed ]. - blockWithPossibleArgument := args second. - expression := rcvrOrNil. - comparand := blockWithPossibleArgument args - ifEmpty: [ expression ] - ifNotEmpty: [ (TVariableNode new setName: blockWithPossibleArgument args first) ]. - - usedSelector := #ifTrue:ifFalse:. - rcvrOrNil := TSendNode new - setSelector: #== - receiver: comparand - arguments: { TVariableNode new setName: 'nil' }. - - "If there is a variable we should epand the message as a statement" - blockWithPossibleArgument args notEmpty ifTrue: [ - ^ TStatementListNode - parameters: #() - statements: { - TAssignmentNode new - setVariable: (TVariableNode new setName: blockWithPossibleArgument args first) - expression: expression. - - TSendNode new - setSelector: usedSelector - receiver: rcvrOrNil - arguments: args - } - ] ]. - - (usedSelector == #ifNil:ifNotNil:) ifTrue: [ + (usedSelector == #ifNotNil: and: [ args first arguments notEmpty ]) + ifTrue: [ + ^ TStatementListNode parameters: #( ) statements: { + (TAssignmentNode new + setVariable: + (TVariableNode new setName: args first arguments first) + expression: rcvrOrNil). + + (TSendNode new + setSelector: #ifFalse: + receiver: (TSendNode new + setSelector: #== + receiver: + (TVariableNode new setName: args first arguments first) + arguments: { (TVariableNode new setName: 'nil') }; + yourself) + arguments: { args first }) } ]. + + (#( #ifNotNil:ifNil: #ifNil:ifNotNil: ) includes: usedSelector) + ifTrue: [ + | comparand expression blockWithPossibleArgument | + "We turn it always to an ifTrueIfFalse" + usedSelector = #ifNotNil:ifNil: ifTrue: [ args := args reversed ]. + blockWithPossibleArgument := args second. + expression := rcvrOrNil. + comparand := blockWithPossibleArgument arguments + ifEmpty: [ expression ] + ifNotEmpty: [ + TVariableNode new setName: + blockWithPossibleArgument arguments first ]. + + usedSelector := #ifTrue:ifFalse:. + rcvrOrNil := TSendNode new + setSelector: #== + receiver: comparand + arguments: { (TVariableNode new setName: 'nil') }. + + "If there is a variable we should epand the message as a statement" + blockWithPossibleArgument arguments notEmpty ifTrue: [ + ^ TStatementListNode parameters: #( ) statements: { + (TAssignmentNode new + setVariable: + (TVariableNode new setName: + blockWithPossibleArgument arguments first) + expression: expression). + + (TSendNode new + setSelector: usedSelector + receiver: rcvrOrNil + arguments: args) } ] ]. + + usedSelector == #ifNil:ifNotNil: ifTrue: [ usedSelector := #ifTrue:ifFalse:. rcvrOrNil := TSendNode new - setSelector: #== - receiver: rcvrOrNil - arguments: { TVariableNode new setName: 'nil' } ]. - - (usedSelector == #ifTrue:ifFalse: and: [arguments first statements isEmpty]) ifTrue: - [usedSelector := #ifFalse:. args := {args last}]. - (usedSelector == #ifTrue:ifFalse: and: [arguments last statements isEmpty]) ifTrue: - [usedSelector := #ifTrue:. args := {args first}]. - (usedSelector == #ifFalse:ifTrue: and: [arguments first statements isEmpty]) ifTrue: - [usedSelector := #ifTrue:. args := {args last}]. - (usedSelector == #ifFalse:ifTrue: and: [arguments last statements isEmpty]) ifTrue: - [usedSelector := #ifTrue:. args := {args first}]. - - ((usedSelector == #ifFalse: or: [usedSelector == #or:]) - and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: - ["Restore argument block that got moved by transformOr: or transformIfFalse:" - args := {(arguments at: 2) asTranslatorNodeIn: aTMethod}]. - (args size > usedSelector numArgs and: [usedSelector ~~ #to:by:do:]) ifTrue: "to:by:do: has iLimiT hidden in last arg" - ["prune the extra blocks left by ifTrue:, ifFalse:, and: & or:" - self assert: args size - usedSelector numArgs = 1. - self assert: (args last isStatementList - and: [args last statements size = 1 - and: [(args last statements first isVariable - or: [args last statements first isConstant]) - and: [#('nil' true false) includes: args last statements first nameOrValue]]]). - args := args first: usedSelector numArgs]. - - ((CCodeGenerator isVarargsSelector: usedSelector) - and: [args last isCollection - and: [args last isSequenceable]]) ifTrue: - [args := args allButLast, args last]. - ^TSendNode new - setSelector: usedSelector - receiver: rcvrOrNil - arguments: args + setSelector: #== + receiver: rcvrOrNil + arguments: { (TVariableNode new setName: 'nil') } ]. + + (usedSelector == #ifTrue:ifFalse: and: [ + arguments first statements isEmpty ]) ifTrue: [ + usedSelector := #ifFalse:. + args := { args last } ]. + (usedSelector == #ifTrue:ifFalse: and: [ + arguments last statements isEmpty ]) ifTrue: [ + usedSelector := #ifTrue:. + args := { args first } ]. + (usedSelector == #ifFalse:ifTrue: and: [ + arguments first statements isEmpty ]) ifTrue: [ + usedSelector := #ifTrue:. + args := { args last } ]. + (usedSelector == #ifFalse:ifTrue: and: [ + arguments last statements isEmpty ]) ifTrue: [ + usedSelector := #ifTrue:. + args := { args first } ]. + + ((usedSelector == #ifFalse: or: [ usedSelector == #or: ]) and: [ + arguments size = 2 and: [ (arguments at: 2) notNil ] ]) ifTrue: [ "Restore argument block that got moved by transformOr: or transformIfFalse:" + args := { ((arguments at: 2) asTranslatorNodeIn: aTMethod) } ]. + (args size > usedSelector numArgs and: [ usedSelector ~~ #to:by:do: ]) + ifTrue: [ "prune the extra blocks left by ifTrue:, ifFalse:, and: & or:""to:by:do: has iLimiT hidden in last arg" + self assert: args size - usedSelector numArgs = 1. + self assert: (args last isStatementList and: [ + args last statements size = 1 and: [ + (args last statements first isVariable or: [ + args last statements first isConstant ]) and: [ + #( 'nil' true false ) includes: + args last statements first nameOrValue ] ] ]). + args := args first: usedSelector numArgs ]. + + ((CCodeGenerator isVarargsSelector: usedSelector) and: [ + args last isCollection and: [ args last isSequenceable ] ]) + ifTrue: [ args := args allButLast , args last ]. + ^ TSendNode new + setSelector: usedSelector + receiver: rcvrOrNil + arguments: args ] From 07e57e6c3f7e323c78d1f11c28b11467a79cafbe Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 23:37:16 +0100 Subject: [PATCH 59/75] Hoisting closure arguments as method locals From b503e9b248cd5bfdf4af37eab79a5f520761d184 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Mon, 3 Jan 2022 23:37:48 +0100 Subject: [PATCH 60/75] Hoisting closure arguments as method locals --- smalltalksrc/Slang/TMethod.class.st | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 9ac5a36a84..8d8fca202c 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -82,8 +82,8 @@ TMethod >> addCASTLocalsIn: aCASTBlock generator: aCodeGen [ maybeExternFunctions := (declarations select: [ :decl | decl beginsWith: 'extern' ]) keys. - (self locals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ - (aCodeGen sortStrings: self locals , maybeExternFunctions) do: [ :var | + (self allLocalLocals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ + (aCodeGen sortStrings: self allLocalLocals , maybeExternFunctions) do: [ :var | | decl | decl := self declarationAt: var @@ -150,6 +150,20 @@ TMethod >> allCalls [ ^parseTree allCalls ] +{ #category : #accessing } +TMethod >> allLocalLocals [ + "The merge of locals and declarations (don't ask)" + + | allLocals | + allLocals := Set new. + allLocals addAll: self locals. + self nodesDo: [ :node | + node isStatementList ifTrue: [ + allLocals addAll: node arguments. + allLocals addAll: node locals ] ]. + ^ allLocals +] + { #category : #accessing } TMethod >> allLocals [ "The merge of locals and declarations (don't ask)" From 2fbdf9b0cb9176b9c4bc9aae8f01edc9f888d931 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 4 Jan 2022 16:45:21 +0100 Subject: [PATCH 61/75] Make tests green --- .../SLInterpreterThreadingTest.class.st | 12 +- .../SlangBasicTranslationTest.class.st | 111 +++++++++++----- .../SlangLocalizationTestCase.class.st | 124 +++++++++--------- ...angMethodPrototypeTranslationTest.class.st | 28 +--- smalltalksrc/Slang/CCodeGenerator.class.st | 77 ++++------- smalltalksrc/Slang/TMethod.class.st | 23 +++- smalltalksrc/Slang/TParseNode.class.st | 11 +- smalltalksrc/Slang/TReturnNode.class.st | 8 +- .../Slang/TStatementListNode.class.st | 23 +++- 9 files changed, 226 insertions(+), 191 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st b/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st index 5bec1101ba..06133b515e 100644 --- a/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st +++ b/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st @@ -113,10 +113,10 @@ SLInterpreterThreadingTest >> testReplaceLocalFPInterpreterVariablesByItsGnuDefi | gnuified | gnuified := self gnuify: 'sqInt interpret(void){ - localFP; + local_framePointer; }'. - self assert: (gnuified lineNumber: 6) equals: ' register char* localFP FP_REG;' + self assert: (gnuified lineNumber: 6) equals: ' register char* local_framePointer FP_REG;' ] { #category : #tests } @@ -125,10 +125,10 @@ SLInterpreterThreadingTest >> testReplaceLocalIPInterpreterVariablesByItsGnuDefi | gnuified | gnuified := self gnuify: 'sqInt interpret(void){ - localIP; + local_instructionPointer; }'. - self assert: (gnuified lineNumber: 6) equals: ' register char* localIP IP_REG;' + self assert: (gnuified lineNumber: 6) equals: ' register char* local_instructionPointer IP_REG;' ] { #category : #tests } @@ -137,8 +137,8 @@ SLInterpreterThreadingTest >> testReplaceLocalSPInterpreterVariablesByItsGnuDefi | gnuified | gnuified := self gnuify: 'sqInt interpret(void){ - localSP; + local_stackPointer; }'. - self assert: (gnuified lineNumber: 6) equals: ' register char* localSP SP_REG;' + self assert: (gnuified lineNumber: 6) equals: ' register char* local_stackPointer SP_REG;' ] diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index fdbe71f814..e148177a6b 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -953,10 +953,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenArr self assert: translation equals: '{ - int * bar; - int[17] foo; VM_LABEL(methodUsingSingleArrayVariable); { + int * bar; + int[17] foo; + bar = foo; } }' @@ -971,10 +972,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenExt self assert: translation equals: '{ - sqInt bar; - external int foo; VM_LABEL(methodUsingSingleExternalVariable); { + sqInt bar; + external int foo; + bar = foo; } }' @@ -989,10 +991,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenIni self assert: translation equals: '{ - sqInt bar; - sqInt foo; VM_LABEL(methodUsingSingleNonInitializedVariable); { + sqInt bar; + sqInt foo; + foo = 0; bar = foo; } @@ -1008,10 +1011,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenSta self assert: translation equals: '{ - int bar; - static int foo; VM_LABEL(methodUsingSingleStaticVariable); { + int bar; + static int foo; + bar = foo; } }' @@ -1026,9 +1030,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotRemoveExternalTemp [ self assert: translation equals: '{ - extern int foo; VM_LABEL(methodDefiningSingleExternVariable); { + extern int foo; + + } }' ] @@ -1042,9 +1048,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotRemoveStaticTemp [ self assert: translation equals: '{ - static int foo; VM_LABEL(methodDefiningSingleStaticVariable); { + static int foo; + + } }' ] @@ -1075,13 +1083,14 @@ SlangBasicTranslationTest >> testInlineNodeSortsLocalTemps [ self assert: translation equals: '{ - sqInt aaa; - sqInt bar; - sqInt ddd; - sqInt foo; - sqInt zzz; VM_LABEL(methodWithUnsortedTemps); { + sqInt aaa; + sqInt bar; + sqInt ddd; + sqInt foo; + sqInt zzz; + aaa = 0; foo = 0; zzz = 0; @@ -5253,8 +5262,12 @@ SlangBasicTranslationTest >> testSendToByDo [ expression: expression) }) }. translation := self translate: send. - self assert: translation trimBoth equals: 'for (i = 1; i <= 10; i += 2) { - var -= 7; + self assert: translation trimBoth equals: '{ + sqInt i; + + for (i = 1; i <= 10; i += 2) { + var -= 7; + }; }' ] @@ -5292,8 +5305,12 @@ SlangBasicTranslationTest >> testSendToByDoLimitExpressionHasSideEffect [ self assert: translation trimBoth - equals: 'for (i = 1, toDoLimit = foo(var); i <= toDoLimit; i += 2) { - var -= 7; + equals: '{ + sqInt i; + + for (i = 1, toDoLimit = foo(var); i <= toDoLimit; i += 2) { + var -= 7; + }; }' ] @@ -5322,8 +5339,12 @@ SlangBasicTranslationTest >> testSendToByDoWithNegativeStep [ expression: expression) }) }. translation := self translate: send. - self assert: translation trimBoth equals: 'for (i = 10; i >= 0; i += -2) { - var -= 7; + self assert: translation trimBoth equals: '{ + sqInt i; + + for (i = 10; i >= 0; i += -2) { + var -= 7; + }; }' ] @@ -5361,8 +5382,12 @@ SlangBasicTranslationTest >> testSendToByDoWithOperationReceiver [ self assert: translation trimBoth - equals: 'for (i = 1 + (foo(1, 2)); i <= 10; i += 2) { - var -= 7; + equals: '{ + sqInt i; + + for (i = 1 + (foo(1, 2)); i <= 10; i += 2) { + var -= 7; + }; }' ] @@ -5400,8 +5425,12 @@ SlangBasicTranslationTest >> testSendToByDoWithOperationUpdate [ self assert: translation trimBoth - equals: 'for (i = 1; i <= 10; i += 1 + (foo(1, 2))) { - var -= 7; + equals: '{ + sqInt i; + + for (i = 1; i <= 10; i += 1 + (foo(1, 2))) { + var -= 7; + }; }' ] @@ -5429,8 +5458,12 @@ SlangBasicTranslationTest >> testSendToDo [ expression: expression) }) }. translation := self translate: send. - self assert: translation trimBoth equals: 'for (i = 1; i <= 10; i++) { - var -= 7; + self assert: translation trimBoth equals: '{ + sqInt i; + + for (i = 1; i <= 10; i++) { + var -= 7; + }; }' ] @@ -5466,8 +5499,12 @@ SlangBasicTranslationTest >> testSendToDoAvoidUnderflowingOfLimitExpression [ self assert: translation trimBoth - equals: 'for (i = 1; i < foo; i++) { - var -= 7; + equals: '{ + sqInt i; + + for (i = 1; i < foo; i++) { + var -= 7; + }; }' ] @@ -5501,8 +5538,12 @@ SlangBasicTranslationTest >> testSendToDoLimitExpressionHasSideEffect [ self assert: translation trimBoth - equals: 'for (i = 1; i <= (foo(var)); i++) { - var -= 7; + equals: '{ + sqInt i; + + for (i = 1; i <= (foo(var)); i++) { + var -= 7; + }; }' ] @@ -5536,8 +5577,12 @@ SlangBasicTranslationTest >> testSendToDoWithOperationReceiver [ expression: expression) }) }. translation := self translate: send. - self assert: translation trimBoth equals: 'for (i = 1 + (foo(1, 2)); i <= 10; i++) { - var -= 7; + self assert: translation trimBoth equals: '{ + sqInt i; + + for (i = 1 + (foo(1, 2)); i <= 10; i++) { + var -= 7; + }; }' ] diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 6211980c37..33aba88858 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -54,6 +54,17 @@ SlangLocalizationTestCase >> internalizationOf: aVariableName [ expression: (TVariableNode named: aVariableName)) ] +{ #category : #helpers } +SlangLocalizationTestCase >> linearizedBlockOfCaseMethod: aTMethod [ + + | case inlinedMethod | + case := (aTMethod statements detect: [ :e | + e children anySatisfy: [ :c | c isCaseStmt ] ]) first cases first. + inlinedMethod := case statements second first method. + "Return the first non label, to avoid the labels introduced by inlining" + ^ inlinedMethod statements detect: [ :e | e first isLabel not ] +] + { #category : #running } SlangLocalizationTestCase >> setUp [ @@ -115,10 +126,13 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnRef prettyPrintOn: str ]. self assert: printedString equals: '{ { + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); { autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; - return (autoLocalizedVariable += 1); + return t0; } } }' @@ -132,15 +146,15 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ | interpretMethod sendNode | interpretMethod := self applyLocalizationTo: #interpretWithReturnExpression. - sendNode := interpretMethod statements last statements first statements second.. - self assert: sendNode arguments first statements first statements first statements last isReturn. + sendNode := interpretMethod last first second. + self assert: sendNode arguments first first first last isReturn. self - assert: (sendNode arguments first statements first statements first statements first + assert: (sendNode arguments first first first first isSameAs: (self externalizationOf: #autoLocalizedVariable)). - self assert: sendNode arguments second statements first statements first statements last isReturn. + self assert: sendNode arguments second first first last isReturn. self - assert: (sendNode arguments second statements first statements first statements first + assert: (sendNode arguments second first first first isSameAs: (self externalizationOf: #autoLocalizedVariable)). ] @@ -164,8 +178,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ interpretMethod := self applyLocalizationToInterpretWith: #initializeWithAutoLocalizedVariableOnly. "Fail if we find some node inside the case that uses the localized variable" - case := interpretMethod statements second statements first cases first. - variableNode := case statements second statements first method statements first statements first variable. + case := interpretMethod statements second first cases first. + variableNode := case statements second first method first first variable. self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). ] @@ -173,19 +187,19 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgument [ - | interpretMethod case cast printedString inlinedMethod linearizedBlock | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCallAsArgument. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second statements first cases first. - inlinedMethod := case statements second statements first method. - linearizedBlock := inlinedMethod statements first. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ + sqInt t0; + { autoLocalizedVariable = local_autoLocalizedVariable; t0 = foo2(); @@ -199,18 +213,18 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgument [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ - | interpretMethod case cast printedString inlinedMethod linearizedBlock | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCallAsArgumentOfExternalCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth statements first cases first. - inlinedMethod := case statements second statements first method. - linearizedBlock := inlinedMethod statements first. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ + sqInt t0; + { autoLocalizedVariable1 = local_autoLocalizedVariable1; t0 = nonInlinedMethodUsingAutolocalizedVariable1(); @@ -231,13 +245,11 @@ SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ - | interpretMethod case inlinedMethod cast printedString linearizedBlock | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithInlinedMethodCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth statements first cases first. - inlinedMethod := case statements second statements first method. - linearizedBlock := inlinedMethod statements second. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. @@ -256,22 +268,23 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ { #category : #tests } SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod cast printedString linearizedBlock | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second statements first cases first. - inlinedMethod := case statements second statements first method. - linearizedBlock := inlinedMethod statements first. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); { autoLocalizedVariable = local_autoLocalizedVariable; - foo((local_autoLocalizedVariable += 1)); + foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; } }' @@ -280,23 +293,24 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ - | interpretMethod case inlinedMethod cast printedString linearizedBlock | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth statements first cases first. - inlinedMethod := case statements second statements first method. - linearizedBlock := inlinedMethod statements first. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); { autoLocalizedVariable = local_autoLocalizedVariable; autoLocalizedVariable1 = local_autoLocalizedVariable1; autoLocalizedVariable2 = local_autoLocalizedVariable2; - foo((local_autoLocalizedVariable += 1)); + foo(t0); local_autoLocalizedVariable = autoLocalizedVariable; local_autoLocalizedVariable1 = autoLocalizedVariable1; local_autoLocalizedVariable2 = autoLocalizedVariable2; @@ -307,19 +321,19 @@ SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNe { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ - | interpretMethod case inlinedMethod cast printedString linearizedBlock | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements second statements first cases first. - inlinedMethod := case statements second statements first method. - linearizedBlock := inlinedMethod statements first. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ + sqInt t0; + { autoLocalizedVariable = local_autoLocalizedVariable; t0 = nonInlinedMethodUsingAutolocalizedVariable(); @@ -341,6 +355,7 @@ SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableInNestedLexicalScope. ccg prepareMethods. + ccg currentMethod: methodToLinearize. ccg linearizeExternalCallsIn: methodToLinearize. "Before it was @@ -377,6 +392,7 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpression. ccg prepareMethods. + ccg currentMethod: methodToLinearize. ccg linearizeExternalCallsIn: methodToLinearize. "Before it was @@ -400,27 +416,6 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ self assert: replacementBlock statements size equals: 2. ] -{ #category : #'tests - linearization' } -SlangLocalizationTestCase >> testLinearizeNestedCallsDefinesIntermediateVariables [ - - | methodToLinearize | - ccg addClass: MockLocalizationInterpreterMock. - methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment. - - ccg prepareMethods. - ccg linearizeExternalCallsIn: methodToLinearize. - - "Before it was - self foo: self nonInlinedMethodUsingAutolocalizedVariable. - After - t0 := self nonInlinedMethodUsingAutolocalizedVariable. - self foo: t0 - - => t0 should be defined in the method" - - self assert: (methodToLinearize locals includes: 't0'). -] - { #category : #'tests - initialization' } SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ @@ -429,6 +424,7 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment. ccg prepareMethods. + ccg currentMethod: methodToLinearize. ccg linearizeExternalCallsIn: methodToLinearize. "Before it was @@ -466,6 +462,7 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithReturn [ methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInReturn. ccg prepareMethods. + ccg currentMethod: methodToLinearize. ccg linearizeExternalCallsIn: methodToLinearize. "Before it was @@ -501,6 +498,7 @@ SlangLocalizationTestCase >> testLinearizeSingleCalls [ methodToLinearize := ccg methodNamed: #bytecodeUsingInlinedCall. ccg prepareMethods. + ccg currentMethod: methodToLinearize. ccg linearizeExternalCallsIn: methodToLinearize. "Before it was @@ -509,7 +507,7 @@ SlangLocalizationTestCase >> testLinearizeSingleCalls [ self inlinedMethodUsingExternalCall" replacementBlock := methodToLinearize statements first. - self assert: (replacementBlock statements first + self assert: (replacementBlock first isSameAs: (TSendNode receiver: TVariableNode selfNode selector: #inlinedMethodUsingExternalCall)) @@ -570,19 +568,19 @@ SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAre { #category : #tests } SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ - | interpretMethod case inlinedMethod externalCall cast printedString | + | interpretMethod cast printedString linearizedBlock | interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithSafeEscapingCall. "Assert that the send node is preceded by variable externalization" - case := interpretMethod statements sixth statements first cases first. - inlinedMethod := case statements second statements first method. - - externalCall := inlinedMethod statements first. - cast := externalCall asCASTIn: ccg. + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. + cast := linearizedBlock asCASTIn: ccg. printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. self assert: printedString equals: '{ - nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1)); + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); + nonInlinedMethodNotUsingAutolocalizedVariables(t0); }' ] diff --git a/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st index fbd3f49d01..a920269939 100644 --- a/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st @@ -1,20 +1,12 @@ Class { #name : #SlangMethodPrototypeTranslationTest, - #superclass : #ParametrizedTestCase, + #superclass : #TestCase, #instVars : [ - 'generator', - 'translationStrategy' + 'generator' ], #category : #'Slang-Tests' } -{ #category : #'building suites' } -SlangMethodPrototypeTranslationTest class >> testParameters [ - - ^ ParametrizedTestMatrix new - forSelector: #translationStrategy addOptions: { #slangTranslate . #astTranslate } -] - { #category : #helpers } SlangMethodPrototypeTranslationTest >> astTranslate: tMethod inStream: aWriteStream [ @@ -53,19 +45,5 @@ SlangMethodPrototypeTranslationTest >> testMethodPrototype [ SlangMethodPrototypeTranslationTest >> translate: tast [ ^ String streamContents: [ :str | - self - perform: (translationStrategy , #':inStream:') asSymbol - withArguments: { tast . str } ] -] - -{ #category : #accessing } -SlangMethodPrototypeTranslationTest >> translationStrategy [ - - ^ translationStrategy -] - -{ #category : #accessing } -SlangMethodPrototypeTranslationTest >> translationStrategy: anObject [ - - translationStrategy := anObject + self astTranslate: tast inStream: str ] ] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 4c9e098ba0..f35abb0372 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -483,10 +483,7 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: "Replace all localized variables by their localized versions" m parseTree bindVariablesIn: (replacementDict collect: [ :asso | - asso key -> (TVariableNode named: asso value) ]) asDictionary - unless: [ :node | - node isTMethod not and: [ - node isReturn or: [ node isExternalSend ] ] ]. + asso key -> (TVariableNode named: asso value) ]) asDictionary. self linearizeExternalCallsIn: m. @@ -499,10 +496,6 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: m statements addFirst: (TAssignmentNode variable: (TVariableNode named: asso value) expression: (TVariableNode named: asso key)) ]. - "self - externalizeAtReturnsIn: m - withVariablesToLocalize: replacementDict." - ] { #category : #utilities } @@ -918,13 +911,21 @@ CCodeGenerator >> currentMethod: aTMethod [ currentMethod := aTMethod ] -{ #category : #declarations } -CCodeGenerator >> declarationAt: aString ifAbsent: aFullBlockClosure [ - - | type | - type := (self typeOfVariable: aString) ifNil: [ - ^ aFullBlockClosure value ]. - ^ type , ' ', aString +{ #category : #'C code generator' } +CCodeGenerator >> declarationAt: aVariableName ifAbsent: absentBlock [ + + scopeStack reverseDo: [:scope| + scope declarationAt: aVariableName ifPresent: [ :declaration | ^ declaration ] ]. + variableDeclarations + at: aVariableName + ifPresent: [ :declaration | ^ declaration ]. + ^(constants at: aVariableName ifAbsent: [ ^ absentBlock value ]) ifNotNil: + [:const| + const value isInteger + ifTrue: [self defaultType] + ifFalse: + [const value isFloat ifTrue: + [#double]]] ] { #category : #public } @@ -1309,28 +1310,6 @@ CCodeGenerator >> externalizationOf: aVariableName [ expression: (TVariableNode named: #local_, aVariableName)) ] -{ #category : #'automatic-localization' } -CCodeGenerator >> externalizeAtReturnsIn: aTMethod withVariablesToLocalize: variablesReplacement [ - - | replacementDictionary variablesReplacementDict | - replacementDictionary := Dictionary new. - variablesReplacementDict := (variablesReplacement collect: [ :each | - each value - -> (TVariableNode named: each key) ]) - asDictionary. - aTMethod nodesDo: [ :e | - e isReturn ifTrue: [ - replacementDictionary - at: e - put: - (TStatementListNode statements: - (variablesReplacement collect: [ :each | - TAssignmentNode - variableNamed: each key - expression: (TVariableNode named: each value) ]) , { e }) ] ]. - aTMethod replaceNodesIn: replacementDictionary -] - { #category : #utilities } CCodeGenerator >> extractTypeFor: aVariable fromDeclaration: aVariableDeclaration [ "Eliminate inessentials from aVariableDeclaration to answer a C type without the variable, @@ -2850,9 +2829,9 @@ CCodeGenerator >> generateCASTToByDoUntil: limitExpr iterativeVariable: itVar ne CCodeGenerator >> generateCASTToDo: tast [ | iterationVar init until step | - tast arguments last args size = 1 ifFalse: [ + tast arguments last arguments size = 1 ifFalse: [ self error: 'wrong number of block arguments' ]. - iterationVar := tast arguments last args first. + iterationVar := tast arguments last arguments first. init := CAssignmentNode lvalue: (CIdentifierNode name: iterationVar) rvalue: (tast receiver asCASTExpressionIn: self). @@ -2863,12 +2842,13 @@ CCodeGenerator >> generateCASTToDo: tast [ negative: false. step := CIncrementNode object: (CIdentifierNode name: iterationVar). ^ CCompoundStatementNode - declarations: {(CRawCodeNode code: self defaultType, ' ', iterationVar)} - statements: { CForStatementNode - init: { init } - until: until - step: { step } - statement: (tast arguments last asCASTIn: self) } + declarations: + { (CRawCodeNode code: self defaultType , ' ' , iterationVar) } + statements: { (CForStatementNode + init: { init } + until: until + step: { step } + statement: (tast arguments last asCASTIn: self)) } ] { #category : #'CAST translation' } @@ -3744,10 +3724,7 @@ CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ replacementDictionary := Dictionary new. statementListsToLinearize := aTMethod parseTree select: [ :e | - e isStatementList and: [ - e parent notNil and: [ - e parent isSend not - or: [ e parent parent isStatementList ] ]] ]. + e isStatementList ]. statementListsToLinearize do: [ :statementList | statementList statements do: [ :statement | | replacement previousParent | previousParent := statement parent. @@ -5480,7 +5457,7 @@ CCodeGenerator >> wrapStatements: tMethod withVariableBindings: replacementDict - static function calls - dynamic function calls (perform & co)" - tMethod allStatements do: [ :statement | | replacement oldParent | + tMethod allStatements withIndexDo: [ :statement :i | | replacement oldParent | oldParent := statement parent. replacement := self wrapStatementWithExternalizationAndLocalizations: statement diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 8d8fca202c..15e228910b 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -426,11 +426,6 @@ TMethod >> asCASTInlinedIn: aBuilder [ self removeUnusedTempsAndNilIfRequiredIn: aBuilder. compoundStatement := CCompoundStatementNode new. - self locals ifNotEmpty: [ - (aBuilder sortStrings: self locals) do: [ :var | - compoundStatement add: (CRawCodeNode code: (self - declarationAt: var - ifAbsent: [ aBuilder defaultType , ' ' , var ])) ] ]. compoundStatement add: (aBuilder asmLabelNodeFor: selector ). aBuilder pushScope: self @@ -676,8 +671,14 @@ TMethod >> declarationAt: aVariableName ifAbsent: absentBlock [ ^declarations at: aVariableName ifAbsent: absentBlock ] +{ #category : #accessing } +TMethod >> declarationAt: aVariableName ifPresent: presentBlock [ + ^declarations at: aVariableName ifPresent: presentBlock +] + { #category : #accessing } TMethod >> declarationAt: aVariableName "" put: aDeclaration [ "" "^aDeclaration" + ^declarations at: aVariableName put: aDeclaration ] @@ -1170,6 +1171,12 @@ TMethod >> findReadBeforeAssignedIn: variables in: aCodeGen [ ^readBeforeAssigned ] +{ #category : #accessing } +TMethod >> first [ + + ^ self statements first +] + { #category : #'primitive compilation' } TMethod >> fixUpReturns: argCount postlog: postlog [ "Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return." @@ -2023,6 +2030,12 @@ TMethod >> labels: aCollection [ labels := aCollection asSet ] +{ #category : #accessing } +TMethod >> last [ + + ^ parseTree last +] + { #category : #inlining } TMethod >> localizeVariables: localizationCandidates [ diff --git a/smalltalksrc/Slang/TParseNode.class.st b/smalltalksrc/Slang/TParseNode.class.st index b03330666f..3167856b33 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -363,10 +363,11 @@ TParseNode >> linearizeIn: aCodeGenerator [ callsInStatement := OrderedCollection new. self - nodesDo: [ :node | - ((aCodeGenerator isFunctionCall: node) or: [ - aCodeGenerator isDynamicCall: node ]) - ifTrue: [ callsInStatement add: node ] ] + nodesDo: [ :node | + (node isAssignment or: [ + (aCodeGenerator isFunctionCall: node) or: [ + aCodeGenerator isDynamicCall: node ]]) + ifTrue: [ callsInStatement add: node ] ] unless: [ :unlessNode | unlessNode isStatementList ]. replacementBlock := OrderedCollection new. @@ -382,7 +383,7 @@ TParseNode >> linearizeIn: aCodeGenerator [ valueNode := TAssignmentNode variable: variableNode expression: (e replaceNodesIn: replacementsSoFar). - declarations at: variableNode name put: (aCodeGenerator typeFor: valueNode in: aCodeGenerator currentMethod). + declarations at: variableNode name put: (aCodeGenerator typeFor: valueNode in: aCodeGenerator currentMethod) , ' ', variableNode name. replacementBlock add: valueNode. replacementsSoFar at: e put: variableNode ]. rewrittenStatement := self replaceNodesIn: replacementsSoFar. diff --git a/smalltalksrc/Slang/TReturnNode.class.st b/smalltalksrc/Slang/TReturnNode.class.st index 37186cf3fe..c7219bb0e3 100644 --- a/smalltalksrc/Slang/TReturnNode.class.st +++ b/smalltalksrc/Slang/TReturnNode.class.st @@ -11,7 +11,7 @@ Class { TReturnNode class >> expression: anExpression [ ^ self new - setExpression: anExpression; + expression: anExpression; yourself ] @@ -122,6 +122,12 @@ TReturnNode >> expression [ ^expression ] +{ #category : #accessing } +TReturnNode >> expression: anExpression [ + + expression := anExpression +] + { #category : #testing } TReturnNode >> isReturn [ diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 29629579d4..fdda24dec8 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -173,11 +173,10 @@ TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ | cDeclarations collect | cDeclarations := OrderedCollection new. collect := OrderedCollection new. - - self locals do: [ :var | + (aBuilder sortStrings: self locals asSet) do: [ :var | cDeclarations add: (CRawCodeNode code: (aBuilder declarationAt: var - ifAbsent: [ aBuilder defaultType , ' ' , var ])) ]. + ifAbsent: [ aBuilder defaultType, ' ' , var ])) ]. statements doWithIndex: [ :e :index | (e isLeaf and: [ @@ -269,6 +268,12 @@ TStatementListNode >> copyWithoutReturn [ yourself ] +{ #category : #declarations } +TStatementListNode >> declarationAt: aString ifPresent: aFullBlockClosure [ + + ^ declarations at: aString ifPresent: aFullBlockClosure +] + { #category : #accessing } TStatementListNode >> declarations [ @@ -351,6 +356,12 @@ TStatementListNode >> isStatementList [ ^true ] +{ #category : #accessing } +TStatementListNode >> last [ + + ^ self statements last +] + { #category : #accessing } TStatementListNode >> locals [ @@ -492,6 +503,12 @@ TStatementListNode >> returnsExpression [ and: [statements last variable ~= 'nil'] ] +{ #category : #accessing } +TStatementListNode >> second [ + + ^ self statements second +] + { #category : #accessing } TStatementListNode >> setArguments: argList [ From afb8a291e99f3e8832308c554bae9e5811bab5e4 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 4 Jan 2022 17:04:08 +0100 Subject: [PATCH 62/75] Fix gnufication tabbing --- smalltalksrc/Slang/Gnuifier.class.st | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/smalltalksrc/Slang/Gnuifier.class.st b/smalltalksrc/Slang/Gnuifier.class.st index c82826d1e6..f2a8258e2d 100644 --- a/smalltalksrc/Slang/Gnuifier.class.st +++ b/smalltalksrc/Slang/Gnuifier.class.st @@ -146,15 +146,15 @@ Gnuifier >> gnuifyFrom: inputFile to: outFileStream [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" - (inLine beginsWith: ' case ') ifTrue: [ + (inLine beginsWith: ' case ') ifTrue: [ | tokens | tokens := inLine findTokens: ' :'. - outLine := ' CASE(' , tokens second , ')'. + outLine := ' CASE(' , tokens second , ')'. tokens size > 2 ifTrue: [ (tokens allButFirst: 2) do: [ :token | outLine := outLine , ' ' , token ] ] ]. - inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. + inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. inLine = '}' ifTrue: [ "all finished with interpret()" inInterpret := false ] ] ifFalse: [ From f95f92cc4410b235d2b5c441b14f969b510c51e1 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Tue, 4 Jan 2022 18:12:30 +0100 Subject: [PATCH 63/75] Only linearise if needed --- .../MockLocalizationInterpreterMock.class.st | 24 +++++++ .../SLInterpreterThreadingTest.class.st | 8 +-- .../SlangLocalizationTestCase.class.st | 57 ++++++++++++----- smalltalksrc/Slang/CCodeGenerator.class.st | 63 ++++++++++--------- smalltalksrc/Slang/TMethod.class.st | 6 ++ smalltalksrc/Slang/TVariableNode.class.st | 6 +- .../EncoderForV3PlusClosures.extension.st | 10 --- 7 files changed, 114 insertions(+), 60 deletions(-) delete mode 100644 smalltalksrc/VMMaker/EncoderForV3PlusClosures.extension.st diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 81c16d21ae..9855cd2818 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -121,12 +121,29 @@ MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithoutAutoLocalizedVariable [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeNotUsingAutoLocalizedVariable) + ) +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeInliningSharedMethod [ self sharedMethod ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeNotUsingAutoLocalizedVariable [ + + "None of these use localized variables" + self nonInlinedMethodNotUsingAutolocalizedVariables: self nonInlinedMethodNotUsingAutolocalizedVariables +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> bytecodeToInline [ @@ -328,6 +345,13 @@ MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ sharedVariableToLocalize := 17 ] +{ #category : #inline } +MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables [ + + + ^ 10 +] + { #category : #inline } MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables: anObject [ diff --git a/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st b/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st index 06133b515e..22a60cb6ea 100644 --- a/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st +++ b/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st @@ -54,10 +54,10 @@ SLInterpreterThreadingTest >> testReplaceBreakStatementByBREAKMacro [ interpret(void){ localSP; - break; + break; }'. - self assert: (gnuified lineNumber: 14) equals: ' BREAK;' + self assert: (gnuified lineNumber: 14) equals: ' BREAK;' ] { #category : #tests } @@ -68,10 +68,10 @@ SLInterpreterThreadingTest >> testReplaceCaseStatementByCASEMacroWithArgument [ interpret(void){ localSP; - case 1 : + case 1 : }'. - self assert: (gnuified lineNumber: 14) equals: ' CASE(1)' + self assert: (gnuified lineNumber: 14) equals: ' CASE(1)' ] { #category : #tests } diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index 33aba88858..c70b0f0615 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -58,11 +58,10 @@ SlangLocalizationTestCase >> internalizationOf: aVariableName [ SlangLocalizationTestCase >> linearizedBlockOfCaseMethod: aTMethod [ | case inlinedMethod | - case := (aTMethod statements detect: [ :e | - e children anySatisfy: [ :c | c isCaseStmt ] ]) first cases first. - inlinedMethod := case statements second first method. + case := (aTMethod detect: [ :e | e isCaseStmt ]) cases first. + inlinedMethod := (case detect: [ :e | e isInline ]) method. "Return the first non label, to avoid the labels introduced by inlining" - ^ inlinedMethod statements detect: [ :e | e first isLabel not ] + ^ inlinedMethod statements detect: [ :e | e isLabel not and: [ e isStatementList not or: [ e first isLabel not ]] ] ] { #category : #running } @@ -103,6 +102,20 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ self assert: (method locals includes: #local_autoLocalizedVariable) ] +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableDoesNotLineariseUnnecessaryStatements [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + + | interpretMethod printedString block | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithoutAutoLocalizedVariable. + block := self linearizedBlockOfCaseMethod: interpretMethod. + + printedString := String streamContents: [ :str | (block asCASTIn: ccg) prettyPrintOn: str ]. + + self assert: printedString equals: 'nonInlinedMethodNotUsingAutolocalizedVariables(nonInlinedMethodNotUsingAutolocalizedVariables())' +] + { #category : #tests } SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesAtTheEnd [ @@ -178,8 +191,8 @@ SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ interpretMethod := self applyLocalizationToInterpretWith: #initializeWithAutoLocalizedVariableOnly. "Fail if we find some node inside the case that uses the localized variable" - case := interpretMethod statements second first cases first. - variableNode := case statements second first method first first variable. + case := (interpretMethod detect: [:e | e isCaseStmt ]) cases first. + variableNode := (case detect: [ :e | e isAssignment ]) variable. self assert: (variableNode isVariable and: [ variableNode name = #local_autoLocalizedVariable ]). ] @@ -356,7 +369,10 @@ SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ ccg prepareMethods. ccg currentMethod: methodToLinearize. - ccg linearizeExternalCallsIn: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). "Before it was true ifTrue: [ @@ -393,7 +409,10 @@ SlangLocalizationTestCase >> testLinearizeNestedCalls [ ccg prepareMethods. ccg currentMethod: methodToLinearize. - ccg linearizeExternalCallsIn: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). "Before it was self foo: self nonInlinedMethodUsingAutolocalizedVariable. @@ -425,7 +444,10 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ ccg prepareMethods. ccg currentMethod: methodToLinearize. - ccg linearizeExternalCallsIn: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). "Before it was foo := self foo: self nonInlinedMethodUsingAutolocalizedVariable. @@ -463,7 +485,10 @@ SlangLocalizationTestCase >> testLinearizeNestedCallsWithReturn [ ccg prepareMethods. ccg currentMethod: methodToLinearize. - ccg linearizeExternalCallsIn: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). "Before it was ^ self foo: self nonInlinedMethodUsingAutolocalizedVariable. @@ -499,7 +524,10 @@ SlangLocalizationTestCase >> testLinearizeSingleCalls [ ccg prepareMethods. ccg currentMethod: methodToLinearize. - ccg linearizeExternalCallsIn: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). "Before it was self inlinedMethodUsingExternalCall. @@ -577,10 +605,5 @@ SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: printedString equals: '{ - sqInt t0; - - t0 = (local_autoLocalizedVariable += 1); - nonInlinedMethodNotUsingAutolocalizedVariables(t0); -}' + self assert: printedString equals: 'nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' ] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index f35abb0372..83ec0083db 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -474,27 +474,28 @@ CCodeGenerator >> asmLabelNodeFor: selector [ ] { #category : #'automatic-localization' } -CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: replacementDict [ +CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: replacementList [ - | m | + | m replacementDict | (m := self methodNamed: selector) ifNil: [ ^ self ]. - (replacementDict isNil or: [ replacementDict isEmpty ]) ifTrue: [ ^ self ]. + (replacementList isNil or: [ replacementList isEmpty ]) ifTrue: [ ^ self ]. + replacementDict := (replacementList collect: [ :asso | + asso key -> (TVariableNode named: asso value) ]) asDictionary. "Replace all localized variables by their localized versions" m parseTree - bindVariablesIn: (replacementDict collect: [ :asso | - asso key -> (TVariableNode named: asso value) ]) asDictionary. + bindVariablesIn: replacementDict. - self linearizeExternalCallsIn: m. + self linearizeExternalCallsIn: m withVariableBindings: replacementDict. "Wrap sends with externalization/internalization statements" self wrapStatements: m withVariableBindings: replacementDict. "Localize global values at the beginning of the function AND externalize local values on each return" - replacementDict do: [ :asso | + replacementDict associationsDo: [ :asso | m statements addFirst: (TAssignmentNode - variable: (TVariableNode named: asso value) + variable: asso value copy expression: (TVariableNode named: asso key)) ]. ] @@ -3716,24 +3717,26 @@ CCodeGenerator >> isVoidPointer: aCType [ "" ] { #category : #'automatic-localization' } -CCodeGenerator >> linearizeExternalCallsIn: aTMethod [ - +CCodeGenerator >> linearizeExternalCallsIn: aTMethod withVariableBindings: replacementDict [ + "Should be applied after inlining. Linearize all calls inside this method" + | replacementDictionary statementListsToLinearize | replacementDictionary := Dictionary new. - statementListsToLinearize := aTMethod parseTree select: [ :e | - e isStatementList ]. - statementListsToLinearize do: [ :statementList | - statementList statements do: [ :statement | | replacement previousParent | - previousParent := statement parent. - replacement := statement linearizeIn: self. + statementListsToLinearize := aTMethod parseTree select: [ :e | e isStatementList ]. + statementListsToLinearize do: [ :statementList | + statementList statements do: [ :statement | + | replacement previousParent | + (self + shouldLinearizeStatement: statement + withVariableBindings: replacementDict) ifTrue: [ + previousParent := statement parent. + replacement := statement linearizeIn: self. - "Do not ask the child to replace itself, as it may have been already moved" - previousParent replaceChild: statement with: replacement. - ]. - ] + "Do not ask the child to replace itself, as it may have been already moved" + previousParent replaceChild: statement with: replacement ] ] ] ] { #category : #utilities } @@ -4803,6 +4806,17 @@ CCodeGenerator >> shouldIncludeMethodFor: aClass selector: selector [ ^ true ] +{ #category : #'automatic-localization' } +CCodeGenerator >> shouldLinearizeStatement: statement withVariableBindings: replacementDict [ + + "Optimization: only externalize/localize variables used by the statement's called functions" + | collector | + collector := MLVMVariableAccessCollector + inCodeGenerator: self + fromGlobals: replacementDict keys. + ^ (statement accept: collector) accessedVariables notEmpty +] + { #category : #'type inference' } CCodeGenerator >> signedTypeForIntegralType: aCTypeString [ (aCTypeString beginsWith: 'unsigned ') ifTrue: @@ -5446,13 +5460,6 @@ CCodeGenerator >> wrapStatementWithExternalizationAndLocalizations: statement of CCodeGenerator >> wrapStatements: tMethod withVariableBindings: replacementDict [ "Wrap statements with external calls with TExternalSendNode" - - | methodsReferencesToVarsToLocalize variablesDict | - variablesDict := (replacementDict collect: [ :asso | - asso key -> (TVariableNode named: asso value) ]) - asDictionary. - - methodsReferencesToVarsToLocalize := Dictionary new. "Apply externalization/localization of variables around - static function calls - dynamic function calls (perform & co)" @@ -5461,7 +5468,7 @@ CCodeGenerator >> wrapStatements: tMethod withVariableBindings: replacementDict oldParent := statement parent. replacement := self wrapStatementWithExternalizationAndLocalizations: statement - ofLocalizedVariables: (replacementDict collect: [ :asso | asso key ]). + ofLocalizedVariables: replacementDict keys. oldParent replaceChild: statement with: replacement. ]. ] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 15e228910b..7211497374 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -737,6 +737,12 @@ TMethod >> deny: aBooleanOrBlock [ aBooleanOrBlock value ifTrue: [AssertionFailure signal: 'Assertion failed'] ] +{ #category : #enumerating } +TMethod >> detect: aFullBlockClosure [ + + ^ parseTree detect: aFullBlockClosure +] + { #category : #'C code generation' } TMethod >> determineTypeFor: aNode in: aCodeGen [ aNode isSend ifTrue: diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index b9b15a3a5e..c71157d5ce 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -113,7 +113,11 @@ TVariableNode >> nodesDo: aBlock parent: parent [ { #category : #printing } TVariableNode >> printOn: aStream level: level [ - aStream nextPutAll: name. + super printOn: aStream level: level. + aStream + nextPutAll: '('; + nextPutAll: name; + nextPutAll: ')' ] { #category : #accessing } diff --git a/smalltalksrc/VMMaker/EncoderForV3PlusClosures.extension.st b/smalltalksrc/VMMaker/EncoderForV3PlusClosures.extension.st deleted file mode 100644 index f098692811..0000000000 --- a/smalltalksrc/VMMaker/EncoderForV3PlusClosures.extension.st +++ /dev/null @@ -1,10 +0,0 @@ -Extension { #name : #EncoderForV3PlusClosures } - -{ #category : #'*VMMaker' } -EncoderForV3PlusClosures class >> extensionsAt: pc in: aCompiledMethod into: trinaryBlock [ - "If the bytecode at pc is an extension then evaluate aTrinaryBlock - with the values of extA and extB and number of extension *bytes*. - If the bytecode at pc is not an extension then evaluate with 0, 0, 0. - There are no extensions in the SqueakV3/Smalltalk-80 bytecode set, so..." - ^trinaryBlock value: 0 value: 0 value: 0 -] From 15df79bef1351b87428597c1890ad7696ba497b4 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 14:27:27 +0100 Subject: [PATCH 64/75] Fixing tabbing (again) --- smalltalksrc/Slang/Gnuifier.class.st | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/smalltalksrc/Slang/Gnuifier.class.st b/smalltalksrc/Slang/Gnuifier.class.st index f2a8258e2d..c82826d1e6 100644 --- a/smalltalksrc/Slang/Gnuifier.class.st +++ b/smalltalksrc/Slang/Gnuifier.class.st @@ -146,15 +146,15 @@ Gnuifier >> gnuifyFrom: inputFile to: outFileStream [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" - (inLine beginsWith: ' case ') ifTrue: [ + (inLine beginsWith: ' case ') ifTrue: [ | tokens | tokens := inLine findTokens: ' :'. - outLine := ' CASE(' , tokens second , ')'. + outLine := ' CASE(' , tokens second , ')'. tokens size > 2 ifTrue: [ (tokens allButFirst: 2) do: [ :token | outLine := outLine , ' ' , token ] ] ]. - inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. + inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. inLine = '}' ifTrue: [ "all finished with interpret()" inInterpret := false ] ] ifFalse: [ From f9855ac6bd74ec9fda5000df24295b581aa33719 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 15:09:59 +0100 Subject: [PATCH 65/75] Fix double declaration --- .../SlangBasicTranslationTest.class.st | 112 ++++++++++++++++-- smalltalksrc/Slang/TMethod.class.st | 57 +++++---- .../Slang/TStatementListNode.class.st | 20 +++- 3 files changed, 153 insertions(+), 36 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index e148177a6b..4affb797ae 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -1239,8 +1239,6 @@ SlangBasicTranslationTest >> testMethodConditionalCompilationWithAnOption [ static sqInt methodWithAnOptionPragma(void) { - { - } return 0; } @@ -1262,8 +1260,6 @@ SlangBasicTranslationTest >> testMethodConditionalCompilationWithSeveralOptions static sqInt methodWithOptionPragma(void) { - { - } return 0; } @@ -1307,13 +1303,109 @@ SlangBasicTranslationTest >> testMethodLocals [ tMethod recordDeclarationsIn: generator. translation := self translate: tMethod. translation := translation trimBoth. + self - assert: (translation lineNumber: 5) , self newLine - , (translation lineNumber: 6) , self newLine - , (translation lineNumber: 7) - equals: ' int a; + assert: translation + equals: '/* SlangBasicTranslationTestClass>>#methodWithLocalVariables */ +static float +methodWithLocalVariables(void) +{ + int a; + int b; + float foo; + + foo = 1.2; + a = 1; + b = 1; + return (a + b) + foo; +}' +] + +{ #category : #'tests-method' } +SlangBasicTranslationTest >> testMethodLocalsWithGlobalStruct [ + + "Test method local variables printing." + | translation tMethod | + tMethod := self getTMethodFrom: #methodWithLocalVariables. + tMethod referencesGlobalStruct. + tMethod recordDeclarationsIn: generator. + translation := self translate: tMethod. + translation := translation trimBoth. + + self + assert: translation + equals: '/* SlangBasicTranslationTestClass>>#methodWithLocalVariables */ +static float +methodWithLocalVariables(void) +{ + DECL_MAYBE_SQ_GLOBAL_STRUCT; + int a; int b; - float foo;' + float foo; + + foo = 1.2; + a = 1; + b = 1; + return (a + b) + foo; +}' +] + +{ #category : #'tests-method' } +SlangBasicTranslationTest >> testMethodLocalsWithGlobalStructAndVolatile [ + + "Test method local variables printing." + | translation tMethod | + tMethod := self getTMethodFrom: #methodWithLocalVariables. + tMethod referencesGlobalStruct. + tMethod recordDeclarationsIn: generator. + tMethod properties: { #volatile -> true } asDictionary. + translation := self translate: tMethod. + translation := translation trimBoth. + + self + assert: translation + equals: '/* SlangBasicTranslationTestClass>>#methodWithLocalVariables */ +static float +methodWithLocalVariables(void) +{ + DECL_MAYBE_VOLATILE_SQ_GLOBAL_STRUCT; + volatile int a; + volatile int b; + volatile float foo; + + foo = 1.2; + a = 1; + b = 1; + return (a + b) + foo; +}' +] + +{ #category : #'tests-method' } +SlangBasicTranslationTest >> testMethodLocalsWithVolatile [ + + "Test method local variables printing." + | translation tMethod | + tMethod := self getTMethodFrom: #methodWithLocalVariables. + tMethod recordDeclarationsIn: generator. + tMethod properties: { #volatile -> true } asDictionary. + translation := self translate: tMethod. + translation := translation trimBoth. + + self + assert: translation + equals: '/* SlangBasicTranslationTestClass>>#methodWithLocalVariables */ +static float +methodWithLocalVariables(void) +{ + volatile int a; + volatile int b; + volatile float foo; + + foo = 1.2; + a = 1; + b = 1; + return (a + b) + foo; +}' ] { #category : #'tests-method' } @@ -1458,8 +1550,6 @@ SlangBasicTranslationTest >> testMethodWithReturnTypeWithoutReturnReturnsZero [ static sqInt methodWithoutReturn(void) { - { - } return 0; }' ] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 7211497374..d5eae3ae1d 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -82,18 +82,20 @@ TMethod >> addCASTLocalsIn: aCASTBlock generator: aCodeGen [ maybeExternFunctions := (declarations select: [ :decl | decl beginsWith: 'extern' ]) keys. - (self allLocalLocals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ - (aCodeGen sortStrings: self allLocalLocals , maybeExternFunctions) do: [ :var | - | decl | - decl := self - declarationAt: var - ifAbsent: [ aCodeGen defaultType , ' ' , var ]. - (volatileVariables or: [ - (decl beginsWith: 'static') or: [ - (decl beginsWith: 'extern') or: [ - usedVariablesCache includes: var ] ] ]) ifTrue: [ - volatileVariables ifTrue: [ decl := 'volatile ' , decl ]. - aCASTBlock declarations add: (CRawCodeNode code: decl) ] ] ] + (self allLocalLocals isEmpty and: [ maybeExternFunctions isEmpty ]) + ifFalse: [ + (aCodeGen sortStrings: self allLocalLocals , maybeExternFunctions) + do: [ :var | + | decl | + decl := self + declarationAt: var + ifAbsent: [ aCodeGen defaultType , ' ' , var ]. + (volatileVariables or: [ + (decl beginsWith: 'static') or: [ + (decl beginsWith: 'extern') or: [ + self usedVariablesCache includes: var ] ] ]) ifTrue: [ + volatileVariables ifTrue: [ decl := 'volatile ' , decl ]. + aCASTBlock declarations add: (CRawCodeNode code: decl) ] ] ] ] { #category : #accessing } @@ -404,18 +406,24 @@ TMethod >> asCASTIn: aCodeGen [ space ])). functionDefinition := self asCASTFunctionPrototypeIn: aCodeGen - isPrototype: false. - functionDefinition body: CCompoundStatementNode new. + isPrototype: false. + aCodeGen pushScope: self - while: [ body := (parseTree asCASTIn: aCodeGen) ]. "Generation will note used variables in usedVariablesCache" - self addCASTLocalsIn: functionDefinition body generator: aCodeGen. - functionDefinition body add: body. + while: [ body := (parseTree asCASTIn: aCodeGen) ]. + functionDefinition body: body. + + "Generation will note used variables in usedVariablesCache" usedVariablesCache := nil. + ((returnType = #void) not and: [parseTree endsWithReturn not]) ifTrue: [ - functionDefinition body add: (CReturnStatementNode expression: (CConstantNode value: 0))]. - functionDefinition := self addCASTConditionalCompilationFor: functionDefinition generator: aCodeGen. - compoundStatement add: functionDefinition. + functionDefinition body + add: (CReturnStatementNode expression: (CConstantNode value: 0)) + ]. + + compoundStatement add: (self + addCASTConditionalCompilationFor: functionDefinition + generator: aCodeGen). ^ compoundStatement ] @@ -1332,7 +1340,8 @@ TMethod >> incompleteSendsIn: aCodeGen [ TMethod >> initialize [ super initialize. - declarations := Dictionary new + declarations := Dictionary new. + self clearReferencesToGlobalStruct ] { #category : #accessing } @@ -2024,6 +2033,12 @@ TMethod >> isTMethod [ ^true ] +{ #category : #testing } +TMethod >> isVolatile [ + + ^ self hasProperties and: [properties includesKey: #volatile] +] + { #category : #accessing } TMethod >> labels [ diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index fdda24dec8..09e7f97a74 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -170,13 +170,25 @@ TStatementListNode >> asCASTIn: aBuilder [ { #category : #tranforming } TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ - | cDeclarations collect | + | cDeclarations collect methodIsVolatile | cDeclarations := OrderedCollection new. collect := OrderedCollection new. - (aBuilder sortStrings: self locals asSet) do: [ :var | - cDeclarations add: (CRawCodeNode code: (aBuilder + + methodIsVolatile := aBuilder currentMethod isVolatile. + aBuilder currentMethod refersToGlobalStruct ifTrue: [ + cDeclarations add: + (CIdentifierNode name: (methodIsVolatile + ifTrue: [ 'DECL_MAYBE_VOLATILE_SQ_GLOBAL_STRUCT' ] + ifFalse: [ 'DECL_MAYBE_SQ_GLOBAL_STRUCT' ])) ]. + + (aBuilder sortStrings: self locals asSet) do: [ :var | | declaration | + declaration := aBuilder declarationAt: var - ifAbsent: [ aBuilder defaultType, ' ' , var ])) ]. + ifAbsent: [ aBuilder defaultType, ' ' , var ]. + + methodIsVolatile ifTrue: [ declaration := 'volatile ' , declaration ]. + cDeclarations add: (CRawCodeNode code: declaration) + ]. statements doWithIndex: [ :e :index | (e isLeaf and: [ From 9214ffb2e148a67e35acecb638674f0b75d51e17 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 15:13:14 +0100 Subject: [PATCH 66/75] Reducing tabs even more --- smalltalksrc/Slang/Gnuifier.class.st | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/smalltalksrc/Slang/Gnuifier.class.st b/smalltalksrc/Slang/Gnuifier.class.st index c82826d1e6..b7fdc27cef 100644 --- a/smalltalksrc/Slang/Gnuifier.class.st +++ b/smalltalksrc/Slang/Gnuifier.class.st @@ -146,15 +146,15 @@ Gnuifier >> gnuifyFrom: inputFile to: outFileStream [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" - (inLine beginsWith: ' case ') ifTrue: [ + (inLine beginsWith: ' case ') ifTrue: [ | tokens | tokens := inLine findTokens: ' :'. - outLine := ' CASE(' , tokens second , ')'. + outLine := ' CASE(' , tokens second , ')'. tokens size > 2 ifTrue: [ (tokens allButFirst: 2) do: [ :token | outLine := outLine , ' ' , token ] ] ]. - inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. + inLine = ' break;' ifTrue: [ outLine := ' BREAK;' ]. inLine = '}' ifTrue: [ "all finished with interpret()" inInterpret := false ] ] ifFalse: [ From 66abdc119ead770028d463ab8c9b98e09b47c39d Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 16:15:37 +0100 Subject: [PATCH 67/75] Cleaning usedVariable cache --- .../Melchor/MLVMCCodeGenerator.class.st | 6 ++ .../SlangBasicTranslationTest.class.st | 64 +++++++++++++++---- ...angMethodPrototypeTranslationTest.class.st | 1 - smalltalksrc/Slang/CCodeGenerator.class.st | 61 +++++++++++------- smalltalksrc/Slang/TMethod.class.st | 26 +------- .../Slang/TStatementListNode.class.st | 46 ++++++++----- smalltalksrc/Slang/TVariableNode.class.st | 4 +- 7 files changed, 129 insertions(+), 79 deletions(-) diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index 3d8d8796f0..9770b47ac4 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -82,6 +82,12 @@ MLVMCCodeGenerator >> constants [ ^ constants keys reject: [ :any | unused includes: any ] ] +{ #category : #accessing } +MLVMCCodeGenerator >> currentScope [ + + ^ scopeStack last +] + { #category : #'C code generator' } MLVMCCodeGenerator >> declaredConstants [ | unused | diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 4affb797ae..6790bf6074 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -97,8 +97,10 @@ SlangBasicTranslationTest >> setUp [ generator vmMaker vmmakerConfiguration: VMMakerConfiguration. generator currentMethod: (TMethod new labels: Set new; - resetUsedVariablesCache; + definingClass: self class; + selector: #setUp; yourself). + generator pushScope: TStatementListNode new. "The translator accesses it directly using class variables..." SpurMemoryManager initBytesPerWord: 8. @@ -2318,19 +2320,20 @@ SlangBasicTranslationTest >> testSendCCodeInSmalltalkWithString [ { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendCCodeInSmalltalkWithStringNotesVariables [ - | translation send | + | translation send scope | send := TSendNode new setSelector: #cCode:inSmalltalk: receiver: (TVariableNode new setName: 'self') arguments: { TConstantNode value: 'some 1 _underscoreToo #yep'. 'unused' }. - translation := self translate: send. + scope := TStatementListNode statements: { send }. + translation := self translate: scope. - self assert: (generator currentMethod usedVariablesCache includes: 'some'). - self assert: (generator currentMethod usedVariablesCache includes: '_underscoreToo'). - self assert: (generator currentMethod usedVariablesCache includes: 'yep'). - self deny: (generator currentMethod usedVariablesCache includes: '1'). + self assert: (scope usedVariables includes: 'some'). + self assert: (scope usedVariables includes: '_underscoreToo'). + self assert: (scope usedVariables includes: 'yep'). + self deny: (scope usedVariables includes: '1'). ] { #category : #'tests-builtins' } @@ -2362,17 +2365,18 @@ SlangBasicTranslationTest >> testSendCCodeWithString [ { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendCCodeWithStringNotesVariables [ - | translation send | + | translation send scope | send := TSendNode new setSelector: #cCode: receiver: (TVariableNode new setName: 'self') arguments: { TConstantNode value: 'some 1 _underscoreToo #yep' }. - translation := self translate: send. + scope := TStatementListNode statements: { send }. + translation := self translate: scope. - self assert: (generator currentMethod usedVariablesCache includes: 'some'). - self assert: (generator currentMethod usedVariablesCache includes: '_underscoreToo'). - self assert: (generator currentMethod usedVariablesCache includes: 'yep'). - self deny: (generator currentMethod usedVariablesCache includes: '1'). + self assert: (scope usedVariables includes: 'some'). + self assert: (scope usedVariables includes: '_underscoreToo'). + self assert: (scope usedVariables includes: 'yep'). + self deny: (scope usedVariables includes: '1'). ] { #category : #'tests-assignment' } @@ -3598,6 +3602,38 @@ SlangBasicTranslationTest >> testSendIfNotNilIfNilWithNilConstantReceiver [ }' ] +{ #category : #'tests-builtins' } +SlangBasicTranslationTest >> testSendIfNotNilWithArgument [ + + | translation send | + generator generateDeadCode: true. + send := TSendNode new + setSelector: #ifNotNil: + receiver: (TSendNode new + setSelector: #foo + receiver: (TVariableNode new setName: 'self') + arguments: { (TVariableNode new setName: 'x') }) + arguments: { (TStatementListNode + parameters: #( c ) + statements: { (TAssignmentNode new + setVariable: (TVariableNode new setName: 'a') + expression: (TVariableNode new setName: 'c')) }) }. + generator currentMethod parseTree: (TStatementListNode statements: { send }). + translation := self translate: generator currentMethod. + + self assert: translation trimBoth equals: '/* SlangBasicTranslationTest>>#setUp */ +sqInt +setUp(void) +{ + sqInt c; + + if (foo(x)) { + a = c; + } + return 0; +}' +] + { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendIfNotNilWithNilConstantReceiver [ @@ -5167,7 +5203,7 @@ SlangBasicTranslationTest >> testSendSignedRightBitShiftVariable64Bits [ arguments: { (TConstantNode value: 3) }. translation := self translate: send. - self assert: translation equals: '((sqInt) a ) >> 3' + self assert: translation equals: '((sqLong) a ) >> 3' ] { #category : #'tests-assignment' } diff --git a/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st index a920269939..bfcd19f3a4 100644 --- a/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st @@ -27,7 +27,6 @@ SlangMethodPrototypeTranslationTest >> setUp [ generator vmMaker vmmakerConfiguration: VMMakerConfiguration. generator currentMethod: (TMethod new labels: Set new; - resetUsedVariablesCache; yourself). ] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 83ec0083db..bae66bc6c7 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -480,12 +480,15 @@ CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: (m := self methodNamed: selector) ifNil: [ ^ self ]. (replacementList isNil or: [ replacementList isEmpty ]) ifTrue: [ ^ self ]. + self currentMethod: m. + replacementDict := (replacementList collect: [ :asso | asso key -> (TVariableNode named: asso value) ]) asDictionary. "Replace all localized variables by their localized versions" m parseTree bindVariablesIn: replacementDict. + self linearizeExternalCallsIn: m withVariableBindings: replacementDict. "Wrap sends with externalization/internalization statements" @@ -903,13 +906,16 @@ CCodeGenerator >> conventionalTypeForType: aCTypeString [ { #category : #accessing } CCodeGenerator >> currentMethod [ - ^currentMethod + + "The method is the bottom of the scope stack" + ^ scopeStack first ] { #category : #accessing } CCodeGenerator >> currentMethod: aTMethod [ - previousCommenter := nil. - currentMethod := aTMethod + + scopeStack := OrderedCollection with: aTMethod. + previousCommenter := nil ] { #category : #'C code generator' } @@ -990,7 +996,7 @@ CCodeGenerator >> doBasicInlining: inlineFlagOrSymbol [ during: [:bar | (self sortMethods: methods) doWithIndex: [:m :i | bar value: i. - currentMethod := m. + self currentMethod: m. (m tryToInlineMethodsIn: self) ifTrue: [progress := true]]]]. @@ -1427,7 +1433,7 @@ CCodeGenerator >> generateBytesPerWord: msgNode on: aStream indent: level [ CCodeGenerator >> generateCASTAbs: tast [ | type strippedType absFun | - type := self typeFor: tast receiver in: currentMethod. + type := self typeFor: tast receiver in: self currentMethod. strippedType := (type beginsWith: 'unsigned ') ifTrue: [type allButFirst: 'unsigned ' size] ifFalse: [(type beginsWith: 'u') @@ -2028,6 +2034,9 @@ CCodeGenerator >> generateCASTIfNilIfNotNilAsArgument: tast [ CCodeGenerator >> generateCASTIfNotNil: tast [ (self isNilConstantReceiverOf: tast) ifFalse: [ + tast arguments first arguments do: [ :argName | + self noteUsedVariableName: argName + ]. ^ CIfStatementNode if: (tast receiver asCASTExpressionIn: self) then: (tast arguments first asCASTIn: self) ]. @@ -2230,7 +2239,7 @@ CCodeGenerator >> generateCASTIntegerObjectOf: msgNode [ (int)(16r1FFFFF << 3) = (int)16rFFFFFFF8 = -8 whereas (long)(16r1FFFFF << 3) = (long) 16rFFFFFFF8 = 4294967288." - type := self typeFor: expr in: currentMethod. + type := self typeFor: expr in: self currentMethod. typeIsUnsigned := type first = $u. mustCastToUnsigned := typeIsUnsigned not or: [ (self sizeOfIntegralCType: type) @@ -2551,7 +2560,7 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ right: (arg asCASTIn: self) ]. receiverNode := tast receiver asCASTExpressionIn: self. leftNode := receiverNode. - type := self typeFor: rcvr in: currentMethod. + type := self typeFor: rcvr in: self currentMethod. castToLong := castToLong and: [ (self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqLong) ]. @@ -2898,7 +2907,7 @@ CCodeGenerator >> generateCASTValue: tast [ OrderedCollection new. castStatements needsBrackets: false. substitution := tast receiver copy. - substitution renameLabelsForInliningInto: currentMethod. + substitution renameLabelsForInliningInto: self currentMethod. substitutionDict := Dictionary new: tast arguments size * 2. tast receiver arguments with: tast arguments @@ -2912,13 +2921,13 @@ CCodeGenerator >> generateCASTValue: tast [ self noteUsedVariableName: argName ] ]. substitution bindVariablesIn: substitutionDict. castStatements add: (substitution asCASTIn: self). - newLabels := Set withAll: currentMethod labels. + newLabels := Set withAll: self currentMethod labels. substitution nodesDo: [ :node | node isLabel ifTrue: [ node label ifNotNil: [ :label | newLabels add: label ] ] ]. "now add the new labels so that a subsequent inline of the same block will be renamed with different labels." - currentMethod labels: newLabels. + self currentMethod labels: newLabels. ^ castStatements ] @@ -2932,19 +2941,19 @@ CCodeGenerator >> generateCASTValueAsArgument: tast [ self assert: tast receiver isStatementList. self assert: tast receiver arguments size = tast arguments size. substitution := tast receiver copy. - substitution renameLabelsForInliningInto: currentMethod. + substitution renameLabelsForInliningInto: self currentMethod. substitutionDict := Dictionary new: tast arguments size * 2. tast receiver arguments with: tast arguments do: [ :argName :exprNode | substitutionDict at: argName put: exprNode ]. - newLabels := Set withAll: currentMethod labels. + newLabels := Set withAll: self currentMethod labels. substitution nodesDo: [ :node | node isLabel ifTrue: [ node label ifNotNil: [ :label | newLabels add: label ] ] ]. "now add the new labels so that a subsequent inline of the same block will be renamed with different labels." - currentMethod labels: newLabels. + self currentMethod labels: newLabels. ^ substitution bindVariablesIn: substitutionDict; asCASTExpressionIn: self @@ -4182,18 +4191,17 @@ CCodeGenerator >> nonStructClassesForTranslationClasses: classes [ { #category : #utilities } CCodeGenerator >> noteUsedVariableName: variableName [ - currentMethod ifNotNil: - [:m| m noteUsedVariableName: variableName] + + self currentScope noteUsedVariableName: variableName ] { #category : #utilities } CCodeGenerator >> noteVariableUsageInString: aString [ - currentMethod ifNotNil: - [:m| - (Scanner new typedScanTokens: aString) do: - [:token| - (token isString and: [token first isLetter or: [token first == $_]]) ifTrue: - [m noteUsedVariableName: token]]] + + (Scanner new typedScanTokens: aString) do: [ :token | + (token isString and: [ + token first isLetter or: [ token first == $_ ] ]) ifTrue: [ + self noteUsedVariableName: token ] ] ] { #category : #utilities } @@ -4473,8 +4481,15 @@ CCodeGenerator >> pruneUnreachableMethods [ ] { #category : #'C code generator' } -CCodeGenerator >> pushScope: variableToType "" while: aBlock [ - scopeStack addLast: variableToType. +CCodeGenerator >> pushScope: aScope [ + + scopeStack addLast: aScope +] + +{ #category : #'C code generator' } +CCodeGenerator >> pushScope: aScope while: aBlock [ + + self pushScope: aScope. ^aBlock ensure: [scopeStack removeLast] ] diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index d5eae3ae1d..f298fd75d6 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -25,7 +25,6 @@ Class { 'static', 'writtenToGlobalVarsCache', 'functionAttributes', - 'usedVariablesCache', 'cachedLocals' ], #classVars : [ @@ -389,7 +388,6 @@ TMethod >> asCASTIn: aCodeGen [ | compoundStatement functionDefinition body| aCodeGen currentMethod: self. - self resetUsedVariablesCache. compoundStatement := CCompoundStatementNode new needsBrackets: false; yourself. @@ -412,9 +410,6 @@ TMethod >> asCASTIn: aCodeGen [ pushScope: self while: [ body := (parseTree asCASTIn: aCodeGen) ]. functionDefinition body: body. - - "Generation will note used variables in usedVariablesCache" - usedVariablesCache := nil. ((returnType = #void) not and: [parseTree endsWithReturn not]) ifTrue: [ functionDefinition body @@ -1340,6 +1335,9 @@ TMethod >> incompleteSendsIn: aCodeGen [ TMethod >> initialize [ super initialize. + labels := args := #(). + properties := Dictionary new. + export := false. declarations := Dictionary new. self clearReferencesToGlobalStruct ] @@ -2193,12 +2191,6 @@ TMethod >> nodesDo: aBlock [ parseTree nodesDo: aBlock ] -{ #category : #utilities } -TMethod >> noteUsedVariableName: token [ - usedVariablesCache ifNotNil: - [usedVariablesCache add: token] -] - { #category : #'C code generation' } TMethod >> outputConditionalDefineFor: compileTimeOptionPragmas on: aStream [ aStream nextPutAll: '#if '. @@ -2752,12 +2744,6 @@ TMethod >> replaceSizeMessages [ ] -{ #category : #'C code generation' } -TMethod >> resetUsedVariablesCache [ - - usedVariablesCache := Set new -] - { #category : #accessing } TMethod >> returnType [ "The type of the values returned by this method. This string will be used in the C declaration of this function." @@ -3274,12 +3260,6 @@ TMethod >> unusedNamePrefixedBy: aString avoiding: usedNames [ ^usedNames add: newVarName ] -{ #category : #utilities } -TMethod >> usedVariablesCache [ - - ^ usedVariablesCache -] - { #category : #inlining } TMethod >> usesVariableUninlinably: argName in: aCodeGen [ diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 09e7f97a74..edece83f58 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -5,7 +5,8 @@ Class { 'locals', 'declarations', 'arguments', - 'statements' + 'statements', + 'usedVariables' ], #category : #'Slang-AST' } @@ -173,33 +174,35 @@ TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ | cDeclarations collect methodIsVolatile | cDeclarations := OrderedCollection new. collect := OrderedCollection new. + + statements doWithIndex: [ :e :index | + (e isLeaf and: [ + e isLabel not and: [ + aNodeOrNil isNil or: [ index < statements size ] ] ]) + ifFalse: [ + (aNodeOrNil notNil and: [ index = statements size ]) + ifTrue: [ + collect add: (e asCASTIn: aBuilder prependToEnd: aNodeOrNil) ] + ifFalse: [ collect add: (e asCASTIn: aBuilder) ] ] + ifTrue: [ CEmptyStatementNode new ] ]. + "We should collect the variable declarations after generating the body, because the body generation will record used yet non declared variables" methodIsVolatile := aBuilder currentMethod isVolatile. aBuilder currentMethod refersToGlobalStruct ifTrue: [ cDeclarations add: (CIdentifierNode name: (methodIsVolatile ifTrue: [ 'DECL_MAYBE_VOLATILE_SQ_GLOBAL_STRUCT' ] ifFalse: [ 'DECL_MAYBE_SQ_GLOBAL_STRUCT' ])) ]. - - (aBuilder sortStrings: self locals asSet) do: [ :var | | declaration | + + (aBuilder sortStrings: (self locals asSet, self usedVariables) asSet) do: [ :var | | declaration | declaration := aBuilder declarationAt: var ifAbsent: [ aBuilder defaultType, ' ' , var ]. - + methodIsVolatile ifTrue: [ declaration := 'volatile ' , declaration ]. cDeclarations add: (CRawCodeNode code: declaration) - ]. + ]. - statements doWithIndex: [ :e :index | - (e isLeaf and: [ - e isLabel not and: [ - aNodeOrNil isNil or: [ index < statements size ] ] ]) - ifFalse: [ - (aNodeOrNil notNil and: [ index = statements size ]) - ifTrue: [ - collect add: (e asCASTIn: aBuilder prependToEnd: aNodeOrNil) ] - ifFalse: [ collect add: (e asCASTIn: aBuilder) ] ] - ifTrue: [ CEmptyStatementNode new ] ]. ^ CCompoundStatementNode declarations: cDeclarations statements: collect ] @@ -337,6 +340,7 @@ TStatementListNode >> initialize [ super initialize. declarations := Dictionary new. + usedVariables := Set new. locals := #(). arguments := #() ] @@ -426,6 +430,12 @@ TStatementListNode >> nodesDo: aBlock value: parent [ aBlock value: self value: parent ] +{ #category : #accessing } +TStatementListNode >> noteUsedVariableName: aString [ + + usedVariables add: aString +] + { #category : #accessing } TStatementListNode >> parameterNames [ @@ -568,3 +578,9 @@ TStatementListNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ ^statements isEmpty ifFalse: [statements last typeOrNilFrom: aCodeGenerator in: aTMethod] ] + +{ #category : #accessing } +TStatementListNode >> usedVariables [ + + ^ usedVariables +] diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index c71157d5ce..4db31708e9 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -30,11 +30,9 @@ TVariableNode >> accept: aVisitor [ { #category : #tranforming } TVariableNode >> asCASTIn: aBuilder [ - aBuilder currentMethod ifNotNil: [ :m | m noteUsedVariableName: name ]. ^ name = 'nil' ifTrue: [ CIdentifierNode name: aBuilder nilTranslation ] - ifFalse: [ - CIdentifierNode name: (aBuilder returnPrefixFromVariable: name) ] + ifFalse: [ CIdentifierNode name: (aBuilder returnPrefixFromVariable: name) ] ] { #category : #transformations } From 64f9a0bdfac023da54c78367fdbe3878f3f3ee08 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 16:32:33 +0100 Subject: [PATCH 68/75] Note variables used in statement lists --- smalltalksrc/Melchor/MLVMCCodeGenerator.class.st | 6 ------ smalltalksrc/Slang/CCodeGenerator.class.st | 9 ++++++--- smalltalksrc/Slang/TStatementListNode.class.st | 4 ++++ 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index 9770b47ac4..3d8d8796f0 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -82,12 +82,6 @@ MLVMCCodeGenerator >> constants [ ^ constants keys reject: [ :any | unused includes: any ] ] -{ #category : #accessing } -MLVMCCodeGenerator >> currentScope [ - - ^ scopeStack last -] - { #category : #'C code generator' } MLVMCCodeGenerator >> declaredConstants [ | unused | diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index bae66bc6c7..086a54ae29 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -918,6 +918,12 @@ CCodeGenerator >> currentMethod: aTMethod [ previousCommenter := nil ] +{ #category : #accessing } +CCodeGenerator >> currentScope [ + + ^ scopeStack last +] + { #category : #'C code generator' } CCodeGenerator >> declarationAt: aVariableName ifAbsent: absentBlock [ @@ -2034,9 +2040,6 @@ CCodeGenerator >> generateCASTIfNilIfNotNilAsArgument: tast [ CCodeGenerator >> generateCASTIfNotNil: tast [ (self isNilConstantReceiverOf: tast) ifFalse: [ - tast arguments first arguments do: [ :argName | - self noteUsedVariableName: argName - ]. ^ CIfStatementNode if: (tast receiver asCASTExpressionIn: self) then: (tast arguments first asCASTIn: self) ]. diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index edece83f58..788d5d4454 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -163,6 +163,10 @@ TStatementListNode >> asCASTExpressionIn: aBuilder [ { #category : #tranforming } TStatementListNode >> asCASTIn: aBuilder [ + "Push the argument before pushing myself in the scope stack. + This makes the variable available my the parent scope" + self arguments do: [ :e | aBuilder noteUsedVariableName: e ]. + ^ aBuilder pushScope: self while: [ self asCASTIn: aBuilder prependToEnd: nil ] From ae25b0c79cf73c2bd71cdb3726f3cb101ce77198 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 16:55:03 +0100 Subject: [PATCH 69/75] Do not look for variables inside noteVariableUsageInString: --- smalltalksrc/Slang/CCodeGenerator.class.st | 11 ----------- smalltalksrc/Slang/Scanner.class.st | 14 -------------- .../VMMaker/InterpreterPrimitives.class.st | 10 +++++++++- 3 files changed, 9 insertions(+), 26 deletions(-) diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 086a54ae29..bfd3676791 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -2167,7 +2167,6 @@ CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ So it was printing it in a new line" self error: 'unsupported' ]. - self noteVariableUsageInString: aTSendNode arguments first value. ^ CRawCodeNode code: aTSendNode arguments first value ]. ^ aTSendNode arguments first asCASTIn: self @@ -2182,7 +2181,6 @@ CCodeGenerator >> generateCASTInlineCCodeAsArgument: aTSendNode [ So it was printing it in a new line" self error: 'unsupported' ]. - self noteVariableUsageInString: aTSendNode arguments first value. ^ CRawCodeNode code: aTSendNode arguments first value ]. ^ aTSendNode arguments first asCASTExpressionIn: self @@ -4198,15 +4196,6 @@ CCodeGenerator >> noteUsedVariableName: variableName [ self currentScope noteUsedVariableName: variableName ] -{ #category : #utilities } -CCodeGenerator >> noteVariableUsageInString: aString [ - - (Scanner new typedScanTokens: aString) do: [ :token | - (token isString and: [ - token first isLetter or: [ token first == $_ ] ]) ifTrue: [ - self noteUsedVariableName: token ] ] -] - { #category : #utilities } CCodeGenerator >> optionIsTrue: pragma in: aClass [ "Answer whether an option: or notOption: pragma is true in the context of aClass. diff --git a/smalltalksrc/Slang/Scanner.class.st b/smalltalksrc/Slang/Scanner.class.st index b9057623bb..2964e5b1e9 100644 --- a/smalltalksrc/Slang/Scanner.class.st +++ b/smalltalksrc/Slang/Scanner.class.st @@ -9,17 +9,3 @@ Scanner >> scanTokens: aString [ ^ (RBScanner on: aString readStream) contents ] - -{ #category : #accessing } -Scanner >> typedScanTokens: textOrString [ - "Answer an Array that has been tokenized with literals mapped to literals, - special characters mapped to symbols and variable names and keywords - to strings. This methiod accepts _ (underscore) as an assignment token - irrespective of whether the system prefers := as the assignment token." - - ^ (self scanTokens: textOrString) - collect: [ :e | | value | - value := e value. - e isSpecial ifTrue: [ value := value asSymbol ]. - value ] -] diff --git a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st index dc43613f2b..2d9a61d533 100644 --- a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st +++ b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st @@ -299,6 +299,14 @@ InterpreterPrimitives >> initializeInterpreter: bytesToShift [ sHEAFn := self ioLoadFunction: 'secHasEnvironmentAccess' From: 'SecurityPlugin' ] +{ #category : #'process primitives' } +InterpreterPrimitives >> ioClearProfile [ + + + "No simulation version for this yet" + self notYetImplemented +] + { #category : #'simulation support' } InterpreterPrimitives >> ioGetCurrentWorkingDirectory: aCStringHolder maxLength: maxLength [ @@ -1190,7 +1198,7 @@ InterpreterPrimitives >> primitiveClass [ { #category : #'process primitives' } InterpreterPrimitives >> primitiveClearVMProfile [ "Primitive. Void the VM profile histograms." - self cCode: 'ioClearProfile()'. + self ioClearProfile. self pop: argumentCount ] From 56b339392f19cb77b565d05bd7b63353a22b0f00 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 17:11:47 +0100 Subject: [PATCH 70/75] Fix doWhile translation with temporaries --- .../SlangBasicTranslationTest.class.st | 96 ++++++++++--------- smalltalksrc/Slang/CCodeGenerator.class.st | 11 ++- 2 files changed, 59 insertions(+), 48 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 6790bf6074..21cf6221f4 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -2317,25 +2317,6 @@ SlangBasicTranslationTest >> testSendCCodeInSmalltalkWithString [ self assert: translation equals: 'some string' ] -{ #category : #'tests-builtins' } -SlangBasicTranslationTest >> testSendCCodeInSmalltalkWithStringNotesVariables [ - - | translation send scope | - send := TSendNode new - setSelector: #cCode:inSmalltalk: - receiver: (TVariableNode new setName: 'self') - arguments: { - TConstantNode value: 'some 1 _underscoreToo #yep'. - 'unused' }. - scope := TStatementListNode statements: { send }. - translation := self translate: scope. - - self assert: (scope usedVariables includes: 'some'). - self assert: (scope usedVariables includes: '_underscoreToo'). - self assert: (scope usedVariables includes: 'yep'). - self deny: (scope usedVariables includes: '1'). -] - { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendCCodeWithNonConstant [ @@ -2362,23 +2343,6 @@ SlangBasicTranslationTest >> testSendCCodeWithString [ self assert: translation equals: 'some string' ] -{ #category : #'tests-builtins' } -SlangBasicTranslationTest >> testSendCCodeWithStringNotesVariables [ - - | translation send scope | - send := TSendNode new - setSelector: #cCode: - receiver: (TVariableNode new setName: 'self') - arguments: { TConstantNode value: 'some 1 _underscoreToo #yep' }. - scope := TStatementListNode statements: { send }. - translation := self translate: scope. - - self assert: (scope usedVariables includes: 'some'). - self assert: (scope usedVariables includes: '_underscoreToo'). - self assert: (scope usedVariables includes: 'yep'). - self deny: (scope usedVariables includes: '1'). -] - { #category : #'tests-assignment' } SlangBasicTranslationTest >> testSendCCoerceFloatLiteralToFloat [ @@ -5818,9 +5782,11 @@ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ arguments: { }. translation := self translate: send. - self assert: translation trimBoth equals: 'do{ - var -= 7; -}while(!(var >= 21))' + self assert: translation trimBoth equals: '{ + do{ + var -= 7; + }while(!(var >= 21)); +}' ] { #category : #'tests-builtins' } @@ -5885,9 +5851,11 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ { (TVariableNode new setName: 'nil') }) }. translation := self translate: send. - self assert: translation trimBoth equals: 'do{ - var -= 7; -}while(a && b)' + self assert: translation trimBoth equals: '{ + do{ + var -= 7; + }while(a && b); +}' ] { #category : #'tests-builtins' } @@ -5918,6 +5886,42 @@ SlangBasicTranslationTest >> testSendWhileTrueWithOneStatementInReceiverBlock [ }' ] +{ #category : #'tests-builtins' } +SlangBasicTranslationTest >> testSendWhileTrueWithTemporary [ + + "[ | temp | var := var - 7. var >= 21 ] whileTrue" + + | translation send variable expression | + variable := TVariableNode new setName: 'var'. + + expression := TSendNode new + setSelector: #- + receiver: variable + arguments: { (TConstantNode value: 7) }. + send := TSendNode new + setSelector: #whileTrue + receiver: (TStatementListNode + declarations: { 'var' -> 'int var' } asDictionary + statements: { + (TAssignmentNode new + setVariable: variable + expression: expression). + (TSendNode new + setSelector: #>= + receiver: (TVariableNode new setName: 'var') + arguments: { (TConstantNode value: 21) }) }) + arguments: { }. + translation := self translate: send. + + self assert: translation trimBoth equals: '{ + int var; + + do{ + var -= 7; + }while(var >= 21); +}' +] + { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ @@ -5943,9 +5947,11 @@ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ arguments: { }. translation := self translate: send. - self assert: translation trimBoth equals: 'do{ - var -= 7; -}while(var >= 21)' + self assert: translation trimBoth equals: '{ + do{ + var -= 7; + }while(var >= 21); +}' ] { #category : #'tests-assignment' } diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index bfd3676791..1428fc83a4 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -1784,13 +1784,18 @@ CCodeGenerator >> generateCASTDivide: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTDoWhile: boolean loop: tast [ - | block cond| + | block cond parent | + parent := (TStatementListNode + declarations: tast receiver declarations + statements: { }) asCASTIn: self. + block := (TStatementListNode statements: tast receiver statements allButLast) asCASTIn: self. cond := (tast receiver statements last asCASTExpressionIn: self). - ^ CDoStatementNode + parent statements: {CDoStatementNode while: (boolean ifTrue: [ cond ] ifFalse: [ CUnaryOperatorNode operator: #! expression: cond ]) - statement: block + statement: block}. + ^ parent ] { #category : #'CAST translation' } From 2bea1888b55bf541d6952e4e203fd3c911963388 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 17:18:40 +0100 Subject: [PATCH 71/75] Making locals without declarations work too --- .../SlangBasicTranslationTest.class.st | 41 ++++++++++++++++++- smalltalksrc/Slang/CCodeGenerator.class.st | 1 + .../Slang/TStatementListNode.class.st | 10 +++++ 3 files changed, 50 insertions(+), 2 deletions(-) diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 21cf6221f4..6a57aaef50 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -5901,7 +5901,8 @@ SlangBasicTranslationTest >> testSendWhileTrueWithTemporary [ send := TSendNode new setSelector: #whileTrue receiver: (TStatementListNode - declarations: { 'var' -> 'int var' } asDictionary + declarations: Dictionary new + locals: #( temp ) statements: { (TAssignmentNode new setVariable: variable @@ -5914,7 +5915,43 @@ SlangBasicTranslationTest >> testSendWhileTrueWithTemporary [ translation := self translate: send. self assert: translation trimBoth equals: '{ - int var; + sqInt temp; + + do{ + var -= 7; + }while(var >= 21); +}' +] + +{ #category : #'tests-builtins' } +SlangBasicTranslationTest >> testSendWhileTrueWithTemporaryDeclaration [ + + "[ | temp | var := var - 7. var >= 21 ] whileTrue" + + | translation send variable expression | + variable := TVariableNode new setName: 'var'. + + expression := TSendNode new + setSelector: #- + receiver: variable + arguments: { (TConstantNode value: 7) }. + send := TSendNode new + setSelector: #whileTrue + receiver: (TStatementListNode + declarations: { 'temp' -> 'int temp' } asDictionary + statements: { + (TAssignmentNode new + setVariable: variable + expression: expression). + (TSendNode new + setSelector: #>= + receiver: (TVariableNode new setName: 'var') + arguments: { (TConstantNode value: 21) }) }) + arguments: { }. + translation := self translate: send. + + self assert: translation trimBoth equals: '{ + int temp; do{ var -= 7; diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 1428fc83a4..d06ea2d205 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -1787,6 +1787,7 @@ CCodeGenerator >> generateCASTDoWhile: boolean loop: tast [ | block cond parent | parent := (TStatementListNode declarations: tast receiver declarations + locals: tast receiver locals statements: { }) asCASTIn: self. block := (TStatementListNode statements: diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 788d5d4454..f283bd7883 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -11,6 +11,16 @@ Class { #category : #'Slang-AST' } +{ #category : #'instance creation' } +TStatementListNode class >> declarations: declarations locals: locals statements: aCollection [ + + ^ self new + declarations: declarations; + locals: locals; + statements: aCollection; + yourself +] + { #category : #'instance creation' } TStatementListNode class >> declarations: declarations statements: aCollection [ From 068bce089c46dea587dfab3f4a43c6b265de78ae Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 17:49:55 +0100 Subject: [PATCH 72/75] Do not lose cascade declarations --- smalltalksrc/Slang/TMethod.class.st | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index f298fd75d6..e222d348ed 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -2788,11 +2788,12 @@ TMethod >> setSelector: sel definingClass: class args: argList locals: localList selector := sel. definingClass := class. args := argList asOrderedCollection collect: [:arg | arg name]. + + declarations := Dictionary new. parseTree := aBlockNode. "hack; allows nodes to find their parent, etc" parseTree := aBlockNode asTranslatorNodeIn: self. - declarations := Dictionary new. self addTypeForSelf. primitive := aNumber. properties := methodProperties. From 03edefd06945217f9791c023e603a85b3af8b7a5 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Wed, 5 Jan 2022 18:10:44 +0100 Subject: [PATCH 73/75] Recovering method level locals --- smalltalksrc/Slang/TMethod.class.st | 5 +++-- .../VMMakerCompatibilityForPharo6/RBMethodNode.extension.st | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index e222d348ed..5ac3df4207 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -132,10 +132,10 @@ TMethod >> addTypeForSelf [ TMethod >> addVarsDeclarationsAndLabelsOf: methodToBeInlined except: doNotRename [ "Prepare to inline the body of the given method into the receiver by making the args and locals of the argument to the receiver be locals of the receiver. Record any type declarations for these variables. Record labels. Assumes that the variables have already be renamed to avoid name clashes." - self locals: (self locals + self locals addAll: (methodToBeInlined args reject: [ :v | doNotRename includes: v]); addAll: (methodToBeInlined locals reject: [ :v | doNotRename includes: v]); - yourself). + yourself. methodToBeInlined declarations keysAndValuesDo: [ :v :decl | (doNotRename includes: v) ifFalse: @@ -2793,6 +2793,7 @@ TMethod >> setSelector: sel definingClass: class args: argList locals: localList parseTree := aBlockNode. "hack; allows nodes to find their parent, etc" parseTree := aBlockNode asTranslatorNodeIn: self. + parseTree locals addAll: (localList collect: [:arg | arg name]). self addTypeForSelf. primitive := aNumber. diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st index 79e68d1e3d..92d58f4e24 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBMethodNode.extension.st @@ -58,7 +58,7 @@ RBMethodNode >> asTranslationMethodOfClass: aTMethodClass forCodeGenerator: aCod setSelector: selector definingClass: compilationContext getClass args: arguments - locals: #() + locals: ((self allDefinedVariables copyWithoutAll: (arguments collect: #name)) collect: [:string| string -> string]) block: (body lastIsReturn ifTrue: [body] ifFalse: [body shallowCopy From 4ed32bc9039e7f3864461e35ef767c62fec7a058 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Thu, 6 Jan 2022 10:25:34 +0100 Subject: [PATCH 74/75] externalize/localise on dynamic calls --- .../MockLocalizationInterpreterMock.class.st | 16 ++++++++++++++ .../SlangLocalizationTestCase.class.st | 22 +++++++++++++++++++ .../MLVMVariableAccessCollector.class.st | 5 +++++ 3 files changed, 43 insertions(+) diff --git a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st index 9855cd2818..82ce37f851 100644 --- a/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -111,6 +111,16 @@ MockLocalizationInterpreterMock class >> initializeWithMacroCall [ ) ] +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithPerform [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeWithPerform) + ) +] + { #category : #initialization } MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ @@ -246,6 +256,12 @@ MockLocalizationInterpreterMock >> bytecodeWithEscapingCallAsArgumentOfExternalC self foo: self nonInlinedMethodUsingAutolocalizedVariable1 ] +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeWithPerform [ + + self perform: #foo +] + { #category : #'interpreter shell' } MockLocalizationInterpreterMock >> foo2 [ diff --git a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st index c70b0f0615..53ef686afe 100644 --- a/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -303,6 +303,28 @@ SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithE }' ] +{ #category : #tests } +SlangLocalizationTestCase >> testExternalPerform [ + + | interpretMethod cast printedString linearizedBlock | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithPerform. + + "Assert that the send node is preceded by variable externalization" + linearizedBlock := self linearizedBlockOfCaseMethod: interpretMethod. + cast := linearizedBlock asCASTIn: ccg. + + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + + self assert: printedString equals: +'{ + { + autoLocalizedVariable = local_autoLocalizedVariable; + foo(); + local_autoLocalizedVariable = autoLocalizedVariable; + } +}' +] + { #category : #tests } SlangLocalizationTestCase >> testExternalSendNodeExternalizeAndInternalizeOnlyNeededVariables [ diff --git a/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st index 5e5be10185..3c084732f6 100644 --- a/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st +++ b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st @@ -135,6 +135,11 @@ MLVMVariableAccessCollector >> visitReturnNode: aTReturnNode [ { #category : #visiting } MLVMVariableAccessCollector >> visitSendNode: aTSendNode [ + (codeGenerator isDynamicCall: aTSendNode) + ifTrue: [ + accessedVariables addAll: variableSubset. + ^ self ]. + aTSendNode receiver accept: self. aTSendNode arguments do: [ :argument | argument accept: self ]. self analyzeCallGraphFromMessageSend: aTSendNode From ae1982fbc4d93d92a0e64680c1933ee8cd206c91 Mon Sep 17 00:00:00 2001 From: Guille Polito Date: Thu, 6 Jan 2022 12:18:50 +0100 Subject: [PATCH 75/75] Avoid shadowing and redefinition of global struct macro --- smalltalksrc/Slang/TStatementListNode.class.st | 2 +- .../VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index f283bd7883..19ed1559aa 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -202,7 +202,7 @@ TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ "We should collect the variable declarations after generating the body, because the body generation will record used yet non declared variables" methodIsVolatile := aBuilder currentMethod isVolatile. - aBuilder currentMethod refersToGlobalStruct ifTrue: [ + (self parent isTMethod and: [ self parent refersToGlobalStruct ]) ifTrue: [ cDeclarations add: (CIdentifierNode name: (methodIsVolatile ifTrue: [ 'DECL_MAYBE_VOLATILE_SQ_GLOBAL_STRUCT' ] diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st index 8bf5838a20..a14027dc56 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/RBSequenceNode.extension.st @@ -13,7 +13,6 @@ RBSequenceNode >> asTranslatorNodeIn: aTMethod [ ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. ^TStatementListNode new - locals: (self temporaries collect: [:e | e name ]); setArguments: (parent isMethod ifTrue: [#()] ifFalse: [parent arguments asArray collect: [:arg | arg name]])