Vm-dev January 2022

vm-dev@lists.squeakfoundation.org

15 participants
50 discussions

VM Maker: VMMaker.oscog-eem.3129.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3129.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3129 Author: eem Time: 2 January 2022, 8:19:55.488175 pm UUID: 1e88d1b1-a3cd-4dfa-a731-cfc7bb84c393 Ancestors: VMMaker.oscog-eem.3128 Fix backing up the pc on wait when the process being suspended has an interpreter frame that has a bytecode pc on top of stack rather than the ceReturnToInterpreterPC. Fix a slip in statAverageLivePagesWhenMapping: Fix printing the method field in printContext: (the oop was previously omitted) =============== Diff against VMMaker.oscog-eem.3128 =============== Item was changed: ----- Method: CoInterpreter>>backupProcess:toBlockingSendTo: (in category 'process primitive support') ----- backupProcess: aProcess toBlockingSendTo: conditionVariable "Assume aProcess is waiting on a condition variable. Backup the PC of aProcess to the send that entered the wait state. Since the PC at a send is not a susension point in machine code, this entails converting a machine code frame into an interpreter frame. primitiveEnterCriticalSection pushes false for blocked waiters. false must be replaced by the condition variable." | context theMethod pc sp theIP theNewIP theFP thePage | context := objectMemory fetchPointer: SuspendedContextIndex ofObject: aProcess. self assert: (objectMemory isContext: context). theMethod := objectMemory fetchPointer: MethodIndex ofObject: context. (self isSingleContext: context) ifTrue: [pc := objectMemory fetchPointer: InstructionPointerIndex ofObject: context. sp := objectMemory fetchPointer: StackPointerIndex ofObject: context. self assert: ((objectMemory isIntegerObject: pc) and: [(objectMemory integerValueOf: pc) > 0]). self assert: ((objectMemory isIntegerObject: sp) and: [(objectMemory integerValueOf: sp) > 0]). theIP := theMethod + objectMemory baseHeaderSize + (objectMemory integerValueOf: pc) - 1. theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). pc := theNewIP - theMethod - objectMemory baseHeaderSize + 1. objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: context withValue: (objectMemory integerObjectOf: pc). sp := (objectMemory integerValueOf: sp) + ReceiverIndex. "implicitly converts to 0 relative" self assert: ((objectMemory fetchPointer: sp ofObject: context) = objectMemory falseObject or: [(objectMemory fetchPointer: sp ofObject: context) = conditionVariable]). objectMemory storePointer: sp ofObject: context withValue: conditionVariable. ^self]. self assert: (self isMarriedOrWidowedContext: context). self deny: (self isWidowedContextNoConvert: context). theFP := self frameOfMarriedContext: context. thePage := stackPages stackPageFor: theFP. self deny: thePage = stackPage. self assert: theFP = thePage headFP. (self isMachineCodeFrame: theFP) ifTrue: [| mcpc maybeClosure startBcpc cogMethodForIP | mcpc := stackPages longAt: thePage headSP. "a machine code pc... it must be converted..." maybeClosure := objectMemory fetchPointer: ClosureIndex ofObject: context. (maybeClosure ~= objectMemory nilObject and: [self isVanillaBlockClosure: maybeClosure]) ifTrue: [cogMethodForIP := self mframeHomeMethod: theFP. startBcpc := self startPCOfClosure: maybeClosure] ifFalse: [cogMethodForIP := self cCoerceSimple: (self mframeMethod: theFP) to: #'CogMethod *'. startBcpc := self startPCOfMethod: theMethod]. theIP := cogit bytecodePCFor: mcpc startBcpc: startBcpc in: cogMethodForIP. theIP := theIP + theMethod + objectMemory baseHeaderSize. theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). self convertFrame: theFP toInterpreterFrame: theIP - theNewIP] ifFalse: + [theIP := stackPages longAt: thePage headSP. + theIP = cogit ceReturnToInterpreterPC + ifTrue: + [theIP := (self iframeSavedIP: theFP) + 1. "fetchByte uses pre-increment; must + 1 to point at correct bytecode..." + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + self iframeSavedIP: theFP put: theNewIP - 1] "fetchByte uses pre-increment; must - 1 to fetch correct bytecode..." + ifFalse: + [theIP := theIP + 1. "fetchByte uses pre-increment; must + 1 to point at correct bytecode..." + self assert: (self validInstructionPointer: theIP inMethod: theMethod framePointer: theFP). + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + stackPages longAt: thePage headSP put: theNewIP - 1]]. "fetchByte uses pre-increment; must - 1 to fetch correct bytecode..." - [self assert: (stackPages longAt: thePage headSP) = cogit ceReturnToInterpreterPC. - theIP := (self iframeSavedIP: theFP) + 1 "fetchByte uses pre-increment; must + 1 to point at correct bytecode...". - theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. - self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). - self iframeSavedIP: theFP put: theNewIP - 1]. "fetchByte uses pre-increment; must - 1 to fetch correct bytecode..." self assert: ((stackPages longAt: thePage headSP + objectMemory wordSize) = objectMemory falseObject or: [(stackPages longAt: thePage headSP + objectMemory wordSize) = conditionVariable]). stackPages longAt: thePage headSP + objectMemory wordSize put: conditionVariable! Item was changed: ----- Method: CoInterpreter>>printMethodFieldForPrintContext: (in category 'debug printing') ----- printMethodFieldForPrintContext: aContext <inline: true> | meth | meth := objectMemory fetchPointer: MethodIndex ofObject: aContext. + '%P: ' f: transcript printf: meth. self printOopShortInner: meth. (self methodHasCogMethod: meth) ifTrue: + [' (%P)' f: transcript printf: (self cogMethodOf: meth)]. - [self space; print: '('; printHexnp: (self cogMethodOf: meth); print: ')']. self cr! Item was changed: ----- Method: CogStackPages>>statAverageLivePagesWhenMapping: (in category 'statistics') ----- statAverageLivePagesWhenMapping: aFloat <var: #aFloat type: #double> + aFloat = 0.0 - aFloat == 0.0 ifTrue: [statPageCountWhenMappingSum := statNumMaps := 0] ifFalse: [coInterpreter primitiveFailFor: PrimErrBadArgument]! Item was changed: ----- Method: StackInterpreter>>printMethodFieldForPrintContext: (in category 'debug printing') ----- printMethodFieldForPrintContext: aContext <inline: true> + | theMethod | + theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext. + '%P: ' f: transcript printf: theMethod. + self shortPrintOop: theMethod! - self shortPrintOop: (objectMemory fetchPointer: MethodIndex ofObject: aContext)!

1 0

[OpenSmalltalk/opensmalltalk-vm] af6051: CogVM source as per VMMaker.oscog-eem.3128
by Eliot Miranda 02 Jan '22

02 Jan '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: af6051425fbc20168c199d580680856edd15331b https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/af6051425fbc20168c… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2022-01-02 (Sun, 02 Jan 2022) Changed paths: M src/ckformat.c M src/spur32.cog.lowcode/cogit.h M src/spur32.cog.lowcode/cointerp.c M src/spur32.cog.lowcode/cointerp.h M src/spur32.cog.lowcode/gcc3x-cointerp.c M src/spur32.cog/cogit.h M src/spur32.cog/cointerp.c M src/spur32.cog/cointerp.h M src/spur32.cog/cointerpmt.c M src/spur32.cog/cointerpmt.h M src/spur32.cog/gcc3x-cointerp.c M src/spur32.cog/gcc3x-cointerpmt.c M src/spur32.sista/cogit.h M src/spur32.sista/cointerp.c M src/spur32.sista/cointerp.h M src/spur32.sista/gcc3x-cointerp.c M src/spur64.cog.lowcode/cogit.h M src/spur64.cog.lowcode/cointerp.c M src/spur64.cog.lowcode/cointerp.h M src/spur64.cog.lowcode/gcc3x-cointerp.c M src/spur64.cog/cogit.h M src/spur64.cog/cointerp.c M src/spur64.cog/cointerp.h M src/spur64.cog/cointerpmt.c M src/spur64.cog/cointerpmt.h M src/spur64.cog/gcc3x-cointerp.c M src/spur64.cog/gcc3x-cointerpmt.c M src/spur64.sista/cogit.h M src/spur64.sista/cointerp.c M src/spur64.sista/cointerp.h M src/spur64.sista/gcc3x-cointerp.c M src/v3.cog/cogit.h M src/v3.cog/cointerp.c M src/v3.cog/cointerp.h M src/v3.cog/gcc3x-cointerp.c Log Message: ----------- CogVM source as per VMMaker.oscog-eem.3128 Oops! Forgot to commit the CoInterpreterPrimitives versions of primitiveResume (comment change only) and primitiveSuspend (the new semantics).

1 0

VM Maker: VMMaker.oscog-eem.3128.mcz
by commits＠source.squeak.org 02 Jan '22

02 Jan '22

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3128.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3128 Author: eem Time: 2 January 2022, 1:06:23.161391 pm UUID: 8522e1f3-7b76-400f-91d1-2c491364717b Ancestors: VMMaker.oscog-eem.3127 Oops! Forgot to commit the CoInterpreterPrimitives versions of primitiveResume (comment change only) and primitiveSuspend (the new semantics) =============== Diff against VMMaker.oscog-eem.3127 =============== Item was changed: ----- Method: CoInterpreterPrimitives>>primitiveResume (in category 'process primitives') ----- primitiveResume "Put this process on the scheduler's lists thus allowing it to proceed next time there is a chance for processes of it's priority level. It must go to the back of its run queue so as not to preempt any already running processes at this level. If the process's priority is higher than the current process, preempt the current process." | proc ctxt inInterpreter | proc := self stackTop. "rcvr" + "Alas in Spur we need a read barrier" ctxt := objectMemory followField: SuspendedContextIndex ofObject: proc. "written this way to get better Slang inlining" (objectMemory isContext: ctxt) ifFalse: [^self primitiveFailFor: PrimErrBadReceiver]. "We're about to switch process, either to an interpreted frame or a machine code frame. To know whether to return or enter machine code we have to know from whence we came. We could have come from the interpreter, either directly or via a machine code primitive. We could have come from machine code. The instructionPointer tells us where from:" inInterpreter := instructionPointer >= objectMemory startOfMemory. (self resume: proc preemptedYieldingIf: preemptionYields from: CSResume) ifTrue: + [self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter]! - [self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter] - - "Personally I would like to check MyList, which should not be one of the elements of the scheduler lists. - But there are awful race conditions in things like should:notTakeMoreThan: that mean we can't. - eem 9/27/2010 23:08, updated eem 5/20/2021 15:36. e.g. - - | proc field | - proc := self stackTop. ''rcvr'' - ''We only have to check for myList being nil. If it is nil then this is either the active process or - a process suspended with primitiveSuspend (and if it is the activeProcess suspendedContext will - be nil and the isContext: test will fail). If it is not nil then either the process is waiting on some - semaphore-like list or on one of the scheduler's lists. If it is on some semaphore-like list it should - not resume. If it is on one of the scheduler's lists it is runnable (already resumed).'' - field := objectMemory followField: MyListIndex ofObject: proc. - objectMemory nilObject = field ifFalse: - [^self primitiveFailFor: PrimErrInappropriate]. - field := objectMemory followField: SuspendedContextIndex ofObject: proc. - (objectMemory isContext: field) ifFalse: - [^self primitiveFailFor: PrimErrBadReceiver]. - ''We're about to switch process, either to an interpreted frame or a - machine code frame. To know whether to return or enter machine code - we have to know from whence we came. We could have come from the - interpreter, either directly or via a machine code primitive. We could have - come from machine code. The instructionPointer tells us where from:'' - inInterpreter := instructionPointer >= objectMemory startOfMemory. - (self resume: proc preemptedYieldingIf: preemptionYields from: CSResume) ifTrue: - [self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter]"! Item was changed: ----- Method: CoInterpreterPrimitives>>primitiveSuspend (in category 'process primitives') ----- primitiveSuspend + "Primitive. Suspend the receiver, aProcess, such that it can be executed again + by sending #resume. If the given process is not the active process, take it off + its corresponding list. If the list was not its run queue assume it was on some + condition variable (Semaphore, Mutex) and back up its pc to the send that + invoked the wait state the process entered. Hence when the process resumes + it will reenter the wait state. Answer the list the receiver was previously on iff + it was not active and not blocked, otherwise answer nil." + | process myList ok | - "Primitive. Suspend the receiver, aProcess such that it can be executed again - by sending #resume. If the given process is not currently running, take it off - its corresponding list. The primitive returns the list the receiver was previously on." - | process myList | process := self stackTop. process = self activeProcess ifTrue: [| inInterpreter | "We're going to switch process, either to an interpreted frame or a machine code frame. To know whether to return or enter machine code we have to know from whence we came. We could have come from the interpreter, either directly or via a machine code primitive. We could have come from machine code. The instructionPointer tells us where from:" self pop: 1 thenPush: objectMemory nilObject. inInterpreter := instructionPointer >= objectMemory startOfMemory. self transferTo: self wakeHighestPriority from: CSSuspend. ^self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter]. + "Alas in Spur we need a read barrier" + myList := objectMemory followField: MyListIndex ofObject: process. - myList := objectMemory fetchPointer: MyListIndex ofObject: process. - "XXXX Fixme. We should really check whether myList is a kind of LinkedList or not - but we can't easily so just do a quick check for nil which is the most common case." myList = objectMemory nilObject ifTrue: [^self primitiveFailFor: PrimErrBadReceiver]. + ok := self removeProcess: process fromList: myList. + ok ifFalse: + [^self primitiveFailFor: PrimErrOperationFailed]. + objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject. + self assert: RevisedSuspend. + (RevisedSuspend + and: [(objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag]) + ifTrue: + [self backupProcess: process toBlockingSendTo: myList. + self pop: 1 thenPush: objectMemory nilObject] + ifFalse: + [self pop: 1 thenPush: myList]! - "Alas in Spur we need a read barrier" - (objectMemory isForwarded: myList) ifTrue: - [myList := objectMemory followForwarded: myList. - objectMemory storePointer: MyListIndex ofObject: process withValue: myList]. - self removeProcess: process fromList: myList. - self successful ifTrue: - [objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject. - self pop: 1 thenPush: myList]!

1 0

[OpenSmalltalk/opensmalltalk-vm] b266a5: CogVM source as per Name: VMMaker.oscog-eem.3127
by Eliot Miranda 02 Jan '22

02 Jan '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: b266a5968335f4df11470a7f844391c03d0a9205 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/b266a5968335f4df11… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2022-01-01 (Sat, 01 Jan 2022) Changed paths: M src/plugins/DESPlugin/DESPlugin.c M src/plugins/DSAPrims/DSAPrims.c M src/plugins/MD5Plugin/MD5Plugin.c M src/plugins/SHA2Plugin/SHA2Plugin.c M src/plugins/SqueakFFIPrims/SqueakFFIPrims.c M src/spur32.cog.lowcode/cogit.h M src/spur32.cog.lowcode/cogitARMv5.c M src/spur32.cog.lowcode/cogitIA32.c M src/spur32.cog.lowcode/cointerp.c M src/spur32.cog.lowcode/cointerp.h M src/spur32.cog.lowcode/gcc3x-cointerp.c M src/spur32.cog/cogit.h M src/spur32.cog/cogitARMv5.c M src/spur32.cog/cogitIA32.c M src/spur32.cog/cointerp.c M src/spur32.cog/cointerp.h M src/spur32.cog/cointerpmt.c M src/spur32.cog/cointerpmt.h M src/spur32.cog/gcc3x-cointerp.c M src/spur32.cog/gcc3x-cointerpmt.c M src/spur32.sista/cogit.h M src/spur32.sista/cogitARMv5.c M src/spur32.sista/cogitIA32.c M src/spur32.sista/cointerp.c M src/spur32.sista/cointerp.h M src/spur32.sista/gcc3x-cointerp.c M src/spur32.stack.lowcode/gcc3x-interp.c M src/spur32.stack.lowcode/interp.c M src/spur32.stack/gcc3x-interp.c M src/spur32.stack/interp.c M src/spur32.stack/validImage.c M src/spur64.cog.lowcode/cogit.h M src/spur64.cog.lowcode/cogitARMv8.c M src/spur64.cog.lowcode/cogitX64SysV.c M src/spur64.cog.lowcode/cogitX64WIN64.c M src/spur64.cog.lowcode/cointerp.c M src/spur64.cog.lowcode/cointerp.h M src/spur64.cog.lowcode/gcc3x-cointerp.c M src/spur64.cog/cogit.h M src/spur64.cog/cogitARMv8.c M src/spur64.cog/cogitX64SysV.c M src/spur64.cog/cogitX64WIN64.c M src/spur64.cog/cointerp.c M src/spur64.cog/cointerp.h M src/spur64.cog/cointerpmt.c M src/spur64.cog/cointerpmt.h M src/spur64.cog/gcc3x-cointerp.c M src/spur64.cog/gcc3x-cointerpmt.c M src/spur64.sista/cogit.h M src/spur64.sista/cogitARMv8.c M src/spur64.sista/cogitX64SysV.c M src/spur64.sista/cogitX64WIN64.c M src/spur64.sista/cointerp.c M src/spur64.sista/cointerp.h M src/spur64.sista/gcc3x-cointerp.c M src/spur64.stack.lowcode/gcc3x-interp.c M src/spur64.stack.lowcode/interp.c M src/spur64.stack/gcc3x-interp.c M src/spur64.stack/interp.c M src/spur64.stack/validImage.c M src/v3.cog/cogit.h M src/v3.cog/cogitARMv5.c M src/v3.cog/cogitIA32.c M src/v3.cog/cointerp.c M src/v3.cog/cointerp.h M src/v3.cog/gcc3x-cointerp.c M src/v3.stack/gcc3x-interp.c M src/v3.stack/interp.c Log Message: ----------- CogVM source as per Name: VMMaker.oscog-eem.3127 Revise primitiveSuspend to no longer just remove a process from its condition variable list if waiting on a condition variable. Instead also back up the process one bytecode so that the blocking send will be retried if and when the process is resumed. Distinguish between a process being runnable but not active from a blocked process by the class of myList. If myList is LinkedList the process is runnable. Hence keep track of the class of LinkedList. Refactor convertToInterpreterFrame: to convertFrame:toInterpreterFrame: to facilitate implementation in the Cogit (a send byetcode is not a suspension point in machien code, hence a machien code caller of a blocking primtiive must be converted to an interpreter frame). Fix formatting bug in longPrintOop:. Cog: several places can use startPCOfMethodHeader: instead of startPCOfMethod: convertToInterpreterFrame: needs to assert validInstructionPointer:..., not just evaluate it. Interpreter: better to test process having a context first in printAllStacks.

1 0

[OpenSmalltalk/opensmalltalk-vm] c37666: Update a number of build launch scripts to obey th...
by Eliot Miranda 02 Jan '22

02 Jan '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: c376667e42204bbb837b107f07061fc7783da8f8 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/c376667e42204bbb83… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2022-01-01 (Sat, 01 Jan 2022) Changed paths: M image/buildsistareader64image.sh M image/buildsistareaderimage.sh M image/buildspurtrunk64image.sh M image/buildspurtrunkreader64image.sh M image/buildspurtrunkreaderimage.sh M image/buildspurtrunkvmmaker64image.sh M image/buildspurtrunkvmmakerimage.sh M image/updatespur64SistaV1image.sh M image/updatespur64image.sh M image/updatespurimage.sh M image/updatevmmakerimage.sh Log Message: ----------- Update a number of build launch scripts to obey the new VM command line format such that the file to be run follows "--".

1 0

VM Maker: VMMaker.oscog-eem.3127.mcz
by commits＠source.squeak.org 02 Jan '22

02 Jan '22

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3127.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3127 Author: eem Time: 1 January 2022, 5:58:06.869475 pm UUID: 4d6dd04c-143e-41c0-90bb-ed55b27ff3f1 Ancestors: VMMaker.oscog-eem.3126 Revise primitiveSuspend to no longer just remove a process from its condition variable list if waiting on a condition variable. Instead also back up the process one bytecode so that the blocking send will retried if and when the process is resumed. Distinguish between a process being runnable but not active from a blocked process by the class of myList. If myList is LinkedList the process is runnable. Hence keep track of the class of LinkedList. Refactor convertToInterpreterFrame: to convertFrame:toInterpreterFrame: to facilitate implementation in the Cogit (a send byetcode is not a suspension point in machien code, hence a machien code caller of a blocking primtiive must be converted to an interpreter frame). =============== Diff against VMMaker.oscog-eem.3126 =============== Item was added: + ----- Method: CoInterpreter>>backupProcess:toBlockingSendTo: (in category 'process primitive support') ----- + backupProcess: aProcess toBlockingSendTo: conditionVariable + "Assume aProcess is waiting on a condition variable. + Backup the PC of aProcess to the send that entered the wait state. + Since the PC at a send is not a susension point in machine code, this + entails converting a machine code frame into an interpreter frame. + primitiveEnterCriticalSection pushes false for blocked waiters. false + must be replaced by the condition variable." + + | context theMethod pc sp theIP theNewIP theFP thePage | + context := objectMemory fetchPointer: SuspendedContextIndex ofObject: aProcess. + self assert: (objectMemory isContext: context). + theMethod := objectMemory fetchPointer: MethodIndex ofObject: context. + (self isSingleContext: context) ifTrue: + [pc := objectMemory fetchPointer: InstructionPointerIndex ofObject: context. + sp := objectMemory fetchPointer: StackPointerIndex ofObject: context. + self assert: ((objectMemory isIntegerObject: pc) and: [(objectMemory integerValueOf: pc) > 0]). + self assert: ((objectMemory isIntegerObject: sp) and: [(objectMemory integerValueOf: sp) > 0]). + theIP := theMethod + objectMemory baseHeaderSize + (objectMemory integerValueOf: pc) - 1. + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + pc := theNewIP - theMethod - objectMemory baseHeaderSize + 1. + objectMemory + storePointerUnchecked: InstructionPointerIndex + ofObject: context + withValue: (objectMemory integerObjectOf: pc). + sp := (objectMemory integerValueOf: sp) + ReceiverIndex. "implicitly converts to 0 relative" + self assert: ((objectMemory fetchPointer: sp ofObject: context) = objectMemory falseObject + or: [(objectMemory fetchPointer: sp ofObject: context) = conditionVariable]). + objectMemory storePointer: sp ofObject: context withValue: conditionVariable. + ^self]. + self assert: (self isMarriedOrWidowedContext: context). + self deny: (self isWidowedContextNoConvert: context). + theFP := self frameOfMarriedContext: context. + thePage := stackPages stackPageFor: theFP. + self deny: thePage = stackPage. + self assert: theFP = thePage headFP. + (self isMachineCodeFrame: theFP) + ifTrue: + [| mcpc maybeClosure startBcpc cogMethodForIP | + mcpc := stackPages longAt: thePage headSP. "a machine code pc... it must be converted..." + maybeClosure := objectMemory fetchPointer: ClosureIndex ofObject: context. + (maybeClosure ~= objectMemory nilObject + and: [self isVanillaBlockClosure: maybeClosure]) + ifTrue: [cogMethodForIP := self mframeHomeMethod: theFP. + startBcpc := self startPCOfClosure: maybeClosure] + ifFalse: [cogMethodForIP := self cCoerceSimple: (self mframeMethod: theFP) to: #'CogMethod *'. + startBcpc := self startPCOfMethod: theMethod]. + theIP := cogit bytecodePCFor: mcpc startBcpc: startBcpc in: cogMethodForIP. + theIP := theIP + theMethod + objectMemory baseHeaderSize. + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + self convertFrame: theFP toInterpreterFrame: theIP - theNewIP] + ifFalse: + [self assert: (stackPages longAt: thePage headSP) = cogit ceReturnToInterpreterPC. + theIP := (self iframeSavedIP: theFP) + 1 "fetchByte uses pre-increment; must + 1 to point at correct bytecode...". + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + self iframeSavedIP: theFP put: theNewIP - 1]. "fetchByte uses pre-increment; must - 1 to fetch correct bytecode..." + self assert: ((stackPages longAt: thePage headSP + objectMemory wordSize) = objectMemory falseObject + or: [(stackPages longAt: thePage headSP + objectMemory wordSize) = conditionVariable]). + stackPages longAt: thePage headSP + objectMemory wordSize put: conditionVariable! Item was changed: ----- Method: CoInterpreter>>ceSendMustBeBooleanTo:interpretingAtDelta: (in category 'trampolines') ----- ceSendMustBeBooleanTo: aNonBooleanObject interpretingAtDelta: jumpSize "For RegisterAllocatingCogit we want the pc following a conditional branch not to be reachable, so we don't have to generate code to reload registers. But notionally the pc following a conditional branch is reached when continuing from a mustBeBoolean error. Instead of supporting this in the JIT, simply convert to an interpreter frame, backup the pc to the branch, reenter the interpreter and hence retry the mustBeBoolean send therein. N.B. We could do this for immutability violations too, but immutability is used in actual applications and so should be performant, whereas mustBeBoolean errors are extremely rare and so we choose brevity over performance in this case." <api> self assert: (objectMemory addressCouldBeOop: aNonBooleanObject). instructionPointer := self popStack. + self convertFrame: framePointer toInterpreterFrame: jumpSize. - self convertToInterpreterFrame: jumpSize. self push: aNonBooleanObject. "and now reenter the interpreter..." cogit ceInvokeInterpret. "NOTREACHED" ^nil! Item was added: + ----- Method: CoInterpreter>>convertFrame:toInterpreterFrame: (in category 'frame access') ----- + convertFrame: theFP toInterpreterFrame: pcDelta + "Convert the given machine code frame to an interpreter frame. Back up the pc by + pcDelta. Support for backing up the pc in primitiveSuspend for processes waiting + on condition variables. Support for mustBeBoolean in the RegisterAllocatingCogit and + for cloneContext: in shallowCopy when a code compaction is caused by machine code + to bytecode pc mapping." + + <var: 'theFP' type: #'char *'> + | cogMethod methodHeader methodObj startBcpc theIP thePage theSP theNewSP | + <var: 'cogMethod' type: #'CogBlockMethod *'> + <var: 'p' type: #'char *'> + + self assert: (self isMachineCodeFrame: theFP). + + theFP = framePointer + ifTrue: + [theIP := instructionPointer. + theSP := stackPointer] + ifFalse: + [thePage := stackPages stackPageFor: theFP. + self assert: theFP = thePage headFP. + theSP := thePage headSP. + theIP := stackPages longAt: theSP]. + + cogMethod := self mframeCogMethod: theFP. + ((self mframeIsBlockActivation: theFP) + and: [cogMethod cmIsFullBlock not]) + ifTrue: + [| homeMethod | + homeMethod := cogMethod cmHomeMethod. + methodHeader := homeMethod methodHeader. + methodObj := homeMethod methodObject. + startBcpc := cogMethod startpc] + ifFalse: + [methodHeader := (self cCoerceSimple: cogMethod to: #'CogMethod *') methodHeader. + methodObj := (self cCoerceSimple: cogMethod to: #'CogMethod *') methodObject. + startBcpc := self startPCOfMethodHeader: methodHeader]. + + "Map the machine code instructionPointer to the interpreter instructionPointer of the branch." + theIP := cogit bytecodePCFor: theIP startBcpc: startBcpc in: cogMethod. + theIP := methodObj + objectMemory baseHeaderSize + theIP - pcDelta - 1. "fetchByte uses pre-increment, so pre decrement". + self assert: (self validInstructionPointer: theIP inMethod: methodObj framePointer: theFP). + + "Make space for the two extra fields in an interpreter frame" + theSP to: theFP + FoxMFReceiver by: objectMemory wordSize do: + [:p| | oop | + oop := objectMemory longAt: p. + objectMemory + longAt: p - objectMemory wordSize - objectMemory wordSize + put: (objectMemory longAt: p)]. + "Fill in the fields" + objectMemory + longAt: theFP + FoxIFrameFlags + put: (self + encodeFrameFieldHasContext: (self mframeHasContext: theFP) + isBlock: (self mframeIsBlockActivation: theFP) + numArgs: cogMethod cmNumArgs); + longAt: theFP + FoxIFSavedIP + put: theIP; + longAt: theFP + FoxMethod + put: methodObj. + + theFP = framePointer + ifTrue: "If the frame is the top frame, update the top frame..." + [stackPointer := stackPointer - objectMemory wordSize - objectMemory wordSize. + instructionPointer := theIP. + self setMethod: methodObj methodHeader: methodHeader] + ifFalse: "otherwise update the stack pointer and instruction pointer of the top frame..." + [theNewSP := theSP - objectMemory wordSize - objectMemory wordSize. + thePage headSP: theNewSP. + stackPages longAt: theNewSP put: cogit ceReturnToInterpreterPC]! Item was removed: - ----- Method: CoInterpreter>>convertToInterpreterFrame: (in category 'frame access') ----- - convertToInterpreterFrame: pcDelta - "Convert the top machine code frame to an interpreter frame. Support for - mustBeBoolean in the RegisterAllocatingCogit and for cloneContext: in shallowCopy - when a code compaction is caused by machine code to bytecode pc mapping." - - | cogMethod methodHeader methodObj startBcpc | - <var: 'cogMethod' type: #'CogBlockMethod *'> - <var: 'p' type: #'char *'> - - self assert: (self isMachineCodeFrame: framePointer). - - cogMethod := self mframeCogMethod: framePointer. - ((self mframeIsBlockActivation: framePointer) - and: [cogMethod cmIsFullBlock not]) - ifTrue: - [methodHeader := (self cCoerceSimple: cogMethod cmHomeMethod to: #'CogMethod *') methodHeader. - methodObj := (self cCoerceSimple: cogMethod cmHomeMethod to: #'CogMethod *') methodObject. - startBcpc := cogMethod startpc] - ifFalse: - [methodHeader := (self cCoerceSimple: cogMethod to: #'CogMethod *') methodHeader. - methodObj := (self cCoerceSimple: cogMethod to: #'CogMethod *') methodObject. - startBcpc := self startPCOfMethodHeader: methodHeader]. - - "Map the machine code instructionPointer to the interpreter instructionPointer of the branch." - instructionPointer := cogit bytecodePCFor: instructionPointer startBcpc: startBcpc in: cogMethod. - instructionPointer := methodObj + objectMemory baseHeaderSize + instructionPointer - pcDelta - 1. "pre-decrement" - self assert: (self validInstructionPointer: instructionPointer inMethod: methodObj framePointer: framePointer). - - "Make space for the two extra fields in an interpreter frame" - stackPointer to: framePointer + FoxMFReceiver by: objectMemory wordSize do: - [:p| | oop | - oop := objectMemory longAt: p. - objectMemory - longAt: p - objectMemory wordSize - objectMemory wordSize - put: (objectMemory longAt: p)]. - stackPointer := stackPointer - objectMemory wordSize - objectMemory wordSize. - "Fill in the fields" - objectMemory - longAt: framePointer + FoxIFrameFlags - put: (self - encodeFrameFieldHasContext: (self mframeHasContext: framePointer) - isBlock: (self mframeIsBlockActivation: framePointer) - numArgs: cogMethod cmNumArgs); - longAt: framePointer + FoxIFSavedIP - put: instructionPointer; - longAt: framePointer + FoxMethod - put: methodObj. - - self setMethod: methodObj methodHeader: methodHeader! Item was changed: ----- Method: CogStackPages>>stackPageFor: (in category 'page access') ----- stackPageFor: pointer "<Integer>" <inline: true> <var: #pointer type: #'void *'> <returnTypeC: #'StackPage *'> + ^self stackPageAt: (self pageIndexFor: pointer) pages: pages! - ^self stackPageAt: (self pageIndexFor: pointer)! Item was changed: ----- Method: InterpreterPrimitives>>primitiveEnterCriticalSection (in category 'process primitives') ----- primitiveEnterCriticalSection "Attempt to enter a CriticalSection/Mutex. If not owned, set the owner to the current process and answer false. If owned by the current process answer true. Otherwise suspend the process. Answer if the receiver is owned by the current process. For simulation if there is an argument it is taken to be the effective activeProcess (see Process>>effectiveProcess)." | criticalSection owningProcessIndex owningProcess activeProc | argumentCount > 0 ifTrue: [criticalSection := self stackValue: 1. "rcvr" + activeProc := self stackTop. + (objectMemory isOopForwarded: activeProc) ifTrue: + [self primitiveFailFor: PrimErrBadArgument]] - activeProc := self stackTop] ifFalse: [criticalSection := self stackTop. "rcvr" activeProc := self activeProcess]. owningProcessIndex := ExcessSignalsIndex. "CriticalSections are laid out like Semaphores" owningProcess := objectMemory fetchPointer: owningProcessIndex ofObject: criticalSection. owningProcess = objectMemory nilObject ifTrue: [objectMemory storePointer: owningProcessIndex ofObject: criticalSection withValue: activeProc. + ^self methodReturnValue: objectMemory falseObject]. - ^self pop: argumentCount + 1 thenPush: objectMemory falseObject]. owningProcess = activeProc ifTrue: + [^self methodReturnValue: objectMemory trueObject]. - [^self pop: argumentCount + 1 thenPush: objectMemory trueObject]. "Arrange to answer false (unowned) when the process is resumed." self pop: argumentCount + 1 thenPush: objectMemory falseObject. self addLastLink: activeProc toList: criticalSection. self transferTo: self wakeHighestPriority! Item was changed: ----- Method: InterpreterPrimitives>>primitiveResume (in category 'process primitives') ----- primitiveResume "Put this process on the scheduler's lists thus allowing it to proceed next time there is a chance for processes of it's priority level. It must go to the back of its run queue so as not to preempt any already running processes at this level. If the process's priority is higher than the current process, preempt the current process." | proc ctxt | proc := self stackTop. "rcvr" + "Alas in Spur we need a read barrier" ctxt := objectMemory followField: SuspendedContextIndex ofObject: proc. "written this way to get better Slang inlining" (objectMemory isContext: ctxt) ifFalse: [^self primitiveFailFor: PrimErrBadReceiver]. + self resume: proc preemptedYieldingIf: preemptionYields! - self resume: proc preemptedYieldingIf: preemptionYields - - "Personally I would like to check MyList, which should not be one of the elements of the scheduler lists. - But there are awful race conditions in things like should:notTakeMoreThan: that mean we can't. - eem 9/27/2010 23:08, updated eem 5/20/2021 15:36. e.g. - - | proc field | - proc := self stackTop. ''rcvr'' - ''We only have to check for myList being nil. If it is nil then this is either the active process or - a process suspended with primitiveSuspend (and if it is the activeProcess suspendedContext will - be nil and the isContext: test will fail). If it is not nil then either the process is waiting on some - semaphore-like list or on one of the scheduler's lists. If it is on some semaphore-like list it should - not resume. If it is on one of the scheduler's lists it is runnable (already resumed).'' - field := objectMemory followField: MyListIndex ofObject: proc. - objectMemory nilObject = field ifFalse: - [^self primitiveFailFor: PrimErrInappropriate]. - field := objectMemory followField: SuspendedContextIndex ofObject: proc. - (objectMemory isContext: field) ifFalse: - [^self primitiveFailFor: PrimErrBadReceiver]. - self resume: proc preemptedYieldingIf: preemptionYields"! Item was removed: - ----- Method: InterpreterPrimitives>>primitiveSuspend (in category 'process primitives') ----- - primitiveSuspend - "Primitive. Suspend the receiver, aProcess such that it can be executed again - by sending #resume. If the given process is not currently running, take it off - its corresponding list. The primitive returns the list the receiver was previously on." - | process myList | - process := self stackTop. - process = self activeProcess ifTrue: - [self pop: 1 thenPush: objectMemory nilObject. - ^self transferTo: self wakeHighestPriority]. - myList := objectMemory fetchPointer: MyListIndex ofObject: process. - "XXXX Fixme. We should really check whether myList is a kind of LinkedList or not - but we can't easily so just do a quick check for nil which is the most common case." - myList = objectMemory nilObject ifTrue: - [^self primitiveFailFor: PrimErrBadReceiver]. - "Alas in Spur we need a read barrier" - (objectMemory isForwarded: myList) ifTrue: - [myList := objectMemory followForwarded: myList. - objectMemory storePointer: MyListIndex ofObject: process withValue: myList]. - self removeProcess: process fromList: myList. - self successful ifTrue: - [objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject. - self pop: 1 thenPush: myList]! Item was changed: ----- Method: InterpreterPrimitives>>primitiveTestAndSetOwnershipOfCriticalSection (in category 'process primitives') ----- primitiveTestAndSetOwnershipOfCriticalSection "Attempt to test-and-set the ownership of the critical section. If not owned, set the owner to the current process and answer false. If owned by the current process answer true. If owned by some other process answer nil. For simulation if there is an argument it is taken to be the effective activeProcess (see Process>>effectiveProcess)." | criticalSection owningProcessIndex owningProcess activeProc | argumentCount > 0 ifTrue: [criticalSection := self stackValue: 1. "rcvr" + activeProc := self stackTop. + (objectMemory isOopForwarded: activeProc) ifTrue: + [self primitiveFailFor: PrimErrBadArgument]] - activeProc := self stackTop] ifFalse: [criticalSection := self stackTop. "rcvr" activeProc := self activeProcess]. owningProcessIndex := ExcessSignalsIndex. "CriticalSections are laid out like Semaphores" owningProcess := objectMemory fetchPointer: owningProcessIndex ofObject: criticalSection. owningProcess = objectMemory nilObject ifTrue: [objectMemory storePointer: owningProcessIndex ofObject: criticalSection withValue: activeProc. + ^self methodReturnValue: objectMemory falseObject]. - ^self pop: argumentCount + 1 thenPush: objectMemory falseObject]. owningProcess = activeProc ifTrue: + [^self methodReturnValue: objectMemory trueObject]. + self methodReturnValue: objectMemory nilObject! - [^self pop: argumentCount + 1 thenPush: objectMemory trueObject]. - self pop: argumentCount + 1 thenPush: objectMemory nilObject! Item was changed: InterpreterPrimitives subclass: #StackInterpreter (excessive size, no diff calculated) Item was changed: ----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator | vmClass | self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" vmClass := aCCodeGenerator vmClass. "Generate primitiveTable etc based on vmClass, not just StackInterpreter" aCCodeGenerator addHeaderFile: '<stdio.h> /* for printf */'; addHeaderFile: '<stdlib.h> /* for e.g. alloca */'; addHeaderFile: '<setjmp.h>'; addHeaderFile: '<wchar.h> /* for wint_t */'; addHeaderFile: '"vmCallback.h"'; addHeaderFile: '"sqMemoryFence.h"'; addHeaderFile: '"sqImageFileAccess.h"'; addHeaderFile: '"sqSetjmpShim.h"'; addHeaderFile: '"dispdbg.h"'. LowcodeVM ifTrue: [aCCodeGenerator addHeaderFile: '"sqLowcodeFFI.h"']. vmClass declareInterpreterVersionIn: aCCodeGenerator defaultName: 'Stack'. aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'. aCCodeGenerator declareVar: #sendTrace type: 'volatile int'; declareVar: #byteCount type: #usqLong. "see dispdbg.h" "These need to be pointers or unsigned." self declareC: #(instructionPointer 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) as: #'char *' in: aCCodeGenerator. aCCodeGenerator var: #breakSelectorLength declareC: 'sqInt breakSelectorLength = MinSmallInteger'. self declareC: #(stackPage overflowedPage) as: #'StackPage *' in: aCCodeGenerator. aCCodeGenerator var: #transcript type: #'FILE *'. aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code." "This defines bytecodeSetSelector as 0 if MULTIPLEBYTECODESETS is not defined, for the benefit of the interpreter on slow machines." aCCodeGenerator addConstantForBinding: (self bindingOf: #MULTIPLEBYTECODESETS). MULTIPLEBYTECODESETS == false ifTrue: [aCCodeGenerator removeVariable: 'bytecodeSetSelector']. BytecodeSetHasExtensions == false ifTrue: [aCCodeGenerator removeVariable: 'extA'; removeVariable: 'extB']. aCCodeGenerator var: #methodCache declareC: 'sqIntptr_t methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'. NewspeakVM ifTrue: [aCCodeGenerator var: #nsMethodCache declareC: 'sqIntptr_t nsMethodCache[NSMethodCacheSize + 1 /* ', (NSMethodCacheSize + 1) printString, ' */]'] ifFalse: [aCCodeGenerator removeVariable: #nsMethodCache; removeVariable: 'localAbsentReceiver'; removeVariable: 'localAbsentReceiverOrZero']. AtCacheTotalSize isInteger ifTrue: [aCCodeGenerator var: #atCache declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]']. aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */])(void) = ', vmClass primitiveTableString. vmClass primitiveTable do: [:symbolOrNot| (symbolOrNot isSymbol and: [symbolOrNot ~~ #primitiveFail]) ifTrue: [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil: [:tMethod| tMethod returnType: #void]]]. vmClass objectMemoryClass hasSpurMemoryManagerAPI ifTrue: [aCCodeGenerator var: #primitiveAccessorDepthTable type: 'signed char' sizeString: 'MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */' array: (vmClass primitiveAccessorDepthTableUsing: aCCodeGenerator)] ifFalse: [aCCodeGenerator removeVariable: #primitiveAccessorDepthTable]. aCCodeGenerator var: #displayBits type: #'void *'; var: #primitiveCalloutPointer declareC: 'void *primitiveCalloutPointer = (void *)-1'. self declareC: #(displayWidth displayHeight displayDepth) as: #int in: aCCodeGenerator. aCCodeGenerator var: #primitiveFunctionPointer declareC: 'void (*primitiveFunctionPointer)()'; + var: 'pcPreviousToFunction' + declareC: 'sqInt (* const pcPreviousToFunction)(sqInt,sqInt) = ', (aCCodeGenerator cFunctionNameFor: PCPreviousToFunction); var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)'; var: #interruptCheckChain declareC: 'void (*interruptCheckChain)(void) = 0'; var: #showSurfaceFn declareC: 'int (*showSurfaceFn)(sqIntptr_t, int, int, int, int)'; var: #jmpBuf declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'; var: #suspendedCallbacks declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'; var: #suspendedMethods declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. self declareCAsUSqLong: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs "these are high-frequency enough that they're overflowing quite quickly on modern hardware" statProcessSwitch statIOProcessEvents statForceInterruptCheck statCheckForEvents statStackOverflow statStackPageDivorce statIdleUsecs) in: aCCodeGenerator. aCCodeGenerator var: #nextProfileTick type: #sqLong. aCCodeGenerator var: #reenterInterpreter type: 'jmp_buf'. LowcodeVM ifTrue: [aCCodeGenerator var: #lowcodeCalloutState type: #'sqLowcodeCalloutState*'. self declareC: #(nativeSP nativeStackPointer shadowCallStackPointer) as: #'char *' in: aCCodeGenerator] ifFalse: [#(lowcodeCalloutState nativeSP nativeStackPointer shadowCallStackPointer) do: [:var| aCCodeGenerator removeVariable: var]]! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForNewspeakV4 (in category 'initialization') ----- initializeBytecodeTableForNewspeakV4 "StackInterpreter initializeBytecodeTableForNewspeakV4" "Note: This table will be used to generate a C switch statement." InitializationOptions at: #NewsqueakV4BytecodeSet put: (NewsqueakV4BytecodeSet := true). BytecodeTable := Array new: 256. BytecodeEncoderClassName := #EncoderForNewsqueakV4. BytecodeSetHasDirectedSuperSend := true. BytecodeSetHasExtensions := true. LongStoreBytecode := 234. + PCPreviousToFunction := #pcPreviousTo:inNewsqueakV4Method:. self table: BytecodeTable from: #( "1 byte bytecodes" ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushLiteralVariable16CasesBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 75 pushTemporaryVariableBytecode) ( 76 pushReceiverBytecode) ( 77 extPushPseudoVariableOrOuterBytecode) ( 78 pushConstantZeroBytecode) ( 79 pushConstantOneBytecode) ( 80 bytecodePrimAdd) ( 81 bytecodePrimSubtract) ( 82 bytecodePrimLessThanV4) "for booleanCheatV4:" ( 83 bytecodePrimGreaterThanV4) "for booleanCheatV4:" ( 84 bytecodePrimLessOrEqualV4) "for booleanCheatV4:" ( 85 bytecodePrimGreaterOrEqualV4) "for booleanCheatV4:" ( 86 bytecodePrimEqualV4) "for booleanCheatV4:" ( 87 bytecodePrimNotEqualV4) "for booleanCheatV4:" ( 88 bytecodePrimMultiply) ( 89 bytecodePrimDivide) ( 90 bytecodePrimMod) ( 91 bytecodePrimMakePoint) ( 92 bytecodePrimBitShift) ( 93 bytecodePrimDiv) ( 94 bytecodePrimBitAnd) ( 95 bytecodePrimBitOr) ( 96 bytecodePrimAt) ( 97 bytecodePrimAtPut) ( 98 bytecodePrimSize) ( 99 bytecodePrimNext) (100 bytecodePrimNextPut) (101 bytecodePrimAtEnd) (102 bytecodePrimIdenticalV4) "for booleanCheatV4:" (103 bytecodePrimClass) (104 bytecodePrimNotIdenticalV4) "was blockCopy:" (105 bytecodePrimValue) (106 bytecodePrimValueWithArg) (107 bytecodePrimDo) (108 bytecodePrimNew) (109 bytecodePrimNewWithArg) (110 bytecodePrimPointX) (111 bytecodePrimPointY) (112 127 sendLiteralSelector0ArgsBytecode) (128 143 sendLiteralSelector1ArgBytecode) (144 159 sendLiteralSelector2ArgsBytecode) (160 175 sendAbsentImplicit0ArgsBytecode) (176 183 storeAndPopReceiverVariableBytecode) (184 191 storeAndPopTemporaryVariableBytecode) (192 199 shortUnconditionalJump) (200 207 shortConditionalJumpTrue) (208 215 shortConditionalJumpFalse) (216 returnReceiver) (217 returnTopFromMethod) (218 extReturnTopFromBlock) (219 duplicateTopBytecode) (220 popStackBytecode) (221 extNopBytecode) (222 223 unknownBytecode) "2 byte bytecodes" (224 extABytecode) (225 extBBytecode) (226 extPushReceiverVariableBytecode) (227 extPushLiteralVariableBytecode) (228 extPushLiteralBytecode) (229 extPushIntegerBytecode) (230 longPushTemporaryVariableBytecode) (231 pushNewArrayBytecode) (232 extStoreReceiverVariableBytecode) (233 extStoreLiteralVariableBytecode) (234 longStoreTemporaryVariableBytecode) (235 extStoreAndPopReceiverVariableBytecode) (236 extStoreAndPopLiteralVariableBytecode) (237 longStoreAndPopTemporaryVariableBytecode) (238 extSendBytecode) (239 extSendSuperBytecode) (240 extSendAbsentImplicitBytecode) (241 extSendAbsentDynamicSuperBytecode) (242 extUnconditionalJump) (243 extJumpIfTrue) (244 extJumpIfFalse) (245 extSendAbsentSelfBytecode) (246 248 unknownBytecode) "3 byte bytecodes" (249 callPrimitiveBytecode) (250 pushRemoteTempLongBytecode) (251 storeRemoteTempLongBytecode) (252 storeAndPopRemoteTempLongBytecode) (253 extPushClosureBytecode) (254 extSendAbsentOuterBytecode) (255 unknownBytecode) )! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForSistaV1 (in category 'initialization') ----- initializeBytecodeTableForSistaV1 "See e.g. the cass comment for EncoderForSistaV1" "StackInterpreter initializeBytecodeTableForSistaV1" "Note: This table will be used to generate a C switch statement." InitializationOptions at: #SistaV1BytecodeSet put: (SistaV1BytecodeSet := true). BytecodeTable := Array new: 256. BytecodeEncoderClassName := #EncoderForSistaV1. BytecodeSetHasDirectedSuperSend := true. BytecodeSetHasExtensions := true. LongStoreBytecode := 245. + PCPreviousToFunction := #pcPreviousTo:inSistaV1Method:. self table: BytecodeTable from: #( "1 byte bytecodes" ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushLiteralVariable16CasesBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 75 pushTemporaryVariableBytecode) ( 76 pushReceiverBytecode) ( 77 pushConstantTrueBytecode) ( 78 pushConstantFalseBytecode) ( 79 pushConstantNilBytecode) ( 80 pushConstantZeroBytecode) ( 81 pushConstantOneBytecode) ( 82 extPushPseudoVariable) ( 83 duplicateTopBytecode) ( 84 87 unknownBytecode) ( 88 returnReceiver) ( 89 returnTrue) ( 90 returnFalse) ( 91 returnNil) ( 92 returnTopFromMethod) ( 93 returnNilFromBlock) ( 94 returnTopFromBlock) ( 95 extNopBytecode) ( 96 bytecodePrimAdd) ( 97 bytecodePrimSubtract) ( 98 bytecodePrimLessThanSistaV1) "for booleanCheatSistaV1:" ( 99 bytecodePrimGreaterThanSistaV1) "for booleanCheatSistaV1:" (100 bytecodePrimLessOrEqualSistaV1) "for booleanCheatSistaV1:" (101 bytecodePrimGreaterOrEqualSistaV1) "for booleanCheatSistaV1:" (102 bytecodePrimEqualSistaV1) "for booleanCheatSistaV1:" (103 bytecodePrimNotEqualSistaV1) "for booleanCheatSistaV1:" (104 bytecodePrimMultiply) (105 bytecodePrimDivide) (106 bytecodePrimMod) (107 bytecodePrimMakePoint) (108 bytecodePrimBitShift) (109 bytecodePrimDiv) (110 bytecodePrimBitAnd) (111 bytecodePrimBitOr) (112 bytecodePrimAt) (113 bytecodePrimAtPut) (114 bytecodePrimSize) (115 bytecodePrimNext) "i.e. a 0 arg special selector" (116 bytecodePrimNextPut) "i.e. a 1 arg special selector" (117 bytecodePrimAtEnd) (118 bytecodePrimIdenticalSistaV1) "for booleanCheatSistaV1:" (119 bytecodePrimClass) (120 bytecodePrimNotIdenticalSistaV1) "was blockCopy:" (121 bytecodePrimValue) (122 bytecodePrimValueWithArg) (123 bytecodePrimDo) "i.e. a 1 arg special selector" (124 bytecodePrimNew) "i.e. a 0 arg special selector" (125 bytecodePrimNewWithArg) "i.e. a 1 arg special selector" (126 bytecodePrimPointX) "i.e. a 0 arg special selector" (127 bytecodePrimPointY) "i.e. a 0 arg special selector" (128 143 sendLiteralSelector0ArgsBytecode) (144 159 sendLiteralSelector1ArgBytecode) (160 175 sendLiteralSelector2ArgsBytecode) (176 183 shortUnconditionalJump) (184 191 shortConditionalJumpTrue) (192 199 shortConditionalJumpFalse) (200 207 storeAndPopReceiverVariableBytecode) (208 215 storeAndPopTemporaryVariableBytecode) (216 popStackBytecode) (217 unconditionalTrapBytecode) (218 223 unknownBytecode) "2 byte bytecodes" (224 extABytecode) (225 extBBytecode) (226 extPushReceiverVariableBytecode) (227 extPushLiteralVariableBytecode) (228 extPushLiteralBytecode) (229 longPushTemporaryVariableBytecode) (230 unknownBytecode) (231 pushNewArrayBytecode) (232 extPushIntegerBytecode) (233 extPushCharacterBytecode) (234 extSendBytecode) (235 extSendSuperBytecode) (236 callMappedInlinedPrimitive) (237 extUnconditionalJump) (238 extJumpIfTrue) (239 extJumpIfFalse) (240 extStoreAndPopReceiverVariableBytecode) (241 extStoreAndPopLiteralVariableBytecode) (242 longStoreAndPopTemporaryVariableBytecode) (243 extStoreReceiverVariableBytecode) (244 extStoreLiteralVariableBytecode) (245 longStoreTemporaryVariableBytecode) (246 247 unknownBytecode) "3 byte bytecodes" (248 callPrimitiveBytecode) (249 extPushFullClosureBytecode) (250 extPushClosureBytecode) (251 pushRemoteTempLongBytecode) (252 storeRemoteTempLongBytecode) (253 storeAndPopRemoteTempLongBytecode) (254 255 unknownBytecode) )! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForSqueakV3PlusClosures (in category 'initialization') ----- initializeBytecodeTableForSqueakV3PlusClosures "StackInterpreter initializeBytecodeTableForSqueakV3PlusClosures" "Note: This table will be used to generate a C switch statement." InitializationOptions at: #SqueakV3PlusClosuresBytecodeSet put: (SqueakV3PlusClosuresBytecodeSet := true). BytecodeTable := Array new: 256. BytecodeEncoderClassName := #EncoderForV3PlusClosures. - LongStoreBytecode := 129. BytecodeSetHasExtensions := false. + LongStoreBytecode := 129. + PCPreviousToFunction := #pcPreviousTo:inSqueakV3PlusClosuresMethod:. self table: BytecodeTable from: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiver) (121 returnTrue) (122 returnFalse) (123 returnNil) (124 returnTopFromMethod) (125 returnTopFromBlock) (126 127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) (138 pushNewArrayBytecode)), ((InitializationOptions at: #SpurObjectMemory ifAbsent: [false]) ifTrue: [#((139 callPrimitiveBytecode))] "V3PlusClosures on Spur" ifFalse: [#((139 unknownBytecode))]), "V3PlusClosures on V3" #( (140 pushRemoteTempLongBytecode) (141 storeRemoteTempLongBytecode) (142 storeAndPopRemoteTempLongBytecode) (143 pushClosureCopyCopiedValuesBytecode) (144 151 shortUnconditionalJump) (152 159 shortConditionalJumpFalse) (160 167 longUnconditionalJump) (168 171 longJumpIfTrue) (172 175 longJumpIfFalse) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimIdentical) (199 bytecodePrimClass) (200 bytecodePrimNotIdentical) "was bytecodePrimSpecialSelector24 / blockCopy" (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 223 sendLiteralSelector0ArgsBytecode) (224 239 sendLiteralSelector1ArgBytecode) (240 255 sendLiteralSelector2ArgsBytecode) )! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForSqueakV3PlusClosuresNewspeakV4Hybrid (in category 'initialization') ----- initializeBytecodeTableForSqueakV3PlusClosuresNewspeakV4Hybrid "StackInterpreter initializeBytecodeTableForSqueakV3PlusClosuresNewspeakV4Hybrid" | v3Table v4Table | self initializeBytecodeTableForNewspeakV4. v4Table := BytecodeTable. AltBytecodeEncoderClassName := BytecodeEncoderClassName. AltLongStoreBytecode := LongStoreBytecode. self initializeBytecodeTableForSqueakV3PlusClosures. BytecodeSetHasExtensions := true. + PCPreviousToFunction := #pcPreviousTo:inSqueakV3PlusClosuresOrNewsqueakV4Method:. v3Table := BytecodeTable. BytecodeTable := v3Table, v4Table! Item was changed: ----- Method: StackInterpreter class>>initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid (in category 'initialization') ----- initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid "StackInterpreter initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid" | v3Table v1Table | self initializeBytecodeTableForSistaV1. v1Table := BytecodeTable. AltBytecodeEncoderClassName := BytecodeEncoderClassName. AltLongStoreBytecode := LongStoreBytecode. self initializeBytecodeTableForSqueakV3PlusClosures. BytecodeSetHasExtensions := true. + PCPreviousToFunction := #pcPreviousTo:inSqueakV3PlusClosuresOrSistaV1Method:. v3Table := BytecodeTable. BytecodeTable := v3Table, v1Table! Item was changed: ----- Method: StackInterpreter class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants super initializeMiscConstants. STACKVM := true. + RevisedSuspend := true. "primitiveSuspend no longer allows a process waiting on a condition variable to go past the condition variable" + "These flags identify a GC operation (& hence a reason to leak check), or just operations the leak checker can be run for." GCModeFull := 1. "stop-the-world global GC" GCModeNewSpace := 2. "Spur's scavenge, or V3's incremental" GCModeIncremental := 4. "incremental global gc (Dijkstra tri-colour marking); as yet unimplemented" GCModeBecome := 8. "v3 post-become sweeping/Spur forwarding" GCCheckImageSegment := 16. "just a flag for leak checking image segments" GCCheckFreeSpace := 32. "just a flag for leak checking free space; Spur only" GCCheckShorten := 64. "just a flag for leak checking object shortening operations; Spur only" GCCheckPrimCall := 128. "just a flag for leak checking external primitive calls" StackPageTraceInvalid := -1. StackPageUnreached := 0. StackPageReachedButUntraced := 1. StackPageTraced := 2. DumpStackOnLowSpace := 0. MillisecondClockMask := 16r1FFFFFFF. "Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)" MaxExternalPrimitiveTableSize := 4096. "entries" MaxJumpBuf := 32. "max. callback depth" FailImbalancedPrimitives := InitializationOptions at: #FailImbalancedPrimitives ifAbsentPut: [true]. EnforceAccessControl := InitializationOptions at: #EnforceAccessControl ifAbsent: [true]. ReturnToInterpreter := 1. "setjmp/longjmp code." "Because of a hack with callbacks in the non-threaded VM they must not conflct with the VM's tag bits." DisownVMForFFICall := 16. DisownVMForThreading := 32 ! Item was changed: ----- Method: StackInterpreter class>>requiredMethodNames: (in category 'translation') ----- requiredMethodNames: options "Answer the list of method names that should be retained for export or other support reasons" | requiredList | "A number of methods required by VM support code, specific platforms, etc" requiredList := #( assertValidExecutionPointe:r:s: characterForAscii: findClassOfMethod:forReceiver: findSelectorOfMethod: forceInterruptCheck forceInterruptCheckFromHeartbeat fullDisplayUpdate getCurrentBytecode getFullScreenFlag getInterruptKeycode getInterruptPending getSavedWindowSize getThisSessionID interpret loadInitialContext primitiveFail primitiveFailFor: primitiveFlushExternalPrimitives printAllStacks printCallStack printContext: printExternalHeadFrame printFramesInPage: printFrame: printMemory printOop: printStackPages printStackPageList printStackPagesInUse printStackPageListInUse readImageFromFile:HeapSize:StartingAt: setFullScreenFlag: setInterruptKeycode: setInterruptPending: setInterruptCheckChain: setSavedWindowSize: success: validInstructionPointer:inMethod:framePointer:) asSet. "Nice to actually have all the primitives available" requiredList addAll: (self primitiveTable select: [:each| each isSymbol]). "InterpreterProxy is the internal analogue of sqVirtualMachine.c, so make sure to keep all those" InterpreterProxy organization categories do: [:cat | ((cat ~= 'initialize') and: [cat ~= 'private']) ifTrue: [requiredList addAll: (InterpreterProxy organization listAtCategoryNamed: cat)]]. + requiredList add: PCPreviousToFunction. + ^requiredList! Item was added: + ----- Method: StackInterpreter>>backupProcess:toBlockingSendTo: (in category 'process primitive support') ----- + backupProcess: aProcess toBlockingSendTo: conditionVariable + "Assume aProcess is waiting on a condition variable. + Backup the PC of aProcess to the send that entered the wait state. + primitiveEnterCriticalSection pushes false for blocked waiters. false + must be replaced by the condition variable." + + | context theMethod pc sp theIP theNewIP theFP thePage | + context := objectMemory fetchPointer: SuspendedContextIndex ofObject: aProcess. + self assert: (objectMemory isContext: context). + theMethod := objectMemory fetchPointer: MethodIndex ofObject: context. + (self isSingleContext: context) ifTrue: + [pc := objectMemory fetchPointer: InstructionPointerIndex ofObject: context. + sp := objectMemory fetchPointer: StackPointerIndex ofObject: context. + self assert: ((objectMemory isIntegerObject: pc) and: [(objectMemory integerValueOf: pc) > 0]). + self assert: ((objectMemory isIntegerObject: sp) and: [(objectMemory integerValueOf: sp) > 0]). + theIP := theMethod + objectMemory baseHeaderSize + (objectMemory integerValueOf: pc) - 1. + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + pc := theNewIP - theMethod - objectMemory baseHeaderSize + 1. + objectMemory + storePointerUnchecked: InstructionPointerIndex + ofObject: context + withValue: (objectMemory integerObjectOf: pc). + sp := (objectMemory integerValueOf: sp) + ReceiverIndex. "implicitly converts to 0 relative" + self assert: ((objectMemory fetchPointer: sp ofObject: context) = objectMemory falseObject + or: [(objectMemory fetchPointer: sp ofObject: context) = conditionVariable]). + objectMemory storePointer: sp ofObject: context withValue: conditionVariable. + ^self]. + self assert: (self isMarriedOrWidowedContext: context). + self deny: (self isWidowedContextNoConvert: context). + theFP := self frameOfMarriedContext: context. + thePage := stackPages stackPageFor: theFP. + self deny: thePage = stackPage. + self assert: theFP = thePage headFP. + theIP := (stackPages longAt: thePage headSP) + 1 "fetchByte uses pre-increment; must + 1 to point at correct bytecode...". + theNewIP := self perform: pcPreviousToFunction with: theIP with: theMethod. + self assert: (theNewIP < theIP and: [theIP - theNewIP <= 3]). + stackPages longAt: thePage headSP put: theNewIP - 1. "fetchByte uses pre-increment; must - 1 to fetch correct bytecode..." + self assert: ((stackPages longAt: thePage headSP + objectMemory wordSize) = objectMemory falseObject + or: [(stackPages longAt: thePage headSP + objectMemory wordSize) = conditionVariable]). + stackPages longAt: thePage headSP + objectMemory wordSize put: conditionVariable! Item was added: + ----- Method: StackInterpreter>>getClassTagOfLinkedList (in category 'process primitive support') ----- + getClassTagOfLinkedList + "primitiveSuspend needs to know the class of LinkedList. + In Spur we use the class index, which will not chasnge over time. + In V3 we need the class object itself." + + classLinkedListClassTag := objectMemory fetchClassTagOfNonImm: + (objectMemory + fetchPointer: 0 + ofObject: (objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer))! Item was changed: ----- Method: StackInterpreter>>getCogVMFeatureFlags (in category 'internal interpreter access') ----- getCogVMFeatureFlags "Answer an array of flags indicating various optional features of the Cog VM. + If the bit is set then... Bit 0: supports two bytecode sets (MULTIPLEBYTECODESETS) Bit 1: supports immutablity (IMMUTABILITY) Bit 2: suffers from a UNIX setitimer signal-based heartbeat + Bit 3: the VM provides cross-platform bit-identical floating point + Bit 4: the VM can catch exceptions in FFI calls and answer them as primitive failures + Bit 5: the suspend primitive backs up a process to before the wait if it was waiting on a condition variable" - Bit 3: the VM provides cross-platform bit-identical floating point" ^objectMemory integerObjectOf: (MULTIPLEBYTECODESETS ifTrue: [1] ifFalse: [0]) + (IMMUTABILITY ifTrue: [2] ifFalse: [0]) + (self cppIf: #'ITIMER_HEARTBEAT' ifTrue: [4] ifFalse: [0]) + (self cppIf: #'BIT_IDENTICAL_FLOATING_POINT' ifTrue: [8] ifFalse: [0]) + + (self ioCanCatchFFIExceptions ifTrue: [16] ifFalse: [0]) + + (RevisedSuspend ifTrue: [32] ifFalse: [0])! - + (self ioCanCatchFFIExceptions ifTrue: [16] ifFalse: [0])! Item was changed: ----- Method: StackInterpreter>>initialize (in category 'initialization') ----- initialize "Here we can initialize the variables C initializes to zero. #initialize methods do /not/ get translated." super initialize. primitiveDoMixedArithmetic := true. "whether we authorize primitives to perform mixed arithmetic or not". newFinalization := false. stackLimit := 0. "This is also the initialization flag for the stack system." stackPage := overflowedPage := 0. extraFramesToMoveOnOverflow := 0. bytecodeSetSelector := 0. highestRunnableProcessPriority := 0. nextPollUsecs := 0. nextWakeupUsecs := 0. tempOop := tempOop2 := theUnknownShort := 0. interruptPending := false. inIOProcessEvents := 0. fullScreenFlag := 0. sendWheelEvents := deferDisplayUpdates := false. displayBits := displayWidth := displayHeight := displayDepth := 0. pendingFinalizationSignals := statPendingFinalizationSignals := 0. globalSessionID := 0. jmpDepth := 0. maxExtSemTabSizeSet := false. debugCallbackInvokes := debugCallbackPath := debugCallbackReturns := 0. primitiveCalloutPointer := -1. "initialized in declaration in declareCVarsIn:" transcript := Transcript. "initialized to stdout in readImageFromFile:HeapSize:StartingAt:" + pcPreviousToFunction := PCPreviousToFunction. "initialized via StackInterpreter class>>declareCVarsIn:" statForceInterruptCheck := statStackOverflow := statCheckForEvents := statProcessSwitch := statIOProcessEvents := statStackPageDivorce := statIdleUsecs := 0! Item was added: + ----- Method: StackInterpreter>>isNewsqueakV4Extension: (in category 'process primitive support') ----- + isNewsqueakV4Extension: bytecode + <inline: #always> + ^bytecode between: 16rE0 and: 16rE1! Item was added: + ----- Method: StackInterpreter>>isResumableContext: (in category 'process primitive support') ----- + isResumableContext: aContext + self assert: (objectMemory isContext: aContext). + ^objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)! Item was added: + ----- Method: StackInterpreter>>isSistaV1Extension: (in category 'process primitive support') ----- + isSistaV1Extension: bytecode + <inline: #always> + ^bytecode between: 16rE0 and: 16rE1! Item was changed: ----- Method: StackInterpreter>>isWidowedContext: (in category 'frame access') ----- isWidowedContext: aOnceMarriedContext + "Answer if the argument is married to a live frame or not. - "See if the argument is married to a live frame or not. If it is not, turn it into a bereaved single context. This version is safe for use only when no frameContext fields may be forwarded (as maybe the case when scavenging). Post become: all frameContext fields are followed, and + hence normally no following of frameContext fields is necessary. But during - hence nrmally no following of frameCOtext fields is necessary. But during a scavenge one must use isWidowedContextDuringGC:." + | widowed | + widowed := self isWidowedContextNoConvert: aOnceMarriedContext. + widowed ifFalse: + [^false]. - | theFrame thePage shouldBeFrameCallerField | - <var: #theFrame type: #'char *'> - <var: #thePage type: #'StackPage *'> - <var: #shouldBeFrameCallerField type: #'char *'> - self assert: ((objectMemory isContext: aOnceMarriedContext) - and: [self isMarriedOrWidowedContext: aOnceMarriedContext]). - theFrame := self frameOfMarriedContext: aOnceMarriedContext. - thePage := stackPages stackPageFor: theFrame. - ((stackPages isFree: thePage) - or: [theFrame < thePage headFP]) ifFalse: - ["The frame pointer is within the bounds of a live page. - Now check if it matches a frame." - shouldBeFrameCallerField := self withoutSmallIntegerTags: - (objectMemory - fetchPointer: InstructionPointerIndex - ofObject: aOnceMarriedContext). - ((self frameCallerFP: theFrame) = shouldBeFrameCallerField - and: [self frameHasContext: theFrame]) ifTrue: - [self deny: (((self isFrame: theFrame onPage: thePage)) - and: [objectMemory isForwarded: (self frameContext: theFrame)]). - (self frameContext: theFrame) = aOnceMarriedContext ifTrue: "It is still married!!" - [^false]]]. - "It is out of range or doesn't match the frame's context. - It is widowed. Time to wear black." self markContextAsDead: aOnceMarriedContext. ^true! Item was added: + ----- Method: StackInterpreter>>isWidowedContextNoConvert: (in category 'frame access') ----- + isWidowedContextNoConvert: aOnceMarriedContext + "Answer if the argument is married to a live frame or not. + This method is safe for use only when no frameContext fields may be + forwarded (as maybe the case when scavenging). Post become: all + frameContext fields are followed, and hence normally no following of + frameContext fields is necessary." + <inline: true> "i.e. inline into isWidowedContext:" + | theFrame thePage shouldBeFrameCallerField | + self assert: ((objectMemory isContext: aOnceMarriedContext) + and: [self isMarriedOrWidowedContext: aOnceMarriedContext]). + theFrame := self frameOfMarriedContext: aOnceMarriedContext. + thePage := stackPages stackPageFor: theFrame. + ((stackPages isFree: thePage) + or: [theFrame < thePage headFP]) ifFalse: + ["The frame pointer is within the bounds of a live page. + Now check if it matches a frame." + shouldBeFrameCallerField := self withoutSmallIntegerTags: + (objectMemory + fetchPointer: InstructionPointerIndex + ofObject: aOnceMarriedContext). + ((self frameCallerFP: theFrame) = shouldBeFrameCallerField + and: [self frameHasContext: theFrame]) ifTrue: + [self deny: (((self isFrame: theFrame onPage: thePage)) + and: [objectMemory isForwarded: (self frameContext: theFrame)]). + (self frameContext: theFrame) = aOnceMarriedContext ifTrue: "It is still married!!" + [^false]]]. + ^true! Item was changed: ----- Method: StackInterpreter>>loadInitialContext (in category 'initialization') ----- loadInitialContext <inline: false> | activeProc activeContext | self cCode: [] inSmalltalk: [self initExtensions]. objectMemory runLeakCheckerFor: GCModeFull. + "primitiveSuspend needs to know the class of LinkedList" + self getClassTagOfLinkedList. activeProc := self activeProcess. activeContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: activeProc. self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext! Item was changed: ----- Method: StackInterpreter>>mapInterpreterOops (in category 'object memory support') ----- mapInterpreterOops "Map all oops in the interpreter's state to their new values during garbage collection or a become: operation." "Assume: All traced variables contain valid oops." <inline: false> self mapStackPages. self mapMachineCode: self getGCMode. self mapTraceLogs. self mapVMRegisters. self mapProfileState. self remapCallbackState. (tempOop ~= 0 and: [objectMemory shouldRemapOop: tempOop]) ifTrue: [tempOop := objectMemory remapObj: tempOop]. (tempOop2 ~= 0 and: [objectMemory shouldRemapOop: tempOop2]) ifTrue: + [tempOop2 := objectMemory remapObj: tempOop2]. + objectMemory hasSpurMemoryManagerAPI ifFalse: + [self getClassTagOfLinkedList]! - [tempOop2 := objectMemory remapObj: tempOop2]! Item was added: + ----- Method: StackInterpreter>>pcPreviousTo:inNewsqueakV4Method: (in category 'process primitive support') ----- + pcPreviousTo: theIP inNewsqueakV4Method: aMethod + | byte previousPC thisIP | + thisIP := (self startPCOfMethod: aMethod) + aMethod + objectMemory baseHeaderSize. + self assert: (self oop: thisIP isLessThan: theIP). + [self oop: thisIP isLessThan: theIP] whileTrue: + [previousPC := thisIP. + [byte := objectMemory byteAt: thisIP. + thisIP := thisIP + (self sizeOfNewsqueakV4Bytecode: byte). + self isNewsqueakV4Extension: byte] whileTrue]. + ^previousPC! Item was added: + ----- Method: StackInterpreter>>pcPreviousTo:inSistaV1Method: (in category 'process primitive support') ----- + pcPreviousTo: theIP inSistaV1Method: aMethod + | byte previousPC thisIP | + thisIP := (self startPCOfMethod: aMethod) + aMethod + objectMemory baseHeaderSize. + self assert: (self oop: thisIP isLessThan: theIP). + [self oop: thisIP isLessThan: theIP] whileTrue: + [previousPC := thisIP. + [byte := objectMemory byteAt: thisIP. + thisIP := thisIP + (self sizeOfSistaV1Bytecode: byte). + self isSistaV1Extension: byte] whileTrue]. + ^previousPC! Item was added: + ----- Method: StackInterpreter>>pcPreviousTo:inSqueakV3PlusClosuresMethod: (in category 'process primitive support') ----- + pcPreviousTo: theIP inSqueakV3PlusClosuresMethod: aMethod + | byte previousPC thisIP | + thisIP := (self startPCOfMethod: aMethod) + aMethod + objectMemory baseHeaderSize. + self assert: (self oop: thisIP isLessThan: theIP). + [self oop: thisIP isLessThan: theIP] whileTrue: + [previousPC := thisIP. + byte := objectMemory byteAt: thisIP. + thisIP := thisIP + (self sizeOfSqueakV3Bytecode: byte)]. + ^previousPC! Item was added: + ----- Method: StackInterpreter>>pcPreviousTo:inSqueakV3PlusClosuresOrNewsqueakV4Method: (in category 'process primitive support') ----- + pcPreviousTo: theIP inSqueakV3PlusClosuresOrNewsqueakV4Method: aMethod + (self methodUsesAlternateBytecodeSet: aMethod) ifTrue: + [^self pcPreviousTo: theIP inNewsqueakV4Method: aMethod]. + ^self pcPreviousTo: theIP inSqueakV3PlusClosuresMethod: aMethod! Item was added: + ----- Method: StackInterpreter>>pcPreviousTo:inSqueakV3PlusClosuresOrSistaV1Method: (in category 'process primitive support') ----- + pcPreviousTo: theIP inSqueakV3PlusClosuresOrSistaV1Method: aMethod + (self methodUsesAlternateBytecodeSet: aMethod) ifTrue: + [^self pcPreviousTo: theIP inSistaV1Method: aMethod]. + ^self pcPreviousTo: theIP inSqueakV3PlusClosuresMethod: aMethod! Item was changed: ----- Method: StackInterpreter>>removeProcess:fromList: (in category 'process primitive support') ----- removeProcess: aProcess fromList: aList "Remove a given process from a linked list. May fail if aProcess is not on the list." | firstLink lastLink nextLink tempLink | self deny: (objectMemory isForwarded: aProcess). self deny: (objectMemory isForwarded: aList). firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList. lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList. self deny: (objectMemory isForwarded: firstLink). self deny: (objectMemory isForwarded: lastLink). aProcess = firstLink ifTrue: [nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess. self deny: (objectMemory isForwarded: nextLink). objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink. aProcess = lastLink ifTrue: [objectMemory storePointerUnchecked: LastLinkIndex ofObject: aList withValue: objectMemory nilObject]] ifFalse: [tempLink := firstLink. [self deny: (objectMemory isForwarded: tempLink). tempLink = objectMemory nilObject ifTrue: + [^false]. - [self primitiveFail. ^self]. nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink. nextLink = aProcess] whileFalse: [tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink]. nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess. objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink. aProcess = lastLink ifTrue: [objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink]]. + objectMemory storePointerUnchecked: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject. + ^true! - objectMemory storePointerUnchecked: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject! Item was added: + ----- Method: StackInterpreter>>sizeOfNewsqueakV4Bytecode: (in category 'process primitive support') ----- + sizeOfNewsqueakV4Bytecode: bytecode + <inline: #always> + "Answer the number of bytes in the bytecode." + ^bytecode < 16rE0 + ifTrue: [1] + ifFalse: + [bytecode < 16rF9 + ifTrue: [2] + ifFalse: [3]]! Item was added: + ----- Method: StackInterpreter>>sizeOfSistaV1Bytecode: (in category 'process primitive support') ----- + sizeOfSistaV1Bytecode: bytecode + <inline: #always> + "Answer the number of bytes in the bytecode." + ^bytecode < 16rE0 + ifTrue: [1] + ifFalse: + [bytecode < 16rF8 + ifTrue: [2] + ifFalse: [3]]! Item was added: + ----- Method: StackInterpreter>>sizeOfSqueakV3Bytecode: (in category 'process primitive support') ----- + sizeOfSqueakV3Bytecode: bytecode + <inline: #always> + | extensionSizes | + extensionSizes := self + cCoerce: #[2 2 2 2 3 2 2 1 1 1 2 3 3 3 3 4] + to: #'unsigned char *'. + "Answer the number of bytes in the bytecode." + ^bytecode <= 125 + ifTrue: [1] + ifFalse: + [bytecode >= 176 + ifTrue: [1] + ifFalse: + [bytecode >= 160 "long jumps" + ifTrue: [2] + ifFalse: + [bytecode >= 144 "short jumps" + ifTrue: [1] + ifFalse: + [bytecode >= 128 "extensions" + ifTrue: [extensionSizes at: bytecode - 128] + ifFalse: + [self assertf: 'illegal bytecode in sizeOfSqueakV3Bytecode:'. "126 & 127 are unused" + 1]]]]]! Item was added: + ----- Method: StackInterpreterPrimitives>>primitiveSuspend (in category 'process primitives') ----- + primitiveSuspend + "Primitive. Suspend the receiver, aProcess, such that it can be executed again + by sending #resume. If the given process is not the active process, take it off + its corresponding list. If the list was not its run queue assume it was on some + condition variable (Semaphore, Mutex) and back up its pc to the send that + invoked the wait state the process entered. Hence when the process resumes + it will reenter the wait state. Answer the list the receiver was previously on iff + it was not active and not blocked, otherwise answer nil." + | process myList ok | + process := self stackTop. + process = self activeProcess ifTrue: + [self pop: 1 thenPush: objectMemory nilObject. + ^self transferTo: self wakeHighestPriority]. + "Alas in Spur we need a read barrier" + myList := objectMemory followField: MyListIndex ofObject: process. + myList = objectMemory nilObject ifTrue: + [^self primitiveFailFor: PrimErrBadReceiver]. + ok := self removeProcess: process fromList: myList. + ok ifFalse: + [^self primitiveFailFor: PrimErrOperationFailed]. + objectMemory storePointerUnchecked: MyListIndex ofObject: process withValue: objectMemory nilObject. + self assert: RevisedSuspend. + (RevisedSuspend + and: [(objectMemory fetchClassTagOfNonImm: myList) ~= classLinkedListClassTag]) + ifTrue: + [self backupProcess: process toBlockingSendTo: myList. + self pop: 1 thenPush: objectMemory nilObject] + ifFalse: + [self pop: 1 thenPush: myList]! Item was changed: ----- Method: StackInterpreterSimulator>>primitiveSuspend (in category 'debugging traps') ----- primitiveSuspend "Catch errors before we start the whole morphic error process" "byteCount > 1000000 ifTrue: [self halt]." "Ignore early process activity" + "self stackTop = (objectMemory fetchPointer: FirstLinkIndex ofObject: (objectMemory splObj: TheFinalizationSemaphore)) ifTrue: + [self halt]." ^ super primitiveSuspend! Item was changed: ----- Method: StackInterpreterSimulator>>primitiveWait (in category 'debugging traps') ----- primitiveWait "Catch errors before we start the whole morphic error process" "byteCount > 1000000 ifTrue: [self halt]." "Ignore early process activity" + "self stackTop = (objectMemory splObj: TheFinalizationSemaphore) ifTrue: + [self halt]." ^ super primitiveWait!

1 0

VM Maker: VMMaker.oscog-eem.3126.mcz
by commits＠source.squeak.org 01 Jan '22

01 Jan '22

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3126.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3126 Author: eem Time: 1 January 2022, 11:33:08.289665 am UUID: f737161c-666f-4f30-8f47-377359e874ff Ancestors: VMMaker.oscog-eem.3125 Restore the Interpreter primitives (not Interpreterprimitives primitives) deleted in VMMaker.oscog-nice.1793. I need the old versions for reference, Yes, we want to merge with VMMaker at some point, and I think that is easier with the primitives in place. =============== Diff against VMMaker.oscog-eem.3125 =============== Item was added: + ----- Method: Interpreter>>primitiveAdd (in category 'arithmetic integer primitives') ----- + primitiveAdd + + self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) + (self stackIntegerValue: 0)! Item was added: + ----- Method: Interpreter>>primitiveArctan (in category 'arithmetic float primitives') ----- + primitiveArctan + + | rcvr | + <var: #rcvr type: 'double '> + rcvr := self popFloat. + successFlag + ifTrue: [self pushFloat: (self cCode: 'atan(rcvr)' inSmalltalk: [rcvr arcTan])] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveArrayBecome (in category 'object access primitives') ----- + primitiveArrayBecome + "We must flush the method cache here, to eliminate stale references + to mutated classes and/or selectors." + + | arg rcvr | + arg := self stackTop. + rcvr := self stackValue: 1. + self success: (self become: rcvr with: arg twoWay: true copyHash: false). + successFlag ifTrue: [ self pop: 1 ].! Item was added: + ----- Method: Interpreter>>primitiveArrayBecomeOneWay (in category 'object access primitives') ----- + primitiveArrayBecomeOneWay + "We must flush the method cache here, to eliminate stale references + to mutated classes and/or selectors." + + | arg rcvr | + arg := self stackTop. + rcvr := self stackValue: 1. + self success: (self become: rcvr with: arg twoWay: false copyHash: true). + successFlag ifTrue: [ self pop: 1 ].! Item was added: + ----- Method: Interpreter>>primitiveArrayBecomeOneWayCopyHash (in category 'object access primitives') ----- + primitiveArrayBecomeOneWayCopyHash + "Similar to primitiveArrayBecomeOneWay but accepts a third argument whether to copy + the receiver's identity hash over the argument's identity hash." + + | copyHashFlag arg rcvr | + copyHashFlag := self booleanValueOf: (self stackTop). + arg := self stackValue: 1. + rcvr := self stackValue: 2. + self success: (self become: rcvr with: arg twoWay: false copyHash: copyHashFlag). + successFlag ifTrue: [ self pop: 2 ].! Item was added: + ----- Method: Interpreter>>primitiveAsFloat (in category 'arithmetic float primitives') ----- + primitiveAsFloat + | arg | + arg := self popInteger. + self successful + ifTrue: [self pushFloat: arg asFloat] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveAt (in category 'array primitives') ----- + primitiveAt + + self commonAt: false.! Item was added: + ----- Method: Interpreter>>primitiveAtPut (in category 'array primitives') ----- + primitiveAtPut + + self commonAtPut: false.! Item was added: + ----- Method: Interpreter>>primitiveBeCursor (in category 'I/O primitives') ----- + primitiveBeCursor + "Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk." + + | cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor | + + argumentCount = 0 ifTrue: [ + cursorObj := self stackTop. + maskBitsIndex := nil]. + argumentCount = 1 ifTrue: [ + cursorObj := self stackValue: 1. + maskObj := self stackTop]. + self success: (argumentCount < 2). + + self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]). + successFlag ifTrue: [ + bitsObj := self fetchPointer: 0 ofObject: cursorObj. + extentX := self fetchInteger: 1 ofObject: cursorObj. + extentY := self fetchInteger: 2 ofObject: cursorObj. + depth := self fetchInteger: 3 ofObject: cursorObj. + offsetObj := self fetchPointer: 4 ofObject: cursorObj]. + self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]). + + successFlag ifTrue: [ + offsetX := self fetchInteger: 0 ofObject: offsetObj. + offsetY := self fetchInteger: 1 ofObject: offsetObj. + + (argumentCount = 0 and: [depth = 32]) + ifTrue: [ + "Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51" + self success: ((extentX > 0) and: [extentY > 0]). + self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]). + self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]). + cursorBitsIndex := bitsObj + self baseHeaderSize. + self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]). + self cCode: '' inSmalltalk: + [ourCursor := Cursor + extent: extentX @ extentY + depth: 32 + fromArray: ((1 to: extentX * extentY) collect: [:i | + self fetchLong32: i-1 ofObject: bitsObj]) + offset: offsetX @ offsetY]] + ifFalse: [ + self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]). + self success: ((offsetX >= -16) and: [offsetX <= 0]). + self success: ((offsetY >= -16) and: [offsetY <= 0]). + self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]). + cursorBitsIndex := bitsObj + self baseHeaderSize. + self cCode: '' inSmalltalk: + [ourCursor := Cursor + extent: extentX @ extentY + fromArray: ((1 to: 16) collect: [:i | + ((self fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF]) + offset: offsetX @ offsetY]]]. + + argumentCount = 1 ifTrue: [ + self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]). + successFlag ifTrue: [ + bitsObj := self fetchPointer: 0 ofObject: maskObj. + extentX := self fetchInteger: 1 ofObject: maskObj. + extentY := self fetchInteger: 2 ofObject: maskObj. + depth := self fetchInteger: 3 ofObject: maskObj]. + + successFlag ifTrue: [ + self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]). + self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]). + maskBitsIndex := bitsObj + self baseHeaderSize]]. + + + successFlag ifTrue: [ + argumentCount = 0 + ifTrue: [ + depth = 32 + ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)' + inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor]) + ifFalse: [^self success: false. ]] + ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)' + inSmalltalk: [ourCursor show]]] + ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)' + inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler" + ourCursor show]]. + self pop: argumentCount]! Item was added: + ----- Method: Interpreter>>primitiveBeDisplay (in category 'I/O primitives') ----- + primitiveBeDisplay + "Record the system Display object in the specialObjectsTable." + | rcvr | + rcvr := self stackTop. + self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]). + successFlag ifTrue: [self storePointer: TheDisplay ofObject: specialObjectsOop withValue: rcvr]! Item was added: + ----- Method: Interpreter>>primitiveBeep (in category 'I/O primitives') ----- + primitiveBeep + "make the basic beep noise" + self ioBeep.! Item was added: + ----- Method: Interpreter>>primitiveBitAnd (in category 'arithmetic integer primitives') ----- + primitiveBitAnd + | integerReceiver integerArgument | + integerArgument := self popPos32BitInteger. + integerReceiver := self popPos32BitInteger. + successFlag + ifTrue: [self push: (self positive32BitIntegerFor: + (integerReceiver bitAnd: integerArgument))] + ifFalse: [self unPop: 2]! Item was added: + ----- Method: Interpreter>>primitiveBitOr (in category 'arithmetic integer primitives') ----- + primitiveBitOr + | integerReceiver integerArgument | + integerArgument := self popPos32BitInteger. + integerReceiver := self popPos32BitInteger. + successFlag + ifTrue: [self push: (self positive32BitIntegerFor: + (integerReceiver bitOr: integerArgument))] + ifFalse: [self unPop: 2]! Item was added: + ----- Method: Interpreter>>primitiveBitShift (in category 'arithmetic integer primitives') ----- + primitiveBitShift + | integerReceiver integerArgument shifted | + integerArgument := self popInteger. + integerReceiver := self popPos32BitInteger. + successFlag ifTrue: [ + integerArgument >= 0 ifTrue: [ + "Left shift -- must fail if we lose bits beyond 32" + self success: integerArgument <= 31. + shifted := integerReceiver << integerArgument. + self success: (shifted >> integerArgument) = integerReceiver. + ] ifFalse: [ + "Right shift -- OK to lose bits" + self success: integerArgument >= -31. + shifted := integerReceiver bitShift: integerArgument. + ]. + ]. + successFlag + ifTrue: [self push: (self positive32BitIntegerFor: shifted)] + ifFalse: [self unPop: 2]! Item was added: + ----- Method: Interpreter>>primitiveBitXor (in category 'arithmetic integer primitives') ----- + primitiveBitXor + | integerReceiver integerArgument | + integerArgument := self popPos32BitInteger. + integerReceiver := self popPos32BitInteger. + successFlag + ifTrue: [self push: (self positive32BitIntegerFor: + (integerReceiver bitXor: integerArgument))] + ifFalse: [self unPop: 2]! Item was added: + ----- Method: Interpreter>>primitiveBytesLeft (in category 'memory space primitives') ----- + primitiveBytesLeft + "Reports bytes available at this moment. For more meaningful + results, calls to this primitive should be precedeed by a full + or incremental garbage collection." + | aBool | + self methodArgumentCount = 0 + ifTrue: ["old behavior - just return the size of the free block" + ^self pop: 1 thenPushInteger: (self sizeOfFree: freeBlock)]. + self methodArgumentCount = 1 + ifTrue: ["new behaviour -including or excluding swap space depending on aBool" + aBool := self booleanValueOf: self stackTop. + successFlag ifFalse: [^ nil]. + ^self pop: 2 thenPushInteger: (self bytesLeft: aBool)]. + ^ self primitiveFail! Item was added: + ----- Method: Interpreter>>primitiveCalloutToFFI (in category 'message sending') ----- + primitiveCalloutToFFI + "Perform a function call to a foreign function. + Only invoked from method containing explicit external call spec. + Due to this we use the pluggable prim mechanism explicitly here + (the first literal of any FFI spec'ed method is an ExternalFunction + and not an array as used in the pluggable primitive mechanism)." + + | function moduleName functionName | + <var: #function declareC: 'static void *function = 0'> + <var: #moduleName declareC: 'static char *moduleName = "SqueakFFIPrims"'> + <var: #functionName declareC: 'static char *functionName = "primitiveCallout"'> + function = 0 ifTrue: [ + function := self + ioLoadExternalFunction: (self oopForPointer: functionName) + OfLength: 16 + FromModule: (self oopForPointer: moduleName) + OfLength: 14. + function == 0 ifTrue: [^self primitiveFail]]. + ^self cCode: '((sqInt (*)(void))function)()'. + ! Item was added: + ----- Method: Interpreter>>primitiveChangeClass (in category 'object access primitives') ----- + primitiveChangeClass + "Primitive. Change the class of the receiver into the class of the argument given that + the format of the receiver matches the format of the argument's class. Fail if the + receiver or argument are SmallIntegers, or the receiver is an instance of a compact + class and the argument isn't, or when the argument's class is compact and the receiver + isn't, or when the format of the receiver is different from the format of the argument's + class, or when the arguments class is fixed and the receiver's size differs from the size + that an instance of the argument's class should have." + | arg rcvr argClass err | + arg := self stackObjectValue: 0. + rcvr := self stackObjectValue: 1. + self successful ifFalse:[^nil]. + argClass := self fetchClassOfNonImm: arg. + err := self changeClassOf: rcvr to: argClass. + err = 0 + ifTrue: ["Flush at cache because rcvr's class has changed." + self flushAtCache. + self pop: self methodArgumentCount] + ifFalse: [self primitiveFail]. + ^nil! Item was added: + ----- Method: Interpreter>>primitiveClass (in category 'object access primitives') ----- + primitiveClass + | instance | + instance := self stackTop. + self pop: argumentCount+1 thenPush: (self fetchClassOf: instance)! Item was added: + ----- Method: Interpreter>>primitiveClipboardText (in category 'I/O primitives') ----- + primitiveClipboardText + "When called with a single string argument, post the string to + the clipboard. When called with zero arguments, return a + string containing the current clipboard contents." + | s sz | + argumentCount = 1 + ifTrue: [s := self stackTop. + (self isBytes: s) ifFalse: [^ self primitiveFail]. + successFlag + ifTrue: [sz := self stSizeOf: s. + self clipboardWrite: sz From: s + self baseHeaderSize At: 0. + self pop: 1]] + ifFalse: [sz := self clipboardSize. + (self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail]. + s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz. + self clipboardRead: sz Into: s + self baseHeaderSize At: 0. + self pop: 1 thenPush: s]! Item was added: + ----- Method: Interpreter>>primitiveConstantFill (in category 'sound primitives') ----- + primitiveConstantFill + "Fill the receiver, which must be an indexable bytes or words + objects, with the given integer value." + | fillValue rcvr rcvrIsBytes end i | + <var: #end type: 'usqInt'> + <var: #i type: 'usqInt'> + fillValue := self positive32BitValueOf: self stackTop. + rcvr := self stackValue: 1. + self success: (self isWordsOrBytes: rcvr). + rcvrIsBytes := self isBytes: rcvr. + rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])]. + successFlag + ifTrue: [end := rcvr + (self sizeBitsOf: rcvr). + i := rcvr + self baseHeaderSize. + rcvrIsBytes + ifTrue: [[i < end] + whileTrue: [self byteAt: i put: fillValue. + i := i + 1]] + ifFalse: [[i < end] + whileTrue: [self long32At: i put: fillValue. + i := i + 4]]. + self pop: 1]! Item was added: + ----- Method: Interpreter>>primitiveDisablePowerManager (in category 'system control primitives') ----- + primitiveDisablePowerManager + "Pass in a non-negative value to disable the architectures powermanager if any, zero to enable. This is a named (not numbered) primitive in the null module (ie the VM)" + + | integer | + <export: true> + integer := self stackIntegerValue: 0. + successFlag ifTrue: [ + self ioDisablePowerManager: integer. + self pop: 1]. "integer; leave rcvr on stack" + ! Item was added: + ----- Method: Interpreter>>primitiveDiv (in category 'arithmetic integer primitives') ----- + primitiveDiv + | quotient | + quotient := self doPrimitiveDiv: (self stackValue: 1) by: (self stackTop). + self pop2AndPushIntegerIfOK: quotient! Item was added: + ----- Method: Interpreter>>primitiveDivide (in category 'arithmetic integer primitives') ----- + primitiveDivide + | integerReceiver integerArgument | + integerReceiver := self stackIntegerValue: 1. + integerArgument := self stackIntegerValue: 0. + (integerArgument ~= 0 and: [integerReceiver \\ integerArgument = 0]) + ifTrue: [self pop2AndPushIntegerIfOK: integerReceiver // integerArgument] + ifFalse: [self primitiveFail]! Item was added: + ----- Method: Interpreter>>primitiveEqual (in category 'arithmetic integer primitives') ----- + primitiveEqual + | integerReceiver integerArgument result | + integerArgument := self popStack. + integerReceiver := self popStack. + result := self compare31or32Bits: integerReceiver equal: integerArgument. + self checkBooleanResult: result! Item was added: + ----- Method: Interpreter>>primitiveEquivalent (in category 'object access primitives') ----- + primitiveEquivalent + "is the receiver/first argument the same object as the (last) argument?. + pop argumentCount because this can be used as a mirror primitive." + | thisObject otherObject | + otherObject := self stackValue: 1. + thisObject := self stackTop. + self pop: argumentCount + 1 thenPushBool: thisObject = otherObject! Item was added: + ----- Method: Interpreter>>primitiveExitToDebugger (in category 'system control primitives') ----- + primitiveExitToDebugger + + self error: 'Exit to debugger at user request'.! Item was added: + ----- Method: Interpreter>>primitiveExp (in category 'arithmetic float primitives') ----- + primitiveExp + "Computes E raised to the receiver power." + + | rcvr | + <var: #rcvr type: 'double '> + rcvr := self popFloat. + successFlag + ifTrue: [self pushFloat: (self cCode: 'exp(rcvr)' inSmalltalk: [rcvr exp])] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveExponent (in category 'arithmetic float primitives') ----- + primitiveExponent + "Exponent part of this float." + + | rcvr frac pwr | + <var: #rcvr type: 'double '> + <var: #frac type: 'double '> + <var: #pwr type: 'int '> + rcvr := self popFloat. + successFlag + ifTrue: [ "rcvr = frac * 2^pwr, where frac is in [0.5..1.0)" + self cCode: 'frac = frexp(rcvr, &pwr)' + inSmalltalk: [pwr := rcvr exponent]. + self pushInteger: pwr - 1] + ifFalse: [self unPop: 1].! Item was added: + ----- Method: Interpreter>>primitiveFail (in category 'primitive support') ----- + primitiveFail + + successFlag := false.! Item was added: + ----- Method: Interpreter>>primitiveFindHandlerContext (in category 'process primitives') ----- + primitiveFindHandlerContext + "Primitive. Search up the context stack for the next method context marked for exception handling starting at the receiver. Return nil if none found" + | thisCntx nilOop | + thisCntx := self popStack. + nilOop := nilObj. + + [(self isHandlerMarked: thisCntx) ifTrue:[ + self push: thisCntx. + ^nil]. + thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx. + thisCntx = nilOop] whileFalse. + + ^self push: nilObj! Item was added: + ----- Method: Interpreter>>primitiveFindNextUnwindContext (in category 'process primitives') ----- + primitiveFindNextUnwindContext + "Primitive. Search up the context stack for the next method context marked for unwind handling from the receiver up to but not including the argument. Return nil if none found." + | thisCntx nilOop aContext unwindMarked | + aContext := self popStack. + thisCntx := self fetchPointer: SenderIndex ofObject: self popStack. + nilOop := nilObj. + + [(thisCntx = aContext) or: [thisCntx = nilOop]] whileFalse: [ + unwindMarked := self isUnwindMarked: thisCntx. + unwindMarked ifTrue:[ + self push: thisCntx. + ^nil]. + thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx]. + + ^self push: nilOop! Item was added: + ----- Method: Interpreter>>primitiveFloatAdd (in category 'arithmetic float primitives') ----- + primitiveFloatAdd + self primitiveFloatAdd: (self stackValue: 1) toArg: self stackTop! Item was added: + ----- Method: Interpreter>>primitiveFloatDivide (in category 'arithmetic float primitives') ----- + primitiveFloatDivide + ^ self primitiveFloatDivide: (self stackValue: 1) byArg: self stackTop! Item was added: + ----- Method: Interpreter>>primitiveFloatEqual (in category 'arithmetic float primitives') ----- + primitiveFloatEqual + | aBool | + aBool := self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop. + successFlag ifTrue: [self pop: 2. self pushBool: aBool]. + ! Item was added: + ----- Method: Interpreter>>primitiveFloatGreaterOrEqual (in category 'float primitives') ----- + primitiveFloatGreaterOrEqual + | aBool | + aBool := self primitiveFloatGreaterOrEqual: (self stackValue: 1) toArg: self stackTop. + successFlag ifTrue: [self pop: 2. self pushBool: aBool].! Item was added: + ----- Method: Interpreter>>primitiveFloatGreaterThan (in category 'arithmetic float primitives') ----- + primitiveFloatGreaterThan + | aBool | + aBool := self primitiveFloatGreater: (self stackValue: 1) thanArg: self stackTop. + successFlag ifTrue: [self pop: 2. self pushBool: aBool]. + ! Item was added: + ----- Method: Interpreter>>primitiveFloatLessOrEqual (in category 'float primitives') ----- + primitiveFloatLessOrEqual + | aBool | + aBool := self primitiveFloatLessOrEqual: (self stackValue: 1) toArg: self stackTop. + successFlag ifTrue: [self pop: 2. self pushBool: aBool].! Item was added: + ----- Method: Interpreter>>primitiveFloatLessThan (in category 'arithmetic float primitives') ----- + primitiveFloatLessThan + | aBool | + aBool := self primitiveFloatLess: (self stackValue: 1) thanArg: self stackTop. + successFlag ifTrue: [self pop: 2. self pushBool: aBool]. + ! Item was added: + ----- Method: Interpreter>>primitiveFloatMultiply (in category 'arithmetic float primitives') ----- + primitiveFloatMultiply + ^ self primitiveFloatMultiply: (self stackValue: 1) byArg: self stackTop! Item was added: + ----- Method: Interpreter>>primitiveFloatNotEqual (in category 'arithmetic float primitives') ----- + primitiveFloatNotEqual + | aBool | + aBool := self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop. + successFlag ifTrue: [self pop: 2. self pushBool: aBool not]. + ! Item was added: + ----- Method: Interpreter>>primitiveFloatSubtract (in category 'arithmetic float primitives') ----- + primitiveFloatSubtract + self primitiveFloatSubtract: (self stackValue: 1) fromArg: self stackTop! Item was added: + ----- Method: Interpreter>>primitiveFlushCache (in category 'system control primitives') ----- + primitiveFlushCache + "Clear the method lookup cache. This must be done after every programming change." + + self flushMethodCache. + self compilerFlushCacheHook: nil. "Flush the dynamic compiler's inline caches." + ! Item was added: + ----- Method: Interpreter>>primitiveFlushCacheSelective (in category 'system control primitives') ----- + primitiveFlushCacheSelective + "The receiver is a message selector. Clear all entries in the method lookup cache with this selector, presumably because an associated method has been redefined." + | selector probe | + selector := self stackTop. + probe := 0. + 1 to: MethodCacheEntries do: + [:i | (methodCache at: probe + MethodCacheSelector) = selector ifTrue: + [methodCache at: probe + MethodCacheSelector put: 0]. + probe := probe + MethodCacheEntrySize]! Item was added: + ----- Method: Interpreter>>primitiveFlushExternalPrimitives (in category 'plugin primitives') ----- + primitiveFlushExternalPrimitives + "Primitive. Flush all the existing external primitives in the image thus forcing a reload on next invokation." + ^self flushExternalPrimitives! Item was added: + ----- Method: Interpreter>>primitiveForceDisplayUpdate (in category 'I/O primitives') ----- + primitiveForceDisplayUpdate + "On some platforms, this primitive forces enqueued display updates to be processed immediately. On others, it does nothing." + + self ioForceDisplayUpdate. + ! Item was added: + ----- Method: Interpreter>>primitiveForceTenure (in category 'I/O primitives') ----- + primitiveForceTenure + "Set force tenure flag to true, this forces a tenure operation on the next incremental GC" + + <export: true> + forceTenureFlag := 1! Item was added: + ----- Method: Interpreter>>primitiveFormPrint (in category 'I/O primitives') ----- + primitiveFormPrint + "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer." + + | landscapeFlag vScale hScale rcvr bitsArray w h + depth pixelsPerWord wordsPerLine bitsArraySize ok | + + <var: #vScale type: 'double '> + <var: #hScale type: 'double '> + landscapeFlag := self booleanValueOf: self stackTop. + vScale := self floatValueOf: (self stackValue: 1). + hScale := self floatValueOf: (self stackValue: 2). + rcvr := self stackValue: 3. + (rcvr isIntegerObject: rcvr) ifTrue: [self success: false]. + successFlag ifTrue: [ + ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]) + ifFalse: [self success: false]]. + successFlag ifTrue: [ + bitsArray := self fetchPointer: 0 ofObject: rcvr. + w := self fetchInteger: 1 ofObject: rcvr. + h := self fetchInteger: 2 ofObject: rcvr. + depth := self fetchInteger: 3 ofObject: rcvr. + (w > 0 and: [h > 0]) ifFalse: [self success: false]. + pixelsPerWord := 32 // depth. + wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord. + ((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray]) + ifTrue: [ + bitsArraySize := self numBytesOf: bitsArray. + self success: (bitsArraySize = (wordsPerLine * h * 4))] + ifFalse: [self success: false]]. + successFlag ifTrue: [ + ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'. + self success: ok]. + successFlag ifTrue: [ + self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack" + ! Item was added: + ----- Method: Interpreter>>primitiveFractionalPart (in category 'arithmetic float primitives') ----- + primitiveFractionalPart + | rcvr frac trunc | + <var: #rcvr type: 'double '> + <var: #frac type: 'double '> + <var: #trunc type: 'double '> + rcvr := self popFloat. + successFlag + ifTrue: [self cCode: 'frac = modf(rcvr, &trunc)' inSmalltalk: [frac := rcvr fractionPart]. + self pushFloat: frac] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveFullGC (in category 'memory space primitives') ----- + primitiveFullGC + "Do a full garbage collection and return the number of bytes available (including swap space if dynamic memory management is supported)." + + self pop: 1. + self incrementalGC. "maximimize space for forwarding table" + self fullGC. + self pushInteger: (self bytesLeft: true).! Item was added: + ----- Method: Interpreter>>primitiveGetAttribute (in category 'system control primitives') ----- + primitiveGetAttribute + "Fetch the system attribute with the given integer ID. The + result is a string, which will be empty if the attribute is not + defined." + | attr sz s | + attr := self stackIntegerValue: 0. + successFlag + ifTrue: [sz := self attributeSize: attr]. + successFlag + ifTrue: [s := self + instantiateClass: (self splObj: ClassByteString) + indexableSize: sz. + self + getAttribute: attr + Into: s + self baseHeaderSize + Length: sz. + self pop: 2 thenPush: s]! Item was added: + ----- Method: Interpreter>>primitiveGetNextEvent (in category 'I/O primitives') ----- + primitiveGetNextEvent + "Primitive. Return the next input event from the VM event queue." + | evtBuf arg value | + <var: #evtBuf declareC:'int evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'> + self cCode:'' inSmalltalk:[evtBuf := CArrayAccessor on: (IntegerArray new: 8)]. + arg := self stackTop. + ((self isArray: arg) and:[(self slotSizeOf: arg) = 8]) ifFalse:[^self primitiveFail]. + + self ioGetNextEvent: (self cCoerce: evtBuf to: 'sqInputEvent*'). + successFlag ifFalse:[^nil]. + + "Event type" + self storeInteger: 0 ofObject: arg withValue: (evtBuf at: 0). + successFlag ifFalse:[^nil]. + + "Event time stamp" + self storeInteger: 1 ofObject: arg withValue: ((evtBuf at: 1) bitAnd: MillisecondClockMask). + successFlag ifFalse:[^nil]. + + "Event arguments" + 2 to: 7 do:[:i| + value := evtBuf at: i. + (self isIntegerValue: value) + ifTrue:[self storeInteger: i ofObject: arg withValue: value] + ifFalse:["Need to remap because allocation may cause GC" + self pushRemappableOop: arg. + value := self positive32BitIntegerFor: value. + arg := self popRemappableOop. + self storePointer: i ofObject: arg withValue: value]]. + + successFlag ifFalse:[^nil]. + self pop: 1.! Item was added: + ----- Method: Interpreter>>primitiveGreaterOrEqual (in category 'arithmetic integer primitives') ----- + primitiveGreaterOrEqual + | integerReceiver integerArgument | + integerArgument := self popInteger. + integerReceiver := self popInteger. + self checkBooleanResult: integerReceiver >= integerArgument! Item was added: + ----- Method: Interpreter>>primitiveGreaterThan (in category 'arithmetic integer primitives') ----- + primitiveGreaterThan + | integerReceiver integerArgument | + integerArgument := self popInteger. + integerReceiver := self popInteger. + self checkBooleanResult: integerReceiver > integerArgument! Item was added: + ----- Method: Interpreter>>primitiveImageName (in category 'other primitives') ----- + primitiveImageName + "When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name." + + | s sz sCRIfn okToRename | + <var: #sCRIfn type: 'void *'> + argumentCount = 1 ifTrue: [ + "If the security plugin can be loaded, use it to check for rename permission. + If not, assume it's ok" + sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'. + sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'. + okToRename ifFalse:[^self primitiveFail]]. + s := self stackTop. + self assertClassOf: s is: (self splObj: ClassByteString). + successFlag ifTrue: [ + sz := self stSizeOf: s. + self imageNamePut: (s + self baseHeaderSize) Length: sz. + self pop: 1. "pop s, leave rcvr on stack" + ]. + ] ifFalse: [ + sz := self imageNameSize. + s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz. + self imageNameGet: (s + self baseHeaderSize) Length: sz. + self pop: 1. "rcvr" + self push: s. + ]. + ! Item was added: + ----- Method: Interpreter>>primitiveIncrementalGC (in category 'memory space primitives') ----- + primitiveIncrementalGC + "Do a quick, incremental garbage collection and return the number of bytes immediately available. (Note: more space may be made available by doing a full garbage collection." + + self pop: 1. + self incrementalGC. + self pushInteger: (self bytesLeft: false).! Item was added: + ----- Method: Interpreter>>primitiveInputSemaphore (in category 'I/O primitives') ----- + primitiveInputSemaphore + "Register the input semaphore. If the argument is not a + Semaphore, unregister the current input semaphore." + | arg | + arg := self stackTop. + (self isIntegerObject: arg) + ifTrue: ["If arg is integer, then use it as an index + into the external objects array and install it + as the new event semaphore" + self ioSetInputSemaphore: (self integerValueOf: arg). + successFlag + ifTrue: [self pop: 1]. + ^ nil]. + + "old code for compatibility" + arg := self popStack. + (self fetchClassOf: arg) = (self splObj: ClassSemaphore) + ifTrue: [self + storePointer: TheInputSemaphore + ofObject: specialObjectsOop + withValue: arg] + ifFalse: [self + storePointer: TheInputSemaphore + ofObject: specialObjectsOop + withValue: nilObj]! Item was added: + ----- Method: Interpreter>>primitiveInputWord (in category 'I/O primitives') ----- + primitiveInputWord + "Return an integer indicating the reason for the most recent input interrupt." + + self pop: 1 thenPushInteger: 0. "noop for now"! Item was added: + ----- Method: Interpreter>>primitiveInstVarAt (in category 'object access primitives') ----- + primitiveInstVarAt + | index rcvr hdr fmt totalLength fixedFields value | + index := self stackIntegerValue: 0. + rcvr := self stackValue: 1. + successFlag + ifTrue: [hdr := self baseHeader: rcvr. + fmt := hdr >> 8 bitAnd: 15. + totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt. + fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength. + (index >= 1 and: [index <= fixedFields]) + ifFalse: [successFlag := false]]. + successFlag ifTrue: [value := self subscript: rcvr with: index format: fmt]. + successFlag ifTrue: [self pop: argumentCount + 1 thenPush: value]! Item was added: + ----- Method: Interpreter>>primitiveInstVarAtPut (in category 'object access primitives') ----- + primitiveInstVarAtPut + | newValue index rcvr hdr fmt totalLength fixedFields | + newValue := self stackTop. + index := self stackIntegerValue: 1. + rcvr := self stackValue: 2. + successFlag + ifTrue: [hdr := self baseHeader: rcvr. + fmt := hdr >> 8 bitAnd: 15. + totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt. + fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength. + (index >= 1 and: [index <= fixedFields]) ifFalse: [successFlag := false]]. + successFlag ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt]. + successFlag ifTrue: [self pop: argumentCount + 1 thenPush: newValue]! Item was added: + ----- Method: Interpreter>>primitiveInstVarsPutFromStack (in category 'quick primitives') ----- + primitiveInstVarsPutFromStack + "Note: this primitive has been decommissioned. It is only here for short-term compatibility with an internal 2.3beta-d image that used this. It did not save much time and it complicated several things. Plus Jitter will do it right anyway." + | rcvr offsetBits | + rcvr := self stackValue: argumentCount. + "Mark dirty so stores below can be unchecked" + (self oop: rcvr isLessThan: youngStart) ifTrue: [ self beRootIfOld: rcvr ]. + 0 to: argumentCount-1 do: + [:i | (i bitAnd: 3) = 0 ifTrue: + [offsetBits := self positive32BitValueOf: (self literal: i//4 ofMethod: newMethod)]. + self storePointerUnchecked: (offsetBits bitAnd: 16rFF) ofObject: rcvr + withValue: (self stackValue: i). + offsetBits := offsetBits >> 8]. + self pop: argumentCount! Item was added: + ----- Method: Interpreter>>primitiveIntegerAt (in category 'sound primitives') ----- + primitiveIntegerAt + "Return the 32bit signed integer contents of a words receiver" + + | index rcvr sz addr value intValue | + <var: #intValue type: 'int'> + index := self stackIntegerValue: 0. + rcvr := self stackValue: 1. + (self isIntegerObject: rcvr) ifTrue: [^self success: false]. + (self isWords: rcvr) ifFalse: [^self success: false]. + sz := self lengthOf: rcvr. "number of fields" + self success: ((index >= 1) and: [index <= sz]). + successFlag ifTrue: [ + addr := rcvr + self baseHeaderSize + (index - 1 * self wordSize). "for zero indexing" + value := self intAt: addr. + self pop: 2. "pop rcvr, index" + "push element value" + (self isIntegerValue: value) + ifTrue: [self pushInteger: value] + ifFalse: [ + intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt" + self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt" + ].! Item was added: + ----- Method: Interpreter>>primitiveIntegerAtPut (in category 'sound primitives') ----- + primitiveIntegerAtPut + "Return the 32bit signed integer contents of a words receiver" + | index rcvr sz addr value valueOop | + valueOop := self stackValue: 0. + index := self stackIntegerValue: 1. + rcvr := self stackValue: 2. + (self isIntegerObject: rcvr) ifTrue:[^self success: false]. + (self isWords: rcvr) ifFalse:[^self success: false]. + sz := self lengthOf: rcvr. "number of fields" + ((index >= 1) and: [index <= sz]) ifFalse:[^self success: false]. + value := self signed32BitValueOf: valueOop. + successFlag ifTrue:[ + addr := rcvr + self baseHeaderSize + (index - 1 * self wordSize). "for zero indexing" + value := self intAt: addr put: value. + self pop: 3 thenPush: valueOop. "pop all; return value" + ]. + ! Item was added: + ----- Method: Interpreter>>primitiveInterruptSemaphore (in category 'I/O primitives') ----- + primitiveInterruptSemaphore + "Register the user interrupt semaphore. If the argument is + not a Semaphore, unregister the current interrupt + semaphore. " + | arg | + arg := self popStack. + (self fetchClassOf: arg) = (self splObj: ClassSemaphore) + ifTrue: [self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: arg] + ifFalse: [self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: nilObj]! Item was added: + ----- Method: Interpreter>>primitiveIsRoot (in category 'memory space primitives') ----- + primitiveIsRoot + "Primitive. Answer whether the argument to the primitive is a root for young space" + | oop | + <export: true> + oop := self stackObjectValue: 0. + successFlag ifTrue: + [self pop: argumentCount + 1 thenPushBool: (self isYoungRoot: oop)]! Item was added: + ----- Method: Interpreter>>primitiveIsYoung (in category 'memory space primitives') ----- + primitiveIsYoung + "Primitive. Answer whether the argument to the primitive resides in young space." + | oop | + <export: true> + oop := self stackObjectValue: 0. + successFlag ifTrue:[ + self pop: argumentCount + 1. + self pushBool: (self oop: oop isGreaterThanOrEqualTo: youngStart). + ].! Item was added: + ----- Method: Interpreter>>primitiveKbdNext (in category 'I/O primitives') ----- + primitiveKbdNext + "Obsolete on virtually all platforms; old style input polling code. + Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>." + + | keystrokeWord | + self pop: 1. + keystrokeWord := self ioGetKeystroke. + keystrokeWord >= 0 + ifTrue: [self pushInteger: keystrokeWord] + ifFalse: [self push: nilObj].! Item was added: + ----- Method: Interpreter>>primitiveKbdPeek (in category 'I/O primitives') ----- + primitiveKbdPeek + "Obsolete on virtually all platforms; old style input polling code. + Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>." + + | keystrokeWord | + self pop: 1. + keystrokeWord := self ioPeekKeystroke. + keystrokeWord >= 0 + ifTrue: [self pushInteger: keystrokeWord] + ifFalse: [self push: nilObj].! Item was added: + ----- Method: Interpreter>>primitiveLessOrEqual (in category 'arithmetic integer primitives') ----- + primitiveLessOrEqual + | integerReceiver integerArgument | + integerArgument := self popInteger. + integerReceiver := self popInteger. + self checkBooleanResult: integerReceiver <= integerArgument! Item was added: + ----- Method: Interpreter>>primitiveLessThan (in category 'arithmetic integer primitives') ----- + primitiveLessThan + | integerReceiver integerArgument | + integerArgument := self popInteger. + integerReceiver := self popInteger. + self checkBooleanResult: integerReceiver < integerArgument! Item was added: + ----- Method: Interpreter>>primitiveListBuiltinModule (in category 'plugin primitives') ----- + primitiveListBuiltinModule + "Primitive. Return the n-th builtin module name." + | moduleName index length nameOop | + <var: #moduleName type: 'char *'> + self methodArgumentCount = 1 ifFalse:[^self primitiveFail]. + index := self stackIntegerValue: 0. + index <= 0 ifTrue:[^self primitiveFail]. + moduleName := self ioListBuiltinModule: index. + moduleName == nil ifTrue:[ + self pop: 2. "arg+rcvr" + ^self push: self nilObject]. + length := self strlen: moduleName. + nameOop := self instantiateClass: self classString indexableSize: length. + 0 to: length-1 do:[:i| + self storeByte: i ofObject: nameOop withValue: (moduleName at: i)]. + self forceInterruptCheck. + self pop: 2 thenPush: nameOop! Item was added: + ----- Method: Interpreter>>primitiveListExternalModule (in category 'plugin primitives') ----- + primitiveListExternalModule + "Primitive. Return the n-th loaded external module name." + | moduleName index length nameOop | + <var: #moduleName type: 'char *'> + self methodArgumentCount = 1 ifFalse:[^self primitiveFail]. + index := self stackIntegerValue: 0. + index <= 0 ifTrue:[^self primitiveFail]. + moduleName := self ioListLoadedModule: index. + moduleName == nil ifTrue:[ + self pop: 2. "arg+rcvr" + ^self push: self nilObject]. + length := self strlen: moduleName. + nameOop := self instantiateClass: self classString indexableSize: length. + 0 to: length-1 do:[:i| + self storeByte: i ofObject: nameOop withValue: (moduleName at: i)]. + self forceInterruptCheck. + self pop: 2 thenPush: nameOop! Item was added: + ----- Method: Interpreter>>primitiveLoadImageSegment (in category 'image segment in/out') ----- + primitiveLoadImageSegment + "This primitive is called from Squeak as... + <imageSegment> loadSegmentFrom: aWordArray outPointers: anArray." + + "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?" + + | outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data | + + <var: #endSeg type: 'usqInt'> + <var: #segOop type: 'usqInt'> + <var: #fieldPtr type: 'usqInt'> + <var: #lastOut type: 'usqInt'> + <var: #outPtr type: 'usqInt'> + <var: #lastPtr type: 'usqInt'> + + DoAssertionChecks ifTrue: [self verifyCleanHeaders]. + outPointerArray := self stackTop. + lastOut := outPointerArray + (self lastPointerOf: outPointerArray). + segmentWordArray := self stackValue: 1. + endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize. + + "Essential type checks" + ((self formatOf: outPointerArray) = 2 "Must be indexable pointers" + and: [(self formatOf: segmentWordArray) = 6]) "Must be indexable words" + ifFalse: [^ self primitiveFail]. + + "Version check. Byte order of the WordArray now" + data := self longAt: segmentWordArray + self baseHeaderSize. + (self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [ + "Not readable -- try again with reversed bytes..." + self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize. + data := self longAt: segmentWordArray + self baseHeaderSize. + (self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [ + "Still NG -- put things back and fail" + self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize. + DoAssertionChecks ifTrue: [self verifyCleanHeaders]. + ^ self primitiveFail]]. + "Reverse the Byte type objects if the is data from opposite endian machine." + "Test top byte. $d on the Mac or $s on the PC. Rest of word is equal." + (data >> 16) = (self imageSegmentVersion >> 16) ifFalse: [ + "Reverse the byte-type objects once" + segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize. + "Oop of first embedded object" + self byteSwapByteObjectsFrom: segOop to: endSeg + self wordSize]. + + "Proceed through the segment, remapping pointers..." + segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize. + [segOop <= endSeg] whileTrue: + [(self headerType: segOop) <= 1 + ifTrue: ["This object has a class field (type = 0 or 1) -- start with that." + fieldPtr := segOop - self wordSize. doingClass := true] + ifFalse: ["No class field -- start with first data field" + fieldPtr := segOop + self baseHeaderSize. doingClass := false]. + lastPtr := segOop + (self lastPointerOf: segOop). "last field" + lastPtr > endSeg ifTrue: [ + DoAssertionChecks ifTrue: [self verifyCleanHeaders]. + ^ self primitiveFail "out of bounds"]. + + "Go through all oops, remapping them..." + [fieldPtr > lastPtr] whileFalse: + ["Examine each pointer field" + fieldOop := self longAt: fieldPtr. + doingClass ifTrue: + [hdrTypeBits := self headerType: fieldPtr. + fieldOop := fieldOop - hdrTypeBits]. + (self isIntegerObject: fieldOop) + ifTrue: + ["Integer -- nothing to do" + fieldPtr := fieldPtr + self wordSize] + ifFalse: + [(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"]. + (fieldOop bitAnd: 16r80000000) = 0 + ifTrue: ["Internal pointer -- add segment offset" + mapOop := fieldOop + segmentWordArray] + ifFalse: ["External pointer -- look it up in outPointers" + outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF). + outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"]. + mapOop := self longAt: outPtr]. + doingClass + ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits. + fieldPtr := fieldPtr + 8. + doingClass := false] + ifFalse: [self longAt: fieldPtr put: mapOop. + fieldPtr := fieldPtr + self wordSize]. + segOop < youngStart + ifTrue: [self possibleRootStoreInto: segOop value: mapOop]. + ]]. + segOop := self objectAfter: segOop]. + + "Again, proceed through the segment checking consistency..." + segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize. + [segOop <= endSeg] whileTrue: + [(self oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"]. + fieldPtr := segOop + self baseHeaderSize. "first field" + lastPtr := segOop + (self lastPointerOf: segOop). "last field" + "Go through all oops, remapping them..." + [fieldPtr > lastPtr] whileFalse: + ["Examine each pointer field" + fieldOop := self longAt: fieldPtr. + (self oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"]. + fieldPtr := fieldPtr + self wordSize]. + segOop := self objectAfter: segOop]. + + "Truncate the segment word array to size = BytesPerWord (vers stamp only)" + extraSize := self extraHeaderBytes: segmentWordArray. + hdrTypeBits := self headerType: segmentWordArray. + extraSize = 8 + ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self wordSize + hdrTypeBits] + ifFalse: [header := self longAt: segmentWordArray. + self longAt: segmentWordArray + put: header - (header bitAnd: SizeMask) + self baseHeaderSize + self wordSize]. + "and return the roots array which was first in the segment" + DoAssertionChecks ifTrue: [self verifyCleanHeaders]. + self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize). + ! Item was added: + ----- Method: Interpreter>>primitiveLogN (in category 'arithmetic float primitives') ----- + primitiveLogN + "Natural log." + + | rcvr | + <var: #rcvr type: 'double '> + rcvr := self popFloat. + successFlag + ifTrue: [self pushFloat: (self cCode: 'log(rcvr)' inSmalltalk: [rcvr ln])] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveLowSpaceSemaphore (in category 'memory space primitives') ----- + primitiveLowSpaceSemaphore + "Register the low-space semaphore. If the argument is not a + Semaphore, unregister the current low-space Semaphore." + | arg | + arg := self popStack. + (self fetchClassOf: arg) = (self splObj: ClassSemaphore) + ifTrue: [self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: arg] + ifFalse: [self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: nilObj]! Item was added: + ----- Method: Interpreter>>primitiveMakePoint (in category 'arithmetic integer primitives') ----- + primitiveMakePoint + | rcvr argument pt | + argument := self stackTop. + rcvr := self stackValue: 1. + (self isIntegerObject: rcvr) + ifTrue: [(self isIntegerObject: argument) + ifTrue: [pt := self makePointwithxValue: (self integerValueOf: rcvr) yValue: (self integerValueOf: argument)] + ifFalse: [pt := self makePointwithxValue: (self integerValueOf: rcvr) yValue: 0. + "Above may cause GC!!" + self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)]] + ifFalse: [(self isFloatObject: rcvr) + ifFalse: [^ self success: false]. + pt := self makePointwithxValue: 0 yValue: 0. + "Above may cause GC!!" + self storePointer: 0 ofObject: pt withValue: (self stackValue: 1). + self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)]. + + self pop: 2 thenPush: pt! Item was added: + ----- Method: Interpreter>>primitiveMarkHandlerMethod (in category 'process primitives') ----- + primitiveMarkHandlerMethod + "Primitive. Mark the method for exception handling. The primitive must fail after marking the context so that the regular code is run." + <inline: false> + ^self primitiveFail! Item was added: + ----- Method: Interpreter>>primitiveMarkUnwindMethod (in category 'process primitives') ----- + primitiveMarkUnwindMethod + "Primitive. Mark the method for exception unwinding. The primitive must fail after marking the context so that the regular code is run." + <inline: false> + self primitiveFail! Item was added: + ----- Method: Interpreter>>primitiveMethod (in category 'plugin primitive support') ----- + primitiveMethod + "Return the method an external primitive was defined in" + ^newMethod! Item was added: + ----- Method: Interpreter>>primitiveMillisecondClock (in category 'system control primitives') ----- + primitiveMillisecondClock + "Return the value of the millisecond clock as an integer. Note that the millisecond clock wraps around periodically. On some platforms it can wrap daily. The range is limited to SmallInteger maxVal / 2 to allow delays of up to that length without overflowing a SmallInteger." + + self pop: 1 thenPush: (self integerObjectOf: (self ioMSecs bitAnd: MillisecondClockMask)). + ! Item was added: + ----- Method: Interpreter>>primitiveMod (in category 'arithmetic integer primitives') ----- + primitiveMod + | mod | + mod := self doPrimitiveMod: (self stackValue: 1) by: (self stackTop). + self pop2AndPushIntegerIfOK: mod! Item was added: + ----- Method: Interpreter>>primitiveMouseButtons (in category 'I/O primitives') ----- + primitiveMouseButtons + "Obsolete on virtually all platforms; old style input polling code. + Return the mouse button state. The low three bits encode the state of the <red><yellow><blue> mouse buttons. The next four bits encode the Smalltalk modifier bits <cmd><option><ctrl><shift>." + + | buttonWord | + self pop: 1. + buttonWord := self ioGetButtonState. + self pushInteger: buttonWord.! Item was added: + ----- Method: Interpreter>>primitiveMousePoint (in category 'I/O primitives') ----- + primitiveMousePoint + "Obsolete on virtually all platforms; old style input polling code. + Return a Point indicating current position of the mouse. Note that mouse coordinates may be negative if the mouse moves above or to the left of the top-left corner of the Smalltalk window." + + | pointWord x y | + self pop: 1. + pointWord := self ioMousePoint. + x := self signExtend16: ((pointWord >> 16) bitAnd: 16rFFFF). + y := self signExtend16: (pointWord bitAnd: 16rFFFF). + self push: (self makePointwithxValue: x yValue: y).! Item was added: + ----- Method: Interpreter>>primitiveMultiply (in category 'arithmetic integer primitives') ----- + primitiveMultiply + | integerRcvr integerArg integerResult | + integerRcvr := self stackIntegerValue: 1. + integerArg := self stackIntegerValue: 0. + successFlag ifTrue: + [integerResult := integerRcvr * integerArg. + "check for C overflow by seeing if computation is reversible" + ((integerArg = 0) or: [(integerResult // integerArg) = integerRcvr]) + ifTrue: [self pop2AndPushIntegerIfOK: integerResult] + ifFalse: [self primitiveFail]]! Item was added: + ----- Method: Interpreter>>primitiveNew (in category 'object access primitives') ----- + primitiveNew + "Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC" + + | class spaceOkay | + class := self stackTop. + "The following may cause GC!!" + spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: 0. + self success: spaceOkay. + successFlag ifTrue: [ self push: (self instantiateClass: self popStack indexableSize: 0) ]! Item was added: + ----- Method: Interpreter>>primitiveNewMethod (in category 'compiled methods') ----- + primitiveNewMethod + | header bytecodeCount class size theMethod literalCount | + header := self popStack. + bytecodeCount := self popInteger. + self success: (self isIntegerObject: header). + successFlag ifFalse: + [self unPop: 2. ^nil]. + class := self popStack. + size := (self literalCountOfMethodHeader: header) + 1 * self wordSize + bytecodeCount. + theMethod := self instantiateClass: class indexableSize: size. + self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header. + literalCount := self literalCountOfMethodHeader: header. + 1 to: literalCount do: + [:i | self storePointer: i ofObject: theMethod withValue: nilObj]. + self push: theMethod! Item was added: + ----- Method: Interpreter>>primitiveNewWithArg (in category 'object access primitives') ----- + primitiveNewWithArg + "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free." + | size class spaceOkay | + size := self positive32BitValueOf: self stackTop. + class := self stackValue: 1. + self success: size >= 0. + successFlag + ifTrue: ["The following may cause GC!!" + spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: size. + self success: spaceOkay. + class := self stackValue: 1]. + successFlag ifTrue: [self pop: 2 thenPush: (self instantiateClass: class indexableSize: size)]! Item was added: + ----- Method: Interpreter>>primitiveNextInstance (in category 'object access primitives') ----- + primitiveNextInstance + | object instance | + object := self stackTop. + (self isIntegerObject: object) ifTrue: + [^self primitiveFail]. + instance := self instanceAfter: object. + instance = nilObj ifTrue: + [^self primitiveFail]. + self pop: argumentCount+1 thenPush: instance! Item was added: + ----- Method: Interpreter>>primitiveNextObject (in category 'object access primitives') ----- + primitiveNextObject + "Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects." + + | object instance | + object := self stackTop. + instance := self accessibleObjectAfter: object. + instance = nil + ifTrue: [ self pop: argumentCount+1 thenPushInteger: 0 ] + ifFalse: [ self pop: argumentCount+1 thenPush: instance ].! Item was added: + ----- Method: Interpreter>>primitiveNoop (in category 'system control primitives') ----- + primitiveNoop + "A placeholder for primitives that haven't been implemented or are being withdrawn gradually. Just absorbs any arguments and returns the receiver." + + self pop: argumentCount. "pop args, leave rcvr on stack"! Item was added: + ----- Method: Interpreter>>primitiveNotEqual (in category 'arithmetic integer primitives') ----- + primitiveNotEqual + | integerReceiver integerArgument result | + integerArgument := self popStack. + integerReceiver := self popStack. + result := (self compare31or32Bits: integerReceiver equal: integerArgument) not. + self checkBooleanResult: result! Item was added: + ----- Method: Interpreter>>primitiveObjectAt (in category 'object access primitives') ----- + primitiveObjectAt + "Defined for CompiledMethods only" + | thisReceiver index | + index := self popInteger. + thisReceiver := self popStack. + self success: index > 0. + self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart). + successFlag + ifTrue: [self push: (self fetchPointer: index - 1 ofObject: thisReceiver)] + ifFalse: [self unPop: 2]! Item was added: + ----- Method: Interpreter>>primitiveObjectAtPut (in category 'object access primitives') ----- + primitiveObjectAtPut + "Defined for CompiledMethods only" + | thisReceiver index newValue | + newValue := self popStack. + index := self popInteger. + thisReceiver := self popStack. + self success: index > 0. + self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart). + successFlag + ifTrue: [self storePointer: index - 1 ofObject: thisReceiver withValue: newValue. + self push: newValue] + ifFalse: [self unPop: 3]! Item was added: + ----- Method: Interpreter>>primitiveObjectPointsTo (in category 'object access primitives') ----- + primitiveObjectPointsTo + | rcvr thang lastField | + thang := self popStack. + rcvr := self popStack. + (self isIntegerObject: rcvr) ifTrue: [^self pushBool: false]. + + lastField := self lastPointerOf: rcvr. + self baseHeaderSize to: lastField by: self wordSize do: + [:i | (self longAt: rcvr + i) = thang + ifTrue: [^ self pushBool: true]]. + self pushBool: false.! Item was added: + ----- Method: Interpreter>>primitivePointX (in category 'object access primitives') ----- + primitivePointX + | rcvr | + <inline: false> + rcvr := self popStack. + self assertClassOf: rcvr is: (self splObj: ClassPoint). + successFlag + ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitivePointY (in category 'object access primitives') ----- + primitivePointY + | rcvr | + <inline: false> + rcvr := self popStack. + self assertClassOf: rcvr is: (self splObj: ClassPoint). + successFlag + ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveQuit (in category 'system control primitives') ----- + primitiveQuit + + self ioExit. + ! Item was added: + ----- Method: Interpreter>>primitiveQuo (in category 'arithmetic integer primitives') ----- + primitiveQuo + "Rounds negative results towards zero." + | integerRcvr integerArg integerResult | + integerRcvr := self stackIntegerValue: 1. + integerArg := self stackIntegerValue: 0. + self success: integerArg ~= 0. + successFlag ifTrue: [ + integerRcvr > 0 ifTrue: [ + integerArg > 0 ifTrue: [ + integerResult := integerRcvr // integerArg. + ] ifFalse: [ + integerResult := 0 - (integerRcvr // (0 - integerArg)). + ]. + ] ifFalse: [ + integerArg > 0 ifTrue: [ + integerResult := 0 - ((0 - integerRcvr) // integerArg). + ] ifFalse: [ + integerResult := (0 - integerRcvr) // (0 - integerArg). + ]. + ]]. + self pop2AndPushIntegerIfOK: integerResult! Item was added: + ----- Method: Interpreter>>primitiveRelinquishProcessor (in category 'I/O primitives') ----- + primitiveRelinquishProcessor + "Relinquish the processor for up to the given number of microseconds. The exact behavior of this primitive is platform dependent." + + | microSecs | + microSecs := self stackIntegerValue: 0. + successFlag ifTrue: [ + "DO NOT allow relinquishing the processor while we are profiling since this + may skew the time base for our measures (it may reduce processor speed etc). + Instead we go full speed, therefore measuring the precise time we spend in the + inner idle loop as a busy loop." + nextProfileTick = 0 ifTrue:[self ioRelinquishProcessorForMicroseconds: microSecs]. + self pop: 1. "microSecs; leave rcvr on stack" + ].! Item was added: + ----- Method: Interpreter>>primitiveRootTable (in category 'memory space primitives') ----- + primitiveRootTable + "Primitive. Answer a copy (snapshot) element of the root table. + The primitive can cause GC itself and if so the return value may + be inaccurate - in this case one should guard the read operation + by looking at the gc counter statistics." + self pop: argumentCount + 1 thenPush: self rootTableObject! Item was added: + ----- Method: Interpreter>>primitiveRootTableAt (in category 'memory space primitives') ----- + primitiveRootTableAt + "Primitive. Answer the nth element of the root table. + This primitive avoids the creation of an extra array; + it is intended for enumerations of the form: + index := 1. + [root := Smalltalk rootTableAt: index. + root == nil] whileFalse:[index := index + 1]. + " + | index | + <export: true> + index := self stackIntegerValue: 0. + self success: (index > 0 and:[index <= rootTableCount]). + successFlag ifTrue:[ + self pop: argumentCount + 1. + self push: (rootTable at: index). + ].! Item was added: + ----- Method: Interpreter>>primitiveScanCharacters (in category 'I/O primitives') ----- + primitiveScanCharacters + "The character scanner primitive." + | kernDelta stops sourceString scanStopIndex scanStartIndex rcvr scanDestX scanLastIndex scanXTable scanMap maxGlyph ascii stopReason glyphIndex sourceX sourceX2 nextDestX scanRightX nilOop | + + self methodArgumentCount = 6 + ifFalse: [^ self primitiveFail]. + + "Load the arguments" + kernDelta := self stackIntegerValue: 0. + stops := self stackObjectValue: 1. + (self isArray: stops) ifFalse: [^ self primitiveFail]. + (self slotSizeOf: stops) >= 258 ifFalse: [^ self primitiveFail]. + scanRightX := self stackIntegerValue: 2. + sourceString := self stackObjectValue: 3. + (self isBytes: sourceString) ifFalse: [^ self primitiveFail]. + scanStopIndex := self stackIntegerValue: 4. + scanStartIndex := self stackIntegerValue: 5. + (scanStartIndex > 0 and: [scanStopIndex > 0 and: [scanStopIndex <= (self byteSizeOf: sourceString)]]) + ifFalse: [^ self primitiveFail]. + + "Load receiver and required instVars" + rcvr := self stackObjectValue: 6. + ((self isPointers: rcvr) and: [(self slotSizeOf: rcvr) >= 4]) ifFalse: [^ self primitiveFail]. + scanDestX := self fetchInteger: 0 ofObject: rcvr. + scanLastIndex := self fetchInteger: 1 ofObject: rcvr. + scanXTable := self fetchPointer: 2 ofObject: rcvr. + scanMap := self fetchPointer: 3 ofObject: rcvr. + ((self isArray: scanXTable) and: [self isArray: scanMap]) ifFalse: [^ self primitiveFail]. + (self slotSizeOf: scanMap) = 256 ifFalse: [^ self primitiveFail]. + successFlag ifFalse: [^ nil]. + maxGlyph := (self slotSizeOf: scanXTable) - 2. + + "Okay, here we go. We have eliminated nearly all failure + conditions, to optimize the inner fetches." + scanLastIndex := scanStartIndex. + nilOop := self nilObject. + [scanLastIndex <= scanStopIndex] + whileTrue: [ + "Known to be okay since scanStartIndex > 0 and scanStopIndex <= sourceString size" + ascii := self fetchByte: scanLastIndex - 1 ofObject: sourceString. + "Known to be okay since stops size >= 258" + (stopReason := self fetchPointer: ascii ofObject: stops) = nilOop + ifFalse: ["Store everything back and get out of here since some stop conditionn needs to be checked" + (self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail]. + self storeInteger: 0 ofObject: rcvr withValue: scanDestX. + self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex. + self pop: 7. "args+rcvr" + ^ self push: stopReason]. + "Known to be okay since scanMap size = 256" + glyphIndex := self fetchInteger: ascii ofObject: scanMap. + "fail if the glyphIndex is out of range" + (self failed or: [glyphIndex < 0 or: [glyphIndex > maxGlyph]]) ifTrue: [^ self primitiveFail]. + sourceX := self fetchInteger: glyphIndex ofObject: scanXTable. + sourceX2 := self fetchInteger: glyphIndex + 1 ofObject: scanXTable. + "Above may fail if non-integer entries in scanXTable" + self failed ifTrue: [^ nil]. + nextDestX := scanDestX + sourceX2 - sourceX. + nextDestX > scanRightX + ifTrue: ["Store everything back and get out of here since we got to the right edge" + (self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail]. + self storeInteger: 0 ofObject: rcvr withValue: scanDestX. + self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex. + self pop: 7. "args+rcvr" + ^ self push: (self fetchPointer: CrossedX - 1 ofObject: stops)]. + scanDestX := nextDestX + kernDelta. + scanLastIndex := scanLastIndex + 1]. + (self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail]. + self storeInteger: 0 ofObject: rcvr withValue: scanDestX. + self storeInteger: 1 ofObject: rcvr withValue: scanStopIndex. + self pop: 7. "args+rcvr" + ^ self push: (self fetchPointer: EndOfRun - 1 ofObject: stops)! Item was added: + ----- Method: Interpreter>>primitiveScreenDepth (in category 'I/O primitives') ----- + primitiveScreenDepth + "Return a SmallInteger indicating the current depth of the OS screen. Negative values are used to imply LSB type pixel format an there is some support in the VM for handling either MSB or LSB" + | depth | + <export: true> + depth := self ioScreenDepth. + self failed ifTrue:[^self primitiveFail]. + self pop: 1 thenPushInteger: depth.! Item was added: + ----- Method: Interpreter>>primitiveScreenSize (in category 'I/O primitives') ----- + primitiveScreenSize + "Return a point indicating the current size of the Smalltalk window. Currently there is a limit of 65535 in each direction because the point is encoded into a single 32bit value in the image header. This might well become a problem one day" + | pointWord | + self pop: 1. + pointWord := self ioScreenSize. + self push: (self makePointwithxValue: (pointWord >> 16 bitAnd: 65535) yValue: (pointWord bitAnd: 65535))! Item was added: + ----- Method: Interpreter>>primitiveSecondsClock (in category 'system control primitives') ----- + primitiveSecondsClock + "Return the number of seconds since January 1, 1901 as an integer." + + self pop: 1 thenPush: (self positive32BitIntegerFor: self ioSeconds).! Item was added: + ----- Method: Interpreter>>primitiveSetDisplayMode (in category 'I/O primitives') ----- + primitiveSetDisplayMode + "Set to OS to the requested display mode. + See also DisplayScreen setDisplayDepth:extent:fullscreen:" + | fsFlag h w d okay | + fsFlag := self booleanValueOf: (self stackTop). + h := self stackIntegerValue: 1. + w := self stackIntegerValue: 2. + d := self stackIntegerValue: 3. + successFlag ifTrue: [okay := self cCode:'ioSetDisplayMode(w, h, d, fsFlag)']. + successFlag ifTrue: [ + self pop: 5. "Pop args+rcvr" + self pushBool: okay].! Item was added: + ----- Method: Interpreter>>primitiveSetFullScreen (in category 'I/O primitives') ----- + primitiveSetFullScreen + "On platforms that support it, set full-screen mode to the value of the boolean argument." + + | argOop | + argOop := self stackTop. + argOop = trueObj + ifTrue: [self ioSetFullScreen: true] + ifFalse: [ argOop = falseObj + ifTrue: [self ioSetFullScreen: false] + ifFalse: [self primitiveFail]]. + successFlag ifTrue: [self pop: 1]. + ! Item was added: + ----- Method: Interpreter>>primitiveSetGCBiasToGrow (in category 'memory space primitives') ----- + primitiveSetGCBiasToGrow + "Primitive. Indicate if the GC logic should have bias to grow" + | flag | + <export: true> + flag := self stackIntegerValue: 0. + successFlag ifTrue:[ + gcBiasToGrow := flag. + self pop: argumentCount. + ].! Item was added: + ----- Method: Interpreter>>primitiveSetGCBiasToGrowGCLimit (in category 'memory space primitives') ----- + primitiveSetGCBiasToGrowGCLimit + "Primitive. If the GC logic has bias to grow, set growth limit" + | value | + <export: true> + value := self stackIntegerValue: 0. + successFlag ifTrue:[ + gcBiasToGrowGCLimit := value. + gcBiasToGrowThreshold := youngStart - (self cCoerce: memory to: 'int'). + self pop: argumentCount. + ].! Item was added: + ----- Method: Interpreter>>primitiveSetInterruptKey (in category 'I/O primitives') ----- + primitiveSetInterruptKey + "Set the user interrupt keycode. The keycode is an integer whose encoding is described in the comment for primitiveKbdNext." + + | keycode | + keycode := self popInteger. + successFlag + ifTrue: [ interruptKeycode := keycode ] + ifFalse: [ self unPop: 1 ].! Item was added: + ----- Method: Interpreter>>primitiveShortAt (in category 'sound primitives') ----- + primitiveShortAt + "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." + + | index rcvr sz addr value | + index := self stackIntegerValue: 0. + rcvr := self stackValue: 1. + self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). + successFlag ifFalse: [ ^ nil ]. + sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields" + self success: ((index >= 1) and: [index <= sz]). + successFlag ifTrue: [ + addr := rcvr + self baseHeaderSize + (2 * (index - 1)). + value := self shortAt: addr. + self pop: 2 thenPushInteger: value. + ]! Item was added: + ----- Method: Interpreter>>primitiveShortAtPut (in category 'sound primitives') ----- + primitiveShortAtPut + "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." + + | index rcvr sz addr value | + value := self stackIntegerValue: 0. + index := self stackIntegerValue: 1. + rcvr := self stackValue: 2. + self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). + successFlag ifFalse: [ ^ nil ]. + sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields" + self success: ((index >= 1) and: [index <= sz]). + self success: ((value >= -32768) and: [value <= 32767]). + successFlag ifTrue: [ + addr := rcvr + self baseHeaderSize + (2 * (index - 1)). + self shortAt: addr put: value. + self pop: 2. "pop index and value; leave rcvr on stack" + ]! Item was added: + ----- Method: Interpreter>>primitiveShowDisplayRect (in category 'I/O primitives') ----- + primitiveShowDisplayRect + "Force the given rectangular section of the Display to be + copied to the screen." + | bottom top right left | + bottom := self stackIntegerValue: 0. + top := self stackIntegerValue: 1. + right := self stackIntegerValue: 2. + left := self stackIntegerValue: 3. + self displayBitsOf: (self splObj: TheDisplay) Left: left Top: top Right: right Bottom: bottom. + successFlag + ifTrue: [self ioForceDisplayUpdate. + self pop: 4]! Item was added: + ----- Method: Interpreter>>primitiveSignal (in category 'process primitives') ----- + primitiveSignal + "synchromously signal the semaphore. This may change the active process as a result" + | sema | + sema := self stackTop. "rcvr" + self assertClassOf: sema is: (self splObj: ClassSemaphore). + successFlag ifTrue: [ self synchronousSignal: sema ].! Item was added: + ----- Method: Interpreter>>primitiveSignalAtBytesLeft (in category 'memory space primitives') ----- + primitiveSignalAtBytesLeft + "Set the low-water mark for free space. When the free space + falls below this level, the new and new: primitives fail and + system attempts to allocate space (e.g., to create a method + context) cause the low-space semaphore (if one is + registered) to be signalled." + | bytes | + bytes := self popInteger. + successFlag + ifTrue: [lowSpaceThreshold := bytes] + ifFalse: [lowSpaceThreshold := 0. + self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveSine (in category 'arithmetic float primitives') ----- + primitiveSine + + | rcvr | + <var: #rcvr type: 'double '> + rcvr := self popFloat. + successFlag + ifTrue: [self pushFloat: (self cCode: 'sin(rcvr)' inSmalltalk: [rcvr sin])] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveSize (in category 'array primitives') ----- + primitiveSize + | rcvr sz | + rcvr := self stackTop. + (self isIntegerObject: rcvr) ifTrue: [^ self primitiveFail]. "Integers are not indexable" + (self formatOf: rcvr) < 2 ifTrue: [^ self primitiveFail]. "This is not an indexable object" + sz := self stSizeOf: rcvr. + successFlag ifTrue: + [self pop: 1 thenPush: (self positive32BitIntegerFor: sz)] + ! Item was added: + ----- Method: Interpreter>>primitiveSnapshot (in category 'system control primitives') ----- + primitiveSnapshot + "save a normal snapshot under the same name as it was loaded unless it has been renamed by the last primitiveImageName" + <inline: false> + ^self snapshot: false + ! Item was added: + ----- Method: Interpreter>>primitiveSnapshotEmbedded (in category 'system control primitives') ----- + primitiveSnapshotEmbedded + "save an embedded snapshot" + <inline: false> + ^self snapshot: true! Item was added: + ----- Method: Interpreter>>primitiveSomeInstance (in category 'object access primitives') ----- + primitiveSomeInstance + | class instance | + class := self stackTop. + instance := self initialInstanceOf: class. + instance + ifNil: [self primitiveFail] + ifNotNil: [self pop: argumentCount+1 thenPush: instance]! Item was added: + ----- Method: Interpreter>>primitiveSomeObject (in category 'object access primitives') ----- + primitiveSomeObject + "Return the first object in the heap." + + self pop: argumentCount+1. + self push: self firstAccessibleObject.! Item was added: + ----- Method: Interpreter>>primitiveSpecialObjectsOop (in category 'system control primitives') ----- + primitiveSpecialObjectsOop + "Return the oop of the SpecialObjectsArray." + + self pop: 1 thenPush: specialObjectsOop.! Item was added: + ----- Method: Interpreter>>primitiveSquareRoot (in category 'arithmetic float primitives') ----- + primitiveSquareRoot + | rcvr | + <var: #rcvr type: 'double '> + rcvr := self popFloat. + self success: rcvr >= 0.0. + successFlag + ifTrue: [self pushFloat: (self cCode: 'sqrt(rcvr)' inSmalltalk: [rcvr sqrt])] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveStoreImageSegment (in category 'image segment in/out') ----- + primitiveStoreImageSegment + "This primitive is called from Squeak as... + <imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray." + + "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). All pointers from within the tree to objects outside the tree will be copied into the array of outPointers. In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set." + + "The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. To simplify truncation, both incoming arrays are required to be whatever the objectMemory considers long objects. If either array is too small, the primitive will fail, but in no other case." + + | outPointerArray segmentWordArray arrayOfRoots ecode | + + outPointerArray := self stackTop. + segmentWordArray := self stackValue: 1. + arrayOfRoots := self stackValue: 2. + + "Essential type checks" + ((self isArray: arrayOfRoots) "Must be indexable pointers" + and: [(self isArray: outPointerArray) "Must be indexable pointers" + and: [self isWords: segmentWordArray]]) ifFalse: "Must be indexable words" + [^self primitiveFail]. + + ecode := self storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots. + ecode = PrimNoErr + ifTrue: [self pop: 3] "...leaving the receiver on the stack as return value" + ifFalse: [self primitiveFail]! Item was added: + ----- Method: Interpreter>>primitiveStringAt (in category 'array primitives') ----- + primitiveStringAt + + self commonAt: true.! Item was added: + ----- Method: Interpreter>>primitiveStringAtPut (in category 'array primitives') ----- + primitiveStringAtPut + + self commonAtPut: true.! Item was added: + ----- Method: Interpreter>>primitiveStringReplace (in category 'array primitives') ----- + primitiveStringReplace + " + <array> primReplaceFrom: start to: stop with: replacement + startingAt: repStart + <primitive: 105> + " + | array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex | + array := self stackValue: 4. + start := self stackIntegerValue: 3. + stop := self stackIntegerValue: 2. + repl := self stackValue: 1. + replStart := self stackIntegerValue: 0. + + successFlag ifFalse: [^ self primitiveFail]. + (self isIntegerObject: repl) ifTrue: ["can happen in LgInt copy" + ^ self primitiveFail]. + + hdr := self baseHeader: array. + arrayFmt := hdr >> 8 bitAnd: 15. + totalLength := self lengthOf: array baseHeader: hdr format: arrayFmt. + arrayInstSize := self fixedFieldsOf: array format: arrayFmt length: totalLength. + (start >= 1 and: [start - 1 <= stop and: [stop + arrayInstSize <= totalLength]]) + ifFalse: [^ self primitiveFail]. + + hdr := self baseHeader: repl. + replFmt := hdr >> 8 bitAnd: 15. + totalLength := self lengthOf: repl baseHeader: hdr format: replFmt. + replInstSize := self fixedFieldsOf: repl format: replFmt length: totalLength. + (replStart >= 1 and: [stop - start + replStart + replInstSize <= totalLength]) + ifFalse: [^ self primitiveFail]. + + "Array formats (without byteSize bits, if bytes array) must be same " + arrayFmt < 8 + ifTrue: [arrayFmt = replFmt + ifFalse: [^ self primitiveFail]] + ifFalse: [(arrayFmt bitAnd: 12) = (replFmt bitAnd: 12) + ifFalse: [^ self primitiveFail]]. + + srcIndex := replStart + replInstSize - 1. + "- 1 for 0-based access" + + arrayFmt <= 4 + ifTrue: ["pointer type objects" + start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | + self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl). + srcIndex := srcIndex + 1]] + ifFalse: [arrayFmt < 8 + ifTrue: ["32-bit-word type objects" + start + arrayInstSize - 1 to: stop + arrayInstSize - 1 + do: [:i | self storeLong32: i ofObject: array withValue: (self fetchLong32: srcIndex ofObject: repl). + srcIndex := srcIndex + 1]] + ifFalse: ["byte-type objects" + start + arrayInstSize - 1 to: stop + arrayInstSize - 1 + do: [:i | self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl). + srcIndex := srcIndex + 1]]]. + "We might consider comparing stop - start to some value here and using forceInterruptCheck" + + self pop: argumentCount "leave rcvr on stack"! Item was added: + ----- Method: Interpreter>>primitiveSubtract (in category 'arithmetic integer primitives') ----- + primitiveSubtract + + self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) - (self stackIntegerValue: 0)! Item was added: + ----- Method: Interpreter>>primitiveSuspend (in category 'process primitives') ----- + primitiveSuspend + "Primitive. Suspend the receiver, aProcess such that it can be executed again + by sending #resume. If the given process is not currently running, take it off + its corresponding list. The primitive returns the list the receiver was previously on." + | process activeProc myList | + process := self stackTop. + activeProc := self fetchPointer: ActiveProcessIndex + ofObject: self schedulerPointer. + process == activeProc ifTrue:[ + self pop: 1. + self push: nilObj. + self transferTo: self wakeHighestPriority. + ] ifFalse:[ + myList := self fetchPointer: MyListIndex ofObject: process. + "XXXX Fixme. We should really check whether myList is a kind of LinkedList or not + but we can't easily so just do a quick check for nil which is the most common case." + myList == self nilObject ifTrue:[^self primitiveFail]. + self removeProcess: process fromList: myList. + successFlag ifTrue:[ + self storePointer: MyListIndex ofObject: process withValue: self nilObject. + self pop: 1. + self push: myList. + ]. + ].! Item was added: + ----- Method: Interpreter>>primitiveTestDisplayDepth (in category 'I/O primitives') ----- + primitiveTestDisplayDepth + "Return true if the host OS does support the given display depth." + | bitsPerPixel okay| + bitsPerPixel := self stackIntegerValue: 0. + successFlag ifTrue: [okay := self ioHasDisplayDepth: bitsPerPixel]. + successFlag ifTrue: [ + self pop: 2. "Pop arg+rcvr" + self pushBool: okay].! Item was added: + ----- Method: Interpreter>>primitiveTimesTwoPower (in category 'arithmetic float primitives') ----- + primitiveTimesTwoPower + | rcvr arg | + <var: #rcvr type: 'double '> + arg := self popInteger. + rcvr := self popFloat. + successFlag + ifTrue: [ self pushFloat: (self cCode: 'ldexp(rcvr, arg)' inSmalltalk: [rcvr timesTwoPower: arg]) ] + ifFalse: [ self unPop: 2 ].! Item was added: + ----- Method: Interpreter>>primitiveTruncated (in category 'arithmetic float primitives') ----- + primitiveTruncated + | rcvr frac trunc | + <var: #rcvr type: 'double '> + <var: #frac type: 'double '> + <var: #trunc type: 'double '> + rcvr := self popFloat. + successFlag ifTrue: + [self cCode: 'frac = modf(rcvr, &trunc)' + inSmalltalk: [trunc := rcvr truncated]. + self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits." + self cCode: 'success((-1073741824.0 <= trunc) && (trunc <= 1073741823.0))' + inSmalltalk: [self success: (trunc between: SmallInteger minVal and: SmallInteger maxVal)]]. + successFlag + ifTrue: [self cCode: 'pushInteger((sqInt) trunc)' inSmalltalk: [self pushInteger: trunc]] + ifFalse: [self unPop: 1]! Item was added: + ----- Method: Interpreter>>primitiveUnloadModule (in category 'plugin primitives') ----- + primitiveUnloadModule + "Primitive. Unload the module with the given name." + "Reloading of the module will happen *later* automatically, when a + function from it is called. This is ensured by invalidating current sessionID." + | moduleName | + self methodArgumentCount = 1 ifFalse:[^self primitiveFail]. + moduleName := self stackTop. + (self isIntegerObject: moduleName) ifTrue:[^self primitiveFail]. + (self isBytes: moduleName) ifFalse:[^self primitiveFail]. + (self ioUnloadModule: (self oopForPointer: (self firstIndexableField: moduleName)) + OfLength: (self byteSizeOf: moduleName)) ifFalse:[^self primitiveFail]. + self flushExternalPrimitives. + self forceInterruptCheck. + self pop: 1 "pop moduleName; return receiver"! Item was added: + ----- Method: Interpreter>>primitiveVMPath (in category 'system control primitives') ----- + primitiveVMPath + "Return a string containing the path name of VM's directory." + + | s sz | + sz := self vmPathSize. + s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz. + self vmPathGet: (s + self baseHeaderSize) Length: sz. + self pop: 1 thenPush: s. + ! Item was added: + ----- Method: Interpreter>>primitiveWait (in category 'process primitives') ----- + primitiveWait + + | sema excessSignals activeProc | + sema := self stackTop. "rcvr" + self assertClassOf: sema is: (self splObj: ClassSemaphore). + successFlag ifTrue: [ + excessSignals := + self fetchInteger: ExcessSignalsIndex ofObject: sema. + excessSignals > 0 ifTrue: [ + self storeInteger: ExcessSignalsIndex + ofObject: sema withValue: excessSignals - 1. + ] ifFalse: [ + activeProc := self fetchPointer: ActiveProcessIndex + ofObject: self schedulerPointer. + self addLastLink: activeProc toList: sema. + self transferTo: self wakeHighestPriority. + ]. + ].! Item was added: + ----- Method: Interpreter>>primitiveYield (in category 'process primitives') ----- + primitiveYield + "primitively do the equivalent of Process>yield" + | activeProc priority processLists processList | + activeProc := self fetchPointer: ActiveProcessIndex + ofObject: self schedulerPointer. + priority := self quickFetchInteger: PriorityIndex ofObject: activeProc. + processLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. + processList := self fetchPointer: priority - 1 ofObject: processLists. + + (self isEmptyList: processList) ifFalse:[ + self addLastLink: activeProc toList: processList. + self transferTo: self wakeHighestPriority]!

1 0

VM Maker: VMMaker.oscog-eem.3125.mcz
by commits＠source.squeak.org 01 Jan '22

01 Jan '22

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3125.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3125 Author: eem Time: 31 December 2021, 7:05:23.768966 pm UUID: ab22e2df-7dff-4b4c-8a0b-63c148eeeaa9 Ancestors: VMMaker.oscog-eem.3124 A bit of a rag bag: Fix in image compilation of primitive methods under Spur; the accessor depth was not being computed correctly. Extract code to compute accessor depths during simulation and in-image compilation to computeAccessorDepthsForInterpreterPrmitives. Nuke unused zoneEnd:. Fix formatting bug in longPrintOop:. Simplify collectCogMethodConstituent: a little. Comment Spur ensureBehaviorHash: & hashBitsOf: regarding http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217840… =============== Diff against VMMaker.oscog-eem.3124 =============== Item was removed: - ----- Method: CogMethodZone>>zoneEnd: (in category 'simulation only') ----- - zoneEnd: zoneEnd - <doNotGenerate> - limitAddress := zoneEnd! Item was removed: - ----- Method: CogVMSimulator>>codeGeneratorToComputeAccessorDepth (in category 'primitive support') ----- - codeGeneratorToComputeAccessorDepth - ^(VMMaker new - buildCodeGeneratorForInterpreter: (COGMTVM ifTrue: [CoInterpreterMT] ifFalse: [CoInterpreterPrimitives]) - includeAPIMethods: false - initializeClasses: false) - logger: self transcript; - yourself! Item was changed: ----- Method: CogVMSimulator>>initializePluginEntries (in category 'plugin support') ----- initializePluginEntries mappedPluginEntries := OrderedCollection new. objectMemory hasSpurMemoryManagerAPI ifTrue: + [pluginList := {}. - [primitiveAccessorDepthTable := Array new: primitiveTable size. - pluginList := {}. self loadNewPlugin: ''] ifFalse: [pluginList := {'' -> self }]! Item was changed: ----- Method: Cogit>>collectCogMethodConstituent: (in category 'profiling primitives') ----- collectCogMethodConstituent: cogMethod "Answer a description of the mapping between machine code pointers and bytecode pointers for the Cog Method. First value is the address of the cog method. Following values are pairs of machine code pc and bytecode pc" <var: #cogMethod type: #'CogMethod *'> <var: #cogBlockMethod type: #'CogBlockMethod *'> + | nSlots errCode cogBlockMethod address data | - | cm nSlots errCode cogBlockMethod address data | (cogMethod cmType = CMMethod) ifFalse: [^self positiveMachineIntegerFor: cogMethod asUnsignedInteger ]. cogBlockMethod := self cCoerceSimple: cogMethod to: #'CogBlockMethod *'. cogBlockMethod stackCheckOffset = 0 "isFrameless ?" ifTrue: [^self positiveMachineIntegerFor: cogMethod asUnsignedInteger]. + nSlots := ((objectMemory byteSizeOf: cogMethod methodObject) - (coInterpreter startPCOfMethodHeader: cogMethod methodHeader)) * 2 + objectMemory minSlotsForShortening + 1."+1 for first address" - cm := cogMethod methodObject. - nSlots := ((objectMemory byteSizeOf: cm) - (coInterpreter startPCOfMethodHeader: cm methodHeader)) * 2 + objectMemory minSlotsForShortening + 1."+1 for first address" data := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: nSlots. data ifNil: [^nil]. coInterpreter pushRemappableOop: data. "The iteration assumes the object is the top remappable oop" address := (self positiveMachineIntegerFor: cogMethod asUnsignedInteger). address ifNil: [coInterpreter popRemappableOop. ^nil]. coInterpreter storePointerUnchecked: 0 ofObject: coInterpreter topRemappableOop withValue: address. cogConstituentIndex := 1. errCode := self mapFor: cogBlockMethod bcpc: (coInterpreter startPCOfMethod: cogMethod methodObject) performUntil: #collectCogConstituentFor:Annotation:Mcpc:Bcpc:Method: arg: cogMethod asVoidPointer. errCode ~= 0 ifTrue: [coInterpreter popRemappableOop. ^nil]. cogConstituentIndex < nSlots ifTrue: [objectMemory shorten: coInterpreter topRemappableOop toIndexableSize: cogConstituentIndex]. ^coInterpreter popRemappableOop.! Item was changed: ----- Method: CurrentImageCoInterpreterFacadeForSpurObjectRepresentation>>accessorDepthForPrimitiveMethod: (in category 'accessing') ----- accessorDepthForPrimitiveMethod: methodOop | primIndex | primIndex := self primitiveIndexOf: methodOop. ^primIndex = PrimNumberExternalCall ifTrue: [self accessorDepthForExternalPrimitiveMethod: methodOop] ifFalse: + [coInterpreter computeAccessorDepthsForInterpreterPrmitives. - [coInterpreter initializePluginEntries. coInterpreter accessorDepthForPrimitiveIndex: primIndex]! Item was changed: ----- Method: SpurMemoryManager>>ensureBehaviorHash: (in category 'class table') ----- ensureBehaviorHash: aBehavior | hash err | <inline: true> self assert: (coInterpreter addressCouldBeClassObj: aBehavior). + "eem 12/28/2021 the above asserft is too weak (and only an assert)" + self flag: #todo. "See http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217840…. + A solution would be to replace compactClassesArray with #identityHash in the specialObjectsArray + and then lookup identityHash in the receiver and use the appropriate hash generator depending + on the primitive number of the located method. The lookup could be guarded by objCouldBeClassObj:" ^(hash := self rawHashBitsOf: aBehavior) ~= 0 ifTrue: [hash] ifFalse: [(coInterpreter objCouldBeClassObj: aBehavior) ifFalse: [PrimErrBadReceiver negated] ifTrue: [(err := self enterIntoClassTable: aBehavior) ~= 0 ifTrue: [err negated] ifFalse: [self rawHashBitsOf: aBehavior]]]! Item was changed: ----- Method: SpurMemoryManager>>hashBitsOf: (in category 'header access') ----- hashBitsOf: objOop | hash | hash := self rawHashBitsOf: objOop. hash = 0 ifTrue: + ["cb 1/19/2017 18:34: + would like to assert - ["would like to assert self assert: (coInterpreter addressCouldBeClassObj: objOop) not but instance-specific behaviors that are instances of themselves may fail this test." + "eem 12/28/2021 11:52 I'm not sure this is the issue. The issue is only validating objOop as a behavior." + self flag: #todo. "See http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217840…. + A solution would be to replace compactClassesArray with #identityHash in the specialObjectsArray + and then lookup identityHash in the receiver and use the appropriate hash generator depending + on the primitive number of the located method. The lookup could be guarded by objCouldBeClassObj:" hash := self newHashBitsOf: objOop]. ^hash! Item was added: + ----- Method: StackInterpreter>>computeAccessorDepthsForInterpreterPrmitives (in category 'primitive support') ----- + computeAccessorDepthsForInterpreterPrmitives + <doNotGenerate> + | cg | + cg := self codeGeneratorToComputeAccessorDepth. + primitiveAccessorDepthTable ifNil: + [primitiveAccessorDepthTable := Array new: primitiveTable size]. + primitiveTable withIndexDo: + [:prim :index| | depth | + prim isSymbol ifTrue: + [depth := cg accessorDepthForSelector: prim. + self assert: depth isInteger. + primitiveAccessorDepthTable at: index - 1 put: depth]]. + ^cg! Item was changed: ----- Method: StackInterpreter>>frameOfMarriedContext: (in category 'frame access') ----- frameOfMarriedContext: aContext + <returnTypeC: #'char *'> | senderOop | <inline: true> - <returnTypeC: 'char *'> senderOop := objectMemory fetchPointer: SenderIndex ofObject: aContext. ^self withoutSmallIntegerTags: senderOop! Item was changed: ----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') ----- longPrintOop: oop <export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h" | fmt lastIndex startIP column cls | (objectMemory isImmediate: oop) ifTrue: [^objectMemory printImmediateObject: oop on: transcript]. (objectMemory addressCouldBeObj: oop) ifFalse: [^objectMemory printCantBeObject: oop on: transcript]. (objectMemory isFreeObject: oop) ifTrue: [^objectMemory printFreeObject: oop on: transcript]. (objectMemory isForwarded: oop) ifTrue: [^objectMemory printForwarder: oop on: transcript]. (cls := objectMemory fetchClassOfNonImm: oop) ifNil: ['%P has a nil class!!!!\n' f: transcript printf: oop asVoidPointer] ifNotNil: [| className length | className := self nameOfClass: cls lengthInto: (self addressOf: length put: [:v| length := v]). '%P: a(n) %.*s' f: transcript printf: {oop asVoidPointer. length. className }. objectMemory hasSpurMemoryManagerAPI ifTrue: ['(%lx=>%P)' f: transcript printf: { objectMemory compactClassIndexOf: oop. cls asVoidPointer }]]. fmt := objectMemory formatOf: oop. ' format %lx' f: transcript printf: fmt. fmt > objectMemory lastPointerFormat ifTrue: [' nbytes %ld' f: transcript printf: (objectMemory numBytesOf: oop)] ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue: [| len | len := objectMemory lengthOf: oop. ' size %ld' f: transcript printf: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]]. objectMemory printHeaderTypeOf: oop on: transcript. self print: ' hash '; printHex: (objectMemory rawHashBitsOf: oop). self cr. (fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue: ["This will answer false if splObj: ClassAlien is nilObject" (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue: [^' datasize %ld %s @ %p\n' f: transcript printf: {objectMemory sizeFieldOfAlien: oop. (self isIndirectAlien: oop) ifTrue: ['indirect'] ifFalse: [(self isPointerAlien: oop) ifTrue: ['pointer'] ifFalse: ['direct']]. self startOfAlienData: oop }]. (self is: oop KindOfClass: (self superclassOf: (objectMemory splObj: ClassString))) ifTrue: [^objectMemory printStringDataOf: oop on: transcript]. ^objectMemory printNonPointerDataOf: oop on: transcript]. startIP := fmt >= objectMemory firstCompiledMethodFormat ifTrue: [(self startPCOfMethod: oop) / objectMemory wordSize] ifFalse: [objectMemory numSlotsOf: oop]. lastIndex := 256 min: startIP. lastIndex > 0 ifTrue: [1 to: lastIndex do: [:i| | fieldOop | fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop. self space; printNum: i - 1; space; printHex: fieldOop; space. (i = 1 and: [objectMemory isCompiledMethod: oop]) ifTrue: [self printMethodHeaderOop: fieldOop] ifFalse: [self printOopShortInner: fieldOop]. self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > lastIndex ifTrue: [self print: '...'; cr]] ifTrue: [startIP := (self startPCOfMethod: oop) + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 256 ifTrue: [lastIndex := startIP + 256]. column := 1. startIP to: lastIndex do: [:index| | byte | column = 1 ifTrue: + ['%11P ' f: transcript printf: (oop+BaseHeaderSize+index-1) asVoidPointer]. - ['%11P' f: transcript printf: (oop+BaseHeaderSize+index-1) asVoidPointer]. byte := objectMemory fetchByte: index - 1 ofObject: oop. '%02x/%-3d%c' f: transcript printf: { byte. byte. column = 8 ifTrue: [Character cr] ifFalse: [Character space] }. (column := column + 1) > 8 ifTrue: [column := 1]]. (objectMemory lengthOf: oop) > lastIndex ifTrue: [self print: '...']. (column between: 2 and: 7) ifTrue: [self cr]]! Item was changed: ----- Method: StackInterpreter>>startPCOfMethodHeader: (in category 'compiled methods') ----- startPCOfMethodHeader: methodHeader - <api> "Answer the zero-relative index to the initial byte for a method. Zero-relative version of CompiledMethod>>startpc." ^(objectMemory literalCountOfMethodHeader: methodHeader) + LiteralStart * objectMemory bytesPerOop! Item was changed: ----- Method: StackInterpreter>>tryLoadNewPlugin:pluginEntries: (in category 'primitive support') ----- tryLoadNewPlugin: pluginString pluginEntries: pluginEntries "Load the plugin and if on Spur, populate pluginEntries with the prmitives in the plugin." <doNotGenerate> | plugin realPluginClass plugins | self transcript cr; show: 'Looking for module ', pluginString. pluginString isEmpty ifTrue: [plugin := self] ifFalse: [plugins := InterpreterPlugin allSubclasses select: [:psc| psc moduleName asString = pluginString asString and: [psc shouldBeTranslated]]. plugins isEmpty ifTrue: [self transcript show: ' ... not found'. ^nil]. plugins size > 1 ifTrue: [^self error: 'This won''t work...']. "plugins size > 1 ifTrue: [self transcript show: '...multiple plugin classes; choosing ', plugins last name]." realPluginClass := plugins anyOne. "hopefully lowest in the hierarchy..." plugin := realPluginClass simulatorForInterpreterInterface: objectMemory. plugin ifNil: [self transcript show: ' ... no simulator class; cannot simulate'. ^nil]. (plugin respondsTo: #initialiseModule) ifTrue: [plugin initialiseModule ifFalse: [self transcript show: ' ... initialiser failed'. ^nil]]]. "module initialiser failed" self transcript show: ' ... loaded'. objectMemory hasSpurMemoryManagerAPI ifTrue: [| realPlugin cg | self transcript show: '...computing accessor depths'. plugin class isPluginClass ifTrue: [realPlugin := (plugin isSmartSyntaxPluginSimulator ifTrue: [realPluginClass] ifFalse: [plugin class]) withAllSuperclasses detect: [:class| class shouldBeTranslated]. cg := realPlugin buildCodeGenerator] ifFalse: + [cg := self computeAccessorDepthsForInterpreterPrmitives]. - [cg := self codeGeneratorToComputeAccessorDepth. - primitiveTable withIndexDo: - [:prim :index| | depth | - prim isSymbol ifTrue: - [depth := cg accessorDepthForSelector: prim. - self assert: (depth isInteger or: [depth isNil and: [(plugin class whichClassIncludesSelector: prim) isNil]]). - primitiveAccessorDepthTable at: index - 1 put: depth]]]. cg exportedPrimitiveNames do: [:primName| | fnSymbol | fnSymbol := primName asSymbol. pluginEntries addLast: {plugin. fnSymbol. [plugin perform: fnSymbol. self]. self metadataFlagsFor: fnSymbol using: cg}]. self transcript show: '...done']. ^pluginString asString -> plugin! Item was changed: ----- Method: TAssignmentNode>>emitLiteralArrayDeclarationOn:level:generator: (in category 'C code generation') ----- emitLiteralArrayDeclarationOn: aStream level: level generator: aCCodeGen | type literalName | type := expression args last value. self assert: type last = $*. literalName := variable name, 'Initializer'. aStream crtab: level; nextPutAll: '{ static '; nextPutAll: (aCCodeGen arrayInitializerCalled: literalName for: expression args first value sizeString: nil type: type allButLast) withBlanksTrimmed; nextPut: $;; crtab: level + 1; nextPutAll: variable name; nextPutAll: ' = '; nextPutAll: literalName; nextPut: $; ; crtab: level; nextPut: $}; + cr + + "self systemNavigation browseAllSelect: + [:m| + (m sendsSelector: #cCoerce:to:) + and: [| flag | + flag := false. + m methodNode nodesDo: + [:n| + (n isMessageNode + and: [n selector key = #cCoerce:to: + and: [n arguments first isLiteralNode + and: [n arguments first key isCollection]]]) ifTrue: + [flag := true]]. + flag]]"! - cr! Item was changed: ----- Method: TSendNode>>isLiteralArrayDeclaration (in category 'testing') ----- isLiteralArrayDeclaration ^selector == #cCoerce:to: and: [arguments first isConstant and: [arguments first value isLiteral + and: [arguments first value isCollection]]] + + "self systemNavigation browseAllSelect: + [:m| + (m sendsSelector: #cCoerce:to:) + and: [| flag | + flag := false. + m methodNode nodesDo: + [:n| + (n isMessageNode + and: [n selector key = #cCoerce:to: + and: [n arguments first isLiteralNode + and: [n arguments first key isCollection]]]) ifTrue: + [flag := true]]. + flag]]"! - and: [arguments first value isCollection]]]!

1 0

[OpenSmalltalk/opensmalltalk-vm] f9a983: CogVM source as per VMMaker.oscog-eem.3124
by Eliot Miranda 01 Jan '22

01 Jan '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: f9a983a0d2c3a72d83e534280b3e9953fc8d95a2 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/f9a983a0d2c3a72d83… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2021-12-31 (Fri, 31 Dec 2021) Changed paths: M building/macos32x86/squeak.cog.spur/plugins.ext M building/macos32x86/squeak.cog.v3/plugins.ext M building/macos32x86/squeak.sista.spur/plugins.ext M building/macos32x86/squeak.stack.spur/plugins.ext M building/macos32x86/squeak.stack.v3/plugins.ext M building/macos64ARMv8/squeak.cog.spur/plugins.ext M building/macos64ARMv8/squeak.sista.spur/plugins.ext M building/macos64ARMv8/squeak.stack.spur/plugins.ext M building/macos64x64/squeak.cog.spur/plugins.ext M building/macos64x64/squeak.sista.spur/plugins.ext M building/macos64x64/squeak.stack.spur/plugins.ext M platforms/iOS/plugins/ClipboardExtendedPlugin/Makefile M src/plugins/ClipboardExtendedPlugin/ClipboardExtendedPlugin.c Log Message: ----------- CogVM source as per VMMaker.oscog-eem.3124 Get ClipboardExtendedPlugin to run on 64-bit macOS (iOS). Add ClipboardExtendedPlugin to Squeak external plugins. Add CameraPlugin to macos64ARMv8 Squeak builds.

1 0

VM Maker: VMMaker.oscog-eem.3124.mcz
by commits＠source.squeak.org 01 Jan '22

01 Jan '22

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.3124.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.3124 Author: eem Time: 31 December 2021, 5:39:35.788577 pm UUID: 651be3ef-7098-46a7-9e8a-126511bc7894 Ancestors: VMMaker.oscog-eem.3123 Get ClipboardExtendedPlugin to run on 64-bit macOS (iOS) =============== Diff against VMMaker.oscog-eem.3123 =============== Item was added: + ----- Method: ClipboardExtendedPlugin class>>preambleCCode (in category 'translation') ----- + preambleCCode + ^'// declarations for the support API. eem, 2021/12/31\\void sqPasteboardClear(void *inPasteboard);\sqInt sqPasteboardGetItemCount (void *inPasteboard);\sqInt sqPasteboardCopyItemFlavorsitemNumber (void *inPasteboard, sqInt formatNumber);\void *sqCreateClipboard(void);\void sqPasteboardPutItemFlavordatalengthformatTypeformatLength (void *inPasteboard, char* inData, sqInt dataLength, char* format, sqInt formatLength);\sqInt sqPasteboardCopyItemFlavorDataformatformatLength (void *inPasteboard, char* format, sqInt formatLength);' withCRs + + "quick test:" + "ExtendedClipboardInterface current addClipboardDataConvertFormToPNG: Display"!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev January 2022