Closure support

pharo-project · Dec 1, 2023 · ed8dd56 · ed8dd56
1 parent e6dbbf5
commit ed8dd56
Show file tree

Hide file tree

Showing 7 changed files with 148 additions and 117 deletions.
diff --git a/smalltalksrc/VMMaker/CogBytecodeDescriptor.class.st b/smalltalksrc/VMMaker/CogBytecodeDescriptor.class.st
@@ -119,12 +119,6 @@ CogBytecodeDescriptor >> isBranchTrue: anObject [
 	^isBranchTrue := anObject
 ]
 
-{ #category : #accessing }
-CogBytecodeDescriptor >> isCallPrimitive [
-
-	^generator == #genCallPrimitiveBytecode
-]
-
 { #category : #accessing }
 CogBytecodeDescriptor >> isConditionalBranch [
 	<inline: true>

diff --git a/smalltalksrc/VMMaker/CogObjectRepresentation.class.st b/smalltalksrc/VMMaker/CogObjectRepresentation.class.st
@@ -195,7 +195,7 @@ CogObjectRepresentation >> genCreateClosureAt: bcpc numArgs: numArgs numCopied:
 ]
 
 { #category : #'bytecode generator support' }
-CogObjectRepresentation >> genCreateFullClosure: compiledBlock numArgs: numArgs numCopied: numCopied ignoreContext: ignoreContext contextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock [
+CogObjectRepresentation >> genCreateFullClosureInLiteral: index numCopied: numCopied ignoreContext: ignoreContext contextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock intoRegister: anObject [
 	"Create a full closure"
 	self subclassResponsibility
 ]

diff --git a/smalltalksrc/VMMaker/CogObjectRepresentationForSpur.class.st b/smalltalksrc/VMMaker/CogObjectRepresentationForSpur.class.st
@@ -474,42 +474,60 @@ CogObjectRepresentationForSpur >> genConvertSmallIntegerToCharacterInReg: reg [
 ]
 
 { #category : #'bytecode generator support' }
-CogObjectRepresentationForSpur >> genCreateFullClosure: compiledBlock numArgs: numArgs numCopied: numCopied ignoreContext: ignoreContext contextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock [
+CogObjectRepresentationForSpur >> genCreateFullClosureInIndex: anIndex numCopied: numCopied ignoreContext: ignoreContext contextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock intoRegister: destinationRegister [
 	"Create a full closure with the given values."
-	| numSlots byteSize header skip |
+
 	<var: #skip type: #'AbstractInstruction *'>
+	| numSlots byteSize header skip numArgs compiledBlock |
+	compiledBlock := cogit getLiteral: anIndex.
+	numArgs := coInterpreter argumentCountOf: compiledBlock.
 
-	"First get thisContext into ReceiverResultReg and thence in ClassReg."
+	"First get thisContext into destinationRegister and thence in ClassReg."
 	ignoreContext
 		ifTrue: [ cogit genMoveNilR: ClassReg ]
-		ifFalse: 
-			[self genGetActiveContextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock.
-			cogit MoveR: ReceiverResultReg R: ClassReg ].
-
+		ifFalse: [
+			self
+				genGetActiveContextNumArgs: contextNumArgs
+				large: contextIsLarge
+				inBlock: contextIsBlock.
+			cogit MoveR: destinationRegister R: ClassReg ].
+
 	numSlots := FullClosureFirstCopiedValueIndex + numCopied.
 	byteSize := objectMemory smallObjectBytesForSlots: numSlots.
 	self assert: ClassFullBlockClosureCompactIndex ~= 0.
 	header := objectMemory
-					headerForSlots: numSlots
-					format: objectMemory indexablePointersFormat
-					classIndex: ClassFullBlockClosureCompactIndex.
-	cogit MoveAw: objectMemory freeStartAddress R: ReceiverResultReg.
-	self genStoreHeader: header intoNewInstance: ReceiverResultReg using: TempReg.
+		          headerForSlots: numSlots
+		          format: objectMemory indexablePointersFormat
+		          classIndex: ClassFullBlockClosureCompactIndex.
+	cogit MoveAw: objectMemory freeStartAddress R: destinationRegister.
+	self
+		genStoreHeader: header
+		intoNewInstance: destinationRegister
+		using: TempReg.
 	cogit
-		LoadEffectiveAddressMw: byteSize r: ReceiverResultReg R: TempReg;
+		LoadEffectiveAddressMw: byteSize r: destinationRegister R: TempReg;
 		MoveR: TempReg Aw: objectMemory freeStartAddress;
 		CmpCq: objectMemory getScavengeThreshold R: TempReg.
 	skip := cogit JumpBelow: 0.
 	cogit CallRT: ceScheduleScavengeTrampoline.
 	skip jmpTarget: cogit Label.
 
 	cogit
-		MoveR: ClassReg Mw: FullClosureOuterContextIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg;
+		MoveR: ClassReg
+		Mw: FullClosureOuterContextIndex * objectMemory bytesPerOop
+			+ objectMemory baseHeaderSize
+		r: destinationRegister;
 		genMoveConstant: compiledBlock R: TempReg;
-		MoveR: TempReg Mw: FullClosureCompiledBlockIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg;
+		MoveR: TempReg
+		Mw: FullClosureCompiledBlockIndex * objectMemory bytesPerOop
+			+ objectMemory baseHeaderSize
+		r: destinationRegister;
 		MoveCq: (objectMemory integerObjectOf: numArgs) R: TempReg;
-		MoveR: TempReg Mw: FullClosureNumArgsIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg.
-	^0
+		MoveR: TempReg
+		Mw: FullClosureNumArgsIndex * objectMemory bytesPerOop
+			+ objectMemory baseHeaderSize
+		r: destinationRegister.
+	^ 0
 ]
 
 { #category : #'compile abstract instructions' }

diff --git a/smalltalksrc/VMMaker/DruidJIT.class.st b/smalltalksrc/VMMaker/DruidJIT.class.st
@@ -690,42 +690,60 @@ DruidJIT >> genConvertIntegerToSmallIntegerInReg: reg [
 ]
 
 { #category : #'trait candidates' }
-DruidJIT >> genCreateFullClosure: compiledBlock numArgs: numArgs numCopied: numCopied ignoreContext: ignoreContext contextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock [
+DruidJIT >> genCreateFullClosureInIndex: anIndex numCopied: numCopied ignoreContext: ignoreContext contextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock intoRegister: destinationRegister [
 	"Create a full closure with the given values."
-	| numSlots byteSize header skip |
+
 	<var: #skip type: #'AbstractInstruction *'>
+	| numSlots byteSize header skip numArgs compiledBlock |
+	compiledBlock := self getLiteral: anIndex.
+	numArgs := coInterpreter argumentCountOf: compiledBlock.
 
-	"First get thisContext into ReceiverResultReg and thence in ClassReg."
+	"First get thisContext into destinationRegister and thence in ClassReg."
 	ignoreContext
 		ifTrue: [ self genMoveNilR: ClassReg ]
-		ifFalse: 
-			[self genGetActiveContextNumArgs: contextNumArgs large: contextIsLarge inBlock: contextIsBlock.
-			self MoveR: ReceiverResultReg R: ClassReg ].
-
+		ifFalse: [
+			self
+				genGetActiveContextNumArgs: contextNumArgs
+				large: contextIsLarge
+				inBlock: contextIsBlock.
+			self MoveR: destinationRegister R: ClassReg ].
+
 	numSlots := FullClosureFirstCopiedValueIndex + numCopied.
 	byteSize := objectMemory smallObjectBytesForSlots: numSlots.
 	self assert: ClassFullBlockClosureCompactIndex ~= 0.
 	header := objectMemory
-					headerForSlots: numSlots
-					format: objectMemory indexablePointersFormat
-					classIndex: ClassFullBlockClosureCompactIndex.
-	self MoveAw: objectMemory freeStartAddress R: ReceiverResultReg.
-	self genStoreHeader: header intoNewInstance: ReceiverResultReg using: TempReg.
+		          headerForSlots: numSlots
+		          format: objectMemory indexablePointersFormat
+		          classIndex: ClassFullBlockClosureCompactIndex.
+	self MoveAw: objectMemory freeStartAddress R: destinationRegister.
+	self
+		genStoreHeader: header
+		intoNewInstance: destinationRegister
+		using: TempReg.
 	self
-		LoadEffectiveAddressMw: byteSize r: ReceiverResultReg R: TempReg;
+		LoadEffectiveAddressMw: byteSize r: destinationRegister R: TempReg;
 		MoveR: TempReg Aw: objectMemory freeStartAddress;
 		CmpCq: objectMemory getScavengeThreshold R: TempReg.
 	skip := self JumpBelow: 0.
 	self CallRT: ceScheduleScavengeTrampoline.
 	skip jmpTarget: self Label.
 
 	self
-		MoveR: ClassReg Mw: FullClosureOuterContextIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg;
+		MoveR: ClassReg
+		Mw: FullClosureOuterContextIndex * objectMemory bytesPerOop
+			+ objectMemory baseHeaderSize
+		r: destinationRegister;
 		genMoveConstant: compiledBlock R: TempReg;
-		MoveR: TempReg Mw: FullClosureCompiledBlockIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg;
+		MoveR: TempReg
+		Mw: FullClosureCompiledBlockIndex * objectMemory bytesPerOop
+			+ objectMemory baseHeaderSize
+		r: destinationRegister;
 		MoveCq: (objectMemory integerObjectOf: numArgs) R: TempReg;
-		MoveR: TempReg Mw: FullClosureNumArgsIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg.
-	^0
+		MoveR: TempReg
+		Mw: FullClosureNumArgsIndex * objectMemory bytesPerOop
+			+ objectMemory baseHeaderSize
+		r: destinationRegister.
+	^ 0
 ]
 
 { #category : #'trait candidates' }

diff --git a/smalltalksrc/VMMaker/StackInterpreter.class.st b/smalltalksrc/VMMaker/StackInterpreter.class.st
@@ -4599,6 +4599,36 @@ StackInterpreter >> createActualMessageTo: lookupClass [
 	argumentCount := 1
 ]
 
+{ #category : #'stack bytecodes' }
+StackInterpreter >> createFullClosureInIndex: compiledBlockLiteralIndex numCopied: numCopied ignoreContext: ignoreContext receiverIsOnStack: receiverIsOnStack [
+	"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.."
+
+	<inline: true>
+	| newClosure context numArgs compiledBlock |
+	compiledBlock := self literalMaybeForwarder:
+		                 compiledBlockLiteralIndex.
+	self assert: (objectMemory isOopCompiledMethod: compiledBlock).
+
+	"No need to record the pushed copied values in the outerContext."
+	numArgs := self argumentCountOf: compiledBlock.
+
+	context := ignoreContext
+		           ifTrue: [ objectMemory nilObject ]
+		           ifFalse: [
+			           self
+				           ensureFrameIsMarried: framePointer
+				           SP:
+				           stackPointer + (numCopied * objectMemory bytesPerOop) ].
+	newClosure := self
+		              fullClosureIn: context
+		              numArgs: numArgs
+		              numCopiedValues: numCopied
+		              compiledBlock: compiledBlock.
+	^ newClosure
+]
+
 { #category : #accessing }
 StackInterpreter >> currentBytecode [
 
@@ -5288,18 +5318,40 @@ StackInterpreter >> extPushFullClosureBytecode [
 		ignoreOuterContext: i = 1
 	 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.."
-	| compiledBlockLiteralIndex compiledBlock byte numArgs numCopied receiverIsOnStack ignoreContext |
+	 Sets outerContext, numArgs and receiver as specified.."
+
+	| compiledBlockLiteralIndex byte numCopied receiverIsOnStack ignoreContext newClosure closureReceiver |
 	compiledBlockLiteralIndex := self fetchByte + (extA << 8).
 	extA := 0.
-	compiledBlock := self literalMaybeForwarder: compiledBlockLiteralIndex.
-	self assert: (objectMemory isOopCompiledMethod: compiledBlock).
-	numArgs := self argumentCountOf: compiledBlock.
 	byte := self fetchByte.
-	numCopied := byte bitAnd: 1<< 6 - 1.
+	numCopied := byte bitAnd: 1 << 6 - 1.
 	receiverIsOnStack := byte anyMask: 1 << 7.
 	ignoreContext := byte anyMask: 1 << 6.
-	self pushFullClosureNumArgs: numArgs copiedValues: numCopied compiledBlock: compiledBlock receiverIsOnStack: receiverIsOnStack ignoreContext: ignoreContext
+	newClosure := self
+		              createFullClosureInIndex: compiledBlockLiteralIndex
+		              numCopied: numCopied
+		              ignoreContext: ignoreContext
+		              receiverIsOnStack: receiverIsOnStack.
+
+	self druidIgnore: [ self maybeTraceBlockCreation: newClosure ].
+
+	1 to: numCopied do: [ :i |
+		| value |
+		value := self popStack.
+		objectMemory
+			storePointerUnchecked:
+			FullClosureFirstCopiedValueIndex + numCopied - i
+			ofObject: newClosure
+			withValue: value ].
+	closureReceiver := receiverIsOnStack
+		                   ifTrue: [ self popStack ]
+		                   ifFalse: [ self receiver ].
+	objectMemory
+		storePointerUnchecked: FullClosureReceiverIndex
+		ofObject: newClosure
+		withValue: closureReceiver.
+	self fetchNextBytecode.
+	self push: newClosure
 ]
 
 { #category : #'stack bytecodes' }
@@ -12417,52 +12469,6 @@ StackInterpreter >> pushFloat: f [
 	self push: (objectMemory floatObjectOf: f).
 ]
 
-{ #category : #'stack bytecodes' }
-StackInterpreter >> 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.."
-
-	<inline: true>
-	| numCopied newClosure context startIndex |
-	"No need to record the pushed copied values in the outerContext."
-	context := ignoreContext
-		           ifTrue: [ objectMemory nilObject ]
-		           ifFalse: [
-			           self
-				           ensureFrameIsMarried: framePointer
-				           SP:
-				           stackPointer
-				           + (numCopiedArg * objectMemory bytesPerOop) ].
-	newClosure := self
-		              fullClosureIn: context
-		              numArgs: numArgs
-		              numCopiedValues: numCopiedArg
-		              compiledBlock: compiledBlock.
-	self maybeTraceBlockCreation: newClosure.
-	receiverIsOnStack
-		ifFalse: [
-			startIndex := FullClosureFirstCopiedValueIndex.
-			objectMemory
-				storePointerUnchecked: FullClosureReceiverIndex
-				ofObject: newClosure
-				withValue: self receiver.
-			numCopied := numCopiedArg ]
-		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.
-			 Thus, can use unchecked stores."
-			objectMemory
-				storePointerUnchecked: i + startIndex
-				ofObject: newClosure
-				withValue: (self stackValue: numCopied - i - 1) ].
-		self pop: numCopied ].
-	self fetchNextBytecode.
-	self push: newClosure
-]
-
 { #category : #'internal interpreter access' }
 StackInterpreter >> pushInteger: integerValue [
 	self push: (objectMemory integerObjectOf: integerValue).

diff --git a/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st b/smalltalksrc/VMMaker/StackInterpreterSimulator.class.st
@@ -1380,12 +1380,6 @@ StackInterpreterSimulator >> profileSends: nBytecodes [
 	self close
 ]
 
-{ #category : #'debugging traps' }
-StackInterpreterSimulator >> pushMaybeContextReceiverVariable: index [
-	"(index = SenderIndex or: [index = ClosureIndex]) ifTrue: [self halt]."
-	^super pushMaybeContextReceiverVariable: index
-]
-
 { #category : #'I/O primitives support' }
 StackInterpreterSimulator >> queueForwardedEvent: event [
 	eventQueue ifNil:

diff --git a/smalltalksrc/VMMaker/StackToRegisterMappingCogit.class.st b/smalltalksrc/VMMaker/StackToRegisterMappingCogit.class.st
@@ -1548,43 +1548,44 @@ StackToRegisterMappingCogit >> genCmpArgIsConstant: argIsConstant rcvrIsConstant
 { #category : #'bytecode generators' }
 StackToRegisterMappingCogit >> genExtPushFullClosureBytecode [
 	"Full Block creation compilation. The block's actual code will be compiled separatedly."
+
 	"*	255		11111111	xxxxxxxx	siyyyyyy	push Closure Compiled block literal index xxxxxxxx (+ Extend A * 256) numCopied yyyyyy receiverOnStack: s = 1 ignoreOuterContext: i = 1"
-	| numCopied ignoreContext receiverIsOnStack compiledBlock reg |
+
+	| numCopied ignoreContext receiverIsOnStack reg |
 	self assert: needsFrame.
-	compiledBlock := self getLiteral: byte1 + (extA << 8).
 	extA := 0.
-	numCopied := byte2 bitAnd: 1<< 6 - 1.
+	numCopied := byte2 bitAnd: 1 << 6 - 1.
 	receiverIsOnStack := byte2 anyMask: 1 << 7.
 	ignoreContext := byte2 anyMask: 1 << 6.
 	self voidReceiverResultRegContainsSelf.
-	self ssAllocateCallReg: ReceiverResultReg
+	self
+		ssAllocateCallReg: ReceiverResultReg
 		and: SendNumArgsReg
 		and: ClassReg.
 	objectRepresentation
-		genCreateFullClosure: compiledBlock
-		numArgs: (coInterpreter argumentCountOf: compiledBlock)
+		genCreateFullClosureInIndex: byte1 + (extA << 8)
 		numCopied: numCopied
 		ignoreContext: ignoreContext
 		contextNumArgs: methodOrBlockNumArgs
 		large: (coInterpreter methodNeedsLargeContext: methodObj)
-		inBlock: inBlock.
+		inBlock: inBlock
+		intoRegister: ReceiverResultReg.
 	"Closure in ReceiverResultReg"
-	1 to: numCopied do:
-		[:i| 
+	1 to: numCopied do: [ :i |
 		reg := self ssStorePop: true toPreferredReg: TempReg.
-		 objectRepresentation
+		objectRepresentation
 			genStoreSourceReg: reg
 			slotIndex: FullClosureFirstCopiedValueIndex + numCopied - i
-			intoNewObjectInDestReg: ReceiverResultReg].
+			intoNewObjectInDestReg: ReceiverResultReg ].
 	receiverIsOnStack
-		ifTrue: [reg := self ssStorePop: true toPreferredReg: TempReg]
-		ifFalse: [self simSelf copyToReg: (reg := TempReg)].
+		ifTrue: [ reg := self ssStorePop: true toPreferredReg: TempReg ]
+		ifFalse: [ self simSelf copyToReg: (reg := TempReg) ].
 	objectRepresentation
-			genStoreSourceReg: reg
-			slotIndex: FullClosureReceiverIndex
-			intoNewObjectInDestReg: ReceiverResultReg.
+		genStoreSourceReg: reg
+		slotIndex: FullClosureReceiverIndex
+		intoNewObjectInDestReg: ReceiverResultReg.
 	self ssPushRegister: ReceiverResultReg.
-	^0
+	^ 0
 ]
 
 { #category : #'bytecode generators' }