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/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/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index 078419b31f..3d8d8796f0 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 removeMethodsReferingToGlobals: self vmClass namesOfVariablesToLocalize - except: #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' } @@ -452,54 +449,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. @@ -574,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..40055b0b65 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' } @@ -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/MockLocalizationInterpreterMock.class.st b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st new file mode 100644 index 0000000000..82ce37f851 --- /dev/null +++ b/smalltalksrc/Slang-Tests/MockLocalizationInterpreterMock.class.st @@ -0,0 +1,397 @@ +Class { + #name : #MockLocalizationInterpreterMock, + #superclass : #AbstractInterpreter, + #instVars : [ + 'variableToLocalize', + 'sharedVariableToLocalize', + 'sharedVariableToLocalizeBeforeInlining', + 'autoLocalizedVariable', + 'autoLocalizedVariable1', + 'autoLocalizedVariable2', + 'autoLocalizedVariable3', + 'autoLocalizedVariable4' + ], + #classVars : [ + 'BytecodeTable' + ], + #category : #'Slang-Tests' +} + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initialize [ + + 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) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithEscapingCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeWithEscapingCall) + ) +] + +{ #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 [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingExternalizedAutoLocalizedVariableAsExpression) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithExternalizedAutoLocalizedVariableOnly [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingExternalizedAutoLocalizedVariable) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithInlinedMethodCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingInlinedCall) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithMacroCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingMacro) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithPerform [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeWithPerform) + ) +] + +{ #category : #initialization } +MockLocalizationInterpreterMock class >> initializeWithSafeEscapingCall [ + + BytecodeTable := Array new: 1. + self table: BytecodeTable from: + #( + ( 0 bytecodeUsingSafeExternalCall) + ) +] + +{ #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 [ + + "Do nothing" +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingAutoLocalizedVariable [ + + autoLocalizedVariable := 17 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariable [ + + autoLocalizedVariable := 17. + self nonInlinedMethodUsingAutolocalizedVariable +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingExternalizedAutoLocalizedVariableAsExpression [ + + 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 [ + + self inlinedMethodUsingExternalCall +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingLocalizedVariable [ + + variableToLocalize := 42 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingMacro [ + + self macroMethod +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingSafeExternalCall [ + + self nonInlinedMethodNotUsingAutolocalizedVariables: (autoLocalizedVariable := autoLocalizedVariable +1) +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariable [ + + sharedVariableToLocalize := 42 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeUsingSharedLocalizedVariableBeforeInlining [ + + sharedVariableToLocalizeBeforeInlining := 42. + self methodAlsoSharedLocalizedVariableBeforeInlining +] + +{ #category : #'interpreter shell' } +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 : #'interpreter shell' } +MockLocalizationInterpreterMock >> bytecodeWithPerform [ + + self perform: #foo +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> foo2 [ + + + autoLocalizedVariable := 10. + autoLocalizedVariable1 := 11. + ^ 1 +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> foo: anObject [ + + + autoLocalizedVariable2 := 11. + self foo2 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> inlinedMethodUsingExternalCall [ + + + |arg arg1| + self foo2 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> interpret [ + + + 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 >> macroMethod [ + +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> methodAlsoSharedLocalizedVariableBeforeInlining [ + + sharedVariableToLocalizeBeforeInlining := 17 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> nonBytecodeUsingSharedLocalizedVariable [ + + sharedVariableToLocalize := 17 +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables [ + + + ^ 10 +] + +{ #category : #inline } +MockLocalizationInterpreterMock >> nonInlinedMethodNotUsingAutolocalizedVariables: anObject [ + + + ^ anObject + 10 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable [ + + + ^ autoLocalizedVariable +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> nonInlinedMethodUsingAutolocalizedVariable1 [ + + + ^ autoLocalizedVariable1 +] + +{ #category : #'interpreter shell' } +MockLocalizationInterpreterMock >> sharedMethod [ + + + ^ 1 +] 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/SLInterpreterThreadingTest.class.st b/smalltalksrc/Slang-Tests/SLInterpreterThreadingTest.class.st index 5bec1101ba..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 } @@ -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/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-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 27531bb622..6a57aaef50 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. @@ -142,7 +144,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 +175,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 +205,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 +229,7 @@ SlangBasicTranslationTest >> testBlockValue [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -253,29 +255,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 := TStmtListNode 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: { (TStmtListNode 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 @@ -288,7 +298,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,15 +326,17 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithConstantArgument [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode 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 +344,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithConstantArgument [ receiver: expression arguments: { (TConstantNode value: 4) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -355,13 +367,13 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithMultipleArguments [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode new + expression := TStatementListNode new setArguments: #( i j ) statements: { (TSendNode new setSelector: #foo receiver: (TConstantNode value: 1) - arguments: { TConstantNode value: 2 }). + arguments: { (TConstantNode value: 2) }). (TSendNode new setSelector: #= receiver: (TSendNode new @@ -378,7 +390,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithMultipleArguments [ (TConstantNode value: 4). (TConstantNode value: 5) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -401,15 +413,17 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgument [ | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode 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 +434,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgument [ receiver: (TConstantNode value: 3) arguments: { (TConstantNode value: 4) }) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -443,15 +457,17 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgumentAndMulti | translation variable expression | variable := TVariableNode new setName: 'var'. - expression := TStmtListNode 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 +478,7 @@ SlangBasicTranslationTest >> testBlockValueAsArgumentWithNonLeafArgumentAndMulti receiver: (TConstantNode value: 3) arguments: { (TConstantNode value: 4) }) }) arguments: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TVariableNode new setName: 'b')) }) }). @@ -486,7 +502,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 +537,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 +572,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 +594,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 +621,7 @@ SlangBasicTranslationTest >> testBlockValueWithNonLeafArgumentAndMultipleUse [ translation := self translate: (TSendNode new setSelector: #value: receiver: - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -643,7 +659,7 @@ SlangBasicTranslationTest >> testBlockValueWithVariableAsLastExpression [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -898,7 +914,7 @@ SlangBasicTranslationTest >> testConstantsStatementsInBlockValueAreIgnored [ translation := self translate: (TSendNode new setSelector: #value - receiver: (TStmtListNode new + receiver: (TStatementListNode new setArguments: #() statements: { TSendNode new @@ -939,10 +955,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenArr self assert: translation equals: '{ - int * bar; - int[17] foo; VM_LABEL(methodUsingSingleArrayVariable); { + int * bar; + int[17] foo; + bar = foo; } }' @@ -957,10 +974,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenExt self assert: translation equals: '{ - sqInt bar; - external int foo; VM_LABEL(methodUsingSingleExternalVariable); { + sqInt bar; + external int foo; + bar = foo; } }' @@ -975,10 +993,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenIni self assert: translation equals: '{ - sqInt bar; - sqInt foo; VM_LABEL(methodUsingSingleNonInitializedVariable); { + sqInt bar; + sqInt foo; + foo = 0; bar = foo; } @@ -994,10 +1013,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenSta self assert: translation equals: '{ - int bar; - static int foo; VM_LABEL(methodUsingSingleStaticVariable); { + int bar; + static int foo; + bar = foo; } }' @@ -1012,9 +1032,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotRemoveExternalTemp [ self assert: translation equals: '{ - extern int foo; VM_LABEL(methodDefiningSingleExternVariable); { + extern int foo; + + } }' ] @@ -1028,9 +1050,11 @@ SlangBasicTranslationTest >> testInlineNodeDoesNotRemoveStaticTemp [ self assert: translation equals: '{ - static int foo; VM_LABEL(methodDefiningSingleStaticVariable); { + static int foo; + + } }' ] @@ -1061,13 +1085,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; @@ -1216,8 +1241,6 @@ SlangBasicTranslationTest >> testMethodConditionalCompilationWithAnOption [ static sqInt methodWithAnOptionPragma(void) { - { - } return 0; } @@ -1239,8 +1262,6 @@ SlangBasicTranslationTest >> testMethodConditionalCompilationWithSeveralOptions static sqInt methodWithOptionPragma(void) { - { - } return 0; } @@ -1284,13 +1305,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;' + 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; + + 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' } @@ -1435,8 +1552,6 @@ SlangBasicTranslationTest >> testMethodWithReturnTypeWithoutReturnReturnsZero [ static sqInt methodWithoutReturn(void) { - { - } return 0; }' ] @@ -1478,7 +1593,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 +1665,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. @@ -1596,23 +1711,25 @@ return;' SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitch [ | translation | - translation := self translate: (TReturnNode expression: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: - { (TStmtListNode new setStatements: - { (TConstantNode value: 0) }) }; - cases: - { (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }) }; - yourself) - otherwiseOrNil: - (TStmtListNode 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 +1747,21 @@ SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitch [ SlangBasicTranslationTest >> testReturnSwitchStatementMovesReturnIntoSwitchWithNoDefaultStatement [ | translation | - translation := self translate: (TReturnNode expression: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: - { (TStmtListNode new setStatements: - { (TConstantNode value: 0) }) }; - cases: - { (TStmtListNode 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 +2261,12 @@ 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 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)' @@ -2193,24 +2317,6 @@ SlangBasicTranslationTest >> testSendCCodeInSmalltalkWithString [ self assert: translation equals: 'some string' ] -{ #category : #'tests-builtins' } -SlangBasicTranslationTest >> testSendCCodeInSmalltalkWithStringNotesVariables [ - - | translation send | - send := TSendNode new - setSelector: #cCode:inSmalltalk: - receiver: (TVariableNode new setName: 'self') - arguments: { - TConstantNode value: 'some 1 _underscoreToo #yep'. - 'unused' }. - translation := self translate: send. - - 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'). -] - { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendCCodeWithNonConstant [ @@ -2237,22 +2343,6 @@ SlangBasicTranslationTest >> testSendCCodeWithString [ self assert: translation equals: 'some string' ] -{ #category : #'tests-builtins' } -SlangBasicTranslationTest >> testSendCCodeWithStringNotesVariables [ - - | translation send | - send := TSendNode new - setSelector: #cCode: - receiver: (TVariableNode new setName: 'self') - arguments: { TConstantNode value: 'some 1 _underscoreToo #yep' }. - translation := self translate: send. - - 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'). -] - { #category : #'tests-assignment' } SlangBasicTranslationTest >> testSendCCoerceFloatLiteralToFloat [ @@ -2289,13 +2379,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). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2316,20 +2407,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). - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2391,7 +2483,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 statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'y') expression: (TSendNode new setSelector: #ifTrue: @@ -2427,19 +2519,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 statements: { (TSendNode new setSelector: #cppIf:ifTrue:ifFalse: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: true)). @@ -2470,13 +2562,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 statements: + { (TStatementListNode new statements: { (TSendNode new setSelector: #cppIf:ifTrue: receiver: (TVariableNode new setName: 'self') arguments: { (TConstantNode value: #FEATURE). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2513,11 +2605,11 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSendIfTrueAsCondition [ setSelector: #ifTrue:ifFalse: receiver: (TConstantNode value: true) arguments: { - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: false) }). - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: true) }) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2537,14 +2629,14 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSingleExpressionDoesNotAddsS | translation send | send := TReturnNode expression: (TSendNode new - setSelector: #cppIf:ifTrue: - receiver: (TVariableNode new setName: 'self') - arguments: { - (TConstantNode value: #FEATURE). - (TStmtListNode 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 +2653,11 @@ SlangBasicTranslationTest >> testSendCppIfIfTrueWithSingleStatementAddsSeparator setSelector: #cppIf:ifTrue: receiver: (TVariableNode new setName: 'self') arguments: { - (TConstantNode value: #FEATURE). - (TStmtListNode 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 +2788,7 @@ SlangBasicTranslationTest >> testSendIfFalse [ send := TSendNode new setSelector: #ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2720,7 +2812,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgument [ expression: (TSendNode new setSelector: #ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2746,7 +2838,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgumentWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2775,7 +2867,7 @@ SlangBasicTranslationTest >> testSendIfFalseAsArgumentWithReceiverSendNot [ receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) arguments: { }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2797,14 +2889,15 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrue [ setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { (TAssignmentNode new + (TStatementListNode new statements: + { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: 1)) }) }. translation := self translate: send. @@ -2826,20 +2919,21 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgument [ expression: (TSendNode new setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode 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 - 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 +2954,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgumentCollapseBothArmsOfCo receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2890,14 +2984,14 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueAsArgumentCollapseBothArmsOfCo setSelector: #ifFalse:ifTrue: receiver: (TVariableNode named: 'x') arguments: { - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -2920,19 +3014,19 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditional receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode 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)) }). - (TStmtListNode 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 +3047,19 @@ SlangBasicTranslationTest >> testSendIfFalseIfTrueCollapseBothArmsOfConditionalW setSelector: #ifFalse:ifTrue: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode 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)) }). - (TStmtListNode 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 +3096,10 @@ SlangBasicTranslationTest >> testSendIfFalseWithNonLeafReceiver [ send := TSendNode new setSelector: #ifFalse: receiver: (TSendNode new - setSelector: #& - receiver: (TVariableNode new setName: 'x') - arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStmtListNode 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 +3122,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverFalseConstant [ send := TSendNode new setSelector: #ifFalse: receiver: (TConstantNode value: false) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3053,7 +3147,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverSendNot [ setSelector: #not receiver: (TVariableNode new setName: 'x') arguments: { }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3076,7 +3170,7 @@ SlangBasicTranslationTest >> testSendIfFalseWithReceiverTrueConstant [ send := TSendNode new setSelector: #ifFalse: receiver: (TConstantNode value: true) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3099,7 +3193,7 @@ SlangBasicTranslationTest >> testSendIfNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3194,7 +3288,7 @@ SlangBasicTranslationTest >> testSendIfNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNil: receiver: (TConstantNode value: nil) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3213,6 +3307,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 +3315,21 @@ SlangBasicTranslationTest >> testSendIfNilifNotNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode 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 - 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 +3343,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: { (TStmtListNode 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 - 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 +3385,7 @@ SlangBasicTranslationTest >> testSendIfNotNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3340,6 +3438,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 +3446,21 @@ SlangBasicTranslationTest >> testSendIfNotNilIfNil [ setSelector: #foo receiver: (TVariableNode new setName: 'self') arguments: { (TVariableNode new setName: 'x') }) - arguments: { (TStmtListNode 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 - 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 +3537,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: { (TStmtListNode 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 - 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: '{ @@ -3464,6 +3566,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 [ @@ -3472,7 +3606,7 @@ SlangBasicTranslationTest >> testSendIfNotNilWithNilConstantReceiver [ send := TSendNode new setSelector: #ifNotNil: receiver: (TConstantNode value: nil) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3491,7 +3625,7 @@ SlangBasicTranslationTest >> testSendIfTrue [ send := TSendNode new setSelector: #ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3515,7 +3649,7 @@ SlangBasicTranslationTest >> testSendIfTrueAsArgument [ expression: (TSendNode new setSelector: #ifTrue: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3541,7 +3675,7 @@ SlangBasicTranslationTest >> testSendIfTrueAsArgumentWithNonLeafReceiver [ setSelector: #& receiver: (TVariableNode new setName: 'x') arguments: { (TVariableNode new setName: 'y') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3579,14 +3713,15 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalse [ setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { (TAssignmentNode new + (TStatementListNode new statements: + { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: 1)) }) }. translation := self translate: send. @@ -3608,20 +3743,21 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgument [ expression: (TSendNode new setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') - arguments: { (TStmtListNode 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 - 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 +3778,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgumentCollapseBothArmsOfCo receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3672,14 +3808,14 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseAsArgumentCollapseBothArmsOfCo setSelector: #ifTrue:ifFalse: receiver: (TVariableNode named: 'x') arguments: { - (TStmtListNode 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)) }). - (TStmtListNode new setStatements: { + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3702,19 +3838,19 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditional receiver: (TVariableNode new setName: 'x') arguments: { (TConstantNode value: 7) }) arguments: { - (TStmtListNode 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)) }). - (TStmtListNode 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 +3871,19 @@ SlangBasicTranslationTest >> testSendIfTrueIfFalseCollapseBothArmsOfConditionalW setSelector: #ifTrue:ifFalse: receiver: (TVariableNode new setName: 'x') arguments: { - (TStmtListNode 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)) }). - (TStmtListNode 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 +3919,12 @@ SlangBasicTranslationTest >> testSendIfTrueWithBlockReceiver [ | translation send | send := TSendNode new setSelector: #ifTrue: - receiver: (TStmtListNode new setStatements: { (TAssignmentNode new + receiver: (TStatementListNode new statements: { + (TAssignmentNode new setVariable: (TVariableNode new setName: 'y') expression: (TConstantNode value: false)). - TVariableNode new setName: 'x' }) - arguments: { (TStmtListNode new setStatements: { + (TVariableNode new setName: 'x') }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3812,7 +3949,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverBinaryOperation [ setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: { (TVariableNode new setName: 'b') }) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3835,7 +3972,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverFalseConstant [ send := TSendNode new setSelector: #ifTrue: receiver: (TConstantNode value: false) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -3855,7 +3992,7 @@ SlangBasicTranslationTest >> testSendIfTrueWithReceiverTrueConstant [ send := TSendNode new setSelector: #ifTrue: receiver: (TConstantNode value: true) - arguments: { (TStmtListNode new setStatements: { + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode new setName: 'a') expression: (TConstantNode value: false)). @@ -4697,6 +4834,7 @@ SlangBasicTranslationTest >> testSendRaisedTo [ SlangBasicTranslationTest >> testSendRepeat [ " [ var := var - 7 ] repeat" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -4706,7 +4844,7 @@ SlangBasicTranslationTest >> testSendRepeat [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #repeat - receiver: (TStmtListNode new setStatements: + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) @@ -4782,11 +4920,11 @@ SlangBasicTranslationTest >> testSendSequentialAndWithConstantReceiverTrue [ send := TSendNode new setSelector: #and: receiver: (TConstantNode value: true) - arguments: { (TStmtListNode 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') @@ -5029,7 +5167,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' } @@ -5155,6 +5293,7 @@ SlangBasicTranslationTest >> testSendTimes [ SlangBasicTranslationTest >> testSendTimesRepeat [ "5 timesRepeat: [ var := var - 7 ]" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5165,7 +5304,7 @@ SlangBasicTranslationTest >> testSendTimesRepeat [ send := TSendNode new setSelector: #timesRepeat: receiver: (TConstantNode value: 5) - arguments: { (TStmtListNode new setStatements: + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5205,7 +5344,7 @@ SlangBasicTranslationTest >> testSendToByDo [ arguments: { (TConstantNode value: 10). (TConstantNode value: 2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5213,8 +5352,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; + }; }' ] @@ -5241,7 +5384,7 @@ SlangBasicTranslationTest >> testSendToByDoLimitExpressionHasSideEffect [ receiver: (TVariableNode new setName: 'var') arguments: { }). (TConstantNode value: 2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5252,8 +5395,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; + }; }' ] @@ -5274,7 +5421,7 @@ SlangBasicTranslationTest >> testSendToByDoWithNegativeStep [ arguments: { (TConstantNode value: 0). (TConstantNode value: -2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5282,8 +5429,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; + }; }' ] @@ -5311,7 +5462,7 @@ SlangBasicTranslationTest >> testSendToByDoWithOperationReceiver [ arguments: { (TConstantNode value: 10). (TConstantNode value: 2). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5321,8 +5472,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; + }; }' ] @@ -5350,7 +5505,7 @@ SlangBasicTranslationTest >> testSendToByDoWithOperationUpdate [ setSelector: #foo receiver: (TConstantNode value: 1) arguments: { (TConstantNode value: 2) }) }). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5360,8 +5515,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; + }; }' ] @@ -5381,7 +5540,7 @@ SlangBasicTranslationTest >> testSendToDo [ receiver: (TConstantNode value: 1) arguments: { (TConstantNode value: 10). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5389,8 +5548,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; + }; }' ] @@ -5416,7 +5579,7 @@ SlangBasicTranslationTest >> testSendToDoAvoidUnderflowingOfLimitExpression [ receiver: (TVariableNode new setName: 'foo') arguments: { (TConstantNode value: 1) }). (TConstantNode value: 10). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5426,8 +5589,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; + }; }' ] @@ -5451,7 +5618,7 @@ SlangBasicTranslationTest >> testSendToDoLimitExpressionHasSideEffect [ setSelector: #foo receiver: (TVariableNode new setName: 'var') arguments: { }). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5461,8 +5628,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; + }; }' ] @@ -5488,7 +5659,7 @@ SlangBasicTranslationTest >> testSendToDoWithOperationReceiver [ arguments: { (TConstantNode value: 2) }) }) arguments: { (TConstantNode value: 10). - (TStmtListNode new + (TStatementListNode new setArguments: #( i ) statements: { (TAssignmentNode new @@ -5496,8 +5667,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; + }; }' ] @@ -5518,6 +5693,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 +5703,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndAr arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileFalse: - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5536,12 +5712,13 @@ SlangBasicTranslationTest >> testSendWhileFalseWithManyStatementsInReceiverAndAr receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) arguments: - { (TStmtListNode 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 +5742,11 @@ SlangBasicTranslationTest >> testSendWhileFalseWithOneStatementInReceiverBlock [ send := TSendNode new setSelector: #whileFalse: receiver: - (TStmtListNode new setStatements: { (TSendNode new + (TStatementListNode new statements: { (TSendNode new setSelector: #& receiver: (TVariableNode new setName: 'a') - arguments: {(TVariableNode new setName: 'b')}) }) - arguments: { (TStmtListNode new setStatements: + arguments: { (TVariableNode new setName: 'b') }) }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5584,6 +5761,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithOneStatementInReceiverBlock [ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ "[ var := var - 7. var >= 21 ] whileFalse" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5593,7 +5771,7 @@ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileFalse - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5601,12 +5779,14 @@ SlangBasicTranslationTest >> testSendWhileFalseWithoutArguments [ setSelector: #>= receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) - arguments: {}. + 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' } @@ -5621,7 +5801,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithManyStatementsInReceiverAndArg arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue: - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5630,12 +5810,13 @@ SlangBasicTranslationTest >> testSendWhileTrueWithManyStatementsInReceiverAndArg receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) arguments: - { (TStmtListNode 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 +5839,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue: - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5666,14 +5847,15 @@ SlangBasicTranslationTest >> testSendWhileTrueWithNilAsArgument [ setSelector: #& receiver: (TVariableNode new setName: 'a') arguments: { (TVariableNode new setName: 'b') }) }) - arguments: - { (TStmtListNode new setStatements: - { (TVariableNode new setName: 'nil') }) }. + arguments: { (TStatementListNode new statements: + { (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' } @@ -5689,11 +5871,11 @@ SlangBasicTranslationTest >> testSendWhileTrueWithOneStatementInReceiverBlock [ send := TSendNode new setSelector: #whileTrue: receiver: - (TStmtListNode new setStatements: { (TSendNode new + (TStatementListNode new statements: { (TSendNode new setSelector: #& receiver: (TVariableNode new setName: 'a') - arguments: {(TVariableNode new setName: 'b')}) }) - arguments: { (TStmtListNode new setStatements: + arguments: { (TVariableNode new setName: 'b') }) }) + arguments: { (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression) }) }. @@ -5704,10 +5886,84 @@ 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: Dictionary new + locals: #( temp ) + 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: '{ + 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; + }while(var >= 21); +}' +] + { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ "[ var := var - 7. var >= 21 ] whileTrue" + | translation send variable expression | variable := TVariableNode new setName: 'var'. @@ -5717,7 +5973,7 @@ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ arguments: { (TConstantNode value: 7) }. send := TSendNode new setSelector: #whileTrue - receiver: (TStmtListNode new setStatements: { + receiver: (TStatementListNode new statements: { (TAssignmentNode new setVariable: variable expression: expression). @@ -5725,12 +5981,14 @@ SlangBasicTranslationTest >> testSendWhileTrueWithoutArguments [ setSelector: #>= receiver: (TVariableNode new setName: 'var') arguments: { (TConstantNode value: 21) }) }) - arguments: {}. + 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' } @@ -5774,16 +6032,16 @@ SlangBasicTranslationTest >> testSwitchStatement [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) })). @@ -5808,25 +6066,28 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgument [ translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: { - (TStmtListNode new setStatements: - { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: - { (TConstantNode value: 1) }) }; - cases: { - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 11)) }) }; - yourself) - otherwiseOrNil: nil) - arguments: { TStmtListNode 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 +6104,42 @@ SlangBasicTranslationTest >> testSwitchStatementAsArgumentWithNastedCases [ translation := self translate: (TSendNode new setSelector: #ifTrue: receiver: (TSwitchStmtNode new - expression: (TVariableNode named: 'x') - cases: (TBraceCaseNode new - caseLabels: { - (TStmtListNode new setStatements: - { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: - { (TConstantNode value: 1) }). - (TStmtListNode new setStatements: - { (TConstantNode value: 2) }). - (TStmtListNode new setStatements: - { (TConstantNode value: 3) }) }; - cases: { - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 1)) }) - }; - yourself) - otherwiseOrNil: nil) - arguments: { TStmtListNode 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 +6157,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: { - (TStmtListNode new setStatements: - { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: - { (TConstantNode value: 1) }) }; - cases: { - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: - { (TAssignmentNode new - setVariable: (TVariableNode named: 'foo') - expression: (TConstantNode value: 11)) }) }; - yourself) - otherwiseOrNil: nil) switchVariable: 'jinx') - arguments: { TStmtListNode 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 +6203,17 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 0)) }))). @@ -5973,10 +6242,10 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') @@ -6007,10 +6276,10 @@ SlangBasicTranslationTest >> testSwitchStatementInAssignmentAddAssignmentToEndOf expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') @@ -6038,22 +6307,22 @@ SlangBasicTranslationTest >> testSwitchStatementWithNestedCase [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: { - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: 0) }). - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TConstantNode value: 1) }) }; cases: { - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }). - (TStmtListNode new setStatements: + (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; yourself) otherwiseOrNil: - (TStmtListNode new setStatements: { })). + (TStatementListNode new statements: { })). self assert: translation trimBoth equals: 'switch (x) { case 0: @@ -6076,10 +6345,10 @@ SlangBasicTranslationTest >> testSwitchStatementWithNoDefaultStatement [ expression: (TVariableNode named: 'x') cases: (TBraceCaseNode new caseLabels: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TConstantNode value: 0) }) }; cases: - { (TStmtListNode new setStatements: + { (TStatementListNode new statements: { (TAssignmentNode new setVariable: (TVariableNode named: 'foo') expression: (TConstantNode value: 10)) }) }; @@ -6101,23 +6370,21 @@ SlangBasicTranslationTest >> testSwitchStatementWithNoDefaultStatement [ SlangBasicTranslationTest >> testTranslateBlockAssignmentWithManyStatement [ | translation variable expression | - " var := [ a := b . c := 1 ]." - variable := TVariableNode new setName: 'var'. - expression := TStmtListNode 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). - }. + 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). + translation := self translate: + (TAssignmentNode new + setVariable: variable + expression: expression). self assert: translation trimBoth equals: '{ a = b; @@ -6206,7 +6473,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 new file mode 100644 index 0000000000..53ef686afe --- /dev/null +++ b/smalltalksrc/Slang-Tests/SlangLocalizationTestCase.class.st @@ -0,0 +1,631 @@ +Class { + #name : #SlangLocalizationTestCase, + #superclass : #SlangAbstractTestCase, + #category : #'Slang-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 + variableNamed: aVariableName + expression: (TVariableNode named: #local_, aVariableName)) +] + +{ #category : #running } +SlangLocalizationTestCase >> internalizationOf: aVariableName [ + + ^ (TAssignmentNode + variableNamed: #local_, aVariableName + expression: (TVariableNode named: aVariableName)) +] + +{ #category : #helpers } +SlangLocalizationTestCase >> linearizedBlockOfCaseMethod: aTMethod [ + + | case inlinedMethod | + 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 isLabel not and: [ e isStatementList not or: [ e first isLabel not ]] ] +] + +{ #category : #running } +SlangLocalizationTestCase >> setUp [ + + super setUp. + MockLocalizationInterpreterMock initialize. +] + +{ #category : #'tests - initialization' } +SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariable [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg initAutoLocalizationOfVariablesIn: #interpret. + + self assert: ((ccg methodNamed: #interpret) locals includes: #local_autoLocalizedVariable) +] + +{ #category : #'tests - initialization' } +SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariableWhenNameConflict [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg initAutoLocalizationOfVariablesIn: #interpretWithLocalizedVariableConflict. + self assert: ((ccg methodNamed: #interpretWithLocalizedVariableConflict) locals includes: #local_autoLocalizedVariable1) +] + +{ #category : #'tests - initialization' } +SlangLocalizationTestCase >> testAutoLocalizeVariableDefinesNewLocalVariables [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + | method | + ccg addClass: MockLocalizationInterpreterMock. + ccg initAutoLocalizationOfVariablesIn: #interpretWithSeveralVariablesToLocalize. + method := (ccg methodNamed: #interpretWithSeveralVariablesToLocalize). + self assert: ( method locals includes: #local_autoLocalizedVariable1). + 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 [ + + | externalizationStatement interpretMethod | + interpretMethod := self applyLocalizationTo: #interpret. + externalizationStatement := interpretMethod statements last first first. + + self assert: (externalizationStatement isSameAs: + (self externalizationOf: #autoLocalizedVariable)) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturnReferenchingAutoLocalizedVariable [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + + | interpretMethod printedString | + interpretMethod := self applyLocalizationTo: #interpretWithReturnExpressionUpdatingAutoLocalizedVariable. + printedString := String streamContents: [ :str | + ((TStatementListNode statements: interpretMethod statements last) asCASTIn: ccg) + prettyPrintOn: str ]. + self assert: printedString equals: '{ + { + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); + { + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + return t0; + } + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableExternalizesBeforeReturns [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + + | interpretMethod sendNode | + interpretMethod := self applyLocalizationTo: #interpretWithReturnExpression. + + sendNode := interpretMethod last first second. + self assert: sendNode arguments first first first last isReturn. + self + assert: (sendNode arguments first first first first + isSameAs: (self externalizationOf: #autoLocalizedVariable)). + + self assert: sendNode arguments second first first last isReturn. + self + assert: (sendNode arguments second first first first + isSameAs: (self externalizationOf: #autoLocalizedVariable)). +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableInternalizesAtTheBeginning [ + + | internalizationStatement interpretMethod | + interpretMethod := self applyLocalizationTo: #interpret. + + internalizationStatement := interpretMethod statements first. + + self + assert: (internalizationStatement isSameAs: (self internalizationOf: #autoLocalizedVariable)) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testAutoLocalizeVariableReplacesByLocalOnInline [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + | interpretMethod variableNode case | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithAutoLocalizedVariableOnly. + + "Fail if we find some node inside the case that uses the localized 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 ]). +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalEscapingAsArgument [ + + | interpretMethod cast printedString linearizedBlock | + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCallAsArgument. + + "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: +'{ + sqInt t0; + + { + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = foo2(); + local_autoLocalizedVariable = autoLocalizedVariable; + } + if (1 == t0) { + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalEscapingAsArgumentOfExternalCall [ + + | interpretMethod cast printedString linearizedBlock | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCallAsArgumentOfExternalCall. + + "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: '{ + sqInt t0; + + { + autoLocalizedVariable1 = local_autoLocalizedVariable1; + t0 = nonInlinedMethodUsingAutolocalizedVariable1(); + local_autoLocalizedVariable1 = autoLocalizedVariable1; + } + { + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + foo(t0); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable2 = autoLocalizedVariable2; + } +}'. +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalEscapingSendNodeInInlinedMethod [ + + | interpretMethod cast printedString linearizedBlock | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithInlinedMethodCall. + + "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; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + foo2(); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalEscapingSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ + + | interpretMethod cast printedString linearizedBlock | + + interpretMethod := self applyLocalizationToInterpretWith: #initializeWithEscapingCall. + + "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: '{ + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); + { + autoLocalizedVariable = local_autoLocalizedVariable; + foo(t0); + local_autoLocalizedVariable = autoLocalizedVariable; + } +}' +] + +{ #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 [ + + | interpretMethod cast printedString linearizedBlock | + + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithEscapingCall. + + "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: '{ + sqInt t0; + + t0 = (local_autoLocalizedVariable += 1); + { + autoLocalizedVariable = local_autoLocalizedVariable; + autoLocalizedVariable1 = local_autoLocalizedVariable1; + autoLocalizedVariable2 = local_autoLocalizedVariable2; + foo(t0); + local_autoLocalizedVariable = autoLocalizedVariable; + local_autoLocalizedVariable1 = autoLocalizedVariable1; + local_autoLocalizedVariable2 = autoLocalizedVariable2; + } +}' +] + +{ #category : #tests } +SlangLocalizationTestCase >> testExternalSendNodeShouldBeTranslatedWithExternalizationAndInternalization [ + + | interpretMethod cast printedString linearizedBlock | + interpretMethod := self + applyLocalizationToInterpretWith: #initializeWithExternalizedAutoLocalizedVariableInExpressionOnly. + + "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: '{ + sqInt t0; + + { + autoLocalizedVariable = local_autoLocalizedVariable; + t0 = nonInlinedMethodUsingAutolocalizedVariable(); + local_autoLocalizedVariable = autoLocalizedVariable; + } + { + autoLocalizedVariable = local_autoLocalizedVariable; + foo(t0); + local_autoLocalizedVariable = autoLocalizedVariable; + } +}' +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeCallsInNestedLexicalScope [ + + | methodToLinearize ifBlock | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableInNestedLexicalScope. + + ccg prepareMethods. + ccg currentMethod: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). + + "Before it was + true ifTrue: [ + self foo: self nonInlinedMethodUsingAutolocalizedVariable + ] + After + true ifTrue: [ + | t0 | + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + self foo: t0 + ] " + + ifBlock := methodToLinearize statements first statements first arguments first statements first. + + self assert: (ifBlock statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (ifBlock statements second + isSameAs: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' })) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeNestedCalls [ + + | methodToLinearize replacementBlock | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpression. + + ccg prepareMethods. + ccg currentMethod: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). + + "Before it was + self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + self foo: t0" + + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (replacementBlock statements second + isSameAs: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' })). + self assert: replacementBlock statements size equals: 2. +] + +{ #category : #'tests - initialization' } +SlangLocalizationTestCase >> testLinearizeNestedCallsWithAssignment [ + + | methodToLinearize replacementBlock | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInAssignment. + + ccg prepareMethods. + ccg currentMethod: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). + + "Before it was + foo := self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0. + foo := t1" + + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (replacementBlock statements second + isSameAs: (TAssignmentNode + variableNamed: 't1' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' }))). + self assert: (replacementBlock statements third + isSameAs: (TAssignmentNode + variableNamed: 'foo' + expression: (TVariableNode named: 't1'))) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeNestedCallsWithReturn [ + + | methodToLinearize replacementBlock | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingExternalizedAutoLocalizedVariableAsExpressionInReturn. + + ccg prepareMethods. + ccg currentMethod: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). + + "Before it was + ^ self foo: self nonInlinedMethodUsingAutolocalizedVariable. + After + t0 := self nonInlinedMethodUsingAutolocalizedVariable. + t1 := self foo: t0. + ^ t1" + + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock statements first + isSameAs: (TAssignmentNode + variableNamed: 't0' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #nonInlinedMethodUsingAutolocalizedVariable))). + self assert: (replacementBlock statements second + isSameAs: (TAssignmentNode + variableNamed: 't1' + expression: (TSendNode + receiver: TVariableNode selfNode + selector: #foo: + arguments: { TVariableNode named: 't0' }))). + self assert: (replacementBlock statements third + isSameAs: (TReturnNode expression: (TVariableNode named: 't1'))) +] + +{ #category : #'tests - linearization' } +SlangLocalizationTestCase >> testLinearizeSingleCalls [ + + | methodToLinearize replacementBlock | + ccg addClass: MockLocalizationInterpreterMock. + methodToLinearize := ccg methodNamed: #bytecodeUsingInlinedCall. + + ccg prepareMethods. + ccg currentMethod: methodToLinearize. + ccg + linearizeExternalCallsIn: methodToLinearize + withVariableBindings: ((ccg initAutoLocalizationOfVariablesIn: #interpret) asDictionary + collect: [:n| TVariableNode named: n]). + + "Before it was + self inlinedMethodUsingExternalCall. + After + self inlinedMethodUsingExternalCall" + + replacementBlock := methodToLinearize statements first. + self assert: (replacementBlock first + isSameAs: (TSendNode + receiver: TVariableNode selfNode + selector: #inlinedMethodUsingExternalCall)) +] + +{ #category : #'tests - old localization' } +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). + + "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' ]. +] + +{ #category : #'tests - old localization' } +SlangLocalizationTestCase >> testLocalizeSharedVariableShouldFailIfAllInlinedUsesAreNotInlined [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg retainMethods: #( interpret ). + ccg prepareMethods. + ccg inlineDispatchesInMethodNamed: #interpret. + ccg pruneUnreachableMethods. + + self assert: (ccg methodNamed: #methodAlsoSharedLocalizedVariableBeforeInlining) notNil. + + "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 - old localization' } +SlangLocalizationTestCase >> testLocalizeSharedVariableShouldNotFailIfAllUsesAreInlined [ + + "Prepare methods will replace the bytecode dispatch instruction into a dispatch switch" + ccg addClass: MockLocalizationInterpreterMock. + ccg retainMethods: #( interpret ). + ccg prepareMethods. + ccg doBasicInlining: true. + ccg inlineDispatchesInMethodNamed: #interpret. + ccg pruneUnreachableMethods. + + "This should not fail" + ccg localizeVariables: #( sharedVariableToLocalizeBeforeInlining ) inMethod: (ccg methodNamed: #interpret) +] + +{ #category : #tests } +SlangLocalizationTestCase >> testNoExternalSendNodeOnSafeExternalCall [ + + | interpretMethod cast printedString linearizedBlock | + interpretMethod := self applyManyLocalizationsToInterpretWith: #initializeWithSafeEscapingCall. + + "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: 'nonInlinedMethodNotUsingAutolocalizedVariables((local_autoLocalizedVariable += 1))' +] diff --git a/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st index fbd3f49d01..bfcd19f3a4 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 [ @@ -35,7 +27,6 @@ SlangMethodPrototypeTranslationTest >> setUp [ generator vmMaker vmmakerConfiguration: VMMakerConfiguration. generator currentMethod: (TMethod new labels: Set new; - resetUsedVariablesCache; yourself). ] @@ -53,19 +44,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 75c2c3a8e2..d06ea2d205 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,35 @@ CCodeGenerator >> asmLabelNodeFor: selector [ arguments: { CIdentifierNode name: label } ] +{ #category : #'automatic-localization' } +CCodeGenerator >> autoLocalizationOfVariablesIn: selector withVariableBindings: replacementList [ + + | m replacementDict | + (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" + self wrapStatements: m withVariableBindings: replacementDict. + + "Localize global values at the beginning of the function + AND externalize local values on each return" + replacementDict associationsDo: [ :asso | + m statements addFirst: (TAssignmentNode + variable: asso value copy + expression: (TVariableNode named: asso key)) ]. +] + { #category : #utilities } CCodeGenerator >> baseTypeForPointerType: aCType [ "Answer the type of the referent of a pointer type." @@ -742,11 +773,6 @@ CCodeGenerator >> checkClassForNameConflicts: aClass [ cr]]] ] -{ #category : #utilities } -CCodeGenerator >> checkDeleteVariable: aName [ - "Hook for debugging variable deletion." -] - { #category : #utilities } CCodeGenerator >> checkForGlobalUsage: vars in: aTMethod [ vars do: @@ -755,7 +781,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. @@ -835,22 +861,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 } @@ -888,13 +906,39 @@ 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 : #accessing } +CCodeGenerator >> currentScope [ + + ^ scopeStack last +] + +{ #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 } @@ -958,7 +1002,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]]]]. @@ -978,7 +1022,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. @@ -988,8 +1032,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,6 +1315,14 @@ CCodeGenerator >> exportedPrimitiveNames [ ] +{ #category : #'automatic-localization' } +CCodeGenerator >> externalizationOf: aVariableName [ + + ^ (TAssignmentNode + variableNamed: aVariableName + expression: (TVariableNode named: #local_, aVariableName)) +] + { #category : #utilities } CCodeGenerator >> extractTypeFor: aVariable fromDeclaration: aVariableDeclaration [ "Eliminate inessentials from aVariableDeclaration to answer a C type without the variable, @@ -1386,7 +1439,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') @@ -1699,8 +1752,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: [ @@ -1731,13 +1784,19 @@ CCodeGenerator >> generateCASTDivide: tast [ { #category : #'CAST translation' } CCodeGenerator >> generateCASTDoWhile: boolean loop: tast [ - | block cond| - block := (TStmtListNode new setStatements: + | block cond parent | + parent := (TStatementListNode + declarations: tast receiver declarations + locals: tast receiver locals + 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' } @@ -2107,34 +2166,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. + ^ CRawCodeNode code: aTSendNode arguments first value ]. + + ^ aTSendNode arguments 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 ]. + ^ CRawCodeNode code: aTSendNode arguments first value ]. - ^ aTSendNode args first asCASTExpressionIn: self + ^ aTSendNode arguments first asCASTExpressionIn: self ] { #category : #'CAST translation' } @@ -2179,11 +2234,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/ @@ -2191,24 +2246,26 @@ 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) < (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' } @@ -2221,26 +2278,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' } @@ -2292,15 +2352,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: #- ] @@ -2369,17 +2429,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: #+ ] @@ -2484,7 +2544,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 | @@ -2507,7 +2567,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) ]. @@ -2529,9 +2589,9 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ type: (CTypeNameNode symbol: unsigned) expression: receiverNode ]. finalNode := CBinaryOperatorNode - operator: #<< - left: leftNode - right: (arg asCASTIn: self). + operator: #<< + left: leftNode + right: (arg asCASTExpressionIn: self). mustCastBackToSign := typeIsUnsigned not. mustCastBackToSign ifTrue: [ | promotedType | @@ -2543,8 +2603,8 @@ CCodeGenerator >> generateCASTShiftLeft: tast [ ifTrue: [ #sqInt ] ifFalse: [ type ] ]. finalNode := CCastExpressionNode - type: (CTypeNameNode symbol: promotedType) - expression: finalNode ]. + type: (CTypeNameNode symbol: promotedType) + expression: finalNode ]. ^ finalNode ] @@ -2570,7 +2630,7 @@ CCodeGenerator >> generateCASTShiftRight: tast [ ^ CBinaryOperatorNode operator: #>> left: rcvr - right: (tast arguments first asCASTIn: self) + right: (tast arguments first asCASTExpressionIn: self) ] { #category : #'CAST translation' } @@ -2685,19 +2745,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: #* ] @@ -2721,18 +2780,18 @@ 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. - limitExpr := tast args first. + iterationVar := blockExpr arguments 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)). @@ -2746,11 +2805,14 @@ CCodeGenerator >> generateCASTToByDo: tast [ lvalue: (CIdentifierNode name: iterationVar) operator: '+=' rvalue: (tast arguments second asCASTExpressionIn: self). - ^ CForStatementNode - init: inits - until: until - step: { step } - statement: (blockExpr asCASTIn: self) + ^ CCompoundStatementNode + declarations: + { (CRawCodeNode code: self defaultType , ' ' , iterationVar) } + statements: { (CForStatementNode + init: inits + until: until + step: { step } + statement: (blockExpr asCASTIn: self)) } ] { #category : #'CAST translation' } @@ -2784,21 +2846,26 @@ 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'. - ]. - iterationVar := tast arguments last args first. + tast arguments last arguments size = 1 ifFalse: [ + self error: 'wrong number of block arguments' ]. + iterationVar := tast arguments last arguments 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 } - until: until - step: { step } - statement: (tast arguments last asCASTIn: self) + ^ CCompoundStatementNode + declarations: + { (CRawCodeNode code: self defaultType , ' ' , iterationVar) } + statements: { (CForStatementNode + init: { init } + until: until + step: { step } + statement: (tast arguments last asCASTIn: self)) } ] { #category : #'CAST translation' } @@ -2811,8 +2878,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 @@ -2840,31 +2908,33 @@ CCodeGenerator >> generateCASTValue: tast [ to body with formals substituted for by actuals." | substitution substitutionDict newLabels castStatements | - self assert: tast receiver isStmtList. - self assert: tast receiver args size = tast args size. + self assert: tast receiver isStatementList. + 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 args size * 2. - tast receiver args with: tast args 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 renameLabelsForInliningInto: self currentMethod. + substitutionDict := Dictionary new: tast arguments size * 2. + 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. + 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 ] @@ -2873,23 +2943,24 @@ 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 isStatementList. + self assert: tast receiver arguments size = tast arguments size. substitution := tast receiver copy. - substitution renameLabelsForInliningInto: currentMethod. - substitutionDict := Dictionary new: tast args size * 2. - tast receiver args - with: tast args + 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 @@ -2911,11 +2982,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' } @@ -2924,7 +2995,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 statements: tast receiver statements allButLast) asCASTIn: self. block add: if. block addAll: (tast arguments first asCASTIn: self). @@ -2936,11 +3007,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 } @@ -3116,6 +3187,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. @@ -3363,28 +3455,22 @@ CCodeGenerator >> initializerForInstVar: varName inStartClass: aClass [ ] { #category : #inlining } -CCodeGenerator >> inlineDispatchesInMethodNamed: selector localizingVars: varsList [ - "Inline dispatches (case statements) in the method with the given name." +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 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. - ]. - ] + (m := self methodNamed: selector) ifNil: [ ^ self ]. + + m inlineCaseStatementBranchesIn: self. + + m parseTree nodesDo: [ :n | + n isCaseStmt ifTrue: [ + n + customizeShortCasesForDispatchVar: 'currentBytecode' + in: self + method: m ] ] ] { #category : #utilities } @@ -3393,6 +3479,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 @@ -3488,11 +3582,27 @@ 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 ] +{ #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." @@ -3622,6 +3732,29 @@ CCodeGenerator >> isVoidPointer: aCType [ "" ^#('void *' 'void*') includes: aCType asString ] +{ #category : #'automatic-localization' } +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 | + (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 ] ] ] +] + { #category : #utilities } CCodeGenerator >> localizeGlobalVariables [ | candidates elected localized | @@ -3647,7 +3780,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| @@ -3663,10 +3796,26 @@ 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 @@ -3855,6 +4004,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, @@ -3868,90 +4018,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 isStatementList 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' } @@ -3991,25 +4145,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 } @@ -4040,18 +4198,8 @@ CCodeGenerator >> nonStructClassesForTranslationClasses: classes [ { #category : #utilities } CCodeGenerator >> noteUsedVariableName: variableName [ - currentMethod ifNotNil: - [:m| m 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]]] + self currentScope noteUsedVariableName: variableName ] { #category : #utilities } @@ -4121,7 +4269,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]. @@ -4201,7 +4349,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) @@ -4286,12 +4434,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" @@ -4321,7 +4463,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]. @@ -4335,8 +4479,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] ] @@ -4370,15 +4521,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. ] @@ -4398,25 +4544,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." @@ -4429,16 +4556,10 @@ 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 ] -{ #category : #inlining } -CCodeGenerator >> reportShouldNotBeRemoved: removed varList: varList [ - "Report whether any of the removed methods are still used." -] - { #category : #'C translation support' } CCodeGenerator >> reservedWords [ ^#( 'auto' @@ -4473,6 +4594,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. @@ -4481,83 +4603,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' } @@ -4672,6 +4819,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: @@ -4938,44 +5096,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' } @@ -4997,11 +5172,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: @@ -5094,6 +5269,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 @@ -5241,3 +5441,47 @@ CCodeGenerator >> wordSize: aValue [ wordSize := aValue ] + +{ #category : #'automatic-localization' } +CCodeGenerator >> wrapStatementWithExternalizationAndLocalizations: statement ofLocalizedVariables: localizedVariables [ + + | 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 + 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 statements with external calls with TExternalSendNode" + "Apply externalization/localization of variables around + - static function calls + - dynamic function calls (perform & co)" + + tMethod allStatements withIndexDo: [ :statement :i | | replacement oldParent | + oldParent := statement parent. + replacement := self + wrapStatementWithExternalizationAndLocalizations: statement + ofLocalizedVariables: replacementDict keys. + oldParent replaceChild: statement with: replacement. + ]. +] diff --git a/smalltalksrc/Slang/Gnuifier.class.st b/smalltalksrc/Slang/Gnuifier.class.st index a2444c0ecd..b7fdc27cef 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,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 ] diff --git a/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st new file mode 100644 index 0000000000..3c084732f6 --- /dev/null +++ b/smalltalksrc/Slang/MLVMVariableAccessCollector.class.st @@ -0,0 +1,167 @@ +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 >> visitGoToNode: aTGoToNode [ + + "Nothing" +] + +{ #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 [ + + (codeGenerator isDynamicCall: aTSendNode) + ifTrue: [ + accessedVariables addAll: variableSubset. + ^ self ]. + + 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 >> 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 [ + + (variableSubset includes: aTVariableNode name) + ifTrue: [ accessedVariables add: aTVariableNode name ] +] 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/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/Slang/SlangTyper.class.st b/smalltalksrc/Slang/SlangTyper.class.st index fe58ce820f..4d45bcf249 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 isStatementList ] ] whileTrue: [ + expr isAssignment ifTrue: [ expr := expr variable ]. + expr isStatementList 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 } @@ -83,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. @@ -207,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. @@ -216,26 +218,29 @@ 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 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." (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 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 33995a6be6..f4745ad260 100644 --- a/smalltalksrc/Slang/TAssignmentNode.class.st +++ b/smalltalksrc/Slang/TAssignmentNode.class.st @@ -17,10 +17,24 @@ TAssignmentNode class >> variable: aVariable expression: anExpression [ yourself ] +{ #category : #'instance creation' } +TAssignmentNode class >> variableNamed: aVariableName expression: anExpression [ + + ^ self new + setVariable: (TVariableNode named: aVariableName) expression: anExpression; + yourself +] + +{ #category : #visiting } +TAssignmentNode >> accept: aVisitor [ + + ^ aVisitor visitAssignmentNode: self +] + { #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; @@ -31,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 @@ -57,7 +71,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; @@ -119,14 +133,14 @@ TAssignmentNode >> asCASTValueExpansionIn: aCodeGen [ ^ (TSendNode new setSelector: expression selector receiver: copy - arguments: expression args) asCASTIn: aCodeGen + arguments: expression arguments) asCASTIn: aCodeGen ] { #category : #transformations } 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). ] @@ -146,8 +160,22 @@ 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]. + self variable: (variable bindVariablesIn: aDictionary unless: cautionaryBlock). + self expression: (expression bindVariablesIn: aDictionary unless: cautionaryBlock). +] + +{ #category : #accessing } +TAssignmentNode >> children [ + + ^ { variable . expression } ] { #category : #accessing } @@ -156,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 [ @@ -221,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' } @@ -251,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 } @@ -293,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 36d4dd8db2..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,8 +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]. + self caseLabels: (caseLabels collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock]). + self cases: (cases collect: [:node| node bindVariablesIn: aDictionary unless: cautionaryBlock]) ] { #category : #accessing } @@ -48,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 } @@ -62,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 } @@ -113,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 36aed0e74a..148cbb7fbe 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 [ @@ -133,12 +139,26 @@ 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 [ ^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." @@ -212,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. @@ -278,67 +314,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 } @@ -381,7 +417,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. ]. @@ -389,5 +425,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/TConstantNode.class.st b/smalltalksrc/Slang/TConstantNode.class.st index 7228630d64..43d79f69d4 100644 --- a/smalltalksrc/Slang/TConstantNode.class.st +++ b/smalltalksrc/Slang/TConstantNode.class.st @@ -15,6 +15,18 @@ TConstantNode class >> value: aValue [ yourself ] +{ #category : #comparing } +TConstantNode >> = aNode [ + + ^ aNode isConstant and: [ value = aNode value ] +] + +{ #category : #visiting } +TConstantNode >> accept: aVisitor [ + + ^ aVisitor visitConstantNode: self +] + { #category : #tranforming } TConstantNode >> asCASTIn: aBuilder [ @@ -29,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/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/TExternalSendNode.class.st b/smalltalksrc/Slang/TExternalSendNode.class.st new file mode 100644 index 0000000000..e4b0998648 --- /dev/null +++ b/smalltalksrc/Slang/TExternalSendNode.class.st @@ -0,0 +1,172 @@ +Class { + #name : #TExternalSendNode, + #superclass : #TParseNode, + #instVars : [ + 'variableBindings', + 'wrappedSendNode' + ], + #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 [ + + ^ self new + wrappedSendNode: aWrappedSendNode; + variableBindings: bindings; + yourself +] + +{ #category : #tranforming } +TExternalSendNode >> asCASTExpressionIn: aCodeGenerator [ + + self notYetImplemented +] + +{ #category : #tranforming } +TExternalSendNode >> asCASTIn: aCodeGenerator [ + + ^ CCompoundStatementNode statements: (self cExternalizationsIn: aCodeGenerator) + , { (wrappedSendNode 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 : #transformations } +TExternalSendNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + wrappedSendNode := wrappedSendNode bindVariablesIn: aDictionary unless: cautionaryBlock +] + +{ #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 : #testing } +TExternalSendNode >> isSend [ + + ^ true +] + +{ #category : #testing } +TExternalSendNode >> isValueExpansion [ + + ^ wrappedSendNode isValueExpansion +] + +{ #category : #accessing } +TExternalSendNode >> localizedVariables [ + + ^ variableBindings keys +] + +{ #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 : #accessing } +TExternalSendNode >> nodesDo: aBlock parent: parent [ + + wrappedSendNode nodesDo: aBlock parent: self. + aBlock value: self value: parent +] + +{ #category : #transformations } +TExternalSendNode >> printOn: aStream level: level [ + + wrappedSendNode printOn: aStream level: level +] + +{ #category : #asd } +TExternalSendNode >> replaceNodesIn: aDictionary [ + + ^aDictionary at: self ifAbsent: [ | newNode | + newNode := wrappedSendNode replaceNodesIn: aDictionary. + wrappedSendNode := newNode. + self] +] + +{ #category : #accessing } +TExternalSendNode >> selector [ + + ^ wrappedSendNode selector +] + +{ #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/TGoToNode.class.st b/smalltalksrc/Slang/TGoToNode.class.st index 510f324262..ea3f678354 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,12 +31,25 @@ TGoToNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ ^ self asCASTExpressionIn: aBuilder ] +{ #category : #accessing } +TGoToNode >> children [ + + ^ #() +] + { #category : #testing } 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 9a9ac0a365..58bc686c97 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 [ @@ -31,11 +37,40 @@ TInlineNode >> bindVariableUsesIn: aDictionary andConstantFoldIf: constantFold i yourself] ] +{ #category : #transformations } +TInlineNode >> bindVariablesIn: aDictionary [ + + method := method bindVariablesIn: aDictionary. + +] + +{ #category : #transformations } +TInlineNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + method := method bindVariablesIn: aDictionary unless: cautionaryBlock. + +] + +{ #category : #accessing } +TInlineNode >> children [ + + ^ { method } +] + { #category : #testing } 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 @@ -105,3 +140,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/TLabeledCommentNode.class.st b/smalltalksrc/Slang/TLabeledCommentNode.class.st index f532b9bb7d..e04e8c66da 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)." @@ -90,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/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 9ed1c49155..5ac3df4207 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,7 @@ Class { 'static', 'writtenToGlobalVarsCache', 'functionAttributes', - 'usedVariablesCache' + 'cachedLocals' ], #classVars : [ 'CaseStatements' @@ -81,19 +80,21 @@ TMethod >> addCASTLocalsIn: aCASTBlock generator: aCodeGen [ ifFalse: [ 'DECL_MAYBE_SQ_GLOBAL_STRUCT' ])) ]. maybeExternFunctions := (declarations select: [ :decl | decl beginsWith: 'extern' ]) keys. - - (locals isEmpty and: [ maybeExternFunctions isEmpty ]) ifFalse: [ - (aCodeGen sortStrings: locals , 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 } @@ -108,6 +109,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. @@ -124,9 +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." - 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: @@ -142,74 +151,114 @@ 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)" - ^(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 } 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 isStmtList ifTrue: [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 } +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 [ + "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 arguments ]. + 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). + + 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: [ + 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' } @@ -339,7 +388,6 @@ TMethod >> asCASTIn: aCodeGen [ | compoundStatement functionDefinition body| aCodeGen currentMethod: self. - self resetUsedVariablesCache. compoundStatement := CCompoundStatementNode new needsBrackets: false; yourself. @@ -356,18 +404,21 @@ TMethod >> asCASTIn: aCodeGen [ space ])). functionDefinition := self asCASTFunctionPrototypeIn: aCodeGen - isPrototype: false. - functionDefinition body: CCompoundStatementNode new. + isPrototype: false. + aCodeGen - pushScope: declarations - while: [ body := (parseTree asCASTIn: aCodeGen) ]. "Generation will note used variables in usedVariablesCache" - self addCASTLocalsIn: functionDefinition body generator: aCodeGen. - functionDefinition body add: body. - usedVariablesCache := nil. + pushScope: self + while: [ body := (parseTree asCASTIn: aCodeGen) ]. + functionDefinition body: body. + ((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 ] @@ -378,14 +429,9 @@ TMethod >> asCASTInlinedIn: aBuilder [ self removeUnusedTempsAndNilIfRequiredIn: aBuilder. compoundStatement := CCompoundStatementNode new. - locals isEmpty ifFalse: [ - (aBuilder sortStrings: 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. @@ -428,43 +474,76 @@ 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 >> 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 [ + "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 } 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 isStatementList ]) + ifFalse: [ + cachedLocals := nil. + switch switchVariable: + (self locals add: (self extraVariableName: 'switch')) ]. + ^ switch ] { #category : #'inlining support' } @@ -516,17 +595,9 @@ TMethod >> checkSuccessExpr [ ] { #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 +TMethod >> children [ + + ^ { parseTree } ] { #category : #accessing } @@ -577,7 +648,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 @@ -603,8 +674,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 ] @@ -615,11 +692,36 @@ TMethod >> declarations [ ^declarations ] +{ #category : #'automatic-localization' } +TMethod >> declareNonConflictingLocalNamedLike: aString [ + + | definedVariables n newVarName | + definedVariables := (self allLocals, args) asSet. + n := 1. + newVarName := aString. + [ definedVariables includes: newVarName ] whileTrue: [ + newVarName := aString , n printString. + n := n + 1 ]. + + cachedLocals := nil. + self locals add: newVarName. + ^ 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 } @@ -638,6 +740,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: @@ -649,17 +757,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' } @@ -759,31 +868,44 @@ 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: [ + cachedLocals := nil. + 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: [ + | var | + 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 arguments first + ifPresent: [ :decl | + self + declarationAt: var + put: + (self + typeFor: node arguments third arguments first + in: aCodeGen) , ' ' , var ] ] ] ] { #category : #inlining } @@ -850,14 +972,24 @@ 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 ] +{ #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 [ @@ -870,6 +1002,17 @@ TMethod >> export: aBoolean [ export := aBoolean ] +{ #category : #'automatic-localization' } +TMethod >> externalCallsIn: codeGenerator [ + + | calls | + calls := Set new. + parseTree nodesDo: [ :node | + ((codeGenerator isFunctionCall: node) or: [ codeGenerator isDynamicCall: node ]) + ifTrue: [ calls add: node ] ]. + ^ calls +] + { #category : #initialization } TMethod >> extraVariableName: root [ extraVariableNumber := extraVariableNumber @@ -938,6 +1081,7 @@ TMethod >> extractExpandCaseDirective [ { #category : #transformations } TMethod >> extractExportDirective [ + "Scan the top-level statements for an inlining directive of the form: self export: @@ -945,30 +1089,33 @@ 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' } 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 } TMethod >> extractSharedCase [ + "Scan the pragmas for an shared case directive of the form: @@ -977,24 +1124,27 @@ 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 ] { #category : #transformations } TMethod >> extractStaticDirective [ + "Scan the top-level statements for an inlining directive of the form: self static: @@ -1002,10 +1152,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' } @@ -1030,13 +1180,19 @@ 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." | newStmts | parseTree nodesDo: [:node | - node isStmtList ifTrue: [ + node isStatementList ifTrue: [ newStmts := OrderedCollection new: 100. node statements do: [:stmt | stmt isReturn @@ -1062,6 +1218,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." @@ -1072,7 +1234,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 ] @@ -1173,7 +1335,11 @@ TMethod >> incompleteSendsIn: aCodeGen [ TMethod >> initialize [ super initialize. - declarations := Dictionary new + labels := args := #(). + properties := Dictionary new. + export := false. + declarations := Dictionary new. + self clearReferencesToGlobalStruct ] { #category : #accessing } @@ -1188,65 +1354,41 @@ 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 localizingVars: varsList [ - | maxTemp usedVars v exitLabel | - maxTemp := 0. - 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]]]]]]. - 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]) +TMethod >> inlineCaseStatementBranchesIn: aCodeGen [ + + parseTree nodesDo: [ :n | + n isCaseStmt ifTrue: [ + n cases do: [ :stmtNode | + | stmt meth | + (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 ] ] ] ] ] ] ] { #category : #inlining } @@ -1274,20 +1416,23 @@ 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 isStatementList. + ^ (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 } 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: @@ -1297,136 +1442,172 @@ 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: - [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 } 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}]) + ^ TStatementListNode 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 [ + + | exitLabel newStatements | + "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 statements: newStatements ] { #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: [ + TStatementListNode new setArguments: #( ) statements: { + replacementTree. + label } ] ] { #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 @@ -1442,92 +1623,101 @@ 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: [ | 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 ] + 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 } 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 } @@ -1545,6 +1735,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." @@ -1607,21 +1804,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 isStatementList. + 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 } @@ -1683,7 +1884,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, @@ -1711,7 +1912,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: @@ -1735,7 +1936,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: @@ -1791,14 +1992,14 @@ 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 ]. ]. "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 @@ -1814,7 +2015,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 ]. @@ -1830,6 +2031,12 @@ TMethod >> isTMethod [ ^true ] +{ #category : #testing } +TMethod >> isVolatile [ + + ^ self hasProperties and: [properties includesKey: #volatile] +] + { #category : #accessing } TMethod >> labels [ @@ -1842,11 +2049,35 @@ TMethod >> labels: aCollection [ labels := aCollection asSet ] +{ #category : #accessing } +TMethod >> last [ + + ^ parseTree last +] + +{ #category : #inlining } +TMethod >> localizeVariables: localizationCandidates [ + + | definedVariables | + definedVariables := (self allLocals , args) asSet. + "make local versions of the given globals" + 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 } @@ -1931,7 +2162,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})]]]. @@ -1954,19 +2185,10 @@ TMethod >> nodeCount [ ^cnt ] -{ #category : #utilities } -TMethod >> noteUsedVariableName: token [ - usedVariablesCache ifNotNil: - [usedVariablesCache add: token] -] - -{ #category : #private } -TMethod >> oopVariable: aString [ +{ #category : #iterating } +TMethod >> nodesDo: aBlock [ - (locals includes: aString) ifFalse: - [locals add: aString. - self declarationAt: aString put: 'sqInt ', aString]. - ^TVariableNode new setName: aString + parseTree nodesDo: aBlock ] { #category : #'C code generation' } @@ -2008,7 +2230,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 @@ -2026,11 +2248,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| @@ -2119,15 +2342,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. @@ -2245,6 +2471,7 @@ TMethod >> readsVariable: variableName [ { #category : #transformations } TMethod >> recordDeclarationsIn: aCCodeGen [ + "Record C type declarations of the forms @@ -2254,58 +2481,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 setStatements: 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 } @@ -2325,6 +2516,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. @@ -2333,19 +2525,30 @@ 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 } +TMethod >> removeLocal: local [ + + cachedLocals := nil. + self locals remove: local ] { #category : #utilities } @@ -2356,11 +2559,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 @@ -2388,24 +2592,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" - locals do: - [:local| - (usedVariables includes: local) ifFalse: - [(((declarations at: local ifAbsent: ['']) includesSubstring: 'static') - or: [(declarations at: local ifAbsent: ['']) includesSubstring: 'extern']) - ifFalse: - [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' } @@ -2444,57 +2652,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 ] ]. - locals := locals collect: [ :v | aDictionary at: v ifAbsent: [ v ] ]. + args := args collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]. + + cachedLocals := nil. + 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 isStmtList 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' } @@ -2506,9 +2710,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: @@ -2540,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." @@ -2589,16 +2787,19 @@ 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]. + declarations := Dictionary new. + + 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. 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. @@ -2638,12 +2839,12 @@ TMethod >> smalltalkSelector [ { #category : #accessing } TMethod >> statements [ - parseTree isStmtList - 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' } @@ -2670,6 +2871,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 @@ -2679,46 +2881,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 isStatementList 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 } @@ -2740,8 +2939,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), @@ -2753,7 +2952,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]. @@ -2786,6 +2986,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]] @@ -2797,15 +2998,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 } @@ -2829,7 +3032,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}; @@ -2855,7 +3058,7 @@ TMethod >> transformReturns [ [returnType = #void ifTrue: [parent replaceChild: node - with: (TStmtListNode new + with: (TStatementListNode new setArguments: #() statements: {node expression. TReturnNode new @@ -2906,7 +3109,7 @@ TMethod >> tryToInlineMethodExpressionsIn: aCodeGen [ | sendsToInline | sendsToInline := Dictionary new: 100. aCodeGen - pushScope: declarations + pushScope: self while: [parseTree nodesDo: [:node| @@ -2933,45 +3136,51 @@ 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 | + 1 haltIf: [ + stmt isSend and: [ stmt selector = #initStackPagesAndInterpret ] ]. + (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 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." - 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 } @@ -3003,23 +3212,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 } @@ -3055,23 +3262,15 @@ TMethod >> unusedNamePrefixedBy: aString avoiding: usedNames [ ^usedNames add: newVarName ] -{ #category : #utilities } -TMethod >> usedVariablesCache [ - - ^ 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 e5adbe592b..3167856b33 100644 --- a/smalltalksrc/Slang/TParseNode.class.st +++ b/smalltalksrc/Slang/TParseNode.class.st @@ -5,11 +5,18 @@ Class { #name : #TParseNode, #superclass : #Object, #instVars : [ + 'parent', 'comment' ], #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 +46,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]]. @@ -103,12 +116,17 @@ TParseNode >> bindVariablesIn: aDictionary [ ^self ] +{ #category : #transformations } +TParseNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + ^self +] + { #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 ] @@ -153,6 +171,12 @@ TParseNode >> endsWithReturn [ ^false ] +{ #category : #flattenin } +TParseNode >> flattened [ + + ^ { self } +] + { #category : #testing } TParseNode >> hasExplicitReturn [ @@ -209,6 +233,12 @@ TParseNode >> isDefine [ ^false ] +{ #category : #testing } +TParseNode >> isExternalSend [ + + ^ false +] + { #category : #testing } TParseNode >> isGoTo [ @@ -259,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 } @@ -269,7 +299,7 @@ TParseNode >> isSend [ ] { #category : #testing } -TParseNode >> isStmtList [ +TParseNode >> isStatementList [ ^false ] @@ -295,6 +325,73 @@ TParseNode >> isVariable [ ^false ] +{ #category : #linearization } +TParseNode >> linearizeIn: aCodeGenerator [ + + "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 + + 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 declarations | + replacementDictionary := Dictionary new. + + callsInStatement := OrderedCollection new. + self + nodesDo: [ :node | + (node isAssignment or: [ + (aCodeGenerator isFunctionCall: node) or: [ + aCodeGenerator isDynamicCall: node ]]) + ifTrue: [ callsInStatement add: node ] ] + unless: [ :unlessNode | unlessNode isStatementList ]. + + replacementBlock := OrderedCollection new. + declarations := Dictionary new. + replacementsSoFar := Dictionary new. + + "Apply linearization to all nodes except itself" + callsInStatement + select: [ :e | e ~= self ] + thenDo: [ :e | + | variableNode valueNode | + variableNode := TVariableNode named: 't' , replacementBlock size asString. + valueNode := TAssignmentNode + variable: variableNode + expression: (e replaceNodesIn: replacementsSoFar). + 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. + replacementBlock add: rewrittenStatement. + + ^ TStatementListNode declarations: declarations statements: replacementBlock +] + { #category : #accessing } TParseNode >> nameOrValue [ @@ -398,6 +495,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." @@ -417,6 +526,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/TReturnNode.class.st b/smalltalksrc/Slang/TReturnNode.class.st index 2da953906f..c7219bb0e3 100644 --- a/smalltalksrc/Slang/TReturnNode.class.st +++ b/smalltalksrc/Slang/TReturnNode.class.st @@ -11,10 +11,25 @@ Class { TReturnNode class >> expression: anExpression [ ^ self new - setExpression: anExpression; + expression: anExpression; yourself ] +{ #category : #comparing } +TReturnNode >> = aNode [ + + super = aNode ifFalse: [ ^false ]. + aNode isReturn ifFalse: [ ^false ]. + expression = aNode expression ifFalse: [ ^ false ]. + ^ true +] + +{ #category : #visiting } +TReturnNode >> accept: aVisitor [ + + ^ aVisitor visitReturnNode: self +] + { #category : #tranforming } TReturnNode >> asCASTIn: aBuilder [ @@ -77,6 +92,19 @@ 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 : #accessing } +TReturnNode >> children [ + + ^ { expression } +] + { #category : #transformations } TReturnNode >> copyWithoutReturn [ ^expression @@ -94,12 +122,25 @@ TReturnNode >> expression [ ^expression ] +{ #category : #accessing } +TReturnNode >> expression: anExpression [ + + expression := anExpression +] + { #category : #testing } 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 be46a95645..7261e1d6de 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 [ @@ -20,15 +26,39 @@ 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 : #visiting } +TSendNode >> accept: aVisitor [ + + ^ aVisitor visitSendNode: self +] + { #category : #accessing } TSendNode >> args [ - ^arguments + self + deprecated: 'use #arguments instead' + transformWith: '`@rec args' -> '`@rec arguments'. + + ^ self arguments ] { #category : #accessing } TSendNode >> arguments [ - ^ arguments + + ^arguments ] { #category : #private } @@ -154,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 } @@ -221,8 +251,22 @@ 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]. + self receiver: (receiver bindVariablesIn: aDictionary unless: cautionaryBlock). + self arguments: (arguments collect: [ :a | a bindVariablesIn: aDictionary unless: cautionaryBlock]). +] + +{ #category : #accessing } +TSendNode >> children [ + + ^ { receiver }, arguments ] { #category : #accessing } @@ -330,15 +374,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' } @@ -361,10 +404,20 @@ 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]] ] +{ #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 [ @@ -424,8 +477,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 } @@ -476,8 +529,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] ] @@ -495,18 +548,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 new file mode 100644 index 0000000000..19ed1559aa --- /dev/null +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -0,0 +1,600 @@ +Class { + #name : #TStatementListNode, + #superclass : #TParseNode, + #instVars : [ + 'locals', + 'declarations', + 'arguments', + 'statements', + 'usedVariables' + ], + #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 [ + + ^ self new + declarations: declarations; + locals: declarations keys; + statements: aCollection; + yourself +] + +{ #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 + statements: aCollection; + yourself +] + +{ #category : #comparing } +TStatementListNode >> = aNode [ + + super = aNode ifFalse: [ ^ false ]. + aNode isStatementList ifFalse: [ ^ false ]. + statements size = aNode statements size ifFalse: [ ^ false ]. + statements doWithIndex: [ :stmt :i | + stmt = (aNode statements at: i) ifFalse: [ ^ false ] ]. + ^ true +] + +{ #category : #visiting } +TStatementListNode >> accept: aVisitor [ + + ^ aVisitor visitStatementListNode: self +] + +{ #category : #utilities } +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." + + 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 | + node isSend + ifTrue: [ "First deal with implicit assignments..." + node isValueExpansion ifTrue: [ + 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) arguments. + 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..." + (TStatementListNode new + statements: { 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 arguments + collect: [ :block | + block isStatementList 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 : #enumerating } +TStatementListNode >> allStatementsDo: aFullBlockClosure [ + + statements do: [ :statement | + aFullBlockClosure value: statement. + statement allStatementsDo: aFullBlockClosure ]. +] + +{ #category : #accessing } +TStatementListNode >> args [ + self + deprecated: 'use #arguments instead' + transformWith: '`@rec args' -> '`@rec arguments'. + ^arguments +] + +{ #category : #accessing } +TStatementListNode >> arguments [ + + ^arguments +] + +{ #category : #tranforming } +TStatementListNode >> asCASTExpressionIn: aBuilder [ + + | expressionList | + expressionList := CExpressionListNode new. + statements size == 1 ifTrue: [ + ^ statements first asCASTExpressionIn: aBuilder ]. + statements withIndexDo: [ :node :idx | + (node isLeaf and: [ node isLabel not and: [ idx < statements size ] ]) + ifFalse: [ expressionList , (node asCASTExpressionIn: aBuilder) ] ]. + ^ expressionList +] + +{ #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 ] +] + +{ #category : #tranforming } +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. + (self parent isTMethod and: [ self parent 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, self usedVariables) asSet) do: [ :var | | declaration | + declaration := aBuilder + declarationAt: var + ifAbsent: [ aBuilder defaultType, ' ' , var ]. + + methodIsVolatile ifTrue: [ declaration := 'volatile ' , declaration ]. + cDeclarations add: (CRawCodeNode code: declaration) + ]. + + ^ CCompoundStatementNode declarations: cDeclarations statements: collect +] + +{ #category : #transformations } +TStatementListNode >> asReturnNode [ + self endsWithReturn ifTrue: + [^self]. + ^self class new + setArguments: arguments + statements: statements allButLast, {statements last asReturnNode}; + yourself +] + +{ #category : #transformations } +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]. + statements + at: index + put: (TAssignmentNode new + setVariable: variableNode + expression: (statements at: index)) +] + +{ #category : #transformations } +TStatementListNode >> 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 + statements: newStatements; + yourself ] +] + +{ #category : #transformations } +TStatementListNode >> bindVariablesIn: aDictionary [ + + self statements: (statements collect: [ :s | s bindVariablesIn: aDictionary ]). +] + +{ #category : #transformations } +TStatementListNode >> bindVariablesIn: aDictionary unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + self statements: (statements collect: [ :s | s bindVariablesIn: aDictionary unless: cautionaryBlock]). +] + +{ #category : #enumerating } +TStatementListNode >> children [ + + ^ statements +] + +{ #category : #transformations } +TStatementListNode >> copyWithoutReturn [ + self assert: self endsWithReturn. + statements size = 1 ifTrue: + [^statements last expression]. + ^self class new + setArguments: arguments + statements: statements allButLast, {statements last copyWithoutReturn}; + yourself +] + +{ #category : #declarations } +TStatementListNode >> declarationAt: aString ifPresent: aFullBlockClosure [ + + ^ declarations at: aString ifPresent: aFullBlockClosure +] + +{ #category : #accessing } +TStatementListNode >> declarations [ + + ^ declarations ifNil: [ declarations := Dictionary new ] +] + +{ #category : #accessing } +TStatementListNode >> declarations: anObject [ + + declarations := anObject +] + +{ #category : #testing } +TStatementListNode >> endsWithCloseBracket: aStream [ + "Answer true if the given stream ends in a $} character." + + | ch pos | + ch := (pos := aStream position) > 0 ifTrue: + [aStream class = WriteStream "i.e. nested in StreamContents" + ifTrue: [aStream originalContents at: pos] + ifFalse: [aStream position: pos - 1; next]]. + ^ ch = $} + +] + +{ #category : #testing } +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 : #accessing } +TStatementListNode >> first [ + + ^ self statements first +] + +{ #category : #flattening } +TStatementListNode >> flattened [ + + ^ statements flatCollect: [ :each | + each flattened ] +] + +{ #category : #accessing } +TStatementListNode >> initialize [ + + super initialize. + declarations := Dictionary new. + usedVariables := Set new. + locals := #(). + arguments := #() +] + +{ #category : #testing } +TStatementListNode >> isNilStmtListNode [ + + |stmt| + statements size = 1 ifFalse: [^false]. + stmt := statements at: 1. + ^ stmt isVariable and: [stmt name = 'nil'] +] + +{ #category : #testing } +TStatementListNode >> isSameAs: aTParseNode [ + (aTParseNode isStatementList + and: [statements size = aTParseNode statements size]) ifFalse: + [^false]. + statements with: aTParseNode statements do: + [:mine :theirs| + (mine isSameAs: theirs) ifFalse: + [^false]]. + ^true +] + +{ #category : #testing } +TStatementListNode >> isStatementList [ + + ^true +] + +{ #category : #accessing } +TStatementListNode >> last [ + + ^ self statements last +] + +{ #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. + N.B. This is assumed to be bottom-up, leaves first." + statements do: [ :s | s nodesDo: aBlock ]. + aBlock value: self +] + +{ #category : #enumerating } +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]. + aBlock value: self value: parent +] + +{ #category : #enumerating } +TStatementListNode >> nodesDo: aBlock parent: parent unless: cautionaryBlock [ + + (cautionaryBlock value: self value: parent) ifTrue: [^self]. + statements do: [ :s | s nodesDo: aBlock parent: self unless: cautionaryBlock]. + aBlock value: self value: parent +] + +{ #category : #enumerating } +TStatementListNode >> nodesDo: aBlock unless: cautionaryBlock [ + + (cautionaryBlock value: self) ifTrue: [^self]. + statements do: [ :s | s nodesDo: aBlock unless: cautionaryBlock ]. + aBlock value: self +] + +{ #category : #enumerating } +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.]. + aBlock value: self value: parent +] + +{ #category : #accessing } +TStatementListNode >> noteUsedVariableName: aString [ + + usedVariables add: aString +] + +{ #category : #accessing } +TStatementListNode >> parameterNames [ + + ^ arguments +] + +{ #category : #copying } +TStatementListNode >> postCopy [ + + arguments := arguments copy. + self statements: (statements collect: [ :s | s copy ]) +] + +{ #category : #printing } +TStatementListNode >> printOn: aStream level: level [ + + statements size > 1 ifTrue: [ aStream crtab: level + 1 ]. + aStream nextPut: $[. + (arguments notNil and: [arguments notEmpty]) ifTrue: + [arguments do: [ :arg | aStream nextPutAll: ' :'; nextPutAll: arg]. + aStream nextPutAll: ' | ']. + self printStatementsOn: aStream level: level. + aStream nextPut: $] +] + +{ #category : #printing } +TStatementListNode >> printStatementsOn: aStream level: level [ + + statements + do: [:s| s printOn: aStream level: level] + separatedBy: [aStream nextPut: $.; crtab: level + 1] +] + +{ #category : #transformations } +TStatementListNode >> removeAssertions [ + | newStatements | + newStatements := OrderedCollection new: statements size. + statements do: [ :stmt | + stmt isAssertion ifFalse: [ + newStatements add: (stmt removeAssertions; yourself). + ] + ]. + self setStatements: newStatements asArray +] + +{ #category : #'inlining support' } +TStatementListNode >> renameLabelsForInliningInto: aTMethod [ + "TMethod already has a method for this; hijack it..." + | labels | + labels := OrderedCollection new. + self nodesDo: + [:node| node isLabel ifTrue: [labels add: node label]]. + TMethod new + parseTree: self; + labels: labels; + renameLabelsForInliningInto: aTMethod +] + +{ #category : #transformations } +TStatementListNode >> replaceChild: aNode with: bNode [ + + self statements: (statements collect: [ :node | + node == aNode + ifTrue: [ bNode ] + ifFalse: [ node ] ]) +] + +{ #category : #transformations } +TStatementListNode >> replaceNodesIn: aDictionary [ + + ^aDictionary at: self ifAbsent: [ + self statements: (statements collect: [ :s | s replaceNodesIn: aDictionary ]). + self] +] + +{ #category : #testing } +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: + [^false]. + statements last isReturn ifFalse: + [^false]. + statements last isVariable ifFalse: + [^true]. + ^statements last variable ~= 'self' + and: [statements last variable ~= 'nil'] +] + +{ #category : #accessing } +TStatementListNode >> second [ + + ^ self statements second +] + +{ #category : #accessing } +TStatementListNode >> setArguments: argList [ + + arguments := argList. +] + +{ #category : #accessing } +TStatementListNode >> setArguments: argList statements: statementList [ + "Initialize this method using the given information." + arguments := argList. + self statements: statementList. +] + +{ #category : #accessing } +TStatementListNode >> setStatements: stmtList [ + + self + deprecated: 'Call statements: pliz' + transformWith: '`@receiver setStatements: `@arg' -> '`@receiver statements: `@arg'. + self statements: stmtList. +] + +{ #category : #inlining } +TStatementListNode >> shouldExpand [ + ^(statements detect: [:stmt| stmt isInline]) shouldExpand +] + +{ #category : #accessing } +TStatementListNode >> statements [ + + ^statements +] + +{ #category : #accessing } +TStatementListNode >> statements: anObject [ + + | oldStatements | + oldStatements := statements. + statements := anObject asOrderedCollection. + statements do: [ :e | e parent: self ] +] + +{ #category : #'type inference' } +TStatementListNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ + ^statements isEmpty ifFalse: + [statements last typeOrNilFrom: aCodeGenerator in: aTMethod] +] + +{ #category : #accessing } +TStatementListNode >> usedVariables [ + + ^ usedVariables +] diff --git a/smalltalksrc/Slang/TStmtListNode.class.st b/smalltalksrc/Slang/TStmtListNode.class.st deleted file mode 100644 index 6ca22d6dac..0000000000 --- a/smalltalksrc/Slang/TStmtListNode.class.st +++ /dev/null @@ -1,397 +0,0 @@ -Class { - #name : #TStmtListNode, - #superclass : #TParseNode, - #instVars : [ - 'arguments', - 'statements' - ], - #category : #'Slang-AST' -} - -{ #category : #'instance creation' } -TStmtListNode class >> statements: aCollection [ - - ^ self new - setStatements: aCollection; - yourself -] - -{ #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 | - 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]]. - "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) - 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 -] - -{ #category : #accessing } -TStmtListNode >> args [ - - ^arguments -] - -{ #category : #tranforming } -TStmtListNode >> asCASTExpressionIn: aBuilder [ - - | expressionList | - expressionList := CExpressionListNode new. - statements size == 1 ifTrue: [ - ^ statements first asCASTExpressionIn: aBuilder ]. - statements withIndexDo: [ :node :idx | - (node isLeaf and: [ node isLabel not and: [ idx < statements size ] ]) - ifFalse: [ expressionList , (node asCASTExpressionIn: aBuilder) ] ]. - ^ expressionList -] - -{ #category : #tranforming } -TStmtListNode >> asCASTIn: aBuilder [ - - ^ self asCASTIn: aBuilder prependToEnd: nil -] - -{ #category : #tranforming } -TStmtListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ - - | collect | - 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 ] ]. - ^ CCompoundStatementNode statements: collect -] - -{ #category : #transformations } -TStmtListNode >> asReturnNode [ - self endsWithReturn ifTrue: - [^self]. - ^self class new - setArguments: arguments - statements: statements allButLast, {statements last asReturnNode}; - yourself -] - -{ #category : #transformations } -TStmtListNode >> 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]. - statements - at: index - put: (TAssignmentNode new - setVariable: variableNode - expression: (statements at: index)) -] - -{ #category : #transformations } -TStmtListNode >> bindVariableUsesIn: aDictionary [ - - statements := statements collect: [ :s | s bindVariableUsesIn: aDictionary ]. -] - -{ #category : #transformations } -TStmtListNode >> 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] -] - -{ #category : #transformations } -TStmtListNode >> bindVariablesIn: aDictionary [ - - statements := statements collect: [ :s | s bindVariablesIn: aDictionary ]. -] - -{ #category : #transformations } -TStmtListNode >> copyWithoutReturn [ - self assert: self endsWithReturn. - statements size = 1 ifTrue: - [^statements last expression]. - ^self class new - setArguments: arguments - statements: statements allButLast, {statements last copyWithoutReturn}; - yourself -] - -{ #category : #testing } -TStmtListNode >> endsWithCloseBracket: aStream [ - "Answer true if the given stream ends in a $} character." - - | ch pos | - ch := (pos := aStream position) > 0 ifTrue: - [aStream class = WriteStream "i.e. nested in StreamContents" - ifTrue: [aStream originalContents at: pos] - ifFalse: [aStream position: pos - 1; next]]. - ^ ch = $} - -] - -{ #category : #testing } -TStmtListNode >> endsWithReturn [ - "Answer true if the last statement of this lock is a return." - - ^statements notEmpty - and: [statements last isReturn or: [statements last isReturningIf]] -] - -{ #category : #testing } -TStmtListNode >> isNilStmtListNode [ - - |stmt| - statements size = 1 ifFalse: [^false]. - stmt := statements at: 1. - ^ stmt isVariable and: [stmt name = 'nil'] -] - -{ #category : #testing } -TStmtListNode >> isSameAs: aTParseNode [ - (aTParseNode isStmtList - and: [statements size = aTParseNode statements size]) ifFalse: - [^false]. - statements with: aTParseNode statements do: - [:mine :theirs| - (mine isSameAs: theirs) ifFalse: - [^false]]. - ^true -] - -{ #category : #testing } -TStmtListNode >> isStmtList [ - - ^true -] - -{ #category : #enumerating } -TStmtListNode >> 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 ]. - aBlock value: self -] - -{ #category : #enumerating } -TStmtListNode >> 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]. - aBlock value: self value: parent -] - -{ #category : #enumerating } -TStmtListNode >> nodesDo: aBlock parent: parent unless: cautionaryBlock [ - - (cautionaryBlock value: self value: parent) ifTrue: [^self]. - statements do: [ :s | s nodesDo: aBlock parent: self unless: cautionaryBlock]. - aBlock value: self value: parent -] - -{ #category : #enumerating } -TStmtListNode >> nodesDo: aBlock unless: cautionaryBlock [ - - (cautionaryBlock value: self) ifTrue: [^self]. - statements do: [ :s | s nodesDo: aBlock unless: cautionaryBlock ]. - aBlock value: self -] - -{ #category : #enumerating } -TStmtListNode >> 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.]. - aBlock value: self value: parent -] - -{ #category : #copying } -TStmtListNode >> postCopy [ - - arguments := arguments copy. - statements := statements collect: [ :s | s copy ] -] - -{ #category : #printing } -TStmtListNode >> printOn: aStream level: level [ - - statements size > 1 ifTrue: [ aStream crtab: level + 1 ]. - aStream nextPut: $[. - (arguments notNil and: [arguments notEmpty]) ifTrue: - [arguments do: [ :arg | aStream nextPutAll: ' :'; nextPutAll: arg]. - aStream nextPutAll: ' | ']. - self printStatementsOn: aStream level: level. - aStream nextPut: $] -] - -{ #category : #printing } -TStmtListNode >> printStatementsOn: aStream level: level [ - - statements - do: [:s| s printOn: aStream level: level] - separatedBy: [aStream nextPut: $.; crtab: level + 1] -] - -{ #category : #transformations } -TStmtListNode >> removeAssertions [ - | newStatements | - newStatements := OrderedCollection new: statements size. - statements do: [ :stmt | - stmt isAssertion ifFalse: [ - newStatements add: (stmt removeAssertions; yourself). - ] - ]. - self setStatements: newStatements asArray -] - -{ #category : #'inlining support' } -TStmtListNode >> renameLabelsForInliningInto: aTMethod [ - "TMethod already has a method for this; hijack it..." - | labels | - labels := OrderedCollection new. - self nodesDo: - [:node| node isLabel ifTrue: [labels add: node label]]. - TMethod new - parseTree: self; - labels: labels; - renameLabelsForInliningInto: aTMethod -] - -{ #category : #transformations } -TStmtListNode >> replaceChild: aNode with: bNode [ - statements := Array streamContents: - [:s| - statements do: - [:node| - node == aNode - ifTrue: - [bNode isStmtList - ifTrue: [s nextPutAll: bNode statements] - ifFalse: [s nextPut: bNode]] - ifFalse: [s nextPut: node]]] -] - -{ #category : #transformations } -TStmtListNode >> replaceNodesIn: aDictionary [ - - ^aDictionary at: self ifAbsent: [ - statements := statements collect: [ :s | s replaceNodesIn: aDictionary ]. - self] -] - -{ #category : #testing } -TStmtListNode >> returnsExpression [ - "Answer true if the last statement of this block is a return of some expression, not merely self or nil." - - statements isEmpty ifTrue: - [^false]. - statements last isReturn ifFalse: - [^false]. - statements last isVariable ifFalse: - [^true]. - ^statements last variable ~= 'self' - and: [statements last variable ~= 'nil'] -] - -{ #category : #accessing } -TStmtListNode >> setArguments: argList [ - - arguments := argList. -] - -{ #category : #accessing } -TStmtListNode >> setArguments: argList statements: statementList [ - "Initialize this method using the given information." - - arguments := argList. - statements := statementList. -] - -{ #category : #accessing } -TStmtListNode >> setStatements: stmtList [ - - statements := stmtList asOrderedCollection. -] - -{ #category : #inlining } -TStmtListNode >> shouldExpand [ - ^(statements detect: [:stmt| stmt isInline]) shouldExpand -] - -{ #category : #accessing } -TStmtListNode >> statements [ - - ^statements -] - -{ #category : #'type inference' } -TStmtListNode >> 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 f652ef9e48..5d317090c2 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 [ @@ -42,7 +48,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 +72,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) @@ -157,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) @@ -209,6 +215,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" @@ -223,6 +242,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 @@ -267,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 diff --git a/smalltalksrc/Slang/TVariableNode.class.st b/smalltalksrc/Slang/TVariableNode.class.st index afb88e6729..4db31708e9 100644 --- a/smalltalksrc/Slang/TVariableNode.class.st +++ b/smalltalksrc/Slang/TVariableNode.class.st @@ -15,14 +15,24 @@ TVariableNode class >> named: aName [ yourself ] +{ #category : #'instance creation' } +TVariableNode class >> selfNode [ + + ^ self named: 'self' +] + +{ #category : #visiting } +TVariableNode >> accept: aVisitor [ + + ^ aVisitor visitVariableNode: self +] + { #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 } @@ -42,6 +52,19 @@ 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 : #accessing } +TVariableNode >> children [ + + ^ #() +] + { #category : #testing } TVariableNode >> hasSideEffect [ "Answer if the parse tree rooted at this node has a side-effect or not." @@ -88,7 +111,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 } @@ -107,7 +134,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-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-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 -] 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/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]]] +] diff --git a/smalltalksrc/VMMaker/CoInterpreter.class.st b/smalltalksrc/VMMaker/CoInterpreter.class.st index ca48a0be09..f84aa8acf2 100644 --- a/smalltalksrc/VMMaker/CoInterpreter.class.st +++ b/smalltalksrc/VMMaker/CoInterpreter.class.st @@ -932,16 +932,18 @@ 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 := self frameCallerContext: localFP. + | 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 correct in determining if contextToReturnTo is still married, and in case @@ -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. - localSP := theSP. - localFP := theFP. - localIP := self pointerForOop: self internalStackTop. - localIP asUnsignedInteger < objectMemory startOfMemory ifTrue: - [localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: - ["localIP in the cog method zone indicates a return to machine code." - ^self returnToMachineCodeFrame]. - localIP := self pointerForOop: (self iframeSavedIP: localFP)]. - self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). - self setMethod: (self iframeMethod: localFP). - self internalStackTopPut: localReturnValue. - ^self fetchNextBytecode + stackPointer := theSP. + framePointer := theFP. + 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 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 := self frameCallerFP: localFP. - callersFPOrNull = 0 "baseFrame" ifTrue: - [self assert: localFP = stackPage baseFP. - ^self baseFrameReturn]. - - localIP := self frameCallerSavedIP: localFP. - localSP := localFP + (self frameStackedReceiverOffset: localFP). - localFP := callersFPOrNull. - localIP asUnsignedInteger < objectMemory startOfMemory ifTrue: - [localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue: - ["localIP in the cog method zone indicates a return to machine code." - ^self returnToMachineCodeFrame]. - localIP := self pointerForOop: (self iframeSavedIP: localFP)]. - self setMethod: (self iframeMethod: localFP). + | callersFPOrNull | + callersFPOrNull := self frameCallerFP: framePointer. + callersFPOrNull = 0 ifTrue: [ + self assert: framePointer = stackPage baseFP. + ^ self baseFrameReturn ]. "baseFrame" + + instructionPointer := self frameCallerSavedIP: 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) ]. + 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. - popBoolean ifTrue: [ self internalPop: 1 ]. - variableType = 0 ifTrue: - [objectMemory storePointerImmutabilityCheck: variableIndex ofObject: self receiver withValue: value. - ^ self fetchNextBytecode.]. - variableType = 1 ifTrue: - [ self fetchNextBytecode. - ^self itemporary: variableIndex in: localFP put: value]. - variableType = 3 ifTrue: - [self storeLiteralVariable: variableIndex withValue: value. - ^ self fetchNextBytecode.]. + 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 ]. self error: 'illegal store' ] @@ -3086,10 +3107,8 @@ 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. - stackPointer := localSP. - framePointer := localFP + self assert: instructionPointer asUnsignedInteger ~= cogit ceReturnToInterpreterPC. + stackPointer := stackPointer. ] { #category : #'debug support' } @@ -3692,7 +3711,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. @@ -3704,12 +3723,12 @@ 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: [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] @@ -3717,7 +3736,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' } @@ -3875,7 +3894,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: framePointer currentIP: (self oopForPointer: instructionPointer)]. self error: 'bad index'. ^0 ] @@ -3930,54 +3949,62 @@ 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 internalPush: localIP. - self internalPush: localFP. - localFP := localSP. - self internalPush: newMethod. + self push: instructionPointer. + self push: framePointer. + framePointer := stackPointer. + self push: newMethod. self setMethod: newMethod methodHeader: methodHeader. - self internalPush: objectMemory nilObject. "FxThisContext field" - self internalPush: (self - encodeFrameFieldHasContext: false - isBlock: false - numArgs: (self argumentCountOfMethodHeader: methodHeader)). - self internalPush: 0. "FoxIFSavedIP" - self internalPush: rcvr. + self push: objectMemory nilObject. "FxThisContext field" + self push: (self + encodeFrameFieldHasContext: false + isBlock: false + numArgs: (self argumentCountOfMethodHeader: methodHeader)). + self push: 0. "FoxIFSavedIP" + self push: rcvr. "Initialize temps..." - argumentCount + 1 to: numTemps do: - [:i | self internalPush: objectMemory nilObject]. + argumentCount + 1 to: numTemps do: [ :i | + self push: 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 + (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]]. - - self assert: (self frameNumArgs: localFP) = argumentCount. - self assert: (self frameIsBlockActivation: localFP) not. - self assert: (self frameHasContext: localFP) not. + 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)." - localSP < 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' } @@ -4003,7 +4030,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: framePointer put: instructionPointer asInteger. instructionPointer := cogit ceReturnToInterpreterPC. self externalizeFPandSP. self activateCoggedNewMethod: true. @@ -4053,9 +4080,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. - localIP := self pointerForOop: instructionPointer. - localSP := self pointerForOop: stackPointer. - localFP := self pointerForOop: framePointer. + stackPointer := self pointerForOop: stackPointer ] { #category : #'trampoline support' } @@ -4260,16 +4285,18 @@ CoInterpreter >> longPushTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self internalPush: (self itemporary: index in: localFP) + self push: (self itemporary: index in: framePointer) ] { #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: localFP put: self internalStackTop + self itemporary: index in: framePointer put: self stackTop ] { #category : #simulation } @@ -4944,11 +4971,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: framePointer)] ] { #category : #'debug support' } @@ -5347,7 +5374,7 @@ CoInterpreter >> nextProfileTickLow [ { #category : #simulation } CoInterpreter >> nilLocalFP [ - localFP := nil + framePointer := nil ] { #category : #'cog jit support' } @@ -5928,61 +5955,71 @@ 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: localFP SP: localSP + (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 internalPop: numCopied]. + withValue: (self stackValue: numCopied - i - 1) ]. + self pop: numCopied ]. self fetchNextBytecode. - self internalPush: newClosure + self push: newClosure ] { #category : #'stack bytecodes' } 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]]. - self internalPush: (objectMemory fetchPointer: index ofObject: tempVector) + [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. + 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: localFP) + self push: (self itemporary: temporaryIndex in: framePointer) ] { #category : #'cog jit support' } @@ -6041,7 +6078,7 @@ CoInterpreter >> rawHeaderOf: methodOop put: cogMethodOrMethodHeader [ { #category : #'internal interpreter access' } CoInterpreter >> receiver [ - ^stackPages longAt: localFP + FoxIFReceiver + ^stackPages longAt: framePointer + FoxIFReceiver ] { #category : #'debug support' } @@ -6209,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: localIP asUnsignedInteger < objectMemory startOfMemory. - self assert: (self isMachineCodeFrame: localFP). - self assertValidExecutionPointe: localIP asUnsignedInteger r: localFP s: localSP imbar: false line: #'__LINE__'. - self internalStackTopPut: localIP. - self internalPush: localReturnValue. + self assert: + instructionPointer asUnsignedInteger < objectMemory startOfMemory. + self assert: (self isMachineCodeFrame: framePointer). + 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: localIP]. + self cCode: '' inSmalltalk: [ + self maybeCheckStackDepth: 1 sp: stackPointer pc: instructionPointer ]. cogit ceEnterCogCodePopReceiverReg "NOTREACHED" ] @@ -6565,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: localFP 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 fetchNextBytecode. - self internalPop: 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: localFP. - TempVectReadBarrier - ifTrue: - [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: localFP]]. - objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop + 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 stackTop ] { #category : #'process primitive support' } 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/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 48eaf4d66d..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: localFP 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." @@ -831,7 +820,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 +828,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 +914,7 @@ CogVMSimulator >> externalSetStackPageAndPointersForSuspendedContextOfProcess: a { #category : #'interpreter shell' } CogVMSimulator >> fetchByte [ - ^objectMemory byteAt: (localIP := localIP + 1) + ^objectMemory byteAt: (instructionPointer := instructionPointer + 1) ] { #category : #'interpreter access' } @@ -1367,7 +1356,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 @@ -1667,7 +1656,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: @@ -1686,150 +1675,6 @@ CogVMSimulator >> loadNewPlugin: pluginString [ entry] ] -{ #category : #accessing } -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. @@ -2456,7 +2301,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 @@ -2584,7 +2429,7 @@ CogVMSimulator >> printHexnpnp: anInteger [ { #category : #'debug printing' } CogVMSimulator >> printLCS [ - self printCallStackFP: localFP + self printCallStackFP: framePointer ] { #category : #'debug printing' } @@ -2911,11 +2756,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 " @@ -2946,19 +2786,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: @@ -2983,11 +2810,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 | @@ -3025,116 +2847,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/Cogit.class.st b/smalltalksrc/VMMaker/Cogit.class.st index d2d4d9ab70..6d570e6aa2 100644 --- a/smalltalksrc/VMMaker/Cogit.class.st +++ b/smalltalksrc/VMMaker/Cogit.class.st @@ -11563,55 +11563,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/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 -] diff --git a/smalltalksrc/VMMaker/InterpreterPrimitives.class.st b/smalltalksrc/VMMaker/InterpreterPrimitives.class.st index 0014295d61..2d9a61d533 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 ] @@ -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 ] 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/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/SmartSyntaxPluginTMethod.class.st b/smalltalksrc/VMMaker/SmartSyntaxPluginTMethod.class.st index 68ecd1a622..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; @@ -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: @@ -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. @@ -502,9 +509,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 7436148871..ee77fe869a 100644 --- a/smalltalksrc/VMMaker/StackInterpreter.class.st +++ b/smalltalksrc/VMMaker/StackInterpreter.class.st @@ -316,9 +316,6 @@ Class { #instVars : [ 'currentBytecode', 'bytecodeSetSelector', - 'localFP', - 'localIP', - 'localSP', 'stackLimit', 'stackPage', 'stackPages', @@ -327,8 +324,6 @@ Class { 'stackPointer', 'framePointer', 'localReturnValue', - 'localAbsentReceiver', - 'localAbsentReceiverOrZero', 'extA', 'extB', 'numExtB', @@ -533,11 +528,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 stackPointer framePointer stackLimit breakSelector) as: #'char *' in: aCCodeGenerator. aCCodeGenerator @@ -1505,7 +1500,7 @@ StackInterpreter class >> mustBeGlobal: var [ { #category : #translation } StackInterpreter class >> namesOfVariablesToLocalize [ - ^#(currentBytecode localFP localIP localSP localReturnValue) + ^#(currentBytecode localReturnValue) ] { #category : #translation } @@ -1710,34 +1705,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 @@ -2234,7 +2201,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: framePointer s: stackPointer ] { #category : #'process primitive support' } @@ -2252,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 := self frameCallerContext: localFP. + | 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. - localSP := theSP. - localFP := theFP. - self setMethod: (self frameMethod: localFP). - localIP := self pointerForOop: self internalStackTop. - self internalStackTopPut: localReturnValue. - self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). - ^self fetchNextBytecode + stackPointer := theSP. + framePointer := theFP. + self setMethod: (self frameMethod: framePointer). + instructionPointer := self pointerForOop: self stackTop. + self stackTopPut: localReturnValue. + self assert: (self + checkIsStillMarriedContext: contextToReturnTo + currentFP: framePointer). + ^ self fetchNextBytecode ] { #category : #'frame access' } @@ -2321,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 internalPop: 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 internalPop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) + self + pop: 1; + stackTopPut: (objectMemory booleanObjectOf: result) ] { #category : #'sista inline primitives - binary' } @@ -2459,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 internalPop: 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). @@ -2510,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 internalPop: 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). @@ -2544,7 +2538,7 @@ StackInterpreter >> binarySmiBitInlinePrimitive: primIndex [ [20] -> [self assert: argInt >= 0. result := recInt >> argInt]. }. - self internalPop: 1; internalStackTopPutIntegerObjectOf: result + self pop: 1; stackTopPutIntegerObjectOf: result ] { #category : #'sista inline primitives - binary' } @@ -2552,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: { @@ -2576,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 internalPop: 1; internalStackTopPut: (objectMemory booleanObjectOf: result) + self pop: 1; stackTopPut: (objectMemory booleanObjectOf: result) ] { #category : #utilities } @@ -2596,7 +2590,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]. @@ -2608,7 +2602,7 @@ StackInterpreter >> booleanCheatFalse [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory falseObject + self push: objectMemory falseObject ] { #category : #utilities } @@ -2618,7 +2612,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]. @@ -2630,7 +2624,7 @@ StackInterpreter >> booleanCheatFalseSistaV1 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory falseObject + self push: objectMemory falseObject ] { #category : #utilities } @@ -2640,7 +2634,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]. @@ -2652,7 +2646,7 @@ StackInterpreter >> booleanCheatFalseV4 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory falseObject + self push: objectMemory falseObject ] { #category : #utilities } @@ -2672,7 +2666,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]. @@ -2687,7 +2681,7 @@ StackInterpreter >> booleanCheatTrue [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory trueObject + self push: objectMemory trueObject ] { #category : #utilities } @@ -2697,7 +2691,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]. @@ -2712,7 +2706,7 @@ StackInterpreter >> booleanCheatTrueSistaV1 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory trueObject + self push: objectMemory trueObject ] { #category : #utilities } @@ -2722,7 +2716,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]. @@ -2737,7 +2731,7 @@ StackInterpreter >> booleanCheatTrueV4 [ self cppIf: MULTIPLEBYTECODESETS ifTrue: [currentBytecode := bytecode + bytecodeSetSelector] ifFalse: [currentBytecode := bytecode]. - self internalPush: objectMemory trueObject + self push: objectMemory trueObject ] { #category : #utilities } @@ -2762,12 +2756,12 @@ 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: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + [self pop: 2 thenPush: (objectMemory integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. @@ -2789,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" @@ -2812,7 +2806,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. @@ -2836,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 ]. @@ -2863,7 +2857,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. @@ -2874,11 +2868,11 @@ 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 internalPop: 2 thenPush: (arg bitAnd: rcvr). + [self pop: 2 thenPush: (arg bitAnd: rcvr). ^self fetchNextBytecode "success"]. self initPrimCall. @@ -2896,11 +2890,11 @@ 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 internalPop: 2 thenPush: (arg bitOr: rcvr). + [self pop: 2 thenPush: (arg bitOr: rcvr). ^self fetchNextBytecode "success"]. self initPrimCall. @@ -2931,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 ] @@ -2943,8 +2938,8 @@ StackInterpreter >> bytecodePrimClass [ 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). + quotient := self doPrimitiveDiv: (self stackValue: 1) by: (self stackValue: 0). + self successful ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: quotient). ^ self fetchNextBytecode "success"]. messageSelector := self specialSelector: 13. @@ -2955,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. @@ -2964,7 +2959,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. @@ -2989,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. @@ -3005,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. @@ -3021,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. @@ -3037,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." @@ -3057,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." @@ -3077,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." @@ -3097,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." @@ -3117,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." @@ -3137,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." @@ -3157,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 @@ -3169,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: @@ -3181,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: @@ -3193,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." @@ -3213,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." @@ -3233,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." @@ -3253,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." @@ -3273,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." @@ -3293,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." @@ -3316,15 +3311,15 @@ 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. 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. @@ -3336,9 +3331,9 @@ 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 internalPop: 2 thenPush: (objectMemory integerObjectOf: mod). + [self pop: 2 thenPush: (objectMemory integerObjectOf: mod). ^ self fetchNextBytecode "success"]. messageSelector := self specialSelector: 10. @@ -3349,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. @@ -3365,7 +3360,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. @@ -3413,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. @@ -3429,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. @@ -3445,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. @@ -3461,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 @@ -3473,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: @@ -3485,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: @@ -3499,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. @@ -3516,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. @@ -3530,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. @@ -3564,12 +3560,12 @@ 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: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + [self pop: 2 thenPush: (objectMemory integerObjectOf: result). ^self fetchNextBytecode "success"]] ifFalse: [self initPrimCall. self externalizeIPandSP. @@ -3584,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 ] @@ -3603,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: @@ -3642,7 +3638,7 @@ StackInterpreter >> callMappedInlinedPrimitive [ self fetchNextBytecode. self sistaMappedInlinePrimitive: primIndex] ifFalse: - [localIP := localIP - 2. + [instructionPointer := instructionPointer - 2. self respondToUnknownBytecode]. ] @@ -3663,25 +3659,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]] @@ -3797,9 +3793,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 @@ -4585,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 := self frameCallerFP: localFP. - callersFPOrNull = 0 "baseFrame" ifTrue: - [self assert: localFP = stackPage baseFP. - ^self baseFrameReturn]. - - localIP := self frameCallerSavedIP: localFP. - localSP := localFP + (self frameStackedReceiverOffset: localFP). - localFP := callersFPOrNull. - self setMethod: (self frameMethod: localFP). + | callersFPOrNull | + callersFPOrNull := self frameCallerFP: framePointer. + callersFPOrNull = 0 ifTrue: [ + self assert: framePointer = stackPage baseFP. + ^ self baseFrameReturn ]. "baseFrame" + + instructionPointer := self frameCallerSavedIP: 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: localFP) ifFalse: - [^self commonCallerReturn]. "Update the current page's headFrame pointers to enable the search for unwind protects below to identify widowed contexts correctly." @@ -4626,51 +4625,58 @@ 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." - [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: localFP). - 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: localFP). - 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 @@ -4679,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. - localSP := stackPage headSP. - localFP := 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." - localFP = frameToReturnTo - ifTrue: "pop the saved IP, push the return value and continue." - [localIP := self pointerForOop: self internalStackTop] - ifFalse: - [[callerFP := localFP. - localFP := self frameCallerFP: localFP. - localFP ~~ frameToReturnTo] whileTrue. - localIP := self frameCallerSavedIP: callerFP. - localSP := (self frameCallerSP: callerFP) - objectMemory wordSize]. + framePointer = frameToReturnTo + 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 ]. self maybeReturnToMachineCodeFrame. - self setMethod: (self frameMethod: localFP). + self setMethod: (self frameMethod: framePointer). self fetchNextBytecode. - self internalStackTopPut: localReturnValue + self stackTopPut: localReturnValue ] { #category : #'send bytecodes' } @@ -4728,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. @@ -5066,7 +5081,7 @@ StackInterpreter >> directedSuperclassSend [ "" | class superclass | - class := self internalPopStack. + class := self popStack. (objectMemory isForwarded: class) ifTrue: [class := objectMemory followForwarded: class]. superclass := self superclassOf: class. @@ -5084,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 } @@ -5271,8 +5290,7 @@ StackInterpreter >> dumpPrimTraceLog [ StackInterpreter >> duplicateTopBytecode [ self fetchNextBytecode. - self internalPush: self internalStackTop. - + self push: self stackTop ] { #category : #'debug printing' } @@ -5360,9 +5378,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 } @@ -5490,7 +5508,7 @@ StackInterpreter >> extPushCharacterBytecode [ | value | value := self fetchByte + (extB << 8). self fetchNextBytecode. - self internalPush: (objectMemory characterObjectOf: value). + self push: (objectMemory characterObjectOf: value). numExtB := extB := 0 ] @@ -5525,7 +5543,7 @@ StackInterpreter >> extPushIntegerBytecode [ self fetchNextBytecode. extB := 0. numExtB := 0. - self internalPush: (objectMemory integerObjectOf: value) + self push: (objectMemory integerObjectOf: value) ] { #category : #'stack bytecodes' } @@ -5554,12 +5572,12 @@ StackInterpreter >> extPushPseudoVariable [ | theThingToPush | extB caseOf: { - [0] -> [theThingToPush := self ensureFrameIsMarried: localFP SP: localSP]. + [0] -> [theThingToPush := self ensureFrameIsMarried: framePointer SP: stackPointer]. [1] -> [theThingToPush := self activeProcess] } otherwise: [self respondToUnknownBytecode]. self fetchNextBytecode. - self internalPush: theThingToPush. + self push: theThingToPush. extB := 0. numExtB := 0. ] @@ -5576,12 +5594,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 ] @@ -5623,46 +5643,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. - self internalPop: 1. + 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. - self internalPop: 1. - self storeMaybeContextReceiverVariable: variableIndex withValue: value. - self fetchNextBytecode. + value := self stackTop. + self pop: 1. + 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' } @@ -5674,7 +5706,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 ] @@ -5710,25 +5742,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. - popBoolean ifTrue: [ self internalPop: 1 ]. - variableType = 0 ifTrue: - [objectMemory storePointerImmutabilityCheck: variableIndex ofObject: self receiver withValue: value. - ^ self fetchNextBytecode]. - variableType = 1 ifTrue: - [ self fetchNextBytecode. - self temporary: variableIndex in: localFP put: value. - ^ self "keep slang happy"]. - variableType = 3 ifTrue: - [self storeLiteralVariable: variableIndex withValue: value. - ^ self fetchNextBytecode]. + 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 temporary: variableIndex in: framePointer put: value. + ^ self "keep slang happy" ]. + variableType = 3 ifTrue: [ + self storeLiteralVariable: variableIndex withValue: value. + ^ self fetchNextBytecode ]. self error: 'illegal store' - ] { #category : #'frame access' } @@ -5945,19 +5980,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 := localFP + 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." - - instructionPointer := self oopForPointer: localIP. - stackPointer := localSP. - framePointer := localFP ] { #category : #'primitive support' } @@ -5983,7 +6012,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 } @@ -7351,7 +7380,7 @@ StackInterpreter >> handleForwardedSendFaultForTag: classTag [ StackInterpreter >> handleSpecialSelectorSendFaultFor: obj [ - ^self handleSpecialSelectorSendFaultFor: obj fp: localFP sp: localSP + ^self handleSpecialSelectorSendFaultFor: obj fp: framePointer sp: stackPointer ] { #category : #'message sending' } @@ -7528,7 +7557,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. @@ -7904,7 +7933,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: framePointer currentIP: (self oopForPointer: instructionPointer)]. self error: 'bad index'. ^0 ] @@ -7934,8 +7963,8 @@ StackInterpreter >> instVar: index ofContext: aMarriedContext put: anOop [ self storeSenderOfFrame: theFP withValue: anOop. onCurrentPage ifTrue: - [localFP := stackPage headFP. - localSP := stackPage headSP] + [framePointer := stackPage headFP. + stackPointer := stackPage headSP] ifFalse: [stackPages markStackPageMostRecentlyUsed: stackPage]. ^nil]. @@ -7949,7 +7978,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: framePointer s: stackPointer imbar: true line: #'__LINE__' ] { #category : #'indexing primitive support' } @@ -8037,10 +8066,10 @@ StackInterpreter >> integerArg: index [ StackInterpreter >> internalAboutToReturn: resultOop through: aContext [ | ourContext | - ourContext := self ensureFrameIsMarried: localFP SP: localSP. - self internalPush: ourContext. - self internalPush: resultOop. - self internalPush: aContext. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. + self push: ourContext. + self push: resultOop. + self push: aContext. messageSelector := objectMemory splObj: SelectorAboutToReturn. argumentCount := 2. ^self normalSend @@ -8048,59 +8077,63 @@ 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). - 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 internalPush: localIP. - self internalPush: localFP. - localFP := localSP. - self internalPush: newMethod. + self push: instructionPointer. + self push: framePointer. + framePointer := stackPointer. + self push: newMethod. self setMethod: newMethod methodHeader: methodHeader. - self internalPush: (self - encodeFrameFieldHasContext: false - isBlock: false - numArgs: (self argumentCountOfMethodHeader: methodHeader)). - self internalPush: objectMemory nilObject. "FxThisContext field" - self internalPush: rcvr. + self push: (self + encodeFrameFieldHasContext: false + isBlock: false + numArgs: (self argumentCountOfMethodHeader: methodHeader)). + self push: objectMemory nilObject. "FxThisContext field" + self push: rcvr. "Initialize temps..." - argumentCount + 1 to: numTemps do: - [:i | self internalPush: objectMemory nilObject]. + argumentCount + 1 to: numTemps do: [ :i | + self push: 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 + (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]]. + instructionPointer := instructionPointer + + (self sizeOfCallPrimitiveBytecode: methodHeader). + primFailCode ~= 0 ifTrue: [ + self reapAndResetErrorCodeTo: stackPointer 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: - [self externalizeIPandSP. - self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: newMethod header: methodHeader). - self internalizeIPandSP] + stackPointer < stackLimit ifTrue: [ + self externalizeIPandSP. + self handleStackOverflowOrEventAllowContextSwitch: + (self canContextSwitchIfActivating: newMethod header: methodHeader). + self internalizeIPandSP ] ] { #category : #'return bytecodes' } StackInterpreter >> internalCannotReturn: resultOop [ | ourContext | - ourContext := self ensureFrameIsMarried: localFP SP: localSP. - self internalPush: ourContext. - self internalPush: resultOop. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. + self push: ourContext. + self push: resultOop. messageSelector := objectMemory splObj: SelectorCannotReturn. argumentCount := 1. ^self normalSend @@ -8154,91 +8187,44 @@ StackInterpreter >> internalMustBeBoolean [ self normalSend ] -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPop: nItems [ - "In the StackInterpreter stacks grow down." - localSP := localSP + (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 -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPopStack [ - "In the StackInterpreter stacks grow down." - | top | - top := stackPages longAt: localSP. - localSP := localSP + objectMemory bytesPerOop. - ^top -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalPush: object [ - "In the StackInterpreter stacks grow down." - stackPages longAtPointer: (localSP := localSP - objectMemory bytesPerOop) put: object -] - { #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: localSP -] - -{ #category : #'internal interpreter access' } -StackInterpreter >> internalStackTopPut: aValue [ - - ^stackPages longAtPointer: localSP 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: localSP + (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 + 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 } 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. + stackPointer := self pointerForOop: stackPointer ] { #category : #'interpreter shell' } @@ -8246,6 +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]. @@ -8254,7 +8241,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 @@ -8737,141 +8724,153 @@ 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' } 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: [localIP := localIP + 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: [localIP := localIP + 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: [localIP := localIP + 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: [localIP := localIP + 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. - + 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: - [localIP := localIP + 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: - [localIP := localIP + 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: - [localIP := localIP + 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: - [localIP := localIP - 1. - self fetchNextBytecode. - ^self internalPop: 3]]. - localIP := localIP + offset]. - }. - localIP := localIP - 1. "we've already fetched, but we may have incorrectly fetched if jump" + 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 internalPop: 3 - + 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" - localIP := localIP + (objectMemory integerValueOf: top) - 1. - self fetchNextBytecode. - ^self internalPop: 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]. - self internalPop: 1 + 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]. - self internalPop: 1 + ifTrue: [ self jump: offset ] + ifFalse: [ + boolean = objectMemory falseObject ifFalse: [ + ^ self internalMustBeBoolean ]. + self fetchNextBytecode ]. + self pop: 1 ] { #category : #'message sending' } @@ -8937,7 +8936,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 ] @@ -9144,14 +9143,14 @@ StackInterpreter >> longPushTemporaryVariableBytecode [ | index | index := self fetchByte. self fetchNextBytecode. - self internalPush: (self temporary: index in: localFP) + self push: (self temporary: index in: framePointer) ] { #category : #'stack bytecodes' } 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' } @@ -9170,18 +9169,20 @@ 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: localFP put: self internalStackTop + self temporary: index in: framePointer put: self stackTop ] { #category : #'jump bytecodes' } StackInterpreter >> longUnconditionalJump [ | offset | offset := (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte. - localIP := localIP + offset. + instructionPointer := instructionPointer + offset. self ifBackwardsCheckForEvents: offset. self fetchNextBytecode ] @@ -9654,15 +9655,16 @@ StackInterpreter >> mapVMRegisters [ { #category : #'sista bytecodes' } StackInterpreter >> mappedBackjumpAlwaysInterrupt [ + | top offset | - top := self internalStackTop. + top := self stackTop. self assert: (objectMemory isIntegerObject: top). offset := objectMemory integerObjectOf: top. - localIP := localIP - offset. - self internalPop: 1. + instructionPointer := instructionPointer - offset. + self pop: 1. "+1 since this instr is 3 bytes not 2" - self ifBackwardsCheckForEvents: 0 - offset + 1. - localIP := localIP - 1. + self ifBackwardsCheckForEvents: 0 - offset + 1. + instructionPointer := instructionPointer - 1. self fetchNextBytecode ] @@ -9671,7 +9673,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. @@ -9684,108 +9686,127 @@ 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 internalPop: 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. - self internalPop: 3. - self internalPush: result. - (self isWriteMediatedContextInstVarIndex: argIntAdjusted) - ifFalse: [objectMemory storePointerImmutabilityCheck: argIntAdjusted ofObject: rec withValue: result] - ifTrue: [self externalizeIPandSP. - self externalInstVar: argIntAdjusted ofContext: rec put: result. - self internalizeIPandSP] + 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 ] ] { #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. - self internalPop: 3. - self internalPush: result. + result := self stackTop. + self pop: 3. + self push: result. objectMemory storePointerImmutabilityCheck: argIntAdjusted ofObject: rec @@ -10691,7 +10712,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 @@ -10954,7 +10975,7 @@ StackInterpreter >> popStack [ StackInterpreter >> popStackBytecode [ self fetchNextBytecode. - self internalPop: 1. + self pop: 1. ] @@ -11878,8 +11899,13 @@ StackInterpreter >> printFramesOnStackPageListInUse [ { #category : #'debug printing' } StackInterpreter >> printHeadFrame [ - - self printFrame: localFP WithSP: localSP + + "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: framePointer WithSP: stackPointer ] { #category : #'debug printing' } @@ -12274,7 +12300,7 @@ StackInterpreter >> printSends [ { #category : #'debug printing' } StackInterpreter >> printStackCallStack [ - self printStackCallStackOf: (localFP ifNil: [framePointer]) + self printStackCallStackOf: (framePointer ifNil: [framePointer]) ] { #category : #'debug printing' } @@ -12523,9 +12549,9 @@ StackInterpreter >> push: object [ { #category : #'stack bytecodes' } StackInterpreter >> pushActiveContextBytecode [ | ourContext | - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. self fetchNextBytecode. - self internalPush: ourContext + self push: ourContext ] { #category : #'internal interpreter access' } @@ -12538,7 +12564,7 @@ StackInterpreter >> pushBool: trueOrFalse [ StackInterpreter >> pushConstantFalseBytecode [ self fetchNextBytecode. - self internalPush: objectMemory falseObject. + self push: objectMemory falseObject. ] @@ -12546,7 +12572,7 @@ StackInterpreter >> pushConstantFalseBytecode [ StackInterpreter >> pushConstantMinusOneBytecode [ self fetchNextBytecode. - self internalPush: ConstMinusOne. + self push: ConstMinusOne. ] @@ -12554,7 +12580,7 @@ StackInterpreter >> pushConstantMinusOneBytecode [ StackInterpreter >> pushConstantNilBytecode [ self fetchNextBytecode. - self internalPush: objectMemory nilObject. + self push: objectMemory nilObject. ] @@ -12562,7 +12588,7 @@ StackInterpreter >> pushConstantNilBytecode [ StackInterpreter >> pushConstantOneBytecode [ self fetchNextBytecode. - self internalPush: ConstOne. + self push: ConstOne. ] @@ -12570,7 +12596,7 @@ StackInterpreter >> pushConstantOneBytecode [ StackInterpreter >> pushConstantTrueBytecode [ self fetchNextBytecode. - self internalPush: objectMemory trueObject. + self push: objectMemory trueObject. ] @@ -12578,7 +12604,7 @@ StackInterpreter >> pushConstantTrueBytecode [ StackInterpreter >> pushConstantTwoBytecode [ self fetchNextBytecode. - self internalPush: ConstTwo. + self push: ConstTwo. ] @@ -12586,7 +12612,7 @@ StackInterpreter >> pushConstantTwoBytecode [ StackInterpreter >> pushConstantZeroBytecode [ self fetchNextBytecode. - self internalPush: ConstZero. + self push: ConstZero. ] @@ -12607,7 +12633,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: stackPointer + (numCopiedArg * objectMemory bytesPerOop)]. newClosure := self fullClosureIn: context numArgs: numArgs @@ -12630,10 +12656,10 @@ StackInterpreter >> pushFullClosureNumArgs: numArgs copiedValues: numCopiedArg c Thus, can use unchecked stores." objectMemory storePointerUnchecked: i + startIndex ofObject: newClosure - withValue: (self internalStackValue: numCopied - i - 1)]. - self internalPop: numCopied]. + withValue: (self stackValue: numCopied - i - 1)]. + self pop: numCopied]. self fetchNextBytecode. - self internalPush: newClosure + self push: newClosure ] { #category : #'internal interpreter access' } @@ -12645,7 +12671,7 @@ StackInterpreter >> pushInteger: integerValue [ { #category : #'stack bytecodes' } StackInterpreter >> pushLiteralConstant: literalIndex [ - self internalPush: (self literal: literalIndex). + self push: (self literal: literalIndex). ] { #category : #'stack bytecodes' } @@ -12684,10 +12710,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))] ] @@ -12716,9 +12742,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' } @@ -12758,27 +12784,27 @@ 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)]. - self internalPop: size] + objectMemory storePointerUnchecked: i ofObject: array withValue: (self stackValue: size - i - 1)]. + self pop: size] ifFalse: [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' } @@ -12796,12 +12822,12 @@ 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]]. - self internalPush: (objectMemory fetchPointer: index ofObject: tempVector) + [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: framePointer]]. + self push: (objectMemory fetchPointer: index ofObject: tempVector) ] { #category : #'stack bytecodes' } @@ -12816,7 +12842,7 @@ StackInterpreter >> pushRemoteTempLongBytecode [ { #category : #'stack bytecodes' } StackInterpreter >> pushTemporaryVariable: temporaryIndex [ - self internalPush: (self temporary: temporaryIndex in: localFP). + self push: (self temporary: temporaryIndex in: framePointer). ] { #category : #'stack bytecodes' } @@ -12945,12 +12971,12 @@ 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. - self internalPop: 4. + [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]. 0 to: destLimit - destIndex do: @@ -13101,7 +13127,7 @@ StackInterpreter >> reapAndResetErrorCodeTo: theSP header: methodHeader [ { #category : #'internal interpreter access' } StackInterpreter >> receiver [ - ^stackPages longAt: localFP + FoxReceiver + ^stackPages longAt: framePointer + FoxReceiver ] { #category : #'callback support' } @@ -13246,8 +13272,8 @@ StackInterpreter >> respondToSistaTrap [ | ourContext | messageSelector := objectMemory splObj: SelectorSistaTrap. - ourContext := self ensureFrameIsMarried: localFP SP: localSP. - self internalPush: ourContext. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. + self push: ourContext. argumentCount := 0. self normalSend ] @@ -13261,10 +13287,10 @@ StackInterpreter >> respondToUnknownBytecode [ (messageSelector isNil or: [messageSelector = objectMemory nilObject]) ifTrue: [self error: 'Unknown bytecode']. - ourContext := self ensureFrameIsMarried: localFP SP: localSP. + ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer. "undo fetch of bytecode so that context's pc is pointing to the unknown bytecode." - localIP := localIP - 1. - self internalPush: ourContext. + instructionPointer := instructionPointer - 1. + self push: ourContext. argumentCount := 0. self normalSend ] @@ -13389,14 +13415,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 ] @@ -13581,7 +13610,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 @@ -13593,7 +13622,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 @@ -13605,7 +13634,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 @@ -14058,7 +14087,7 @@ StackInterpreter >> shortPrintFrameAndCallers: theFP [ StackInterpreter >> shortPrintFramesInCurrentPage [ self resetStackPrintedCount. - self shortPrintFrameAndCallers: localFP + self shortPrintFrameAndCallers: framePointer ] { #category : #'debug printing' } @@ -14149,12 +14178,12 @@ 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. - 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' } @@ -14707,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 ] @@ -14821,6 +14849,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 [ @@ -14852,36 +14886,44 @@ 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 internalPop: 1. + self pop: 1. objectMemory storePointerImmutabilityCheck: instVarIndex ofObject: rcvr withValue: top. - self fetchNextBytecode. + self fetchNextBytecode ] { #category : #'stack bytecodes' } StackInterpreter >> storeAndPopRemoteTempLongBytecode [ self storeRemoteTempLongBytecode. - self internalPop: 1 + self pop: 1 ] { #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: localFP 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 fetchNextBytecode. - self internalPop: 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 } @@ -14935,13 +14977,19 @@ StackInterpreter >> storeMaybeContextReceiverVariable: fieldIndex withValue: anO { #category : #'stack bytecodes' } StackInterpreter >> storeRemoteTemp: index inVectorAt: tempVectorIndex [ + | tempVector | - tempVector := self temporary: tempVectorIndex in: localFP. - TempVectReadBarrier - ifTrue: - [(objectMemory isForwarded: tempVector) ifTrue: - [tempVector := self unfollowTempVector: tempVector atIndex: tempVectorIndex in: localFP]]. - objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop. + 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 stackTop ] { #category : #'stack bytecodes' } @@ -15264,92 +15312,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 internalPop: 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) @@ -15368,19 +15435,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 internalPop: 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 internalPop: 2; internalStackTopPut: objectMemory falseObject] ]. - ^self internalPop: 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 ] @@ -15453,86 +15531,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' } @@ -15593,80 +15682,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' } @@ -15681,7 +15785,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' } @@ -15713,7 +15817,7 @@ StackInterpreter >> unknownBytecode [ { #category : #'sista bytecodes' } StackInterpreter >> unknownInlinePrimitive [ "Should be inlined everywhere to access localIP" - localIP := localIP - 3. + instructionPointer := instructionPointer - 3. self respondToUnknownBytecode ] @@ -15990,7 +16094,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: stackPointer inPage: stackPage. self assert: stackPages pageListIsWellFormed ] diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st index 273265ef18..3a9a9a0ed2 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: @@ -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]). @@ -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. @@ -652,7 +641,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' } @@ -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. @@ -900,7 +889,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 +906,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 ] @@ -1210,165 +1199,6 @@ StackInterpreterSimulator >> loadNewPlugin: pluginString [ entry] ] -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localFP [ - ^localFP -] - -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localIP [ - ^localIP -] - -{ #category : #'spur bootstrap' } -StackInterpreterSimulator >> localIP: pc [ - localIP := pc -] - -{ #category : #'spur bootstrap' } -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. @@ -1706,7 +1536,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 @@ -1833,7 +1663,7 @@ StackInterpreterSimulator >> printHexnpnp: anInteger [ { #category : #'debug printing' } StackInterpreterSimulator >> printLCS [ - self printCallStackFP: localFP + self printCallStackFP: framePointer ] { #category : #'debug printing' } @@ -1932,7 +1762,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 ] @@ -1948,13 +1778,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. @@ -1964,9 +1794,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 ] @@ -1985,7 +1815,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 ] @@ -2215,32 +2045,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. @@ -2307,33 +2111,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. @@ -2405,70 +2182,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. diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBAssignmentNode.extension.st index 37a98c6879..cd96487a70 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,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. - ^TStmtListNode 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/RBBlockNode.extension.st b/smalltalksrc/VMMakerCompatibilityForPharo6/RBBlockNode.extension.st index 476b9b4502..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 isStmtList - ifTrue: [statementList addAll: newS statements] - ifFalse: [statementList add: newS]]. - statementList ifEmpty: [ - statementList add: (TVariableNode new setName: 'nil'). - ]. - ^TStmtListNode new - setArguments: (arguments asArray collect: [:arg | arg name]) - statements: statementList; - comment: self commentOrNil + + ^ body asTranslatorNodeIn: aTMethod ] { #category : #'*VMMakerCompatibilityForPharo6-testing' } 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..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,148 +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]. - (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: - [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: [ - ^ TStmtListNode new - setArguments: #(); - setStatements: { - 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} - }; - yourself ]. - - (#(#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: [ - ^ TStmtListNode new - setArguments: #(); - setStatements: { - TAssignmentNode new - setVariable: (TVariableNode new setName: blockWithPossibleArgument args first) - expression: expression. - - TSendNode new - setSelector: usedSelector - receiver: rcvrOrNil - arguments: args - }; - yourself - ] ]. - - (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 isStmtList - 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 ] 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]]) 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 -] 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. ] 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.