Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.1275.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.1275
Author: eem
Time: 30 April 2015, 2:16:10.579 pm
UUID: c6fd91fc-f1cd-4ca7-93f6-38d581973d92
Ancestors: VMMaker.oscog-tfel.1274
Fix SimpleStackBasedCogit primitives for ARM; they
need an abstraqction for stack access on account
of there being a ret pc (x86) or not (ARM).
Fix regressions in genPrimitiveAsCharacter and
genInnerPrimitiveIdentityHash: where RetN: offset
had been replaced with 0.
Remove all the "self flag: 'currently caller pushes result'."
noise. This was the right decision given
StackToRegisterMappingCogit.
Fix the store check trampoline for the
SimpleStackBasedCogit given the better
caller-saved-register logic there now. Move some
reegister mask methods up the hierarchy as a result.
SimpleStackBasedCogit still crashes (in widthOfString:)
but gets much further than it has in recent months.
=============== Diff against VMMaker.oscog-tfel.1274 ===============
Item was changed:
----- Method: CoInterpreter>>ceNonLocalReturn: (in category 'trampolines') -----
ceNonLocalReturn: returnValue
<api>
| closure home unwindContextOrNilOrZero ourContext frameToReturnTo contextToReturnTo theFP callerFP newPage |
<var: #frameToReturnTo type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
"self shortPrintFrameAndCallers: framePointer.
self printOop: returnValue.
self halt."
self assert: (self isMachineCodeFrame: framePointer).
self assert: (self frameIsBlockActivation: framePointer).
"Since this is a block activation the closure is on the stack above any args and the frame."
closure := self pushedReceiverOrClosureOfFrame: framePointer.
home := nil.
"Walk the closure's lexical chain to find the context or frame to return from (home)."
[closure ~= objectMemory nilObject] whileTrue:
[home := objectMemory followField: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory followField: ClosureIndex ofObject: home].
"home is to be returned from provided there is no unwind-protect activation between
this frame and home's sender. Search for an unwind. findUnwindThroughContext:
will answer either the context for an unwind-protect activation or nilObj if the sender
cannot be found or 0 if no unwind is found but the sender is. We must update the
current page's headFrame pointers to enable the search to identify widowed contexts
correctly."
self externalWriteBackHeadFramePointers.
unwindContextOrNilOrZero := self findUnwindThroughContext: home.
unwindContextOrNilOrZero = objectMemory nilObject ifTrue:
["error: can't find home on chain; cannot return"
ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
^self externalCannotReturn: returnValue from: ourContext].
unwindContextOrNilOrZero ~= 0 ifTrue:
[^self externalAboutToReturn: returnValue through: unwindContextOrNilOrZero].
"Now we know home is on the sender chain.
We could be returning to either a context or a frame. Find out which."
contextToReturnTo := nil.
(self isMarriedOrWidowedContext: home)
ifTrue:
[self assert: (self checkIsStillMarriedContext: home currentFP: framePointer).
theFP := self frameOfMarriedContext: home.
(self isBaseFrame: theFP)
ifTrue:
[contextToReturnTo := self frameCallerContext: theFP]
ifFalse:
[frameToReturnTo := self frameCallerFP: theFP]]
ifFalse:
[contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home.
((objectMemory isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer).
frameToReturnTo := self frameOfMarriedContext: contextToReturnTo.
contextToReturnTo := nil]].
"If returning to a context we must make a frame for it unless it is dead."
contextToReturnTo ~= nil ifTrue:
[frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo.
frameToReturnTo == 0 ifTrue:
["error: home's sender is dead; cannot return"
ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
^self externalCannotReturn: returnValue from: ourContext]].
"Now we have a frame to return to. If it is on a different page we must
free intervening pages and nil out intervening contexts. We must free
intervening stack pages because if we leave the pages to be divorced
then their contexts will be divorced with intact senders and instruction
pointers. This code is similar to primitiveTerminateTo."
self assert: stackPages pageListIsWellFormed.
newPage := stackPages stackPageFor: frameToReturnTo.
newPage ~~ stackPage ifTrue:
[| currentCtx thePage nextCntx |
currentCtx := self frameCallerContext: stackPage baseFP.
self assert: (objectMemory isContext: currentCtx).
stackPages freeStackPage: stackPage.
[self assert: (objectMemory isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse:
[(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
currentCtx := self frameCallerContext: thePage baseFP.
stackPages freeStackPage: thePage]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]].
self setStackPageAndLimit: newPage.
stackPointer := stackPage headSP.
framePointer := stackPage headFP].
"Two cases. Returning to the top frame or an interior frame. The
top frame has its instruction pointer on top of stack. An interior
frame has its instruction pointer in the caller frame. We need to
peel back any frames on the page until we get to the correct frame."
- self flag: 'currently caller pushes result'. "(in machine code)"
framePointer = frameToReturnTo
ifTrue:
[instructionPointer := self popStack]
ifFalse:
[[callerFP := framePointer.
framePointer := self frameCallerFP: framePointer.
framePointer ~~ frameToReturnTo] whileTrue.
instructionPointer := (self frameCallerSavedIP: callerFP) asUnsignedInteger.
stackPointer := (self frameCallerSP: callerFP)].
^self return: returnValue toExecutive: false!
Item was changed:
----- Method: CogObjectRepresentationFor32BitSpur>>genInnerPrimitiveIdentityHash: (in category 'primitive generators') -----
genInnerPrimitiveIdentityHash: retNoffset
| jumpImm jumpSI jumpNotSet ret |
<var: #jumpSI type: #'AbstractInstruction *'>
<var: #jumpImm type: #'AbstractInstruction *'>
<var: #jumpNotSet type: #'AbstractInstruction *'>
cogit MoveR: ReceiverResultReg R: ClassReg.
jumpImm := self genJumpImmediateInScratchReg: ClassReg.
self genGetHashFieldNonImmOf: ReceiverResultReg asSmallIntegerInto: TempReg.
cogit CmpCq: ConstZero R: TempReg.
jumpNotSet := cogit JumpZero: 0.
cogit MoveR: TempReg R: ReceiverResultReg.
+ ret := cogit RetN: retNoffset.
- ret := cogit RetN: 0.
jumpImm jmpTarget: (cogit MoveR: ReceiverResultReg R: ClassReg).
jumpSI := self genJumpSmallIntegerInScratchReg: ClassReg.
jumpSI jmpTarget: ret.
self genConvertCharacterToSmallIntegerInReg: ReceiverResultReg.
cogit Jump: ret.
jumpNotSet jmpTarget: cogit Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>compileInterpreterPrimitive: (in category 'primitive generators') -----
compileInterpreterPrimitive: primitiveRoutine
"Compile a call to an interpreter primitive. Call the C routine with the
usual stack-switching dance, test the primFailCode and then either
return on success or continue to the method body."
<var: #primitiveRoutine declareC: 'void (*primitiveRoutine)(void)'>
| flags jmp jmpSamplePrim retry continuePostSamplePrim jmpSampleNonPrim continuePostSampleNonPrim |
<var: #jmp type: #'AbstractInstruction *'>
<var: #retry type: #'AbstractInstruction *'>
<var: #jmpSamplePrim type: #'AbstractInstruction *'>
<var: #continuePostSamplePrim type: #'AbstractInstruction *'>
<var: #jmpSampleNonPrim type: #'AbstractInstruction *'>
<var: #continuePostSampleNonPrim type: #'AbstractInstruction *'>
"Save processor fp, sp and return pc in the interpreter's frame stack and instruction pointers"
self genExternalizePointersForPrimitiveCall.
"Switch to the C stack."
self genLoadCStackPointersForPrimCall.
flags := coInterpreter primitivePropertyFlags: primitiveIndex.
(flags anyMask: PrimCallDoNotJIT) ifTrue:
[^ShouldNotJIT].
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
["Test nextProfileTick for being non-zero and call checkProfileTick if so"
objectMemory wordSize = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSampleNonPrim := self JumpNonZero: 0.
continuePostSampleNonPrim := self Label].
"Old full prim trace is in VMMaker-eem.550 and prior"
self recordPrimTrace ifTrue:
[self genFastPrimTraceUsing: ClassReg and: SendNumArgsReg].
"Clear the primFailCode and set argumentCount"
retry := self MoveCq: 0 R: TempReg.
self MoveR: TempReg Aw: coInterpreter primFailCodeAddress.
methodOrBlockNumArgs ~= 0 ifTrue:
[self MoveCq: methodOrBlockNumArgs R: TempReg].
self MoveR: TempReg Aw: coInterpreter argumentCountAddress.
"If required, set primitiveFunctionPointer and newMethod"
(flags anyMask: PrimCallNeedsPrimitiveFunction) ifTrue:
[self MoveCw: primitiveRoutine asInteger R: TempReg.
self MoveR: TempReg Aw: coInterpreter primitiveFunctionPointerAddress].
(flags anyMask: PrimCallNeedsNewMethod+PrimCallMayCallBack) ifTrue:
["The ceActivateFailingPrimitiveMethod: machinery can't handle framelessness."
(flags anyMask: PrimCallMayCallBack) ifTrue:
[needsFrame := true].
methodLabel addDependent:
(self annotateAbsolutePCRef:
(self MoveCw: methodLabel asInteger R: ClassReg)).
self MoveMw: (self offset: CogMethod of: #methodObject) r: ClassReg R: TempReg.
self MoveR: TempReg Aw: coInterpreter newMethodAddress].
"Invoke the primitive"
self PrefetchAw: coInterpreter primFailCodeAddress.
(flags anyMask: PrimCallMayCallBack)
ifTrue: "Sideways call the C primitive routine so that we return through cePrimReturnEnterCogCode."
["On Spur ceActivateFailingPrimitiveMethod: would like to retry if forwarders
are found. So insist on PrimCallNeedsPrimitiveFunction being set too."
self assert: (flags anyMask: PrimCallNeedsPrimitiveFunction).
backEnd genSubstituteReturnAddress:
((flags anyMask: PrimCallCollectsProfileSamples)
ifTrue: [cePrimReturnEnterCogCodeProfiling]
ifFalse: [cePrimReturnEnterCogCode]).
self JumpFullRT: primitiveRoutine asInteger.
primInvokeLabel := self Label.
jmp := jmpSamplePrim := continuePostSamplePrim := nil]
ifFalse:
["Call the C primitive routine."
self CallFullRT: primitiveRoutine asInteger.
primInvokeLabel := self Label.
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
[self assert: (flags anyMask: PrimCallNeedsNewMethod).
"Test nextProfileTick for being non-zero and call checkProfileTick if so"
objectMemory wordSize = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSamplePrim := self JumpNonZero: 0.
continuePostSamplePrim := self Label].
objectRepresentation maybeCompileRetry: retry onPrimitiveFail: primitiveIndex.
self maybeCompileAllocFillerCheck.
"Switch back to the Smalltalk stack. Stack better be in either of these two states:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
failure: receiver
arg1
...
stackPointer -> argN
return pc
In either case we can push the instructionPointer or load it into the LinkRegister to reestablish the return pc"
self MoveAw: coInterpreter instructionPointerAddress
R: (backEnd hasLinkRegister ifTrue: [LinkReg] ifFalse: [ClassReg]).
backEnd genLoadStackPointers.
"Test primitive failure"
self MoveAw: coInterpreter primFailCodeAddress R: TempReg.
backEnd hasLinkRegister ifFalse: [self PushR: ClassReg]. "Restore return pc on CISCs"
self flag: 'ask concrete code gen if move sets condition codes?'.
self CmpCq: 0 R: TempReg.
jmp := self JumpNonZero: 0.
"Fetch result from stack"
self MoveMw: (backEnd hasLinkRegister ifTrue: [0] ifFalse: [objectMemory wordSize])
r: SPReg
R: ReceiverResultReg.
- self flag: 'currently caller pushes result'.
self RetN: objectMemory wordSize]. "return to caller, popping receiver"
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
["The sample is collected by cePrimReturnEnterCogCode for external calls"
jmpSamplePrim notNil ifTrue:
["Call ceCheckProfileTick: to record sample and then continue."
jmpSamplePrim jmpTarget: self Label.
self assert: (flags anyMask: PrimCallNeedsNewMethod).
self CallFullRT: (self cCode: [#ceCheckProfileTick asUnsignedLong]
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
"reenter the post-primitive call flow"
self Jump: continuePostSamplePrim].
"Null newMethod and call ceCheckProfileTick: to record sample and then continue.
ceCheckProfileTick will map null/0 to coInterpreter nilObject"
jmpSampleNonPrim jmpTarget: self Label.
self MoveCq: 0 R: TempReg.
self MoveR: TempReg Aw: coInterpreter newMethodAddress.
self CallFullRT: (self cCode: [#ceCheckProfileTick asUnsignedLong]
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
"reenter the post-primitive call flow"
self Jump: continuePostSampleNonPrim].
jmp notNil ifTrue:
["Jump to restore of receiver reg and proceed to frame build for failure."
jmp jmpTarget: self Label.
"Restore receiver reg from stack. If on RISCs ret pc is in LinkReg, if on CISCs ret pc is on stack."
self MoveMw: objectMemory wordSize * (methodOrBlockNumArgs + (backEnd hasLinkRegister ifTrue: [0] ifFalse: [1]))
r: SPReg
R: ReceiverResultReg].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genDoubleArithmetic:preOpCheck: (in category 'primitive generators') -----
genDoubleArithmetic: arithmeticOperator preOpCheck: preOpCheckOrNil
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
<var: #preOpCheckOrNil declareC: 'AbstractInstruction *(*preOpCheckOrNil)(int rcvrReg, int argReg)'>
| jumpFailClass jumpFailAlloc jumpFailCheck jumpImmediate jumpNonInt doOp fail |
<var: #jumpFailClass type: #'AbstractInstruction *'>
<var: #jumpFailAlloc type: #'AbstractInstruction *'>
<var: #jumpNonInt type: #'AbstractInstruction *'>
<var: #jumpImmediate type: #'AbstractInstruction *'>
<var: #jumpFailCheck type: #'AbstractInstruction *'>
<var: #doOp type: #'AbstractInstruction *'>
<var: #fail type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
objectRepresentation genGetDoubleValueOf: ReceiverResultReg into: DPFPReg0.
self MoveR: TempReg R: ClassReg.
jumpImmediate := objectRepresentation genJumpImmediateInScratchReg: TempReg.
objectRepresentation genGetCompactClassIndexNonImmOf: ClassReg into: SendNumArgsReg.
objectRepresentation genCmpClassFloatCompactIndexR: SendNumArgsReg.
jumpFailClass := self JumpNonZero: 0.
objectRepresentation genGetDoubleValueOf: ClassReg into: DPFPReg1.
doOp := self Label.
preOpCheckOrNil ifNotNil:
[jumpFailCheck := self perform: preOpCheckOrNil with: DPFPReg0 with: DPFPReg1].
self gen: arithmeticOperator operand: DPFPReg1 operand: DPFPReg0.
jumpFailAlloc := objectRepresentation
genAllocFloatValue: DPFPReg0
into: SendNumArgsReg
scratchReg: ClassReg
scratchReg: TempReg.
self MoveR: SendNumArgsReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpImmediate jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg].
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
self ConvertR: ClassReg Rd: DPFPReg1.
self Jump: doOp.
jumpFailAlloc jmpTarget: self Label.
self compileFallbackToInterpreterPrimitive.
fail := self Label.
jumpFailClass jmpTarget: fail.
preOpCheckOrNil ifNotNil:
[jumpFailCheck jmpTarget: fail].
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt jmpTarget: fail].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genDoubleComparison:invert: (in category 'primitive generators') -----
genDoubleComparison: jumpOpcodeGenerator invert: invertComparison
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
<var: #jumpOpcodeGenerator declareC: 'AbstractInstruction *(*jumpOpcodeGenerator)(void *)'>
| jumpFail jumpImmediate jumpNonInt jumpCond compare |
<var: #jumpImmediate type: #'AbstractInstruction *'>
<var: #jumpNonInt type: #'AbstractInstruction *'>
<var: #jumpCond type: #'AbstractInstruction *'>
<var: #compare type: #'AbstractInstruction *'>
<var: #jumpFail type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
objectRepresentation genGetDoubleValueOf: ReceiverResultReg into: DPFPReg0.
self MoveR: TempReg R: ClassReg.
jumpImmediate := objectRepresentation genJumpImmediateInScratchReg: TempReg.
objectRepresentation genGetCompactClassIndexNonImmOf: ClassReg into: SendNumArgsReg.
objectRepresentation genCmpClassFloatCompactIndexR: SendNumArgsReg.
jumpFail := self JumpNonZero: 0.
objectRepresentation genGetDoubleValueOf: ClassReg into: DPFPReg1.
invertComparison "May need to invert for NaNs"
ifTrue: [compare := self CmpRd: DPFPReg0 Rd: DPFPReg1]
ifFalse: [compare := self CmpRd: DPFPReg1 Rd: DPFPReg0].
jumpCond := self perform: jumpOpcodeGenerator with: 0. "FP jumps are a little weird"
self genMoveFalseR: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpCond jmpTarget: (self genMoveTrueR: ReceiverResultReg).
+ self RetN: (self primRetNOffsetFor: 1).
- self RetN: objectMemory wordSize * 2.
jumpImmediate jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg].
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
self ConvertR: ClassReg Rd: DPFPReg1.
self Jump: compare.
jumpFail jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt jmpTarget: jumpFail getJmpTarget].
^0!
Item was added:
+ ----- Method: SimpleStackBasedCogit>>genLoadArgAtDepth:into: (in category 'primitive generators') -----
+ genLoadArgAtDepth: n into: reg
+ "Load an argument at depth from top-of-stack (0 relative) into a register.
+ The actual offset depends on whether there's a link register or not."
+ self MoveMw: (backEnd hasLinkRegister ifTrue: [n] ifFalse: [n + 1]) * objectMemory wordSize
+ r: SPReg
+ R: reg!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimReturnEnterCogCodeEnilopmart: (in category 'initialization') -----
genPrimReturnEnterCogCodeEnilopmart: profiling
"Generate the substitute return code for an external or FFI primitive call.
On success simply return, extracting numArgs from newMethod.
On primitive failure call ceActivateFailingPrimitiveMethod: newMethod."
| jmpSample continuePostSample jmpFail |
<var: #jmpSample type: #'AbstractInstruction *'>
<var: #continuePostSample type: #'AbstractInstruction *'>
<var: #jmpFail type: #'AbstractInstruction *'>
opcodeIndex := 0.
profiling ifTrue:
["Test nextProfileTick for being non-zero and call checkProfileTick: if so.
N.B. nextProfileTick is 64-bits so 32-bit systems need to test both halves."
objectMemory wordSize = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSample := self JumpNonZero: 0.
continuePostSample := self Label].
self maybeCompileAllocFillerCheck.
"Test primitive failure"
self MoveAw: coInterpreter primFailCodeAddress R: TempReg.
self flag: 'ask concrete code gen if move sets condition codes?'.
self CmpCq: 0 R: TempReg.
jmpFail := self JumpNonZero: 0.
"Switch back to the Smalltalk stack. Stack better be in either of these two states:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
failure: receiver
arg1
...
stackPointer -> argN
return pc
We push the instructionPointer to reestablish the return pc in the success case,
but leave it to ceActivateFailingPrimitiveMethod: to do so in the failure case."
backEnd hasLinkRegister
ifTrue:
[backEnd genLoadStackPointers. "Switch back to Smalltalk stack."
backEnd hasPCRegister
ifTrue:
[self PopR: ReceiverResultReg. "Pop result from stack"
self MoveAw: coInterpreter instructionPointerAddress R: PCReg] "Return"
ifFalse:
[self MoveMw: 0 r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self MoveAw: coInterpreter instructionPointerAddress R: LinkReg. "Get ret pc"
self RetN: objectMemory wordSize]] "Return, popping result from stack"
ifFalse:
[self MoveAw: coInterpreter instructionPointerAddress R: ClassReg. "Get return pc"
backEnd genLoadStackPointers. "Switch back to Smalltalk stack."
self MoveMw: 0 r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self MoveR: ClassReg Mw: 0 r: SPReg. "Restore return pc"
self RetN: 0]. "Return, popping result from stack"
"Primitive failed. Invoke C code to build the frame and continue."
jmpFail jmpTarget: (self MoveAw: coInterpreter newMethodAddress R: SendNumArgsReg).
"Reload sp with CStackPointer; easier than popping args of checkProfileTick."
self MoveAw: self cStackPointerAddress R: SPReg.
self
compileCallFor: #ceActivateFailingPrimitiveMethod:
numArgs: 1
arg: SendNumArgsReg
arg: nil
arg: nil
arg: nil
resultReg: nil
saveRegs: false.
"On Spur ceActivateFailingPrimitiveMethod: may retry the primitive and return if successful.
So continue by returning to the caller.
Switch back to the Smalltalk stack. Stack should be in this state:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
We can push the instructionPointer or load it into the LinkRegister to reestablish the return pc"
self MoveAw: coInterpreter instructionPointerAddress
R: (backEnd hasLinkRegister ifTrue: [LinkReg] ifFalse: [ClassReg]).
backEnd genLoadStackPointers.
backEnd hasLinkRegister
ifTrue:
[self MoveMw: 0 r: SPReg R: ReceiverResultReg] "Fetch result from stack"
ifFalse:
[self MoveMw: objectMemory wordSize r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self PushR: ClassReg]. "Restore return pc on CISCs"
- self flag: 'currently caller pushes result'.
self RetN: objectMemory wordSize. "return to caller, popping receiver"
profiling ifTrue:
["Call ceCheckProfileTick: to record sample and then continue. newMethod
should be up-to-date. Need to save and restore the link reg around this call."
jmpSample jmpTarget: self Label.
backEnd saveAndRestoreLinkRegAround:
[self CallFullRT: (self cCode: '(unsigned long)ceCheckProfileTick'
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick])].
self Jump: continuePostSample]!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAdd (in category 'primitive generators') -----
genPrimitiveAdd
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpNotSI jumpOvfl |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ClassReg.
self MoveR: ReceiverResultReg R: TempReg.
self AddR: ClassReg R: TempReg.
jumpOvfl := self JumpOverflow: 0.
self MoveR: TempReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpOvfl jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAsCharacter (in category 'primitive generators') -----
genPrimitiveAsCharacter
| na r |
na := coInterpreter argumentCountOf: methodObj.
na <= 1 ifTrue:
[na = 1 ifTrue:
+ [self genLoadArgAtDepth: 0 into: Arg0Reg].
- [self MoveMw: objectMemory wordSize r: SPReg R: Arg0Reg].
(r := objectRepresentation
+ genInnerPrimitiveAsCharacter: (self primRetNOffsetFor: na)
- genInnerPrimitiveAsCharacter: 0
inReg: (na = 0 ifTrue: [ReceiverResultReg] ifFalse: [Arg0Reg])) < 0 ifTrue:
[^r]].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAsFloat (in category 'primitive generators') -----
genPrimitiveAsFloat
"Stack looks like
receiver (also in ResultReceiverReg)
return address"
| jumpFailAlloc |
<var: #jumpFailAlloc type: #'AbstractInstruction *'>
self MoveR: ReceiverResultReg R: ClassReg.
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
self ConvertR: ClassReg Rd: DPFPReg0.
jumpFailAlloc := objectRepresentation
genAllocFloatValue: DPFPReg0
into: SendNumArgsReg
scratchReg: ClassReg
scratchReg: TempReg.
self MoveR: SendNumArgsReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 0).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize.
jumpFailAlloc jmpTarget: self Label.
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAt (in category 'primitive generators') -----
genPrimitiveAt
| r |
+ self genLoadArgAtDepth: 0 into: Arg0Reg.
+ (r := objectRepresentation genInnerPrimitiveAt: (self primRetNOffsetFor: 1)) < 0 ifTrue:
- self MoveMw: objectMemory wordSize r: SPReg R: Arg0Reg.
- (r := objectRepresentation genInnerPrimitiveAt: objectMemory wordSize * 2) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAtPut (in category 'primitive generators') -----
genPrimitiveAtPut
| r |
+ self genLoadArgAtDepth: 1 into: Arg0Reg.
+ self genLoadArgAtDepth: 0 into: Arg1Reg.
+ ((r := objectRepresentation genInnerPrimitiveAtPut: (self primRetNOffsetFor: 2)) < 0
- self MoveMw: objectMemory wordSize * 2 r: SPReg R: Arg0Reg.
- self MoveMw: objectMemory wordSize r: SPReg R: Arg1Reg.
- ((r := objectRepresentation genInnerPrimitiveAtPut: objectMemory wordSize * 3) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitAnd (in category 'primitive generators') -----
genPrimitiveBitAnd
| jumpNotSI |
<var: #jumpNotSI type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: Arg0Reg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"Whether the SmallInteger tags are zero or non-zero, anding them together will preserve them."
self AndR: ClassReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpNotSI jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitOr (in category 'primitive generators') -----
genPrimitiveBitOr
| jumpNotSI |
<var: #jumpNotSI type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"Whether the SmallInteger tags are zero or non-zero, oring them together will preserve them."
self OrR: ClassReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpNotSI jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitShift (in category 'primitive generators') -----
genPrimitiveBitShift
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address
rTemp := ArgOffset(SP)
rClass := tTemp
rTemp := rTemp & 1
jz nonInt
rClass >>= 1
cmp 0,rClass
jge neg
cmp 31,rClass // numSmallIntegerBits, jge for sign
jge tooBig
rTemp := rReceiver
rTemp <<= rClass
rTemp >>= rClass (arithmetic)
cmp rTemp,rReceiver
jnz ovfl
rReceiver := rReceiver - 1
rReceiver := rReceiver <<= rClass
rReceiver := rReceiver + 1
ret
neg:
rClass := 0 - rClass
cmp 31,rClass
jge inRange
rClass := 31
inRange
rReceiver := rReceiver >>= rClass.
rReceiver := rReceiver | 1.
ret
ovfl
tooBig
nonInt:
fail"
| jumpNotSI jumpOvfl jumpNegative jumpTooBig jumpInRange |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
<var: #jumpNegative type: #'AbstractInstruction *'>
<var: #jumpTooBig type: #'AbstractInstruction *'>
<var: #jumpInRange type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
(self lastOpcode setsConditionCodesFor: JumpNegative) ifFalse:
[self CmpCq: 0 R: ClassReg]. "N.B. FLAGS := ClassReg - 0"
jumpNegative := self JumpNegative: 0.
self CmpCq: objectRepresentation numSmallIntegerBits R: ClassReg. "N.B. FLAGS := ClassReg - 31"
jumpTooBig := self JumpGreaterOrEqual: 0.
self MoveR: ReceiverResultReg R: TempReg.
self LogicalShiftLeftR: ClassReg R: TempReg.
self ArithmeticShiftRightR: ClassReg R: TempReg.
self CmpR: TempReg R: ReceiverResultReg. "N.B. FLAGS := RRReg - TempReg"
jumpOvfl := self JumpNonZero: 0.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ReceiverResultReg.
self LogicalShiftLeftR: ClassReg R: ReceiverResultReg.
objectRepresentation genAddSmallIntegerTagsTo: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self RetN: objectMemory wordSize * 2.
jumpNegative jmpTarget: (self NegateR: ClassReg).
self CmpCq: objectRepresentation numSmallIntegerBits R: ClassReg. "N.B. FLAGS := ClassReg - 31"
jumpInRange := self JumpLessOrEqual: 0.
self MoveCq: objectRepresentation numSmallIntegerBits R: ClassReg.
jumpInRange jmpTarget: (self ArithmeticShiftRightR: ClassReg R: ReceiverResultReg).
objectRepresentation genSetSmallIntegerTagsIn: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self RetN: objectMemory wordSize * 2.
jumpNotSI jmpTarget: (jumpTooBig jmpTarget: (jumpOvfl jmpTarget: self Label)).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitXor (in category 'primitive generators') -----
genPrimitiveBitXor
| jumpNotSI |
<var: #jumpNotSI type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into:TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"Clear one or the other tag so that xoring will preserve them."
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ClassReg.
self XorR: ClassReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpNotSI jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveCharacterValue (in category 'primitive generators') -----
genPrimitiveCharacterValue
| r |
+ (r := objectRepresentation genInnerPrimitiveCharacterValue: (self primRetNOffsetFor: 0)) < 0 ifTrue:
- (r := objectRepresentation genInnerPrimitiveCharacterValue: objectMemory wordSize) < 0 ifTrue:
[^r].
^r = UnfailingPrimitive
ifTrue: [0]
ifFalse: [self compileFallbackToInterpreterPrimitive]!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveClass (in category 'primitive generators') -----
genPrimitiveClass
"Stack looks like
receiver (also in ReceiverResultReg)
return address"
(objectRepresentation
genGetClassObjectOf: ReceiverResultReg
into: ReceiverResultReg
scratchReg: TempReg
instRegIsReceiver: methodOrBlockNumArgs = 0) = BadRegisterSet ifTrue:
[objectRepresentation
genGetClassObjectOf: ReceiverResultReg
into: ClassReg
scratchReg: TempReg
instRegIsReceiver: methodOrBlockNumArgs = 0.
self MoveR: ClassReg R: ReceiverResultReg].
+ self RetN: (self primRetNOffsetFor: 0).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveDiv (in category 'primitive generators') -----
genPrimitiveDiv
| jumpNotSI jumpZero jumpExact jumpSameSign convert |
<var: #convert type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpExact type: #'AbstractInstruction *'>
<var: #jumpSameSign type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
self MoveR: TempReg R: Arg1Reg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"We must shift away the tags, not just subtract them, so that the
overflow case doesn't actually overflow the machine instruction."
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: ClassReg].
jumpZero := self JumpZero: 0.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"If remainder is zero we must check for overflow."
self CmpCq: 0 R: ClassReg.
jumpExact := self JumpZero: 0.
"If arg and remainder signs are different we must round down."
self XorR: ClassReg R: Arg1Reg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: Arg1Reg].
jumpSameSign := self JumpGreaterOrEqual: 0.
self SubCq: 1 R: TempReg.
jumpSameSign jmpTarget: (convert := self Label).
objectRepresentation genConvertIntegerToSmallIntegerInReg: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
"test for overflow; the only case is SmallInteger minVal // -1"
jumpExact jmpTarget:
(self CmpCq: (1 << (objectRepresentation numSmallIntegerBits - 1)) R: TempReg).
self JumpLess: convert.
jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveDivide (in category 'primitive generators') -----
genPrimitiveDivide
| jumpNotSI jumpZero jumpInexact jumpOverflow |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpInexact type: #'AbstractInstruction *'>
<var: #jumpOverflow type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"We must shift away the tags, not just subtract them, so that the
overflow case doesn't actually overflow the machine instruction."
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
jumpZero := self JumpZero: 0.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"If remainder is non-zero fail."
self CmpCq: 0 R: ClassReg.
jumpInexact := self JumpNonZero: 0.
"test for overflow; the only case is SmallInteger minVal / -1"
self CmpCq: (1 << (objectRepresentation numSmallIntegerBits - 1)) R: TempReg.
jumpOverflow := self JumpGreaterOrEqual: 0.
objectRepresentation genConvertIntegerToSmallIntegerInReg: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpOverflow jmpTarget: (jumpInexact jmpTarget: (jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label))).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveFloatSquareRoot (in category 'primitive generators') -----
genPrimitiveFloatSquareRoot
"Stack looks like
receiver (also in ResultReceiverReg)
return address"
| jumpFailAlloc |
<var: #jumpFailAlloc type: #'AbstractInstruction *'>
objectRepresentation genGetDoubleValueOf: ReceiverResultReg into: DPFPReg0.
self SqrtRd: DPFPReg0.
jumpFailAlloc := objectRepresentation
genAllocFloatValue: DPFPReg0
into: SendNumArgsReg
scratchReg: ClassReg
scratchReg: TempReg.
self MoveR: SendNumArgsReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 0).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize.
jumpFailAlloc jmpTarget: self Label.
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveIdentical (in category 'primitive generators') -----
genPrimitiveIdentical
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
+ self genLoadArgAtDepth: 0 into: Arg0Reg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
^objectRepresentation
+ genInnerPrimitiveIdentical: (self primRetNOffsetFor: 1)
- genInnerPrimitiveIdentical: objectMemory wordSize * 2
orNotIf: false!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveIdentityHash (in category 'primitive generators') -----
genPrimitiveIdentityHash
| r |
+ (r := objectRepresentation genInnerPrimitiveIdentityHash: (self primRetNOffsetFor: 0)) < 0 ifTrue:
- (r := objectRepresentation genInnerPrimitiveIdentityHash: objectMemory wordSize) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveMod (in category 'primitive generators') -----
genPrimitiveMod
| jumpNotSI jumpZero jumpExact jumpSameSign |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpExact type: #'AbstractInstruction *'>
<var: #jumpSameSign type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ClassReg.
jumpZero := self JumpZero: 0.
self MoveR: ClassReg R: Arg1Reg.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"If remainder is zero we're done."
self CmpCq: 0 R: ClassReg.
jumpExact := self JumpZero: 0.
"If arg and remainder signs are different we must reflect around zero."
self XorR: ClassReg R: Arg1Reg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: Arg1Reg].
jumpSameSign := self JumpGreaterOrEqual: 0.
self XorR: ClassReg R: Arg1Reg.
self AddR: Arg1Reg R: ClassReg.
jumpSameSign jmpTarget: (jumpExact jmpTarget: self Label).
objectRepresentation genSetSmallIntegerTagsIn: ClassReg.
self MoveR: ClassReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveMultiply (in category 'primitive generators') -----
genPrimitiveMultiply
| jumpNotSI jumpOvfl |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: TempReg.
self MulR: TempReg R: ClassReg.
jumpOvfl := self JumpOverflow: 0.
objectRepresentation genSetSmallIntegerTagsIn: ClassReg.
self MoveR: ClassReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpOvfl jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNew (in category 'primitive generators') -----
genPrimitiveNew
| r |
+ ((r := objectRepresentation genInnerPrimitiveNew: (self primRetNOffsetFor: 0)) < 0
- ((r := objectRepresentation genInnerPrimitiveNew: objectMemory wordSize) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
"Call the interpreter primitive either when the machine-code primitive
fails, or if the machine-code primitive is unimplemented."
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNewMethod (in category 'primitive generators') -----
genPrimitiveNewMethod
| r |
+ ((r := objectRepresentation genInnerPrimitiveNewMethod: (self primRetNOffsetFor: 2)) < 0
- ((r := objectRepresentation genInnerPrimitiveNewMethod: 2 * objectMemory wordSize) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
"Call the interpreter primitive either when the machine-code primitive
fails, or if the machine-code primitive is unimplemented."
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNewWithArg (in category 'primitive generators') -----
genPrimitiveNewWithArg
| r |
+ ((r := objectRepresentation genInnerPrimitiveNewWithArg: (self primRetNOffsetFor: 1)) < 0
- ((r := objectRepresentation genInnerPrimitiveNewWithArg: objectMemory wordSize) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
"Call the interpreter primitive either when the machine-code primitive
fails, or if the machine-code primitive is unimplemented."
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNotIdentical (in category 'primitive generators') -----
genPrimitiveNotIdentical
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
+ self genLoadArgAtDepth: 0 into: Arg0Reg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
^objectRepresentation
+ genInnerPrimitiveIdentical: (self primRetNOffsetFor: 1)
- genInnerPrimitiveIdentical: objectMemory wordSize * 2
orNotIf: true!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveQuo (in category 'primitive generators') -----
genPrimitiveQuo
| jumpNotSI jumpZero jumpOverflow |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpOverflow type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"We must shift away the tags, not just subtract them, so that the
overflow case doesn't actually overflow the machine instruction."
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: ClassReg].
jumpZero := self JumpZero: 0.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"test for overflow; the only case is SmallInteger minVal quo: -1"
self CmpCq: (1 << (objectRepresentation numSmallIntegerBits - 1)) R: TempReg.
jumpOverflow := self JumpGreaterOrEqual: 0.
objectRepresentation genConvertIntegerToSmallIntegerInReg: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpOverflow jmpTarget: (jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label)).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveSize (in category 'primitive generators') -----
genPrimitiveSize
| r |
+ (r := objectRepresentation genInnerPrimitiveSize: (self primRetNOffsetFor: 0)) < 0 ifTrue:
- (r := objectRepresentation genInnerPrimitiveSize: objectMemory wordSize) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveStringAt (in category 'primitive generators') -----
genPrimitiveStringAt
| r |
+ self genLoadArgAtDepth: 0 into: Arg0Reg.
+ (r := objectRepresentation genInnerPrimitiveStringAt: (self primRetNOffsetFor: 1)) < 0 ifTrue:
- self MoveMw: objectMemory wordSize r: SPReg R: Arg0Reg.
- (r := objectRepresentation genInnerPrimitiveStringAt: objectMemory wordSize * 2) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveStringAtPut (in category 'primitive generators') -----
genPrimitiveStringAtPut
| r |
+ self genLoadArgAtDepth: 1 into: Arg0Reg.
+ self genLoadArgAtDepth: 0 into: Arg1Reg.
+ ((r := objectRepresentation genInnerPrimitiveStringAtPut: (self primRetNOffsetFor: 2)) < 0
- self MoveMw: objectMemory wordSize * 2 r: SPReg R: Arg0Reg.
- self MoveMw: objectMemory wordSize r: SPReg R: Arg1Reg.
- ((r := objectRepresentation genInnerPrimitiveStringAtPut: objectMemory wordSize * 3) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveSubtract (in category 'primitive generators') -----
genPrimitiveSubtract
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpNotSI jumpOvfl |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self MoveR: ReceiverResultReg R: TempReg.
self SubR: ClassReg R: TempReg.
jumpOvfl := self JumpOverflow: 0.
objectRepresentation genAddSmallIntegerTagsTo: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpOvfl jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genReturnNilFromBlock (in category 'bytecode generators') -----
genReturnNilFromBlock
self assert: inBlock.
- self flag: 'currently caller pushes result'.
self genMoveConstant: objectMemory nilObject R: ReceiverResultReg.
^self genBlockReturn!
Item was changed:
----- Method: SimpleStackBasedCogit>>genReturnReceiver (in category 'bytecode generators') -----
genReturnReceiver
"Frameless method activation looks like
receiver
args
sp-> ret pc.
Return pops receiver and arguments off the stack. Callee pushes the result."
- self flag: 'currently caller pushes result'.
needsFrame ifTrue:
[self MoveMw: FoxMFReceiver r: FPReg R: ReceiverResultReg].
^self genUpArrowReturn!
Item was changed:
----- Method: SimpleStackBasedCogit>>genReturnTopFromBlock (in category 'bytecode generators') -----
genReturnTopFromBlock
self assert: inBlock.
- self flag: 'currently caller pushes result'.
self PopR: ReceiverResultReg.
^self genBlockReturn!
Item was changed:
----- Method: SimpleStackBasedCogit>>genReturnTopFromMethod (in category 'bytecode generators') -----
genReturnTopFromMethod
"Return pops receiver and arguments off the stack. Callee pushes the result."
- self flag: 'currently caller pushes result'.
self PopR: ReceiverResultReg.
^self genUpArrowReturn!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSend:numArgs:sendTable: (in category 'bytecode generator support') -----
genSend: selector numArgs: numArgs sendTable: sendTable
<inline: false>
<var: #sendTable type: #'sqInt *'>
| annotation |
(objectMemory isYoung: selector) ifTrue:
[hasYoungReferent := true].
self assert: needsFrame.
annotation := self annotationForSendTable: sendTable.
self assert: (numArgs between: 0 and: 255). "say"
self assert: (objectMemory addressCouldBeOop: selector).
self MoveMw: numArgs * objectMemory wordSize r: SPReg R: ReceiverResultReg.
"Deal with stale super sends; see SpurMemoryManager's class comment."
(self annotationIsForUncheckedEntryPoint: annotation) ifTrue:
[objectRepresentation genEnsureOopInRegNotForwarded: ReceiverResultReg scratchReg: TempReg].
numArgs > 2 ifTrue:
[self MoveCq: numArgs R: SendNumArgsReg].
(BytecodeSetHasDirectedSuperSend
and: [annotation = IsDirectedSuperSend]) ifTrue:
[self genMoveConstant: tempOop R: TempReg].
self MoveCw: selector R: ClassReg.
self annotate: (self Call: (sendTable at: (numArgs min: NumSendTrampolines - 1)))
with: annotation.
- self flag: 'currently caller pushes result'.
self PushR: ReceiverResultReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSmallIntegerComparison: (in category 'primitive generators') -----
genSmallIntegerComparison: jumpOpcode
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpFail jumpTrue |
<var: #jumpFail type: #'AbstractInstruction *'>
<var: #jumpTrue type: #'AbstractInstruction *'>
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpFail := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self CmpR: ClassReg R: ReceiverResultReg. "N.B. FLAGS := RRReg - ClassReg"
jumpTrue := self gen: jumpOpcode.
self genMoveFalseR: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpTrue jmpTarget: (self genMoveTrueR: ReceiverResultReg).
+ self RetN: (self primRetNOffsetFor: 1).
- self RetN: objectMemory wordSize * 2.
jumpFail jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSmallIntegerComparison:orDoubleComparison: (in category 'primitive generators') -----
genSmallIntegerComparison: jumpOpcode orDoubleComparison: jumpFPOpcodeGenerator
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpDouble jumpNonInt jumpFail jumpTrue jumpCond |
<var: #jumpFPOpcodeGenerator declareC: 'AbstractInstruction *(*jumpFPOpcodeGenerator)(void *)'>
<var: #jumpDouble type: #'AbstractInstruction *'>
<var: #jumpNonInt type: #'AbstractInstruction *'>
<var: #jumpCond type: #'AbstractInstruction *'>
<var: #jumpTrue type: #'AbstractInstruction *'>
<var: #jumpFail type: #'AbstractInstruction *'>
backEnd hasDoublePrecisionFloatingPointSupport ifFalse:
[^self genSmallIntegerComparison: jumpOpcode].
+ self genLoadArgAtDepth: 0 into: TempReg.
- self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpDouble := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self CmpR: ClassReg R: ReceiverResultReg. "N.B. FLAGS := RRReg - ClassReg"
jumpTrue := self gen: jumpOpcode.
self genMoveFalseR: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpTrue jmpTarget: (self genMoveTrueR: ReceiverResultReg).
+ self RetN: (self primRetNOffsetFor: 1).
- self RetN: objectMemory wordSize * 2.
"Argument may be a Float : let us check or fail"
jumpDouble jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[self MoveR: ClassReg R: TempReg.
jumpNonInt := objectRepresentation genJumpImmediateInScratchReg: TempReg].
objectRepresentation genGetCompactClassIndexNonImmOf: ClassReg into: SendNumArgsReg.
objectRepresentation genCmpClassFloatCompactIndexR: SendNumArgsReg.
jumpFail := self JumpNonZero: 0.
"It was a Float, so convert the receiver to double and perform the operation"
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genConvertSmallIntegerToIntegerInReg: TempReg.
self ConvertR: TempReg Rd: DPFPReg0.
objectRepresentation genGetDoubleValueOf: ClassReg into: DPFPReg1.
self CmpRd: DPFPReg1 Rd: DPFPReg0.
jumpCond := self perform: jumpFPOpcodeGenerator with: 0. "FP jumps are a little weird"
self genMoveFalseR: ReceiverResultReg.
+ self RetN: (self primRetNOffsetFor: 1).
- self flag: 'currently caller pushes result'.
- self RetN: objectMemory wordSize * 2.
jumpCond jmpTarget: (self genMoveTrueR: ReceiverResultReg).
+ self RetN: (self primRetNOffsetFor: 1).
- self RetN: objectMemory wordSize * 2.
objectRepresentation smallIntegerIsOnlyImmediateType
ifTrue: [jumpFail jmpTarget: self Label]
ifFalse: [jumpNonInt jmpTarget: (jumpFail jmpTarget: self Label)].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSpecialSelectorEqualsEquals (in category 'bytecode generators') -----
genSpecialSelectorEqualsEquals
| jumpNotEqual jumpPush |
<var: #jumpNotEqual type: #'AbstractInstruction *'>
<var: #jumpPush type: #'AbstractInstruction *'>
self PopR: Arg0Reg.
objectRepresentation
+ genEnsureOopInRegNotForwarded: Arg0Reg
- genEnsureObjInRegNotForwarded: Arg0Reg
scratchReg: TempReg.
self MoveMw: 0 r: SPReg R: ClassReg.
objectRepresentation
+ genEnsureOopInRegNotForwarded: ClassReg
- genEnsureObjInRegNotForwarded: ClassReg
scratchReg: TempReg.
self CmpR: Arg0Reg R: ClassReg.
jumpNotEqual := self JumpNonZero: 0.
self annotate: (self genMoveTrueR: Arg0Reg)
objRef: objectMemory trueObject.
jumpPush := self Jump: 0.
jumpNotEqual jmpTarget: (self genMoveFalseR: Arg0Reg).
jumpPush jmpTarget: (self MoveR: Arg0Reg Mw: 0 r: SPReg).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genUpArrowReturn (in category 'bytecode generators') -----
genUpArrowReturn
"Generate a method return from within a method or a block.
Frameless method activation looks like
receiver
args
sp-> ret pc.
Return pops receiver and arguments off the stack. Callee pushes the result."
- self flag: 'currently caller pushes result'.
inBlock ifTrue:
[self assert: needsFrame.
self annotateBytecode: (self CallRT: ceNonLocalReturnTrampoline).
^0].
needsFrame ifTrue:
[self MoveR: FPReg R: SPReg.
self PopR: FPReg.
backEnd hasLinkRegister ifTrue:
[self PopR: LinkReg]].
self RetN: methodOrBlockNumArgs + 1 * objectMemory wordSize.
^0!
Item was added:
+ ----- Method: SimpleStackBasedCogit>>primRetNOffsetFor: (in category 'primitive generators') -----
+ primRetNOffsetFor: nargs
+ "Answer how many bytes to cut back the stack to remove the receiver
+ and arguments after an invocation of a primitive with nargs arguments. "
+ ^nargs + 1 * objectMemory wordSize!
Item was added:
+ ----- Method: SimpleStackBasedCogit>>register:isInMask: (in category 'simulation stack') -----
+ register: reg isInMask: mask
+ <inline: true>
+ ^ mask anyMask: (self registerMaskFor: reg)!
Item was changed:
----- Method: SimpleStackBasedCogit>>returnRegForStoreCheck (in category 'trampolines') -----
returnRegForStoreCheck
+ "We must ensure the ReceiverResultReg is live across the store check so that
+ we can store into receiver inst vars in a frameless method since self exists
+ only in ReceiverResultReg in a frameless method. So if ReceiverResultReg is
+ caller-saved we use the fact that ceStoreCheck: answers its argument to
+ reload ReceiverResultReg cheaply. Otherwise we don't care about the result
+ and use the cResultRegister, effectively a no-op (see compileTrampoline...)"
+
+ ^(self register: ReceiverResultReg isInMask: callerSavedRegMask)
+ ifTrue: [ReceiverResultReg]
+ ifFalse: [backEnd cResultRegister]!
- "See the subclass for explanation."
- ^backEnd cResultRegister!
Item was added:
+ ----- Method: StackToRegisterMappingCogit>>genLoadArgAtDepth:into: (in category 'primitive generators') -----
+ genLoadArgAtDepth: n into: reg
+ self shouldNotImplement!
Item was added:
+ ----- Method: StackToRegisterMappingCogit>>primRetNOffsetFor: (in category 'primitive generators') -----
+ primRetNOffsetFor: nargs
+ self shouldNotImplement!
Item was removed:
- ----- Method: StackToRegisterMappingCogit>>register:isInMask: (in category 'simulation stack') -----
- register: reg isInMask: mask
- <inline: true>
- ^ mask anyMask: (self registerMaskFor: reg)!
Item was removed:
- ----- Method: StackToRegisterMappingCogit>>returnRegForStoreCheck (in category 'trampolines') -----
- returnRegForStoreCheck
- "We must ensure the ReceiverResultReg is live across the store check so that
- we can store into receiver inst vars in a frameless method since self exists
- only in ReceiverResultReg in a frameless method. So if ReceiverResultReg is
- caller-saved we use the fact that ceStoreCheck: answers its argument to
- reload ReceiverResultReg cheaply. Otherwise we don't care about the result
- and use the cResultRegister, effectively a no-op (see compileTrampoline...)"
-
- ^(self register: ReceiverResultReg isInMask: callerSavedRegMask)
- ifTrue: [ReceiverResultReg]
- ifFalse: [backEnd cResultRegister]!
1
0
Hi Tim,
is there a reason why you cannot put this in a subclass, e.g.
RSqueakInterpreterProxy, rather than in the default? Seems to me that
would provide better documentation than the current method. Also you could
at least comment the method to explain that this is for RSqueak, and try
and explain what happens in the RSqueakVM. It looks opaque to me. I like
to know what primitives do. For example, the comment in
BlockClosure>>ensure: is explicit:
ensure: aBlock
"Evaluate a termination block after evaluating the receiver, regardless of
whether the receiver's evaluation completes. N.B. This method is *not*
implemented as a primitive. Primitive 198 always fails. The VM uses prim
198 in a context's method as the mark for an ensure:/ifCurtailed:
activation."
| complete returnValue |
<primitive: 198>
returnValue := self valueNoContextSwitch.
complete ifNil:[
complete := true.
aBlock value.
].
^ returnValue
What you have is mysterious (at least to me):
primitiveFailFor: reasonCode
"Set specific primitive failure.
N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode.
Primitive 255 is called to indicate that we are currently simulating a
primitive that should fail and the VM should handle that case appropriately
(if supported by the VM)."
<primitive: 255>
^ primFailCode := reasonCode
Surely, "Primitive 255 is called to inform the VM that we are failing a
primitive we are simulating. Specific VMs, e.g. the RSqueakVM, choose not
to implement certain primitives and prefer to simulate the code. In this
case the VM needs the primitive execution to catch, and handle, failure of
the simulated code."
On Wed, Apr 29, 2015 at 10:59 PM, <commits(a)source.squeak.org> wrote:
>
> Tim Felgentreff uploaded a new version of VMMaker to project VM Maker:
> http://source.squeak.org/VMMaker/VMMaker.oscog-tfel.1274.mcz
>
> ==================== Summary ====================
>
> Name: VMMaker.oscog-tfel.1274
> Author: tfel
> Time: 30 April 2015, 7:59:26.741 am
> UUID: 11ab491c-b25b-4a4b-bbee-864f39e9d3e7
> Ancestors: VMMaker.oscog-rmacnak.1273
>
> Merge from VMMaker-tfel.363. Add primitive 255 as marker to
> InterpreterProxy>>primitiveFailFor: for RSqueakVM to notice that the
> simulation is about to fail
>
> =============== Diff against VMMaker.oscog-rmacnak.1273 ===============
>
> Item was changed:
> ----- Method: InterpreterProxy>>primitiveFailFor: (in category 'other')
> -----
> primitiveFailFor: reasonCode
> "Set specific primitive failure.
> + N.B. primitiveFailFor: PrimNoErr is expected to clear the
> primFailCode.
> + Primitive 255 is called to indicate that we are currently
> simulating a primitive that should fail and the VM should handle that case
> appropriately (if supported by the VM)."
> + <primitive: 255>
> + ^ primFailCode := reasonCode!
> - N.B. primitiveFailFor: PrimNoErr is expected to clear the
> primFailCode."
> - (self confirm:'A primitive is failing -- Stop simulation?')
> ifTrue:[self halt].
> - ^primFailCode := reasonCode!
>
>
--
best,
Eliot
1
0
Re: [Pharo-users] Reddit discussion (rant) about Pharo 4.0 first time users' experiences
by Ben Coman 30 Apr '15
by Ben Coman 30 Apr '15
30 Apr '15
There was a criticism about the VM build requiring OSX SDK 10.6 being +4
years old.
https://github.com/pharo-project/pharo-vm
Has anyone built with a later SDK?
cheers -ben
On Thu, Apr 30, 2015 at 8:23 PM, Sven Van Caekenberghe <sven(a)stfx.eu> wrote:
> So he didn't find http://pharo.org/documentation ?
>
> It is the first hit if you search for 'Pharo Documentation' !
>
> Of course, one on one mentoring is way better than any documentation for
> anything.
>
> > On 30 Apr 2015, at 13:40, Sergio Fedi <sergio.fedi(a)gmail.com> wrote:
> >
> > Note: I haven't read the reddit link above)
> >
> > I recently (2 weeks) begun working with a total neophite to St and there
> is a lack of proper Tutorial/Documentation to get you started doing
> something.
> >
> > When I say that there is a lack, I mean that this person (who is well
> versed in looking up stuff on the internet) couldn't find proper material
> for getting started.
> > (whether this material does not exist or exists but is difficult to
> find, I don
> > t know)
> >
> > And it's not have been the first time this happened to me.
> >
> > So far, my best (fluid, straightforward) experiences learning St has
> been when someone else taught me.
> >
>
>
>
2
2
Tim Felgentreff uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-tfel.1274.mcz
==================== Summary ====================
Name: VMMaker.oscog-tfel.1274
Author: tfel
Time: 30 April 2015, 7:59:26.741 am
UUID: 11ab491c-b25b-4a4b-bbee-864f39e9d3e7
Ancestors: VMMaker.oscog-rmacnak.1273
Merge from VMMaker-tfel.363. Add primitive 255 as marker to InterpreterProxy>>primitiveFailFor: for RSqueakVM to notice that the simulation is about to fail
=============== Diff against VMMaker.oscog-rmacnak.1273 ===============
Item was changed:
----- Method: InterpreterProxy>>primitiveFailFor: (in category 'other') -----
primitiveFailFor: reasonCode
"Set specific primitive failure.
+ N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode.
+ Primitive 255 is called to indicate that we are currently simulating a primitive that should fail and the VM should handle that case appropriately (if supported by the VM)."
+ <primitive: 255>
+ ^ primFailCode := reasonCode!
- N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode."
- (self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt].
- ^primFailCode := reasonCode!
1
0
Ryan Macnak uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-rmacnak.1273.mcz
==================== Summary ====================
Name: VMMaker.oscog-rmacnak.1273
Author: rmacnak
Time: 29 April 2015, 10:18:51.331 pm
UUID: 10812de2-817a-4ce0-80a3-3732d94687d7
Ancestors: VMMaker.oscog-cb.1272
Allow setting preemptionYields in the stack VM.
=============== Diff against VMMaker.oscog-cb.1272 ===============
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
1
0
Tim Felgentreff uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-tfel.363.mcz
==================== Summary ====================
Name: VMMaker-tfel.363
Author: tfel
Time: 30 April 2015, 12:30:41.609 am
UUID: 9c88f628-a4ad-1944-a0af-3d54a0d4e1da
Ancestors: VMMaker-tfel.362, VMMaker-dtl.359
Fix botched merge of VMMaker-tfel.362 and VMMaker-dtl.359
=============== Diff against VMMaker-tfel.362 ===============
Item was changed:
SystemOrganization addCategory: #'VMMaker-Building'!
SystemOrganization addCategory: #'VMMaker-Interpreter'!
SystemOrganization addCategory: #'VMMaker-InterpreterSimulation'!
SystemOrganization addCategory: #'VMMaker-Plugins'!
SystemOrganization addCategory: #'VMMaker-SmartSyntaxPlugins'!
SystemOrganization addCategory: #'VMMaker-Translation to C'!
SystemOrganization addCategory: #'VMMaker-Tests'!
SystemOrganization addCategory: #'VMMaker-Support'!
SystemOrganization addCategory: #'VMMaker-JIT'!
+ SystemOrganization addCategory: #'VMMaker-JITSimulation'!
Item was changed:
----- Method: BalloonEngineSimulation class>>simulatePrimitive:receiver:args: (in category 'simulation') -----
simulatePrimitive: aString receiver: rcvr args: args
| proxy bb |
proxy := InterpreterProxy new.
proxy synthesizeStackFor: rcvr with: args.
bb := self simulatorClass new.
bb setInterpreter: proxy.
bb initialiseModule.
"rendering state is loaded in the primitive implementations"
+ [bb perform: aString asSymbol] on: Exception do: [:ex |
+ proxy success: false].
- [bb perform: aString asSymbol] on: Exception do: [:ex|
- RSqueak log: 'got an error trying to simulate ', aString.
- RSqueak log: ex messageText.
- RSqueak log: ex signalerContext shortStack].
^ proxy stackValue: 0
!
Item was changed:
Object subclass: #CCodeGenerator
+ instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations uncheckedAbstractMethods selectorTranslations breakSrcInlineSelector breakDestInlineSelector inlineReturnTypes'
- instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations uncheckedAbstractMethods selectorTranslations breakSrcInlineSelector breakDestInlineSelector inlineReturnTypes'
classVariableNames: 'UseRightShiftForDivide'
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.
See VMMaker for more useful info!
Item was added:
+ ReadStream subclass: #FakeStdinStream
+ instanceVariableNames: 'atEnd simulator'
+ classVariableNames: ''
+ poolDictionaries: 'VMBasicConstants'
+ category: 'VMMaker-JITSimulation'!
+
+ !FakeStdinStream commentStamp: '<historical>' prior: 0!
+ Fake Standard input using a dialog to prompt for a line of input at a time.!
Item was added:
+ ----- Method: FakeStdinStream class>>for: (in category 'instance creation') -----
+ for: aCogVMSimulator
+ ^(self basicNew simulator: aCogVMSimulator)
+ on: (String new: 80) from: 1 to: 0
+
+ "self new next"!
Item was added:
+ ----- Method: FakeStdinStream class>>new (in category 'instance creation') -----
+ new
+ ^super on: (String new: 80) from: 1 to: 0
+
+ "self new next"!
Item was added:
+ ----- Method: FakeStdinStream>>atEnd (in category 'testing') -----
+ atEnd
+ ^atEnd ifNil: [atEnd := false]!
Item was added:
+ ----- Method: FakeStdinStream>>atEnd: (in category 'accessing') -----
+ atEnd: aBoolean
+ atEnd := aBoolean!
Item was added:
+ ----- Method: FakeStdinStream>>close (in category 'accessing') -----
+ close
+ atEnd := true!
Item was added:
+ ----- Method: FakeStdinStream>>next (in category 'accessing') -----
+ next
+ "Answer the next object in the Stream represented by the receiver.
+ If there are no more elements in the stream fill up the buffer by prompting for input"
+ | sem inputLine next |
+ position >= readLimit ifTrue:
+ [simulator isThreadedVM
+ ifTrue:
+ ["(simulator cogit singleStep not
+ and: [UIManager confirm: 'Single step?']) ifTrue:
+ [simulator cogit singleStep: true]."
+ "threadIndex := simulator disownVM: DisownVMLockOutFullGC." self flag: #FIXME. "oscog"
+ simulator forceInterruptCheckFromHeartbeat.
+ sem := Semaphore new.
+ WorldState addDeferredUIMessage:
+ [inputLine := UIManager default request: 'Input please!!'.
+ sem signal].
+ sem wait]
+ ifFalse:
+ [inputLine := UIManager default request: 'Input please!!'].
+ collection size <= inputLine size ifTrue:
+ [collection := collection species new: inputLine size + 1].
+ collection
+ replaceFrom: 1 to: inputLine size with: inputLine startingAt: 1;
+ at: (readLimit := inputLine size + 1) put: Character lf.
+ position := 0.
+ "simulator isThreadedVM ifTrue:
+ [simulator ownVM: threadIndex]" self flag: #FiXME "oscog"].
+ next := collection at: (position := position + 1).
+ "This is set temporarily to allow (FilePluginSimulator>>#sqFile:Read:Into:At:
+ to brwak out of its loop. sqFile:Read:Into:At: resets it on the way out."
+ atEnd := position >= readLimit.
+ ^next
+
+
+ " This does it with workspaces:
+ | ws r s |
+ s := Semaphore new.
+ ws := Workspace new contents: ''.
+ ws acceptAction: [:t| r := t asString. s signal].
+ [ws openLabel: 'Yo!!'; shouldStyle: false.
+ (ws dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil]) ifNotNil:
+ [:textMorph| textMorph acceptOnCR: true; hasUnacceptedEdits: true]] fork.
+ Processor activeProcess == Project uiProcess
+ ifTrue: [[r isNil] whileTrue: [World doOneCycle]]
+ ifFalse: [s wait].
+ ws topView delete.
+ s wait. s signal.
+ r"!
Item was added:
+ ----- Method: FakeStdinStream>>simulator: (in category 'initialize-release') -----
+ simulator: aCogVMSimulator
+ simulator := aCogVMSimulator.
+ atEnd := false!
Item was changed:
----- Method: FilePlugin class>>requiredMethodNames (in category 'translation') -----
requiredMethodNames
+ "fileValueOf: nd fileRecordSize are called (questionably so) by support code for DropPlugin"
- "fileValueOf: is called (questionably so) by support code for DropPlugin"
+ ^ super requiredMethodNames, #( fileValueOf: fileRecordSize )!
- ^ super requiredMethodNames, #( fileValueOf: )!
Item was changed:
----- Method: FilePlugin>>fileRecordSize (in category 'file primitives') -----
fileRecordSize
"Return the size of a Smalltalk file record in bytes."
<static: false>
+ ^self sizeof: #SQFile!
- ^ self cCode: 'sizeof(SQFile)'.!
Item was changed:
FilePlugin subclass: #FilePluginSimulator
+ instanceVariableNames: 'openFiles states'
- instanceVariableNames: 'openFiles'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-InterpreterSimulation'!
!FilePluginSimulator commentStamp: 'tpr 5/5/2003 12:02' prior: 0!
File plugin simulation for the VM simulator!
Item was added:
+ ----- Method: FilePluginSimulator>>createDirectory: (in category 'simulation') -----
+ createDirectory: aString
+ ^[FileDirectory default primCreateDirectory: aString.
+ true]
+ on: Error
+ do: [:ex| false]
+ !
Item was changed:
----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') -----
fileValueOf: objectPointer
+ | index file |
- | index |
index := (interpreterProxy isIntegerObject: objectPointer)
ifTrue: [interpreterProxy integerValueOf: objectPointer]
ifFalse:
[((interpreterProxy isBytes: objectPointer)
+ and: [(interpreterProxy byteSizeOf: objectPointer) = (self sizeof: #SQFile)]) ifFalse:
- and: [(interpreterProxy byteSizeOf: objectPointer) = self bytesPerWord]) ifFalse:
[interpreterProxy primitiveFail.
^nil].
+ interpreterProxy longAt: objectPointer + interpreterProxy baseHeaderSize].
+ file := openFiles at: index.
+ "this attempts to preserve file positions across snapshots when debugging the VM
+ requires saving an image in full flight and pushing it over the cliff time after time..."
+ (file closed and: [states includesKey: file]) ifTrue:
+ [[:pos :isBinary|
+ file reopen; position: pos.
+ isBinary ifTrue:
+ [file binary]] valueWithArguments: (states at: file)].
+ ^file!
- interpreterProxy longAt: objectPointer + self baseHeaderSize].
- ^openFiles at: index!
Item was changed:
----- Method: FilePluginSimulator>>initialiseModule (in category 'initialize-release') -----
initialiseModule
"See FilePluginSimulator>>sqFileStdioHandlesInto:"
(openFiles := Dictionary new)
at: 0 put: (FakeStdinStream for: interpreterProxy interpreter); "stdin"
at: 1 put: Transcript; "stdout"
at: 2 put: Transcript. "stderr"
+ states := IdentityDictionary new.
^super initialiseModule!
Item was added:
+ ----- Method: FilePluginSimulator>>recordStateOf: (in category 'simulation') -----
+ recordStateOf: file
+ ([file position]
+ on: Error
+ do: [:ex| nil]) ifNotNil:
+ [:position|
+ states at: file put: {position. file isBinary}]!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:Read:Into:At: (in category 'simulation') -----
sqFile: file Read: count Into: byteArrayIndex At: startIndex
| interpreter |
interpreter := interpreterProxy interpreter.
+ [[startIndex to: startIndex + count - 1 do:
- startIndex to: startIndex + count - 1 do:
[ :i |
+ file atEnd ifTrue:
+ [(file isKindOf: FakeStdinStream) ifTrue: [file atEnd: false].
+ ^i - startIndex].
+ interpreter
+ byteAt: byteArrayIndex + i
+ put: file next asInteger]]
+ on: Error
+ do: [:ex|
+ (file isKindOf: TranscriptStream) ifFalse: [ex pass].
+ ^0]]
+ ensure: [self recordStateOf: file].
- file atEnd ifTrue: [^i - startIndex].
- interpreter byteAt: byteArrayIndex + i put: file next asInteger].
^count!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:SetPosition: (in category 'simulation') -----
sqFile: file SetPosition: newPosition
+ file position: newPosition.
+ self recordStateOf: file!
- file position: newPosition!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:Truncate: (in category 'simulation') -----
sqFile: file Truncate: truncatePosition
+ file truncate: truncatePosition.
+ self recordStateOf: file!
- file truncate: truncatePosition!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:Write:From:At: (in category 'simulation') -----
sqFile: file Write: count From: byteArrayIndex At: startIndex
| interpreter |
interpreter := interpreterProxy interpreter.
file isBinary
ifTrue:
[startIndex to: startIndex + count - 1 do:
[ :i | file nextPut: (interpreter byteAt: byteArrayIndex + i)]]
ifFalse:
[startIndex to: startIndex + count - 1 do:
[ :i | | byte |
byte := interpreter byteAt: byteArrayIndex + i.
file nextPut: (Character value: (byte == 12 "lf" ifTrue: [15"cr"] ifFalse: [byte]))]].
+ self recordStateOf: file.
^count!
Item was changed:
----- Method: FilePluginSimulator>>sqFileClose: (in category 'simulation') -----
sqFileClose: file
+ file close.
+ self recordStateOf: file!
- file close!
Item was removed:
- ----- Method: Interpreter>>isBigEnder (in category 'plugin support') -----
- isBigEnder
- "Answer true (non-zero) if running on a big endian machine."
- | endianness anInt cString len i |
- <var: 'cString' type: 'char *'>
- <var: 'endianness' declareC: 'static sqInt endianness = -1'>
- (endianness == -1) ifFalse: [^ endianness]. "answer cached value"
- len := self cCode: 'sizeof(anInt)'
- inSmalltalk: [^ (Smalltalk endianness == #little) not].
- cString := self cCode: '(char *) &anInt' inSmalltalk: [].
- i := 0.
- [i < len] whileTrue:
- [cString at: i put: i.
- i := i + 1].
- endianness := anInt bitAnd: 255.
- ^ endianness
- !
Item was added:
+ ----- Method: InterpreterPlugin class>>newFor: (in category 'simulation') -----
+ newFor: anUnsimulatedInterpreterPluginClass
+ "Overridden by SmartSyntaxPluginSimulator to wrap a specific plugin class."
+ ^self new!
Item was changed:
+ ----- Method: InterpreterPlugin class>>simulatorClass (in category 'simulation') -----
- ----- Method: InterpreterPlugin class>>simulatorClass (in category 'accessing') -----
simulatorClass
"For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code. By default every non-TestInterpreterPlugin can simulate itself."
^ self!
Item was changed:
----- Method: InterpreterPrimitives class>>requiredMethodNames (in category 'translation') -----
requiredMethodNames
+ "Return the list of method names that should be retained for export or other support reasons.
+ Include all of the selectors for primitives to ensure translation in slang browser."
- "return the list of method names that should be retained for export or other support reasons"
+ ^super requiredMethodNames,
+ #(floatArg: integerArg: methodArg: methodReturnValue: objectArg: primitiveMethod),
+ (self selectors select: [:e | 'primitive*' match: e])!
- ^super requiredMethodNames, #(floatArg: integerArg: methodArg: methodReturnValue: objectArg: primitiveMethod)!
Item was added:
+ ----- Method: InterpreterPrimitives>>isBigEnder (in category 'primitive support') -----
+ isBigEnder
+ "Answer true (non-zero) if running on a big endian machine."
+ | endianness anInt cString len i |
+ <var: 'cString' type: 'char *'>
+ <var: 'endianness' declareC: 'static sqInt endianness = -1'>
+ (endianness == -1) ifFalse: [^ endianness]. "answer cached value"
+ len := self cCode: 'sizeof(anInt)'
+ inSmalltalk: [^ (Smalltalk endianness == #little) not].
+ cString := self cCode: '(char *) &anInt' inSmalltalk: [].
+ i := 0.
+ [i < len] whileTrue:
+ [cString at: i put: i.
+ i := i + 1].
+ endianness := anInt bitAnd: 255.
+ ^ endianness
+ !
Item was added:
+ ----- Method: InterpreterPrimitives>>primitiveIsBigEnder (in category 'other primitives') -----
+ primitiveIsBigEnder
+ "Answer true if running on a big endian machine."
+ <export: true>
+ self isBigEnder
+ ifTrue: [self pop: 1 thenPush: objectMemory trueObject]
+ ifFalse: [self pop: 1 thenPush: objectMemory falseObject]
+ !
Item was changed:
----- Method: InterpreterPrimitives>>success: (in category 'primitive support') -----
success: successBoolean
"Set the state of the primitive failure code/success flag, iff successBoolean
is false. If primFailCode is non-zero a primitive has failed. If primFailCode
is greater than one then its value indicates the reason for failure."
"Use returnTypeC: #sqInt because that's the way it is defined in sq.h.
+ Use no explicit return so that Slang doesn't fail an inlining type-check when
- Use no explicit return so that Slang doesn't fail an inlin ingtype-check when
a primitive with return type void uses ^self success: false to exit."
<returnTypeC: #sqInt>
<inline: true>
successBoolean ifFalse:
["Don't overwrite an error code that has already been set."
self successful ifTrue:
[primFailCode := 1]]!
Item was changed:
----- Method: InterpreterProxy>>initialize (in category 'initialize') -----
initialize
- successFlag := true.
remapBuffer := OrderedCollection new.
stack := OrderedCollection new.
primFailCode := 0.
!
Item was added:
+ ----- Method: InterpreterSimulator>>interpreter (in category 'interpreter shell') -----
+ interpreter
+ ^self!
Item was added:
+ ----- Method: InterpreterSimulator>>isIntegerObject: (in category 'interpreter access') -----
+ isIntegerObject: objectPointer
+ "In simulation, an interpreter simulator serves as the interpreter proxy"
+ ^ objectMemory isIntegerObject: objectPointer!
Item was changed:
----- Method: InterpreterSimulator>>loadNewPlugin: (in category 'plugin support') -----
loadNewPlugin: pluginString
+ | plugin plugins simulatorClasses |
+ transcript cr; show: 'Looking for module ', pluginString.
+ "but *why*??"
+ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: pluginString) ifTrue:
+ [transcript show: ' ... defeated'. ^nil].
+ plugins := InterpreterPlugin allSubclasses select: [:psc| psc moduleName asString = pluginString asString].
+ simulatorClasses := (plugins
+ select: [:psc| psc simulatorClass notNil]
+ thenCollect: [:psc| psc simulatorClass]) asSet.
+ simulatorClasses isEmpty ifTrue: [transcript show: ' ... not found'. ^nil].
+ simulatorClasses size > 1 ifTrue: [^self error: 'This won''t work...'].
+ plugins size > 1 ifTrue:
+ [transcript show: '...multiple plugin classes; choosing ', plugins last name].
+ plugin := simulatorClasses anyOne newFor: plugins last. "hopefully lowest in the hierarchy..."
- | plugin simClass |
- transcript cr; show:'Looking for module ', pluginString.
- (#('FloatArrayPlugin' 'Matrix2x3Plugin')
- includes: pluginString) ifTrue:
- [transcript show: ' ... defeated'. ^ nil].
- plugin := simClass := nil.
- InterpreterPlugin allSubclassesDo:[:plg|
- plg moduleName asString = pluginString asString ifTrue:[
- simClass := plg simulatorClass.
- plugin ifNil:[plugin := simClass]
- ifNotNil:[plugin == simClass ifFalse:[^self error:'This won''t work...']].
- ].
- ].
- plugin ifNil:[transcript show: ' ... not found'. ^nil].
- plugin := plugin new.
plugin setInterpreter: self. "Ignore return value from setInterpreter"
+ (plugin respondsTo: #initialiseModule) ifTrue:
+ [plugin initialiseModule ifFalse:
+ [transcript show: ' ... initialiser failed'. ^nil]]. "module initialiser failed"
- (plugin respondsTo: #initialiseModule) ifTrue:[
- plugin initialiseModule ifFalse:[transcript show: ' ... initialiser failed'.^nil]. "module initialiser failed"
- ].
pluginList := pluginList copyWith: (pluginString asString -> plugin).
+ transcript show: ' ... loaded'.
- transcript show:' ... loaded'.
^pluginList last!
Item was changed:
----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
makeDirEntryName: entryName size: entryNameSize
createDate: createDate modDate: modifiedDate
isDir: dirFlag fileSize: fileSize
| modDateOop createDateOop nameString results |
+ <var: 'entryName' type: 'char *'>
- self var: 'entryName' type: 'char *'.
"allocate storage for results, remapping newly allocated
oops in case GC happens during allocation"
+ self pushRemappableOop:
+ (self instantiateClass: (self splObj: ClassArray) indexableSize: 5).
+ self pushRemappableOop:
+ (self instantiateClass: (self splObj: ClassByteString) indexableSize: entryNameSize).
+ self pushRemappableOop: (self positive32BitIntegerFor: createDate).
+ self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
- objectMemory pushRemappableOop:
- (objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5).
- objectMemory pushRemappableOop:
- (objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: entryNameSize)..
- objectMemory pushRemappableOop: (self positive32BitIntegerFor: createDate).
- objectMemory pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
+ modDateOop := self popRemappableOop.
+ createDateOop := self popRemappableOop.
+ nameString := self popRemappableOop.
+ results := self popRemappableOop.
- modDateOop := objectMemory popRemappableOop.
- createDateOop := objectMemory popRemappableOop.
- nameString := objectMemory popRemappableOop.
- results := objectMemory popRemappableOop.
1 to: entryNameSize do: [ :i |
+ self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
- objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
].
+ self storePointer: 0 ofObject: results withValue: nameString.
+ self storePointer: 1 ofObject: results withValue: createDateOop.
+ self storePointer: 2 ofObject: results withValue: modDateOop.
- objectMemory storePointer: 0 ofObject: results withValue: nameString.
- objectMemory storePointer: 1 ofObject: results withValue: createDateOop.
- objectMemory storePointer: 2 ofObject: results withValue: modDateOop.
dirFlag
+ ifTrue: [ self storePointer: 3 ofObject: results withValue: objectMemory trueObject ]
+ ifFalse: [ self storePointer: 3 ofObject: results withValue: objectMemory falseObject ].
+ self storePointer: 4 ofObject: results
+ withValue: (self integerObjectOf: fileSize).
- ifTrue: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getTrueObj ]
- ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getFalseObj ].
- objectMemory storePointer: 4 ofObject: results
- withValue: (objectMemory integerObjectOf: fileSize).
^ results
!
Item was added:
+ ----- Method: InterpreterSimulator>>primitiveDirectoryEntry (in category 'file primitives') -----
+ primitiveDirectoryEntry
+ | name pathName array result |
+ name := self stringOf: self stackTop.
+ pathName := self stringOf: (self stackValue: 1).
+
+ self successful ifFalse:
+ [^self primitiveFail].
+
+ array := FileDirectory default primLookupEntryIn: pathName name: name.
+ array == nil ifTrue:
+ [self pop: 3 thenPush: objectMemory nilObj.
+ ^array].
+ array == #badDirectoryPath ifTrue:
+ [self halt.
+ ^self primitiveFail].
+ array == #primFailed ifTrue:
+ [self halt.
+ ^self primitiveFail].
+
+ result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
+ createDate: (array at: 2) modDate: (array at: 3)
+ isDir: (array at: 4) fileSize: (array at: 5).
+ self pop: 3.
+ self push: result!
Item was changed:
----- Method: InterpreterSimulator>>primitiveDirectoryLookup (in category 'file primitives') -----
primitiveDirectoryLookup
| index pathName array result |
index := self stackIntegerValue: 0.
pathName := (self stringOf: (self stackValue: 1)).
self successful ifFalse: [
^self primitiveFail.
].
array := FileDirectory default primLookupEntryIn: pathName index: index.
array == nil ifTrue: [
self pop: 3.
+ self push: objectMemory nilObj.
- self push: objectMemory getNilObj.
^array.
].
array == #badDirectoryPath ifTrue: [self halt.
^self primitiveFail.
].
result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
createDate: (array at: 2) modDate: (array at: 3)
isDir: (array at: 4) fileSize: (array at: 5).
self pop: 3.
self push: result.
!
Item was changed:
----- Method: InterpreterSimulator>>writeImageFile:size:screenSize: (in category 'image save/restore') -----
writeImageFile: file size: numberOfBytesToWrite screenSize: screenSize
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize |
objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
+ headerSize := 16 * objectMemory bytesPerWord.
- headerSize := 16 * self bytesPerWord.
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
objectMemory startOfMemory.
objectMemory getSpecialObjectsOop.
objectMemory getLastHash.
screenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1 to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (objectMemory getMemory at: index)
toFile: file].
self success: true
!
Item was changed:
----- Method: InterpreterStackPages>>extraStackBytes (in category 'initialization') -----
extraStackBytes
"See initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom:
``Because stack pages grow down...''"
+ ^self cCode: 'BYTES_PER_WORD' inSmalltalk: [0]!
- ^self cCode: 'BytesPerWord' inSmalltalk: [0]!
Item was removed:
- ----- Method: NewObjectMemory>>objectRepresentationClass (in category 'cog jit support') -----
- objectRepresentationClass
- <doNotGenerate>
- ^CogObjectRepresentationForSqueakV3!
Item was changed:
InterpreterPlugin subclass: #SmartSyntaxInterpreterPlugin
+ instanceVariableNames: 'simulator'
- instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-SmartSyntaxPlugins'!
!SmartSyntaxInterpreterPlugin commentStamp: '<historical>' prior: 0!
Subclass of InterpreterPlugin, used in connection with TestCodeGenerator for named primitives with type coercion specifications!
Item was changed:
+ ----- Method: SmartSyntaxInterpreterPlugin class>>simulatorClass (in category 'simulation') -----
- ----- Method: SmartSyntaxInterpreterPlugin class>>simulatorClass (in category 'instance creation') -----
simulatorClass
"For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code.
By default SmartSyntaxInterpreterPlugin answers nil because methods in these plugins are intended to be embedded in code that pushes and pops from the stack and therefore cannot be run independently. This wrapper code is generated when translated to C. But, unfortunately, this code is missing during simulation. There was an attempt to simulate this, but only the prologue code (getting arg from the stack) is simulated (see simulatePrologInContext:). The epologue code (popping args and pushing result) is not. So I am making this nil until this can be fixed.
Also, beware that primitive methods that take no args exactly match their primitive name (faking out InterpreterSimulator>>callExternalPrimitive:). They should only be called from within wrapper code that simulates the prologue and epilogue. Primitive method that take args don't have this accidental matching problem since their names contain colons while their primitive names do not. - ajh 8/21/2002"
^ nil!
Item was added:
+ ----- Method: SmartSyntaxInterpreterPlugin>>simulator (in category 'accessing') -----
+ simulator
+ <doNotGenerate>
+ ^simulator!
Item was added:
+ ----- Method: SmartSyntaxInterpreterPlugin>>simulator: (in category 'accessing') -----
+ simulator: aSmartSyntaxPluginSimulator
+ <doNotGenerate>
+ simulator := aSmartSyntaxPluginSimulator!
Item was changed:
----- Method: SmartSyntaxPluginSimulator>>setInterpreter: (in category 'initialize') -----
setInterpreter: anInterpreterProxy
interpreterProxy := anInterpreterProxy.
actualPlugin setInterpreter: anInterpreterProxy.
+ "self computeSignatureMap" self flag: #FIXME "part of the oscog type inferencing"!
- self computeSignatureMap!
Item was changed:
----- Method: SocketPlugin>>socketRecordSize (in category 'primitives') -----
socketRecordSize
"Return the size of a Smalltalk socket record in bytes."
+ <inline: true>
+ ^ self sizeof: #SQSocket!
-
- ^ self cCode: 'sizeof(SQSocket)' inSmalltalk: [12]!
Item was changed:
----- Method: StackInterpreter>>activateNewClosureMethod:numArgs:mayContextSwitch: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: mayContextSwitch
"Similar to activateNewMethod but for Closure and newMethod."
| numCopied outerContext theMethod closureIP |
<inline: true>
outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
numCopied := self copiedValueCountOfClosure: blockClosure.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
self push: instructionPointer.
self push: framePointer.
framePointer := stackPointer.
self push: theMethod.
self push: (self encodeFrameFieldHasContext: false isBlock: true numArgs: numArgs).
self push: objectMemory nilObject. "FxThisContext field"
self push: (objectMemory fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the copied values..."
0 to: numCopied - 1 do:
[:i|
self push: (objectMemory
fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: blockClosure)].
self assert: (self frameIsBlockActivation: framePointer).
self assert: (self frameHasContext: framePointer) not.
"The initial instructions in the block nil-out remaining temps."
"the instruction pointer is a pointer variable equal to
+ method oop + ip + objectMemory baseHeaderSize
- method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
closureIP := self quickFetchInteger: ClosureStartPCIndex ofObject: blockClosure.
+ instructionPointer := theMethod + closureIP + objectMemory baseHeaderSize - 2.
- instructionPointer := theMethod + closureIP + self baseHeaderSize - 2.
self setMethod: theMethod.
"Now check for stack overflow or an event (interrupt, must scavenge, etc)"
stackPointer < stackLimit ifTrue:
[self handleStackOverflowOrEventAllowContextSwitch: mayContextSwitch]!
Item was changed:
----- Method: StackInterpreter>>arrayValueOf: (in category 'utilities') -----
arrayValueOf: arrayOop
"Return the address of first indexable field of resulting array object, or fail if
the instance variable does not contain an indexable bytes or words object."
"Note: May be called by translated primitive code."
<returnTypeC: #'void *'>
((objectMemory isNonIntegerObject: arrayOop)
and: [objectMemory isWordsOrBytes: arrayOop]) ifTrue:
+ [^self cCoerceSimple: (self pointerForOop: arrayOop + objectMemory baseHeaderSize) to: #'void *'].
- [^self cCoerceSimple: (self pointerForOop: arrayOop + self baseHeaderSize) to: #'void *'].
self primitiveFail!
Item was changed:
----- Method: StackInterpreter>>checkStackIntegrity (in category 'object memory support') -----
checkStackIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccesibleObjects has set a bit at each
object's header. Scan all objects accessible from the stack
checking that every pointer points to a header. Answer if no
dangling pointers were detected."
| ok |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP oop |
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage = stackPage
ifTrue:
[theSP := stackPointer.
theFP := framePointer]
ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP].
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + objectMemory bytesPerWord].
- [theSP := theSP + self bytesPerWord].
[[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' at: theSP; cr.
ok := false].
+ theSP := theSP + objectMemory bytesPerWord].
- theSP := theSP + self bytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' at: theFP + FoxThisContext; cr.
ok := false].
(self isContext: oop) ifFalse:
[self printFrameThing: 'frame ctxt should be context' at: theFP + FoxThisContext; cr.
ok := false]].
oop := self frameMethod: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame mthd' at: theFP + FoxMethod; cr.
ok := false].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord.
- [theSP := theFP + FoxCallerSavedIP + self bytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext "a.k.a. FoxCallerSavedIP".
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' at: theSP; cr.
ok := false].
+ theSP := theSP + objectMemory bytesPerWord]]].
- theSP := theSP + self bytesPerWord]]].
^ok!
Item was changed:
----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:copiedValues: (in category 'control primitives') -----
closureIn: context numArgs: numArgs instructionPointer: initialIP copiedValues: copiedValues
| newClosure numCopied |
<inline: true>
"numCopied should be zero for nil"
numCopied := objectMemory fetchWordLengthOf: copiedValues.
newClosure := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
- sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context.
objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
0 to: numCopied - 1 do:
[:i|
objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (objectMemory fetchPointer: i ofObject: copiedValues)].
^newClosure!
Item was changed:
----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
closureIn: context numArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
| newClosure |
<inline: true>
+ self assert: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize <= 252.
- self assert: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize <= 252.
newClosure := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
- sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context.
objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
^newClosure!
Item was changed:
----- Method: StackInterpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Note: Assumed to be inlined into the dispatch loop."
| closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage |
<var: #frameToReturnTo type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
<sharedCodeNamed: 'commonReturn' inCase: 120>
"If this is a method simply return to the sender/caller."
(self frameIsBlockActivation: localFP) ifFalse:
[^self commonCallerReturn].
"Since this is a block activation the closure is on the stack above any args and the frame."
closure := self pushedReceiverOrClosureOfFrame: localFP.
home := nil.
"Walk the closure's lexical chain to find the context or frame to return from (home)."
[closure ~~ objectMemory nilObject] whileTrue:
[home := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory fetchPointer: ClosureIndex ofObject: home].
"home is to be returned from provided there is no unwind-protect activation between
this frame and home's sender. Search for an unwind. findUnwindThroughContext:
will answer either the context for an unwind-protect activation or nilObj if the sender
cannot be found or 0 if no unwind is found but the sender is. We must update the
current page's headFrame pointers to enable the search to identify widowed contexts
correctly."
self writeBackHeadFramePointers.
unwindContextOrNilOrZero := self internalFindUnwindThroughContext: home.
unwindContextOrNilOrZero = objectMemory nilObject ifTrue:
["error: can't find home on chain; cannot return"
^self internalCannotReturn: localReturnValue].
unwindContextOrNilOrZero ~~ 0 ifTrue:
[^self internalAboutToReturn: localReturnValue through: unwindContextOrNilOrZero].
"Now we know home is on the sender chain.
We could be returning to either a context or a frame. Find out which."
contextToReturnTo := nil.
(self isMarriedOrWidowedContext: home)
ifTrue:
[self assert: (self checkIsStillMarriedContext: home currentFP: localFP).
theFP := self frameOfMarriedContext: home.
(self isBaseFrame: theFP)
ifTrue:
[contextToReturnTo := self frameCallerContext: theFP]
ifFalse:
[frameToReturnTo := self frameCallerFP: theFP]]
ifFalse:
[contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home.
((self isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
frameToReturnTo := self frameOfMarriedContext: contextToReturnTo.
contextToReturnTo := nil]].
"If returning to a context we must make a frame for it unless it is dead."
contextToReturnTo ~= nil ifTrue:
[frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo.
frameToReturnTo == 0 ifTrue:
["error: home's sender is dead; cannot return"
^self internalCannotReturn: localReturnValue]].
"Now we have a frame to return to. If it is on a different page we must free intervening pages and
nil out intervening contexts. We must free intervening stack pages because if we leave the pages
to be divorced then their contexts will be divorced with intact senders and instruction pointers. This
code is similar to primitiveTerminateTo. We must move any frames on itervening pages above the
frame linked to because these may be in use, e.g. via co-routining (see baseFrameReturn)."
self assert: stackPages pageListIsWellFormed.
newPage := stackPages stackPageFor: frameToReturnTo.
newPage ~~ stackPage ifTrue:
[| currentCtx thePage nextCntx |
currentCtx := self frameCallerContext: stackPage baseFP.
self assert: (self isContext: currentCtx).
stackPages freeStackPage: stackPage.
[self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse:
[(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
theFP ~= thePage headFP ifTrue:
["Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
self moveFramesIn: thePage through: (self findFrameAbove: theFP inPage: thePage) toPage: self newStackPage].
currentCtx := self frameCallerContext: thePage baseFP.
self freeStackPage: thePage]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]].
self setStackPageAndLimit: newPage.
localSP := stackPage headSP.
localFP := stackPage headFP].
"Two cases. Returning to the top frame on a new page or an interior frame on the current page.
The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer
in the caller frame. We need to peel back any frames on the page until we get to the correct frame."
localFP = frameToReturnTo
ifTrue: "pop the saved IP, push the return value and continue."
[localIP := self pointerForOop: self internalStackTop]
ifFalse:
[[callerFP := localFP.
localFP := self frameCallerFP: localFP.
localFP ~~ frameToReturnTo] whileTrue.
localIP := self frameCallerSavedIP: callerFP.
+ localSP := (self frameCallerSP: callerFP) - objectMemory bytesPerWord].
- localSP := (self frameCallerSP: callerFP) - self bytesPerWord].
self internalStackTopPut: localReturnValue.
self setMethod: (self frameMethod: localFP).
^self fetchNextBytecode!
Item was changed:
----- Method: StackInterpreter>>commonSend (in category 'message sending') -----
commonSend
"Send a message, starting lookup with the receiver's class."
"Assume: messageSelector and argumentCount have been set, and that
the receiver and arguments have been pushed onto the stack,"
"Note: This method is inlined into the interpreter dispatch loop."
<sharedCodeNamed: 'commonSend' inCase: 131>
+ self sendBreak: messageSelector + objectMemory baseHeaderSize
- self sendBreak: messageSelector + self baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: (self internalStackValue: argumentCount).
self internalFindNewMethod.
self internalExecuteNewMethod.
self fetchNextBytecode!
Item was changed:
----- Method: StackInterpreter>>contextInstructionPointer:frame: (in category 'frame access') -----
contextInstructionPointer: theIP frame: theFP
<var: #theFP type: #'char *'>
self assert: (self validInstructionPointer: theIP inFrame: theFP).
+ ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - objectMemory baseHeaderSize + 2!
- ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - self baseHeaderSize + 2!
Item was changed:
----- Method: StackInterpreter>>convertFloatsToPlatformOrderFrom:to: (in category 'image save/restore') -----
convertFloatsToPlatformOrderFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part.
Ensure floats are in platform-order."
| oop temp |
objectMemory vmEndianness = imageFloatsBigEndian ifTrue:
[^self].
self assert: ClassFloatCompactIndex ~= 0.
oop := startOop.
[self oop: oop isLessThan: stopAddr] whileTrue:
[(objectMemory isFreeObject: oop) ifFalse:
[(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex ifTrue:
+ [temp := self longAt: oop + objectMemory baseHeaderSize.
+ self longAt: oop + objectMemory baseHeaderSize put: (self longAt: oop + objectMemory baseHeaderSize + 4).
+ self longAt: oop + objectMemory baseHeaderSize + 4 put: temp]].
- [temp := self longAt: oop + self baseHeaderSize.
- self longAt: oop + self baseHeaderSize put: (self longAt: oop + self baseHeaderSize + 4).
- self longAt: oop + self baseHeaderSize + 4 put: temp]].
oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: StackInterpreter>>createActualMessageTo: (in category 'message sending') -----
createActualMessageTo: lookupClass
"Bundle up the selector, arguments and lookupClass into a Message object.
In the process it pops the arguments off the stack, and pushes the message object.
This can then be presented as the argument of e.g. #doesNotUnderstand:"
| argumentArray message |
<inline: false> "This is a useful break-point"
self assert: ((objectMemory isIntegerObject: messageSelector) or: [objectMemory addressCouldBeObj: messageSelector]).
argumentArray := objectMemory eeInstantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
message := objectMemory eeInstantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
"Since the array is new can use unchecked stores."
+ (argumentCount - 1) * objectMemory bytesPerWord to: 0 by: objectMemory bytesPerWord negated do:
- (argumentCount - 1) * self bytesPerWord to: 0 by: self bytesPerWord negated do:
[:i|
+ self longAt: argumentArray + objectMemory baseHeaderSize + i put: self popStack].
- self longAt: argumentArray + self baseHeaderSize + i put: self popStack].
"Since message is new can use unchecked stores."
objectMemory storePointerUnchecked: MessageSelectorIndex ofObject: message withValue: messageSelector.
objectMemory storePointerUnchecked: MessageArgumentsIndex ofObject: message withValue: argumentArray.
objectMemory storePointerUnchecked: MessageLookupClassIndex ofObject: message withValue: lookupClass.
self push: message.
argumentCount := 1.!
Item was changed:
----- Method: StackInterpreter>>dbgFloatValueOf: (in category 'utilities') -----
dbgFloatValueOf: oop
"This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh."
| result |
<returnTypeC: #double>
<var: #result type: #double>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
((objectMemory isNonIntegerObject: oop)
and: [(objectMemory fetchClassOfNonInt: oop) = (objectMemory splObj: ClassFloat)]) ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result.
- objectMemory fetchFloatAt: oop + self baseHeaderSize into: result.
^result].
^nil!
Item was changed:
----- Method: StackInterpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') -----
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
displayObj := objectMemory splObj: TheDisplay.
aForm = displayObj ifFalse: [^ nil].
self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]).
self successful ifTrue: [
dispBits := objectMemory fetchPointer: 0 ofObject: displayObj.
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
d := self fetchInteger: 3 ofObject: displayObj.
].
l < 0 ifTrue:[left := 0] ifFalse: [left := l].
r > w ifTrue: [right := w] ifFalse: [right := r].
t < 0 ifTrue: [top := 0] ifFalse: [top := t].
b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
((left <= right) and: [top <= bottom]) ifFalse: [^nil].
self successful ifTrue: [
(objectMemory isIntegerObject: dispBits) ifTrue: [
surfaceHandle := objectMemory integerValueOf: dispBits.
showSurfaceFn = 0 ifTrue: [
showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
showSurfaceFn = 0 ifTrue: [^self success: false]].
self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
] ifFalse: [
+ dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array"
- dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array"
self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
inSmalltalk: [self showDisplayBits: dispBitsIndex
w: w h: h d: d
left: left right: right top: top bottom: bottom]
].
]!
Item was changed:
----- Method: StackInterpreter>>divorceFramesIn: (in category 'frame access') -----
divorceFramesIn: aStackPage
| theFP calleeFP theSP theIP calleeContext theContext |
<inline: false>
<var: #aStackPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #calleeFP type: #'char *'>
<var: #theSP type: #'char *'>
statStackPageDivorce := statStackPageDivorce + 1.
theFP := aStackPage headFP.
theSP := aStackPage headSP.
theIP := stackPages longAt: theSP.
+ theSP := theSP + objectMemory bytesPerWord. "theSP points at hottest item on frame's stack"
- theSP := theSP + self bytesPerWord. "theSP points at hottest item on frame's stack"
calleeContext := nil.
[theContext := self ensureFrameIsMarried: theFP SP: theSP.
self updateStateOfSpouseContextForFrame: theFP WithSP: theSP.
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self contextInstructionPointer: theIP frame: theFP).
self assert: (self frameReceiver: theFP)
= (objectMemory fetchPointer: ReceiverIndex ofObject: theContext).
calleeContext ~~ nil ifTrue:
[objectMemory storePointer: SenderIndex
ofObject: calleeContext
withValue: theContext].
calleeContext := theContext.
calleeFP := theFP.
theIP := (self frameCallerSavedIP: theFP) asInteger.
theFP := self frameCallerFP: theFP.
theFP ~= 0] whileTrue:
["theSP points at stacked hottest item on frame's stack"
theSP := self frameCallerSP: calleeFP].
objectMemory storePointer: SenderIndex
ofObject: theContext
withValue: (self frameCallerContext: calleeFP).
"The page is now free; mark it so."
aStackPage baseFP: 0!
Item was changed:
----- Method: StackInterpreter>>encodeFrameFieldHasContext:isBlock:numArgs: (in category 'frame access') -----
encodeFrameFieldHasContext: hasContext "<Boolean>" isBlock: isBlock "<Boolean>" numArgs: numArgs
"For ``fast'' temporary access (ok, to mitigate slower temp access) we need
fast access to a method's numArgs. Could have a variable set on save and return.
We'll investigate this. For the moment we just use a byte in the frameFlags
field. This is endian dependent. Store numArgs in byte at FoxFrameFields + 1.
Store hasContext flag in top bit (allows for 64-bit tags) of byte at FoxFrameFields.
Make frameFields look like a SmallInteger for the benefit of gc (dubious)."
"bitsPerWord := BytesPerWord * 8"
<inline: true>
^VMBIGENDIAN
ifTrue: [1
+ + (numArgs << ((objectMemory bytesPerWord * 8) - 8))
+ + (hasContext ifTrue: [1 << ((objectMemory bytesPerWord * 8) - 16)] ifFalse: [0])
+ + (isBlock ifTrue: [1 << ((objectMemory bytesPerWord * 8) - 24)] ifFalse: [0])]
- + (numArgs << ((self bytesPerWord * 8) - 8))
- + (hasContext ifTrue: [1 << ((self bytesPerWord * 8) - 16)] ifFalse: [0])
- + (isBlock ifTrue: [1 << ((self bytesPerWord * 8) - 24)] ifFalse: [0])]
ifFalse: [1
+ (numArgs << 8)
+ (hasContext ifTrue: [1 << 16] ifFalse: [0])
+ (isBlock ifTrue: [1 << 24] ifFalse: [0])]!
Item was changed:
----- Method: StackInterpreter>>externalDivorceFrame:andContext: (in category 'frame access') -----
externalDivorceFrame: theFP andContext: ctxt
"Divorce a single frame and its context. If it is not the top frame of a stack this means splitting its stack."
| thePage onCurrent theSP callerCtx newPage frameAbove callerFP callerSP callerIP theIP |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #callerSP type: #'char *'>
"stackPage needs to have current head pointers to avoid confusion."
self assert: theFP ~= framePointer.
self assert: (stackPage = 0 or: [stackPage = stackPages mostRecentlyUsedPage]).
thePage := stackPages stackPageFor: theFP.
(onCurrent := thePage = stackPage) ifFalse:
[stackPages markStackPageNextMostRecentlyUsed: thePage].
theSP := self findSPOf: theFP on: thePage.
self updateStateOfSpouseContextForFrame: theFP WithSP: theSP.
callerCtx := self ensureCallerContext: theFP.
(frameAbove := self findFrameAbove: theFP inPage: thePage) == 0
ifTrue: "If we're divorcing the top frame we can simply peel it off."
[theIP := stackPages longAt: thePage headSP]
ifFalse: "othewise move all frames above to a new stack and then peel the frame off."
[newPage := self newStackPage.
theIP := self oopForPointer: (self frameCallerSavedIP: frameAbove).
frameAbove := self moveFramesIn: thePage through: frameAbove toPage: newPage.
onCurrent
ifTrue:
[self setStackPageAndLimit: newPage.
framePointer := stackPage headFP.
stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: newPage].
self assert: (self frameCallerContext: frameAbove) = ctxt].
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: ctxt
withValue: (self contextInstructionPointer: theIP frame: theFP).
objectMemory storePointer: SenderIndex
ofObject: ctxt
withValue: callerCtx.
callerFP := self frameCallerFP: theFP.
callerFP == 0 "theFP is a base frame; it is now alone; free the entire page"
ifTrue: [stackPages freeStackPage: thePage]
ifFalse:
[callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
+ callerSP := (self frameCallerSP: theFP) - objectMemory bytesPerWord.
- callerSP := (self frameCallerSP: theFP) - self bytesPerWord.
stackPages longAt: callerSP put: callerIP.
self setHeadFP: callerFP andSP: callerSP inPage: thePage]
!
Item was changed:
----- Method: StackInterpreter>>findSPOrNilOf:on:startingFrom: (in category 'frame access') -----
findSPOrNilOf: theFP on: thePage startingFrom: startFrame
"Search for the stack pointer for theFP. This points to the hottest item on the frame's stack.
DO NOT CALL THIS WITH theFP == localFP OR theFP == framePointer!!"
<var: #aFrame type: #'char *'>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<returnTypeC: #'char *'>
| aFrame theSP |
<inline: true>
<asmLabel: false>
<var: #startFrame type: #'char *'>
<var: #theSP type: #'char *'>
self assert: (stackPages isFree: thePage) not.
aFrame := startFrame.
theSP := thePage headSP.
aFrame = theFP ifTrue:
[theSP >= aFrame ifTrue:
["If the SP is invalid return the pointer to the receiver field."
^self frameReceiverOffset: aFrame].
"Skip the instruction pointer on top of stack of inactive pages."
^thePage = stackPage
ifTrue: [theSP]
+ ifFalse: [theSP + objectMemory bytesPerWord]].
- ifFalse: [theSP + self bytesPerWord]].
[theSP := self frameCallerSP: aFrame.
aFrame := self frameCallerFP: aFrame.
aFrame ~= 0] whileTrue:
[theFP = aFrame ifTrue:
[^theSP]].
^nil!
Item was changed:
----- Method: StackInterpreter>>floatObjectOf: (in category 'object format') -----
floatObjectOf: aFloat
| newFloatObj |
<inline: false>
<var: #aFloat type: #double>
self flag: #Dan.
+ newFloatObj := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + objectMemory baseHeaderSize.
+ objectMemory storeFloatAt: newFloatObj + objectMemory baseHeaderSize from: aFloat.
- newFloatObj := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize.
- objectMemory storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
^ newFloatObj.
!
Item was changed:
----- Method: StackInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
"Note: May be called by translated primitive code."
| result |
<returnTypeC: #double>
<var: #result type: #double>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
(because assertClassOf:is:compactClassIndex: has an inline: pragma) the
phrase (self splObj: ClassArray) is expanded in-place and is _not_
evaluated if ClassArrayCompactIndex is non-zero."
self assertClassOf: oop
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result.
- objectMemory fetchFloatAt: oop + self baseHeaderSize into: result.
^result].
^0.0!
Item was changed:
----- Method: StackInterpreter>>frameCallerSP: (in category 'frame access') -----
frameCallerSP: theFP
"Answer the SP of the caller provided theFP is not a base frame.
This points to the hottest item on the caller frame's stack."
<var: #theFP type: #'char *'>
<returnTypeC: 'char *'>
<asmLabel: false>
self assert: (self isBaseFrame: theFP) not.
+ ^theFP + (self frameStackedReceiverOffset: theFP) + objectMemory bytesPerWord!
- ^theFP + (self frameStackedReceiverOffset: theFP) + self bytesPerWord!
Item was changed:
----- Method: StackInterpreter>>frameCallerStackPointer: (in category 'frame access') -----
frameCallerStackPointer: theFP
"Answer the stack pointer of the caller frame."
<var: #theFP type: #'char *'>
<returnTypeC: #'char *'>
<inline: true>
<asmLabel: false>
self assert: (self isBaseFrame: theFP) not.
+ ^theFP + (self frameStackedReceiverOffset: theFP) + objectMemory bytesPerWord!
- ^theFP + (self frameStackedReceiverOffset: theFP) + self bytesPerWord!
Item was changed:
----- Method: StackInterpreter>>frameInstructionPointerForContext:method: (in category 'frame access') -----
frameInstructionPointerForContext: aContext method: aMethod
"Answer the instruction pointer for usage in a frame (a pointer to a bytecode)
from the index instructionPointer in the given context."
^aMethod
+ (self quickFetchInteger: InstructionPointerIndex ofObject: aContext)
+ + objectMemory baseHeaderSize
- + self baseHeaderSize
- 2!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiver:numArgs: (in category 'frame access') -----
frameStackedReceiver: theFP numArgs: numArgs
"Answer the stacked receiver given the frame's argument count.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
+ ^stackPages longAt: theFP + FoxCallerSavedIP + objectMemory bytesPerWord + (numArgs << self shiftForWord)!
- ^stackPages longAt: theFP + FoxCallerSavedIP + self bytesPerWord + (numArgs << self shiftForWord)!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiverOffset: (in category 'frame access') -----
frameStackedReceiverOffset: theFP
"Answer the offset in bytes from the a frame pointer to its stacked receiver.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
+ ^FoxCallerSavedIP + objectMemory bytesPerWord + ((self frameNumArgs: theFP) << self shiftForWord)!
- ^FoxCallerSavedIP + self bytesPerWord + ((self frameNumArgs: theFP) << self shiftForWord)!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiverOffset:numArgs: (in category 'frame access') -----
frameStackedReceiverOffset: theFP numArgs: numArgs
"Answer the offset in bytes from the a frame pointer to its stacked receiver.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
+ ^FoxCallerSavedIP + objectMemory bytesPerWord + (numArgs << self shiftForWord)!
- ^FoxCallerSavedIP + self bytesPerWord + (numArgs << self shiftForWord)!
Item was changed:
----- Method: StackInterpreter>>getErrorObjectFromPrimFailCode (in category 'message sending') -----
getErrorObjectFromPrimFailCode
"Answer the errorCode object to supply to a failing primitive method that accepts one.
If there is a primitive error table and the primFailCode is a valid index there-in answer
the coprresponding entry in the table, otherwise simply answer the code as an integer."
| table |
primFailCode > 0 ifTrue:
[table := objectMemory splObj: PrimErrTableIndex.
+ primFailCode <= ((objectMemory lastPointerOf: table) // objectMemory bytesPerWord) ifTrue:
- primFailCode <= ((objectMemory lastPointerOf: table) // self bytesPerWord) ifTrue:
[^objectMemory fetchPointer: primFailCode - 1 ofObject: table]].
^objectMemory integerObjectOf: primFailCode!
Item was changed:
----- Method: StackInterpreter>>highBit: (in category 'stack pages') -----
highBit: anUnsignedValue
"This is a C implementation needed by stackPageByteSize when translated."
| shifted bitNo |
<var: #anUnsignedValue type: #usqInt>
<var: #shifted type: #usqInt>
shifted := anUnsignedValue.
bitNo := 0.
+ self cppIf: [objectMemory bytesPerWord > 4]
- self cppIf: [self bytesPerWord > 4]
ifTrue:
[shifted < (1 << 32) ifFalse:
[shifted := shifted >> 32.
bitNo := bitNo + 32]].
shifted < (1 << 16) ifFalse:
[shifted := shifted >> 16.
bitNo := bitNo + 16].
shifted < (1 << 8) ifFalse:
[shifted := shifted >> 8.
bitNo := bitNo + 8].
shifted < (1 << 4) ifFalse:
[shifted := shifted >> 4.
bitNo := bitNo + 4].
shifted < (1 << 2) ifFalse:
[shifted := shifted >> 2.
bitNo := bitNo + 2].
shifted < (1 << 1) ifFalse:
[shifted := shifted >> 1.
bitNo := bitNo + 1].
"shifted 0 or 1 now"
^bitNo + shifted!
Item was changed:
----- Method: StackInterpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') -----
imageFormatCompatibilityVersion
"This VM is backward-compatible with the immediately preceeding version."
+ ^objectMemory bytesPerWord == 4 ifTrue: [6504] ifFalse: [68002]!
- ^self bytesPerWord == 4 ifTrue: [6504] ifFalse: [68002]!
Item was changed:
----- Method: StackInterpreter>>imageFormatVersion (in category 'image save/restore') -----
imageFormatVersion
"Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."
+ ^objectMemory bytesPerWord == 4 ifTrue: [6505] ifFalse: [68003]!
- ^self bytesPerWord == 4 ifTrue: [6505] ifFalse: [68003]!
Item was changed:
----- Method: StackInterpreter>>initStackPages (in category 'initialization') -----
initStackPages
"Initialize the stackPages. This version is only for simulation
because Slang refuses to inline it, which makes the alloca invalid."
| stackPageBytes stackPagesBytes theStackMemory |
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: 'alloca(stackPagesBytes)'
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / objectMemory bytesPerWord
+ pageSize: stackPageBytes / objectMemory bytesPerWord
- numSlots: stackPagesBytes / self bytesPerWord
- pageSize: stackPageBytes / self bytesPerWord
stackLimitOffset: self stackLimitOffset
stackPageHeadroom: self stackPageHeadroom!
Item was changed:
----- Method: StackInterpreter>>initStackPagesAndInterpret (in category 'initialization') -----
initStackPagesAndInterpret
"Initialize the stack pages and enter interpret. Use alloca'ed memory so that when
we have a JIT its stack pointer will be on the native stack since alloca allocates
memory on the stack. Certain thread systems use the native stack pointer as the
frame ID so putting the stack anywhere else can confuse the thread system."
"This should be in its own initStackPages method but Slang can't inline
C code strings."
| stackPageBytes stackPagesBytes theStackMemory |
<var: #theStackMemory type: #'void *'>
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: 'alloca(stackPagesBytes)'
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / objectMemory bytesPerWord
+ pageSize: stackPageBytes / objectMemory bytesPerWord
- numSlots: stackPagesBytes / self bytesPerWord
- pageSize: stackPageBytes / self bytesPerWord
stackLimitOffset: self stackLimitOffset
stackPageHeadroom: self stackPageHeadroom.
"Once the stack pages are initialized we can continue to bootstrap the system."
self loadInitialContext.
"We're ready for the heartbeat (poll interrupt)"
self ioInitHeartbeat.
self interpret.
^nil!
Item was changed:
----- Method: StackInterpreter>>initialPCForHeader:method: (in category 'compiled methods') -----
initialPCForHeader: methodHeader method: theMethod
+ ^theMethod + ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + objectMemory baseHeaderSize!
- ^theMethod + ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + self baseHeaderSize!
Item was changed:
----- Method: StackInterpreter>>internalPop: (in category 'internal interpreter access') -----
internalPop: nItems
"In the StackInterpreter stacks grow down."
+ localSP := localSP + (nItems * objectMemory bytesPerWord)!
- localSP := localSP + (nItems * self bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>internalPop:thenPush: (in category 'internal interpreter access') -----
internalPop: nItems thenPush: oop
"In the StackInterpreter stacks grow down."
+ stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * objectMemory bytesPerWord)) put: oop!
- stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * self bytesPerWord)) put: oop!
Item was changed:
----- Method: StackInterpreter>>internalPopStack (in category 'internal interpreter access') -----
internalPopStack
"In the StackInterpreter stacks grow down."
| top |
top := stackPages longAt: localSP.
+ localSP := localSP + objectMemory bytesPerWord.
- localSP := localSP + self bytesPerWord.
^top!
Item was changed:
----- Method: StackInterpreter>>internalPush: (in category 'internal interpreter access') -----
internalPush: object
"In the StackInterpreter stacks grow down."
+ stackPages longAtPointer: (localSP := localSP - objectMemory bytesPerWord) put: object!
- stackPages longAtPointer: (localSP := localSP - self bytesPerWord) put: object!
Item was changed:
----- Method: StackInterpreter>>internalStackValue: (in category 'internal interpreter access') -----
internalStackValue: offset
"In the StackInterpreter stacks grow down."
+ ^stackPages longAtPointer: localSP + (offset * objectMemory bytesPerWord)!
- ^stackPages longAtPointer: localSP + (offset * self bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>interpreterAllocationReserveBytes (in category 'stack pages') -----
interpreterAllocationReserveBytes
"At a rough approximation we may need to allocate up to a couple
of page's worth of contexts when switching stack pages, assigning
to senders, etc. But the snapshot primitive voids all stack pages.
So a safe margin is the size of a large context times the maximum
number of frames per page times the number of pages."
| availableBytesPerPage maxFramesPerPage |
availableBytesPerPage := self stackPageByteSize - self stackLimitOffset - self stackPageHeadroom.
+ maxFramesPerPage := availableBytesPerPage / objectMemory bytesPerWord // FrameSlots.
- maxFramesPerPage := availableBytesPerPage / self bytesPerWord // FrameSlots.
^2 raisedTo: (maxFramesPerPage * LargeContextSize * numStackPages) highBit!
Item was changed:
----- Method: StackInterpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
If it is a Float, then load its value and return it.
Otherwise fail -- ie return with primErrorCode non-zero."
| result |
<inline: true>
<asmLabel: false>
<returnTypeC: #double>
<var: #result type: #double>
(objectMemory isIntegerObject: floatOrInt) ifTrue:
[^(objectMemory integerValueOf: floatOrInt) asFloat].
self assertClassOf: floatOrInt
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self cCode: '' inSmalltalk: [result := Float new: 2].
self successful ifTrue:
+ [objectMemory fetchFloatAt: floatOrInt + objectMemory baseHeaderSize into: result].
- [objectMemory fetchFloatAt: floatOrInt + self baseHeaderSize into: result].
^result!
Item was changed:
----- Method: StackInterpreter>>lookupMethodInClass: (in category 'message sending') -----
lookupMethodInClass: class
| currentClass dictionary found |
<inline: false>
self assert: class ~~ objectMemory nilObject.
currentClass := class.
[currentClass ~= objectMemory nilObject]
whileTrue:
[dictionary := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currentClass.
dictionary = objectMemory nilObject ifTrue:
["MethodDict pointer is nil (hopefully due a swapped out stub)
-- raise exception #cannotInterpret:."
self createActualMessageTo: class.
messageSelector := objectMemory splObj: SelectorCannotInterpret.
+ self sendBreak: messageSelector + objectMemory baseHeaderSize
- self sendBreak: messageSelector + self baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: nil.
^self lookupMethodInClass: (self superclassOf: currentClass)].
found := self lookupMethodInDictionary: dictionary.
found ifTrue: [^currentClass].
currentClass := self superclassOf: currentClass].
"Could not find #doesNotUnderstand: -- unrecoverable error."
messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
[self error: 'Recursive not understood error encountered'].
"Cound not find a normal message -- raise exception #doesNotUnderstand:"
self createActualMessageTo: class.
messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
+ self sendBreak: messageSelector + objectMemory baseHeaderSize
- self sendBreak: messageSelector + self baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: nil.
^self lookupMethodInClass: class!
Item was changed:
----- Method: StackInterpreter>>makeBaseFrameFor: (in category 'frame access') -----
makeBaseFrameFor: aContext "<Integer>"
"Marry aContext with the base frame of a new stack page. Build
the base frame to reflect the context's state. Answer the new page."
| page pointer theMethod numArgs stackPtrIndex maybeClosure |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
<returnTypeC: 'StackPage *'>
self assert: (self isSingleContext: aContext).
page := self newStackPage.
pointer := page baseAddress.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext.
"If the frame is a closure activation then the closure should be on the stack in
the pushed receiver position (closures receiver the value[:value:] messages).
Otherwise it should be the receiver proper."
maybeClosure := (objectMemory fetchPointer: ClosureIndex ofObject: aContext).
maybeClosure ~= objectMemory nilObject
ifTrue: [numArgs := self argumentCountOfClosure: maybeClosure.
stackPages longAt: pointer put: maybeClosure]
ifFalse:
[numArgs := self argumentCountOf: theMethod.
stackPages longAt: pointer put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is sender context in base frame"
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"base frame's saved fp is null"
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: 0.
page baseFP: pointer; headFP: pointer.
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: theMethod.
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: aContext.
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext).
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"last thing on stack is the instruction pointer"
(objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)) ifFalse:
[self error: 'context is not resumable'].
stackPages
+ longAt: (pointer := pointer - objectMemory bytesPerWord)
- longAt: (pointer := pointer - self bytesPerWord)
put: (self frameInstructionPointerForContext: aContext method: theMethod).
self assert: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)
= (self contextInstructionPointer: (stackPages longAt: pointer) frame: page baseFP).
page headSP: pointer.
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity)"
objectMemory storePointerUnchecked: SenderIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: page baseFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: 0).
self assert: (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)).
self assert: (self frameOfMarriedContext: aContext) = page baseFP.
^page!
Item was changed:
----- Method: StackInterpreter>>makePointwithxValue:yValue: (in category 'utilities') -----
makePointwithxValue: xValue yValue: yValue
"make a Point xValue@yValue.
We know both will be integers so no value nor root checking is needed"
| pointResult |
+ pointResult := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * objectMemory bytesPerWord.
- pointResult := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord.
objectMemory storePointerUnchecked: XIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: xValue).
objectMemory storePointerUnchecked: YIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: yValue).
^ pointResult!
Item was changed:
----- Method: StackInterpreter>>mapStackPages (in category 'object memory support') -----
mapStackPages
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #'char *'>
"Need to write back the frame pointers unless all pages are free (as in snapshot)"
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP theIPPtr theIP oop |
thePage := stackPages stackPageAt: i.
thePage isFree ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage
ifTrue: [theIPPtr := 0]
ifFalse:
[theIPPtr := theSP.
+ theSP := theSP + objectMemory bytesPerWord].
- theSP := theSP + self bytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (thePage addressIsInPage: theSP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theFP]).
[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[stackPages longAt: theSP put: (objectMemory remap: oop)].
+ theSP := theSP + objectMemory bytesPerWord].
- theSP := theSP + self bytesPerWord].
(self frameHasContext: theFP) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory remap: (self frameContext: theFP))].
theIPPtr ~= 0 ifTrue:
[self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
stackPages
longAt: theFP + FoxMethod
put: (objectMemory remap: (self frameMethod: theFP)).
theIPPtr ~= 0 ifTrue:
[stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory bytesPerWord.
- [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + self bytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext. "a.k.a. FoxCallerSavedIP"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[stackPages longAt: theSP put: (objectMemory remap: oop)].
+ theSP := theSP + objectMemory bytesPerWord]]]!
- theSP := theSP + self bytesPerWord]]]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + objectMemory bytesPerWord].
- [theSP := theSP + self bytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + objectMemory bytesPerWord].
- theSP := theSP + self bytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (self isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord.
- [theSP := theFP + FoxCallerSavedIP + self bytesPerWord.
theFP := callerFP].
theSP := self isCog
+ ifTrue: [theFP + FoxCallerSavedIP + objectMemory bytesPerWord] "caller ip is ceBaseReturnPC"
- ifTrue: [theFP + FoxCallerSavedIP + self bytesPerWord] "caller ip is ceBaseReturnPC"
ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + objectMemory bytesPerWord]!
- theSP := theSP + self bytesPerWord]!
Item was changed:
----- Method: StackInterpreter>>marriedContext:pointsTo:stackDeltaForCurrentFrame: (in category 'frame access') -----
marriedContext: spouseContext pointsTo: anOop stackDeltaForCurrentFrame: stackDeltaForCurrentFrame
"This is a helper for primitiveObjectPointsTo so it *does not* check the frameContext field because that is an implicit self-reference not present in the stale ."
| theFP thePage theSP rcvrOffset |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #rcvrOffset type: #'char *'>
theFP := self frameOfMarriedContext: spouseContext.
theFP = framePointer
+ ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * objectMemory bytesPerWord)]
- ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * self bytesPerWord)]
ifFalse:
[thePage := stackPages stackPageFor: theFP.
theSP := self findSPOf: theFP on: thePage].
(objectMemory isIntegerObject: anOop)
ifTrue: "Check stack and instruction pointer fields."
[(anOop = (objectMemory integerObjectOf: (self stackPointerIndexForFrame: theFP WithSP: theSP))
or: [anOop = (self externalInstVar: InstructionPointerIndex ofContext: spouseContext)]) ifTrue:
[^true]]
ifFalse: "Check method and sender fields, avoiding unnecessarily reifying sender context."
[anOop = (self frameMethodObject: theFP) ifTrue:
[^true].
(self isBaseFrame: theFP)
ifTrue: [anOop = (self frameCallerContext: theFP) ifTrue:
[^true]]
ifFalse: [((self frameHasContext: (self frameCallerFP: theFP))
and: [anOop = (self frameContext: (self frameCallerFP: theFP))]) ifTrue:
[^true]]].
"Now check receiver, temps and stack contents"
rcvrOffset := self frameReceiverOffset: theFP.
[theSP <= rcvrOffset] whileTrue:
[anOop = (stackPages longAt: theSP) ifTrue:
[^true].
+ theSP := theSP + objectMemory bytesPerWord].
- theSP := theSP + self bytesPerWord].
"Finally check stacked receiver (closure field or duplicate of receiver) and arguments"
+ theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord.
- theSP := theFP + FoxCallerSavedIP + self bytesPerWord.
rcvrOffset := theFP + (self frameStackedReceiverOffset: theFP).
[theSP <= rcvrOffset] whileTrue:
[anOop = (stackPages longAt: theSP) ifTrue:
[^true].
+ theSP := theSP + objectMemory bytesPerWord].
- theSP := theSP + self bytesPerWord].
^false!
Item was changed:
----- Method: StackInterpreter>>marryFrame:SP: (in category 'frame access') -----
marryFrame: theFP SP: theSP
"Marry an unmarried frame. This means creating a spouse context
initialized with a subset of the frame's state (state through the last argument)
that references the frame."
| theContext methodHeader byteSize numArgs numStack closureOrNil |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
self assert: (self frameHasContext: theFP) not.
methodHeader := self headerOf: (self frameMethod: theFP).
"Decide how much of the stack to preserve in widowed contexts. Preserving too much
state will potentially hold onto garbage. Holding onto too little may mean that a dead
context isn't informative enough in a debugging situation. We compromise, retaining
only the arguments with no temporaries. Note that we still set the stack pointer to its
current value, but stack contents other than the arguments are nil."
numArgs := self frameNumArgs: theFP.
numStack := self stackPointerIndexForFrame: theFP WithSP: theSP.
closureOrNil := (self frameIsBlockActivation: theFP)
ifTrue: [self pushedReceiverOrClosureOfFrame: theFP]
ifFalse: [objectMemory nilObject].
byteSize := (methodHeader bitAnd: LargeContextBit) ~= 0
ifTrue: [LargeContextSize]
ifFalse: [SmallContextSize].
theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize.
+ self assert: numStack + ReceiverIndex << self shiftForWord + objectMemory baseHeaderSize <= byteSize.
- self assert: numStack + ReceiverIndex << self shiftForWord + self baseHeaderSize <= byteSize.
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity)"
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: theFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: numStack).
objectMemory storePointerUnchecked: MethodIndex
ofObject: theContext
withValue: (self frameMethod: theFP).
objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil.
objectMemory storePointerUnchecked: ReceiverIndex
ofObject: theContext
withValue: (self frameReceiver: theFP).
"Store just the arguments. If the frame is divorced the context
will have valid arguments but all temporaries will be nil."
1 to: numArgs do:
[:i|
objectMemory storePointerUnchecked: ReceiverIndex + i
ofObject: theContext "inline self temporary: i - 1 in:theFP"
withValue: (stackPages longAt: theFP
+ FoxCallerSavedIP
+ + ((numArgs - i + 1) * objectMemory bytesPerWord))].
- + ((numArgs - i + 1) * self bytesPerWord))].
numArgs + 1 to: numStack do:
[:i|
objectMemory storePointerUnchecked: ReceiverIndex + i
ofObject: theContext
withValue: objectMemory nilObject].
stackPages longAt: theFP + FoxThisContext put: theContext.
stackPages byteAt: theFP + FoxFrameFlags + 2 put: 1.
self assert: (self frameHasContext: theFP).
self assert: (self frameOfMarriedContext: theContext) = theFP.
self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext).
^theContext
!
Item was changed:
----- Method: StackInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') -----
moveFramesIn: oldPage through: theFP toPage: newPage
"Move frames from the hot end of oldPage through to theFP to newPage.
This has the effect of making theFP a base frame which can be stored into.
Answer theFP's new location."
| newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext |
<inline: false>
<var: #oldPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #newSP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #fpInNewPage type: #'char *'>
<var: #offsetCallerFP type: #'char *'>
<var: #source type: #'char *'>
<returnTypeC: 'char *'>
+ newSP := newPage baseAddress + objectMemory bytesPerWord.
- newSP := newPage baseAddress + self bytesPerWord.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
+ by: objectMemory bytesPerWord negated
- by: self bytesPerWord negated
do: [:source|
+ newSP := newSP - objectMemory bytesPerWord.
- newSP := newSP - self bytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
newFP := newPage baseAddress - stackedReceiverOffset.
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
newPage baseFP: newFP.
callerFP := self frameCallerFP: theFP.
self assert: (self isBaseFrame: theFP) not.
self assert: (self frameHasContext: callerFP).
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
oldPage
headFP: callerFP;
headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page (FoxCallerContext a.k.a. FoxCallerSavedIP)"
stackPages longAt: newFP + FoxCallerContext put: (self frameContext: callerFP).
stackPages longAt: newFP + FoxSavedFP put: 0.
"Now relocate frame pointers, updating married contexts to refer to their moved spouse frames."
fpInNewPage := newPage headFP.
[offsetCallerFP := self frameCallerFP: fpInNewPage.
offsetCallerFP ~= 0 ifTrue:
[offsetCallerFP := offsetCallerFP + delta].
stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP).
(self frameHasContext: fpInNewPage) ifTrue:
[theContext := self frameContext: fpInNewPage.
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: fpInNewPage).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: offsetCallerFP)].
fpInNewPage := offsetCallerFP.
fpInNewPage ~= 0] whileTrue.
^newFP!
Item was changed:
----- Method: StackInterpreter>>pop: (in category 'internal interpreter access') -----
pop: nItems
<inline: true>
"In the StackInterpreter stacks grow down."
+ stackPointer := stackPointer + (nItems * objectMemory bytesPerWord).
- stackPointer := stackPointer + (nItems * self bytesPerWord).
^nil!
Item was changed:
----- Method: StackInterpreter>>pop:thenPush: (in category 'internal interpreter access') -----
pop: nItems thenPush: oop
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
+ stackPages longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
- stackPages longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord)) put: oop.
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pop:thenPushBool: (in category 'internal interpreter access') -----
pop: nItems thenPushBool: trueOrFalse
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
stackPages
+ longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord))
- longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord))
put: (trueOrFalse ifTrue: [objectMemory trueObject] ifFalse: [objectMemory falseObject]).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pop:thenPushFloat: (in category 'internal interpreter access') -----
pop: nItems thenPushFloat: f
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #f type: #double>
<var: #sp type: #'char *'>
stackPages
+ longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord))
- longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord))
put: (self floatObjectOf: f).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pop:thenPushInteger: (in category 'internal interpreter access') -----
pop: nItems thenPushInteger: integerVal
"lots of places pop a few items off the stack and then push an integer. Make it convenient.
In the StackInterpreter stacks grow down."
| sp |
<var: #sp type: #'char *'>
stackPages
+ longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord))
- longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord))
put: (objectMemory integerObjectOf: integerVal).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>popFloat (in category 'stack bytecodes') -----
popFloat
"Note: May be called by translated primitive code."
| top result |
<returnTypeC: #double>
<var: #result type: #double>
top := self popStack.
"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
(because assertClassOf:is:compactClassIndex: has an inline: pragma) the
phrase (self splObj: ClassArray) is expanded in-place and is _not_
evaluated if ClassArrayCompactIndex is non-zero."
self assertClassOf: top
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: top + objectMemory baseHeaderSize into: result].
- objectMemory fetchFloatAt: top + self baseHeaderSize into: result].
^ result!
Item was changed:
----- Method: StackInterpreter>>popStack (in category 'internal interpreter access') -----
popStack
"In the StackInterpreter stacks grow down."
| top |
<inline: true>
top := stackPages longAt: stackPointer.
+ stackPointer := stackPointer + objectMemory bytesPerWord.
- stackPointer := stackPointer + self bytesPerWord.
^top!
Item was changed:
----- Method: StackInterpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
positive32BitIntegerFor: integerValue
| newLargeInteger |
"Note - integerValue is interpreted as POSITIVE, eg, as the result of
Bitmap>at:, or integer>bitAnd:."
integerValue >= 0
ifTrue: [(objectMemory isIntegerValue: integerValue)
ifTrue: [^ objectMemory integerObjectOf: integerValue]].
+ self cppIf: objectMemory bytesPerWord = 4
- self cppIf: self bytesPerWord = 4
ifTrue: "Faster instantiateSmallClass: currently only works with integral word size."
[newLargeInteger := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassLargePositiveInteger)
+ sizeInBytes: objectMemory baseHeaderSize + 4]
- sizeInBytes: self baseHeaderSize + 4]
ifFalse: "Cant use instantiateSmallClass: due to integral word requirement."
[newLargeInteger := objectMemory
eeInstantiateClass: (objectMemory splObj: ClassLargePositiveInteger)
indexableSize: 4].
objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
^newLargeInteger!
Item was changed:
----- Method: StackInterpreter>>primitiveObject:perform:withArguments:lookedUpIn: (in category 'control primitives') -----
primitiveObject: actualReceiver perform: selector withArguments: argumentArray lookedUpIn: lookupClass
"Common routine used by perform:withArgs:, perform:withArgs:inSuperclass:,
object:perform:withArgs:inClass: et al. Answer nil on success.
NOTE: The case of doesNotUnderstand: is not a failure to perform.
The only failures are arg types and consistency of argumentCount.
Since we're in the stack VM we can assume there is space to push the arguments
provided they are within limits (max argument count is 15). We can therefore deal
with the arbitrary amount of state to remove from the stack (lookup class, selector,
mirror receiver) and arbitrary argument orders by deferring popping anything until
we know whether the send has succeeded. So on failure we merely have to remove
the actual receiver and arguments pushed, and on success we have to slide the actual
receiver and arguments down to replace the original ones."
| arraySize performArgCount delta |
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
"Check if number of arguments is reasonable; MaxNumArgs isn't available
so just use LargeContextSize"
arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ arraySize > (LargeContextSize / objectMemory bytesPerWord) ifTrue:
- arraySize > (LargeContextSize / self bytesPerWord) ifTrue:
[^self primitiveFailFor: PrimErrBadNumArgs].
performArgCount := argumentCount.
"Push newMethod to save it in case of failure,
then push the actual receiver and args out of the array."
self push: newMethod.
self push: actualReceiver.
"Copy the arguments to the stack, and execute"
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
argumentCount := arraySize.
messageSelector := selector.
+ self sendBreak: messageSelector + objectMemory baseHeaderSize
- self sendBreak: messageSelector + self baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: actualReceiver.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
((objectMemory isOopCompiledMethod: newMethod)
and: [(self argumentCountOf: newMethod) ~= argumentCount]) ifTrue:
["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
self pop: arraySize + 1.
newMethod := self popStack.
^self primitiveFailFor: PrimErrBadNumArgs].
"Cannot fail this primitive from here-on. Slide the actual receiver and arguments down
to replace the perform arguments and saved newMethod and then execute the new
method. Use argumentCount not arraySize because an MNU may have changed it."
+ delta := objectMemory bytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod"
+ argumentCount * objectMemory bytesPerWord to: 0 by: objectMemory bytesPerWord negated do:
- delta := self bytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod"
- argumentCount * self bytesPerWord to: 0 by: self bytesPerWord negated do:
[:offset|
stackPages
longAt: stackPointer + offset + delta
put: (stackPages longAt: stackPointer + offset)].
self pop: performArgCount + 2.
self executeNewMethod.
self initPrimCall. "Recursive xeq affects primErrorCode"
^nil!
Item was changed:
----- Method: StackInterpreter>>printFrame:WithSP: (in category 'debug printing') -----
printFrame: theFP WithSP: theSP
| theMethod numArgs topThing |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #addr type: #'char *'>
self cCode: '' inSmalltalk: [self transcript ensureCr].
theMethod := self frameMethod: theFP.
numArgs := self frameNumArgs: theFP.
self shortPrintFrame: theFP.
self printFrameOop: 'rcvr/clsr'
+ at: theFP + FoxCallerSavedIP + ((numArgs + 1) * objectMemory bytesPerWord).
- at: theFP + FoxCallerSavedIP + ((numArgs + 1) * self bytesPerWord).
numArgs to: 1 by: -1 do:
+ [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * objectMemory bytesPerWord)].
- [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * self bytesPerWord)].
self printFrameThing: 'cllr ip/ctxt' at: theFP + FoxCallerSavedIP.
self printFrameThing: 'saved fp' at: theFP + FoxSavedFP.
self printFrameOop: 'method' at: theFP + FoxMethod.
self printFrameFlagsForFP: theFP.
self printFrameThing: 'context' at: theFP + FoxThisContext.
self printFrameOop: 'receiver' at: theFP + FoxReceiver.
topThing := stackPages longAt: theSP.
(topThing >= theMethod
and: [topThing <= (theMethod + (objectMemory sizeBitsOfSafe: theMethod))])
ifTrue:
+ [theFP + FoxReceiver - objectMemory bytesPerWord to: theSP + objectMemory bytesPerWord by: objectMemory bytesPerWord negated do:
- [theFP + FoxReceiver - self bytesPerWord to: theSP + self bytesPerWord by: self bytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr].
self printFrameThing: 'frame ip' at: theSP]
ifFalse:
+ [theFP + FoxReceiver - objectMemory bytesPerWord to: theSP by: objectMemory bytesPerWord negated do:
- [theFP + FoxReceiver - self bytesPerWord to: theSP by: self bytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr]]!
Item was changed:
----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
printNameOfClass: classOop count: cnt
"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
<inline: false>
(classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class'].
((objectMemory sizeBitsOf: classOop) = metaclassSizeBytes
+ and: [metaclassSizeBytes > (thisClassIndex * objectMemory bytesPerWord)]) "(Metaclass instSize * 4)"
- and: [metaclassSizeBytes > (thisClassIndex * self bytesPerWord)]) "(Metaclass instSize * 4)"
ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
self print: ' class']
ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine |
<inline: false>
self printHex: oop.
(objectMemory isIntegerObject: oop) ifTrue:
[^self
cCode: 'printf("=%ld\n", integerValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[self printHex: oop; print: ' is not on the heap'; cr.
^nil].
+ (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'; cr.
^nil].
(objectMemory isFreeObject: oop) ifTrue:
[self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
self cr.
(fmt > 4 and: [fmt < 12]) ifTrue:
["This will answer false if splObj: ClassAlien is nilObject"
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
[self print: ' datasize '; printNum: (self sizeOfAlienData: oop).
self print: ((self isIndirectAlien: oop)
ifTrue: [' indirect @ ']
ifFalse:
[(self isPointerAlien: oop)
ifTrue: [' pointer @ ']
ifFalse: [' direct @ ']]).
self printHex: (self startOfAlienData: oop); cr.
^nil].
(objectMemory isWords: oop) ifTrue:
+ [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / objectMemory bytesPerWord).
- [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / self bytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop).
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
^nil].
^self printStringOf: oop; cr].
+ lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / objectMemory bytesPerWord).
- lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / self bytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')'
inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
+ [startIP := startIP * objectMemory bytesPerWord + 1.
- [startIP := startIP * self bytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 10.
startIP to: lastIndex do:
[:index| | byte |
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue:
[self cr]].
((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') -----
printOopShortInner: oop
| classOop name nameLen |
<var: #name type: #'char *'>
<inline: true>
self printChar: $=.
(objectMemory isIntegerObject: oop) ifTrue:
[self printNum: (objectMemory integerValueOf: oop);
printChar: $(;
printHex: (objectMemory integerValueOf: oop);
printChar: $).
^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[self printHex: oop; print: ' is not on the heap'.
^nil].
+ (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'.
^nil].
(self isFloatObject: oop) ifTrue:
[self printFloat: (self dbgFloatValueOf: oop).
^nil].
classOop := objectMemory fetchClassOf: oop.
(objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue:
[self printNameOfClass: oop count: 5.
^nil].
oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil].
oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil].
oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil].
nameLen := self lengthOfNameOfClass: classOop.
nameLen = 0 ifTrue: [self print: 'a ??'. ^nil].
name := self nameOfClass: classOop.
nameLen = 10 ifTrue:
[(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue:
[self printChar: $"; printStringOf: oop; printChar: $".
^nil].
(self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue:
[self printChar: $#; printStringOf: oop.
^nil]].
(nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue:
[self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)).
^nil].
self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name]
inSmalltalk: [self print: 'a(n) '; print: name]!
Item was changed:
----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt cnt i |
<inline: false>
(objectMemory isIntegerObject: oop) ifTrue:
[^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^nil].
+ (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue:
[^nil].
fmt := objectMemory formatOf: oop.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (objectMemory lengthOf: oop).
i := 0.
((objectMemory is: oop
instanceOf: (objectMemory splObj: ClassByteArray)
compactClassIndex: classByteArrayCompactIndex)
or: [(objectMemory is: oop
instanceOf: (objectMemory splObj: ClassLargePositiveInteger)
compactClassIndex: ClassLargePositiveIntegerCompactIndex)
or: [(objectMemory is: oop
instanceOf: (objectMemory splObj: ClassLargeNegativeInteger)
compactClassIndex: ClassLargeNegativeIntegerCompactIndex)]])
ifTrue:
[[i < cnt] whileTrue: [
self printHex: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]]
ifFalse:
[[i < cnt] whileTrue: [
self printChar: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]].
self flush!
Item was changed:
----- Method: StackInterpreter>>push: (in category 'internal interpreter access') -----
push: object
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
+ stackPages longAt: (sp := stackPointer - objectMemory bytesPerWord) put: object.
- stackPages longAt: (sp := stackPointer - self bytesPerWord) put: object.
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
pushClosureCopyCopiedValuesBytecode
"The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following.
Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
| newClosure numArgsNumCopied numArgs numCopied blockSize context |
numArgsNumCopied := self fetchByte.
numArgs := numArgsNumCopied bitAnd: 16rF.
numCopied := numArgsNumCopied bitShift: -4.
"Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
blockSize := self fetchByte << 8.
blockSize := blockSize + self fetchByte.
"No need to record the pushed copied values in the outerContext."
+ context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * objectMemory bytesPerWord).
- context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * self bytesPerWord).
newClosure := self
closureIn: context
numArgs: numArgs
+ instructionPointer: (self oopForPointer: localIP) + 2 - (method+objectMemory baseHeaderSize)
- instructionPointer: (self oopForPointer: localIP) + 2 - (method+self baseHeaderSize)
numCopiedValues: numCopied.
numCopied > 0 ifTrue:
[0 to: numCopied - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self internalStackValue: numCopied - i - 1)].
self internalPop: numCopied].
localIP := localIP + blockSize.
self fetchNextBytecode.
self internalPush: newClosure!
Item was changed:
----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages
minimumMemory memStart bytesRead bytesToShift heapSize hdrEdenBytes
headerFlags hdrMaxExtSemTabSize |
<var: #f type: 'sqImageFile '>
<var: #memStart type: 'usqInt'>
<var: #desiredHeapSize type: 'usqInt'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #dataSize type: 'size_t '>
<var: #imageOffset type: 'squeakFileOffsetType '>
+ metaclassSizeBytes := 6 * objectMemory bytesPerWord. "guess (Metaclass instSize * BPW)"
- metaclassSizeBytes := 6 * self bytesPerWord. "guess (Metaclass instSize * BPW)"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"
- headerStart := (self sqImageFilePosition: f) - self bytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used."
savedWindowSize := self getLongFromFile: f swap: swapBytes.
headerFlags := self getLongFromFile: f swap: swapBytes.
self setImageHeaderFlagsFrom: headerFlags.
extraVMMemory := self getLongFromFile: f swap: swapBytes.
hdrNumStackPages := self getShortFromFile: f swap: swapBytes.
"4 stack pages is small. Should be able to run with as few as
three. 4 should be comfortable but slow. 8 is a reasonable
default. Can be changed via vmParameterAt: 43 put: n.
Can be set as a preference (Info.plist, VM.ini, command line etc).
If desiredNumStackPages is already non-zero then it has been
set as a preference. Ignore (but preserve) the header's default."
numStackPages := desiredNumStackPages ~= 0
ifTrue: [desiredNumStackPages]
ifFalse: [hdrNumStackPages = 0
ifTrue: [self defaultNumStackPages]
ifFalse: [hdrNumStackPages]].
desiredNumStackPages := hdrNumStackPages.
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to images run on Cog."
theUnknownShort := self getShortFromFile: f swap: swapBytes.
hdrEdenBytes := self getLongFromFile: f swap: swapBytes.
objectMemory setEdenBytes: (desiredEdenBytes ~= 0
ifTrue: [desiredEdenBytes]
ifFalse:
[hdrEdenBytes = 0
ifTrue: [objectMemory defaultEdenBytes]
ifFalse: [hdrEdenBytes]]).
desiredEdenBytes := hdrEdenBytes.
hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes.
hdrMaxExtSemTabSize ~= 0 ifTrue:
[self setMaxExtSemSizeTo: hdrMaxExtSemTabSize].
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
"compare memory requirements with availability".
minimumMemory := dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes.
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
objectMemory setMemory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)').
objectMemory getMemory = nil ifTrue: [self insufficientMemoryAvailableError].
memStart := objectMemory startOfMemory.
objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
objectMemory setEndOfMemory: memStart + dataSize.
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := memStart - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
^dataSize
!
Item was changed:
----- Method: StackInterpreter>>reestablishContextPriorToCallback: (in category 'callback support') -----
reestablishContextPriorToCallback: callbackContext
"callbackContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
Its sender is the VM's state prior to the callback. Reestablish that state,
and mark calloutContext as dead."
| calloutContext theFP thePage |
<export: true>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
self flag: #obsolete.
(self isLiveContext: callbackContext) ifFalse:
[^false].
calloutContext := self externalInstVar: SenderIndex ofContext: callbackContext.
(self isLiveContext: calloutContext) ifFalse:
[^false].
"Mark callbackContext as dead; the common case is that it is the current frame.
We go the extra mile for the debugger."
(self isSingleContext: callbackContext)
ifTrue: [self markContextAsDead: callbackContext]
ifFalse:
[theFP := self frameOfMarriedContext: callbackContext.
framePointer = theFP "common case"
ifTrue:
[(self isBaseFrame: theFP)
ifTrue: [stackPages freeStackPage: stackPage]
ifFalse: "calloutContext is immediately below on the same page. Make it current."
[instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
+ stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + self bytesPerWord.
framePointer := self frameCallerFP: framePointer.
^true]]
ifFalse:
[self externalDivorceFrame: theFP andContext: callbackContext.
self markContextAsDead: callbackContext]].
"Make the calloutContext the active frame. The case where calloutContext
is immediately below callbackContext on the same page is handled above."
(self isStillMarriedContext: calloutContext)
ifTrue:
[theFP := self frameOfMarriedContext: calloutContext.
thePage := stackPages stackPageFor: theFP.
"findSPOf:on: points to the word beneath the instructionPointer, but
there is no instructionPointer on the top frame of the current page."
self assert: thePage ~= stackPage.
+ stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord.
- stackPointer := (self findSPOf: theFP on: thePage) - self bytesPerWord.
framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutContext.
framePointer := thePage headFP.
stackPointer := thePage headSP].
instructionPointer := self popStack.
self setStackPageAndLimit: thePage.
^true!
Item was changed:
----- Method: StackInterpreter>>returnAs:ThroughCallback:Context: (in category 'callback support') -----
returnAs: returnTypeOop ThroughCallback: vmCallbackContext Context: callbackMethodContext
"callbackMethodContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
Its sender is the VM's state prior to the callback. Reestablish that state (via longjmp),
and mark callbackMethodContext as dead."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
| calloutMethodContext theFP thePage |
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
((self isIntegerObject: returnTypeOop)
and: [self isLiveContext: callbackMethodContext]) ifFalse:
[^false].
calloutMethodContext := self externalInstVar: SenderIndex ofContext: callbackMethodContext.
(self isLiveContext: calloutMethodContext) ifFalse:
[^false].
"Mark callbackMethodContext as dead; the common case is that it is the current frame.
We go the extra mile for the debugger."
(self isSingleContext: callbackMethodContext)
ifTrue: [self markContextAsDead: callbackMethodContext]
ifFalse:
[theFP := self frameOfMarriedContext: callbackMethodContext.
framePointer = theFP "common case"
ifTrue:
[(self isBaseFrame: theFP)
ifTrue: [stackPages freeStackPage: stackPage]
ifFalse: "calloutMethodContext is immediately below on the same page. Make it current."
[instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
+ stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + self bytesPerWord.
framePointer := self frameCallerFP: framePointer.
self restoreCStackStateForCallbackContext: vmCallbackContext.
"N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
This matches the use of _setjmp in ia32abicc.c."
self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
^true]]
ifFalse:
[self externalDivorceFrame: theFP andContext: callbackMethodContext.
self markContextAsDead: callbackMethodContext]].
"Make the calloutMethodContext the active frame. The case where calloutMethodContext
is immediately below callbackMethodContext on the same page is handled above."
(self isStillMarriedContext: calloutMethodContext)
ifTrue:
[theFP := self frameOfMarriedContext: calloutMethodContext.
thePage := stackPages stackPageFor: theFP.
"findSPOf:on: points to the word beneath the instructionPointer, but
there is no instructionPointer on the top frame of the current page."
self assert: thePage ~= stackPage.
+ stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord.
- stackPointer := (self findSPOf: theFP on: thePage) - self bytesPerWord.
framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutMethodContext.
framePointer := thePage headFP.
stackPointer := thePage headSP].
instructionPointer := self popStack.
self setStackPageAndLimit: thePage.
self restoreCStackStateForCallbackContext: vmCallbackContext.
"N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
This matches the use of _setjmp in ia32abicc.c."
self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
"NOTREACHED"
^true!
Item was changed:
----- Method: StackInterpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
reverseDisplayFrom: startIndex to: endIndex
"Reverse the given range of Display words (at different bit
depths, this will reverse different numbers of pixels). Used to
give feedback during VM activities such as garbage
collection when debugging. It is assumed that the given
word range falls entirely within the first line of the Display."
| displayObj displayBits w wordStartIndex wordEndIndex primFailCodeValue |
displayObj := objectMemory splObj: TheDisplay.
((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
w := objectMemory fetchPointer: 1 ofObject: displayObj.
displayBits := objectMemory fetchPointer: 0 ofObject: displayObj.
((objectMemory isIntegerObject: displayBits)
or: [(objectMemory isNonIntegerObject: w)
or: [objectMemory isPointersNonInt: displayBits]]) ifTrue: [^ nil].
wordStartIndex := startIndex * 4.
wordEndIndex := endIndex * 4 min: (objectMemory sizeBitsOf: displayBits).
+ displayBits := displayBits + objectMemory baseHeaderSize.
- displayBits := displayBits + self baseHeaderSize.
displayBits + wordStartIndex to: displayBits + wordEndIndex by: 4 do:
[:ptr | | reversed |
reversed := (objectMemory long32At: ptr) bitXor: 16rFFFFFFFF.
objectMemory longAt: ptr put: reversed].
primFailCodeValue := primFailCode.
self initPrimCall.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: (objectMemory integerValueOf: w) Bottom: 1.
self ioForceDisplayUpdate.
primFailCode := primFailCodeValue!
Item was changed:
----- Method: StackInterpreter>>roomToPushNArgs: (in category 'primitive support') -----
roomToPushNArgs: n
"Answer if there is room to push n arguments onto the current stack.
There may be room in this stackPage but there may not be room if
the frame were converted into a context."
| cntxSize |
self assert: method = (stackPages longAt: framePointer + FoxMethod).
cntxSize := ((self headerOf: method) bitAnd: LargeContextBit) ~= 0
+ ifTrue: [LargeContextSize / objectMemory bytesPerWord - ReceiverIndex]
+ ifFalse: [SmallContextSize / objectMemory bytesPerWord - ReceiverIndex].
- ifTrue: [LargeContextSize / self bytesPerWord - ReceiverIndex]
- ifFalse: [SmallContextSize / self bytesPerWord - ReceiverIndex].
^self stackPointerIndex + n <= cntxSize!
Item was changed:
----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') -----
sendInvokeCallbackContext: vmCallbackContext
"Send the calllback message to Alien class with the supplied arg(s). Use either the
1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
message, depending on what selector is installed in the specialObjectsArray.
Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
The arguments are raw C addresses and are converted to integer objects on the way."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien).
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[^false]].
primitiveFunctionPointer ~= 0 ifTrue:
[^false].
self saveCStackStateForCallbackContext: vmCallbackContext.
self push: (self splObj: ClassAlien). "receiver"
+ self cppIf: [objectMemory bytesPerWord = 8]
- self cppIf: [self bytesPerWord = 8]
ifTrue:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)]
ifFalse:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)].
self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
self justActivateNewMethod.
(self isMachineCodeFrame: framePointer) ifFalse:
[self maybeFlagMethodAsInterpreted: newMethod].
self externalWriteBackHeadFramePointers.
self handleStackOverflow.
self enterSmalltalkExecutiveFromCallback.
"not reached"
^true!
Item was changed:
----- Method: StackInterpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
sizeOfSTArrayFromCPrimitive: cPtr
"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
"Note: Only called by translated primitive code."
| oop |
<var: #cPtr type: 'void *'>
+ oop := (self oopForPointer: cPtr) - objectMemory baseHeaderSize.
- oop := (self oopForPointer: cPtr) - self baseHeaderSize.
(objectMemory isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
^objectMemory lengthOf: oop
!
Item was changed:
----- Method: StackInterpreter>>slowPrimitiveResponse (in category 'primitive support') -----
slowPrimitiveResponse
"Called under the assumption that primFunctionPtr has been preloaded"
| nArgs savedFramePointer savedStackPointer |
<inline: true>
<asmLabel: false>
<var: #savedFramePointer type: #'char *'>
<var: #savedStackPointer type: #'char *'>
FailImbalancedPrimitives ifTrue:
[nArgs := argumentCount.
savedStackPointer := stackPointer.
savedFramePointer := framePointer].
self initPrimCall.
self dispatchFunctionPointer: primitiveFunctionPointer.
(FailImbalancedPrimitives
and: [self successful
and: [framePointer = savedFramePointer]]) ifTrue:"Don't fail if primitive has done something radical, e.g. perform:"
+ [stackPointer ~= (savedStackPointer + (nArgs * objectMemory bytesPerWord)) ifTrue:
- [stackPointer ~= (savedStackPointer + (nArgs * self bytesPerWord)) ifTrue:
[self flag: 'Would be nice to make this a message send of e.g. unbalancedPrimitive to the current process or context'.
"This is necessary but insufficient; the result may still have been written to the stack.
At least we'll know something is wrong."
stackPointer := savedStackPointer.
self failUnbalancedPrimitive]].
"If we are profiling, take accurate primitive measures"
nextProfileTick > 0 ifTrue:
[self checkProfileTick: newMethod].
^self successful!
Item was changed:
----- Method: StackInterpreter>>snapshotCleanUp (in category 'image save/restore') -----
snapshotCleanUp
"Clean up right before saving an image, sweeping memory and:
* nilling out all fields of contexts above the stack pointer.
* flushing external primitives
* clearing the root bit of any object in the root table
* bereaving widowed contexts.
By ensuring that all contexts are single in a snapshot (i.e. that no married contexts
exist) we can maintain the invariant that a married or widowed context's frame
reference (in its sender field) must point into the stack pages since no married or
widowed contexts are present from older runs of the system."
| oop header fmt sz |
oop := objectMemory firstObject.
[self oop: oop isLessThan: objectMemory freeStart] whileTrue:
[(objectMemory isFreeObject: oop) ifFalse:
[header := self longAt: oop.
fmt := objectMemory formatOfHeader: header.
"Clean out context"
(fmt = 3 and: [self isContextHeader: header]) ifTrue:
["All contexts have been divorced. Bereave remaining widows."
(self isMarriedOrWidowedContext: oop) ifTrue:
[self markContextAsDead: oop].
sz := objectMemory sizeBitsOf: oop.
+ (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord
+ to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord
- (objectMemory lastPointerOf: oop) + self bytesPerWord
- to: sz - self baseHeaderSize by: self bytesPerWord
do: [:i | self longAt: oop + i put: objectMemory nilObject]].
"Clean out external functions"
fmt >= 12 ifTrue:
["This is a compiled method"
(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex ifTrue:
["Its primitiveExternalCall"
self flushExternalPrimitiveOf: oop]]].
oop := objectMemory objectAfter: oop].
objectMemory clearRootsTable!
Item was changed:
----- Method: StackInterpreter>>stackFloatValue: (in category 'internal interpreter access') -----
stackFloatValue: offset
"In the StackInterpreter stacks grow down."
| result floatPointer |
<returnTypeC: #double>
<var: #result type: #double>
+ floatPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
- floatPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord).
"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
(because assertClassOf:is:compactClassIndex: has an inline: pragma) the
phrase (self splObj: ClassArray) is expanded in-place and is _not_
evaluated if ClassArrayCompactIndex is non-zero."
self assertClassOf: floatPointer
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: floatPointer + objectMemory baseHeaderSize into: result.
- objectMemory fetchFloatAt: floatPointer + self baseHeaderSize into: result.
^result].
^0.0!
Item was changed:
----- Method: StackInterpreter>>stackLimitOffset (in category 'stack pages') -----
stackLimitOffset
"Answer the amount of slots needed to fit a new frame at the point the stack
limit is checked. A frame looks like this at the point the stack limit is checked:
stacked receiver/closure
arg0
...
argN
caller's method ip/base frame's sender context
fp-> saved fp
method
method header fields
context (uninitialized)
receiver
first temp
...
sp-> Nth temp
So the amount of headroom is
the maximum number of arguments + 1 (for stacked receiver and arguments)
+ the frame size
+ the max number of temps.
Since a method's number of temps includes its arguments the actual offset is:"
+ ^(FrameSlots + 64) * objectMemory bytesPerWord!
- ^(FrameSlots + 64) * self bytesPerWord!
Item was changed:
----- Method: StackInterpreter>>stackPositiveMachineIntegerValue: (in category 'internal interpreter access') -----
stackPositiveMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
- integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord).
^self positiveMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'internal interpreter access') -----
stackSignedMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
- integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackValue: (in category 'internal interpreter access') -----
stackValue: offset
<api>
"In the StackInterpreter stacks grow down."
+ ^stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord)!
- ^stackPages longAt: stackPointer + (offset * self bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>stackValue:put: (in category 'internal interpreter access') -----
stackValue: offset put: oop
"In the StackInterpreter stacks grow down."
^stackPages
+ longAt: stackPointer + (offset * objectMemory bytesPerWord)
- longAt: stackPointer + (offset * self bytesPerWord)
put: oop!
Item was changed:
----- Method: StackInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
sufficientSpaceToInstantiate: classOop indexableSize: size
"Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
"Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
| format atomSize|
<inline: true>
format := self instSpecOfClass: classOop.
"fail if attempting to call new: on non-indexable class"
((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2])
ifTrue: [^ false].
format < 8
+ ifTrue: ["indexable fields are words or pointers" atomSize := objectMemory bytesPerWord]
- ifTrue: ["indexable fields are words or pointers" atomSize := self bytesPerWord]
ifFalse: ["indexable fields are bytes" atomSize := 1].
^objectMemory sufficientSpaceToAllocate: 2500 + (size * atomSize)!
Item was changed:
----- Method: StackInterpreter>>temporary:in: (in category 'internal interpreter access') -----
temporary: offset in: theFP
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
^offset < (frameNumArgs := self frameNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory bytesPerWord)]
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * self bytesPerWord)]
ifFalse: [stackPages longAt: theFP + FoxReceiver - self bytesPerWord + ((frameNumArgs - offset) * self bytesPerWord)]!
Item was changed:
----- Method: StackInterpreter>>temporary:in:put: (in category 'internal interpreter access') -----
temporary: offset in: theFP put: valueOop
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
offset < (frameNumArgs := self frameNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory bytesPerWord) put: valueOop]
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * self bytesPerWord) put: valueOop]
ifFalse: [stackPages longAt: theFP + FoxReceiver - self bytesPerWord + ((frameNumArgs - offset) * self bytesPerWord) put: valueOop]!
Item was changed:
----- Method: StackInterpreter>>temporaryLocation:in:numArgs: (in category 'internal interpreter access') -----
temporaryLocation: offset in: theFP numArgs: numArgs
"Answer the pointer to a given temporary (for debug frame printing in odd circumstances)"
<var: #theFP type: #'char *'>
<returnTypeC: #'char *'>
<asmLabel: false>
^offset < numArgs
+ ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * objectMemory bytesPerWord)]
- ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * self bytesPerWord)]
ifFalse: [theFP + FoxReceiver - self bytesPerWord + ((numArgs - offset) * self bytesPerWord)]!
Item was changed:
----- Method: StackInterpreter>>unPop: (in category 'internal interpreter access') -----
unPop: nItems
"In the StackInterpreter stacks grow down."
+ stackPointer := stackPointer - (nItems * objectMemory bytesPerWord)!
- stackPointer := stackPointer - (nItems * self bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>updateObjectsPostByteSwapFrom:to: (in category 'image save/restore') -----
updateObjectsPostByteSwapFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part.
Ensure floats are in platform-order."
| oop fmt wordAddr methodHeader swapFloatWords temp |
swapFloatWords := objectMemory vmEndianness ~= imageFloatsBigEndian.
self assert: ClassFloatCompactIndex ~= 0.
oop := startOop.
[self oop: oop isLessThan: stopAddr] whileTrue:
[(objectMemory isFreeObject: oop) ifFalse:
[fmt := objectMemory formatOf: oop.
fmt >= 8 ifTrue: "oop contains bytes"
+ [wordAddr := oop + objectMemory baseHeaderSize.
- [wordAddr := oop + self baseHeaderSize.
fmt >= 12 ifTrue: "compiled method; start after methodHeader and literals"
+ [methodHeader := self longAt: oop + objectMemory baseHeaderSize.
+ wordAddr := wordAddr + objectMemory bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * objectMemory bytesPerWord)].
- [methodHeader := self longAt: oop + self baseHeaderSize.
- wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)].
objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)].
fmt = 6 ifTrue: "Bitmap, Float etc"
[(swapFloatWords
and: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex])
ifTrue:
+ [temp := self longAt: oop + objectMemory baseHeaderSize.
+ self longAt: oop + objectMemory baseHeaderSize put: (self longAt: oop + objectMemory baseHeaderSize + 4).
+ self longAt: oop + objectMemory baseHeaderSize + 4 put: temp]
- [temp := self longAt: oop + self baseHeaderSize.
- self longAt: oop + self baseHeaderSize put: (self longAt: oop + self baseHeaderSize + 4).
- self longAt: oop + self baseHeaderSize + 4 put: temp]
ifFalse:
+ [objectMemory bytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words."
+ [wordAddr := oop + objectMemory baseHeaderSize.
- [self bytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words."
- [wordAddr := oop + self baseHeaderSize.
objectMemory reverseWordsFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)]]]].
oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: StackInterpreter>>updateStateOfSpouseContextForFrame:WithSP: (in category 'frame access') -----
updateStateOfSpouseContextForFrame: theFP WithSP: theSP
"Update the frame's spouse context with the frame's current state except for the
sender and instruction pointer, which are used to mark the context as married."
| theContext tempIndex pointer |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #pointer type: #'char *'>
self assert: (self frameHasContext: theFP).
theContext := self frameContext: theFP.
self assert: (self frameReceiver: theFP)
= (objectMemory fetchPointer: ReceiverIndex ofObject: theContext).
tempIndex := self frameNumArgs: theFP.
+ pointer := theFP + FoxReceiver - objectMemory bytesPerWord.
- pointer := theFP + FoxReceiver - self bytesPerWord.
[pointer >= theSP] whileTrue:
[self assert: (objectMemory addressCouldBeOop: (stackPages longAt: pointer)).
tempIndex := tempIndex + 1.
objectMemory storePointer: ReceiverIndex + tempIndex
ofObject: theContext
withValue: (stackPages longAt: pointer).
+ pointer := pointer - objectMemory bytesPerWord].
- pointer := pointer - self bytesPerWord].
self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') -----
validInstructionPointer: instrPointer inMethod: aMethod framePointer: fp
<var: #instrPointer type: #usqInt>
<var: #aMethod type: #usqInt>
^instrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + self bytesPerWord - 1)
+ and: [instrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + objectMemory baseHeaderSize)]!
- and: [instrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + self baseHeaderSize)]!
Item was changed:
----- Method: StackInterpreter>>withSmallIntegerTags: (in category 'frame access') -----
withSmallIntegerTags: value
<inline: true>
<var: #value type: #'char *'>
+ self assert: ((self oopForPointer: value) bitAnd: objectMemory bytesPerWord - 1) = 0.
- self assert: ((self oopForPointer: value) bitAnd: self bytesPerWord - 1) = 0.
^(self oopForPointer: value) + 1!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure numArgs |
numArgs := self stackIntegerValue: 1.
self successful ifFalse:
[^self primitiveFail].
newClosure := self
closureIn: (self stackValue: 2)
numArgs: numArgs
"greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method + objectMemory baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize)
copiedValues: self stackTop.
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') -----
primitiveDoNamedPrimitiveWithArgs
"Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything.
e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments"
| argumentArray arraySize methodArg methodHeader
moduleName functionName moduleLength functionLength
spec addr primRcvr ctxtRcvr |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
arraySize := objectMemory fetchWordLengthOf: argumentArray.
self success: (self roomToPushNArgs: arraySize).
methodArg := self stackObjectValue: 2.
self successful ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
(objectMemory isOopCompiledMethod: methodArg) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
methodHeader := self headerOf: methodArg.
(self literalCountOfHeader: methodHeader) > 2 ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
(self assertClassOf: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg)
is: (objectMemory splObj: ClassArray)
compactClassIndex: ClassArrayCompactIndex).
(self successful
and: [(objectMemory lengthOf: spec) = 4
and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
[^self primitiveFailFor: -2]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: spec.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [self success: (objectMemory isBytes: moduleName).
moduleLength := objectMemory lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := objectMemory fetchPointer: 1 ofObject: spec.
self success: (objectMemory isBytes: functionName).
functionLength := objectMemory lengthOf: functionName.
self successful ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state"
+ addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
- FromModule: moduleName + self baseHeaderSize
OfLength: moduleLength.
addr = 0 ifTrue:
[^self primitiveFailFor: -1]. "could not find function; answer generic failure (see below)"
"Cannot fail this primitive from now on. Can only fail the external primitive."
objectMemory pushRemappableOop: (argumentArray := self popStack).
objectMemory pushRemappableOop: (primRcvr := self popStack).
objectMemory pushRemappableOop: self popStack. "the method"
objectMemory pushRemappableOop: self popStack. "the context receiver"
self push: primRcvr. "replace context receiver with actual receiver"
argumentCount := arraySize.
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
"Run the primitive (sets primFailCode)"
lkupClass := objectMemory nilObject.
self callExternalPrimitive: addr.
ctxtRcvr := objectMemory popRemappableOop.
methodArg := objectMemory popRemappableOop.
primRcvr := objectMemory popRemappableOop.
argumentArray := objectMemory popRemappableOop.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize + 1.
self push: ctxtRcvr.
self push: methodArg.
self push: primRcvr.
self push: argumentArray.
argumentCount := 3.
"Hack. A nil prim error code (primErrorCode = 1) is interpreted by the image
as meaning this primitive is not implemented. So to pass back nil as an error
code we use -1 to indicate generic failure."
primFailCode = 1 ifTrue:
[primFailCode := -1]]!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveExternalCall (in category 'plugin primitives') -----
primitiveExternalCall
"Call an external primitive. External primitive methods first literals are an array of
* The module name (String | Symbol)
* The function name (String | Symbol)
* The session ID (SmallInteger) [OBSOLETE]
* The function index (Integer) in the externalPrimitiveTable
For fast interpreter dispatch in subsequent invocations the primitiveFunctionPointer
in the method cache is rewritten, either to the function itself, or to zero if the external
function is not found. This allows for fast responses as long as the method stays in
the cache. The cache rewrite relies on lastMethodCacheProbeWrite which is set in
addNewMethodToCache:.
Now that the VM flushes function addresses from its tables, the session ID is obsolete,
but it is kept for backward compatibility. Also, a failed lookup is reported specially. If a
method has been looked up and not been found, the function address is stored as -1
(i.e., the SmallInteger -1 to distinguish from 16rFFFFFFFF which may be returned from
lookup), and the primitive fails with PrimErrNotFound."
| lit addr moduleName functionName moduleLength functionLength index |
<var: #addr declareC: 'void (*addr)()'>
"Fetch the first literal of the method"
(self literalCountOf: newMethod) > 0 ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
lit := self literal: 0 ofMethod: newMethod.
"Check if it's an array of length 4"
((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]) ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
"Look at the function index in case it has been loaded before"
index := objectMemory fetchPointer: 3 ofObject: lit.
(objectMemory isIntegerObject: index) ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
index := objectMemory integerValueOf: index.
"Check if we have already looked up the function and failed."
index < 0 ifTrue:
["Function address was not found in this session,
Void the primitive function."
self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
^self primitiveFailFor: PrimErrNotFound].
"Try to call the function directly"
(index > 0 and: [index <= MaxExternalPrimitiveTableSize]) ifTrue:
[addr := externalPrimitiveTable at: index - 1.
addr ~= 0 ifTrue:
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: 'addr' inSmalltalk: [1000 + index]).
self callExternalPrimitive: addr.
^nil].
"if we get here, then an index to the external prim was
kept on the ST side although the underlying prim
table was already flushed"
^self primitiveFailFor: PrimErrNamedInternal].
"Clean up session id and external primitive index"
objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: lit.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [(objectMemory isBytes: moduleName) ifFalse:
[self primitiveFailFor: PrimErrBadMethod].
moduleLength := objectMemory lengthOf: moduleName].
functionName := objectMemory fetchPointer: 1 ofObject: lit.
(objectMemory isBytes: functionName) ifFalse:
[self primitiveFailFor: PrimErrBadMethod].
functionLength := objectMemory lengthOf: functionName.
+ addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
- FromModule: moduleName + self baseHeaderSize
OfLength: moduleLength.
addr = 0
ifTrue: [index := -1]
ifFalse: ["add the function to the external primitive table"
index := self addToExternalPrimitiveTable: addr].
"Store the index (or -1 if failure) back in the literal"
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
"If the function has been successfully loaded cache and call it"
index >= 0
ifTrue:
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: [addr] inSmalltalk: [1000 + index]).
self callExternalPrimitive: addr]
ifFalse: ["Otherwise void the primitive function and fail"
self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
^self primitiveFailFor: PrimErrNotFound]!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitivePerform (in category 'control primitives') -----
primitivePerform
<returnTypeC: #void>
| performSelector newReceiver lookupClass performMethod |
performSelector := messageSelector.
performMethod := newMethod.
messageSelector := self stackValue: argumentCount - 1.
newReceiver := self stackValue: argumentCount.
"NOTE: the following lookup may fail and be converted to #doesNotUnderstand:,
so we must adjust argumentCount and slide args now, so that will work."
"Slide arguments down over selector"
argumentCount := argumentCount - 1.
argumentCount to: 1 by: -1 do:
[:i|
stackPages
+ longAt: stackPointer + (i * objectMemory bytesPerWord)
+ put: (stackPages longAt: stackPointer + ((i - 1) * objectMemory bytesPerWord))].
- longAt: stackPointer + (i * BytesPerWord)
- put: (stackPages longAt: stackPointer + ((i - 1) * BytesPerWord))].
self pop: 1.
lookupClass := objectMemory fetchClassOf: newReceiver.
+ self sendBreak: messageSelector + objectMemory baseHeaderSize
- self sendBreak: messageSelector + self baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: newReceiver.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - other objects will have to take their chances"
((objectMemory isOopCompiledMethod: newMethod)
and: [(self argumentCountOf: newMethod) = argumentCount]) ifFalse:
["Slide the args back up (sigh) and re-insert the selector."
self unPop: 1.
1 to: argumentCount by: 1 do:
[:i |
+ stackPages longAt: stackPointer + ((i - 1) * objectMemory bytesPerWord)
+ put: (stackPages longAt: stackPointer + (i * objectMemory bytesPerWord))].
+ stackPages longAt: stackPointer + (argumentCount * objectMemory bytesPerWord) put: messageSelector.
- stackPages longAt: stackPointer + ((i - 1) * BytesPerWord)
- put: (stackPages longAt: stackPointer + (i * BytesPerWord))].
- stackPages longAt: stackPointer + (argumentCount * BytesPerWord) put: messageSelector.
argumentCount := argumentCount + 1.
newMethod := performMethod.
messageSelector := performSelector.
^self primitiveFail].
self executeNewMethod.
"Recursive xeq affects primErrorCode"
self initPrimCall!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveTerminateTo (in category 'control primitives') -----
primitiveTerminateTo
"Primitive. Terminate up the context stack from the receiver up to but not including
the argument, if previousContext is on my Context stack. Make previousContext my
sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct."
| thisCtx currentCtx aContextOrNil contextsFP contextsSP contextsIP nextCntx stackedReceiverOffset
theFP newFP newSP pageToStopOn thePage frameAbove |
<var: #contextsFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #newSP type: #'char *'>
<var: #contextsIP type: #usqInt>
<var: #frameAbove type: #'char *'>
<var: #contextsSP type: #'char *'>
<var: #source type: #'char *'>
<var: #pageToStopOn type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
aContextOrNil := self stackTop.
(aContextOrNil = objectMemory nilObject or: [self isContext: aContextOrNil]) ifFalse:
[^self primitiveFail].
thisCtx := self stackValue: 1.
thisCtx = aContextOrNil ifTrue:
[^self primitiveFail].
"All stackPages need to have current head pointers to avoid confusion."
self externalWriteBackHeadFramePointers.
"If we're searching for aContextOrNil it might be on a stack page. Helps to know
if we can free a whole page or not, or if we can short-cut the termination."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0].
"if thisCtx is married ensure it is a base frame. Then we can assign its sender."
(self isStillMarriedContext: thisCtx)
ifTrue:
[theFP := self frameOfMarriedContext: thisCtx.
"Optimize terminating thisContext. Move its frame down to be next to
aContextOrNil's frame. Common in the exception system and so helps to be fast."
(theFP = framePointer
and: [pageToStopOn = stackPage]) ifTrue:
[(self frameCallerFP: theFP) ~= contextsFP ifTrue:
[stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
frameAbove := self findFrameAbove: contextsFP inPage: pageToStopOn.
contextsIP := self frameCallerSavedIP: frameAbove.
newSP := self frameCallerSP: frameAbove.
+ newFP := newSP - stackedReceiverOffset - objectMemory bytesPerWord.
- newFP := newSP - stackedReceiverOffset - BytesPerWord.
theFP + stackedReceiverOffset
to: stackPointer
+ by: objectMemory bytesPerWord negated
- by: BytesPerWord negated
do: [:source|
+ newSP := newSP - objectMemory bytesPerWord.
- newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
stackPages longAt: newFP + FoxSavedFP put: contextsFP.
stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP.
self assert: (self isContext: thisCtx).
objectMemory storePointerUnchecked: SenderIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: newFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: contextsFP).
framePointer := newFP.
stackPointer := newSP].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil].
theFP := self externalEnsureIsBaseFrame: theFP. "May cause a GC!!!!"
currentCtx := self frameCallerContext: theFP.
"May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[currentCtx := objectMemory fetchPointer: SenderIndex ofObject: thisCtx].
(self context: thisCtx hasSender: aContextOrNil) ifTrue:
["Need to walk the stack freeing stack pages and nilling contexts."
[currentCtx = aContextOrNil
or: [currentCtx = objectMemory nilObject]] whileFalse:
[self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[theFP := self frameOfMarriedContext: currentCtx.
thePage := stackPages stackPageFor: theFP.
"If externalEnsureIsBaseFrame: above has moved thisContext to its own stack
then we will always terminate to a frame on a different page. But if we are
terminating some other context to a context somewhere on the current page
we must save the active frames above that context. Things will look e.g. like this:
thisCtx 499383332 s MethodContext(ContextPart)>resume:
499380484 s BlockClosure>ensure:
499377320 s MethodContext(ContextPart)>handleSignal:
499373760 s MethodContext(ContextPart)>handleSignal:
499372772 s MessageNotUnderstood(Exception)>signal
499369068 s CodeSimulationTests(Object)>doesNotUnderstand: absentMethod
499368708 s [] in CodeSimulationTests>testDNU
(sender is 0xbffc2480 I CodeSimulationTests>runSimulated:)
------------
framePointer 0xbffc234c M MethodContext(ContextPart)>doPrimitive:method:receiver:args:
0xbffc2378 M MethodContext(ContextPart)>tryPrimitiveFor:receiver:args:
0xbffc23ac M MethodContext(ContextPart)>send:to:with:super:
0xbffc23e4 M MethodContext(ContextPart)>send:super:numArgs:
0xbffc2418 M MethodContext(InstructionStream)>interpretNextInstructionFor:
0xbffc2434 M MethodContext(ContextPart)>step
0xbffc2458 I MethodContext(ContextPart)>runSimulated:contextAtEachStep:
------------
(499368708's sender) 0xbffc2480 I CodeSimulationTests>runSimulated:
0xbffc249c M CodeSimulationTests>testDNU
0xbffc24bc I CodeSimulationTests(TestCase)>performTest
0xbffc24dc I [] in CodeSimulationTests(TestCase)>runCase
aContextOrNil 0xbffc24fc M BlockClosure>ensure:
0xbffc2520 I CodeSimulationTests(TestCase)>runCase
0xbffc253c M [] in TestResult>runCase:
When we find this case we move the frames above to a new page by making the
frame above currentCtx a base frame, i.e. making 0xbffc2458 in the above example
a base frame. But in this iteration of the loop we don't move down a frame i.e. currentCtx
doesn't change on this iteration."
thePage = stackPage
ifTrue:
[frameAbove := self findFrameAbove: theFP inPage: thePage.
self assert: frameAbove ~= 0.
frameAbove := self externalEnsureIsBaseFrame: frameAbove. "May cause a GC!!!! May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[thePage = pageToStopOn
ifTrue:
["We're here. Cut back the stack to aContextOrNil's frame,
push its instructionPointer if it's not already a head frame,
and we're done."
frameAbove := self findFrameAbove: contextsFP inPage: thePage.
frameAbove ~= 0 ifTrue:
+ [contextsSP := (self frameCallerSP: frameAbove) - objectMemory bytesPerWord.
- [contextsSP := (self frameCallerSP: frameAbove) - BytesPerWord.
stackPages longAt: contextsSP put: (self frameCallerSavedIP: frameAbove).
self setHeadFP: contextsFP andSP: contextsSP inPage: thePage].
currentCtx := aContextOrNil]
ifFalse:
["We can free the entire page without further ado."
currentCtx := self frameCallerContext: thePage baseFP.
"for a short time invariant is violated; assert follows"
stackPages freeStackPageNoAssert: thePage]]]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]]].
self assert: stackPages pageListIsWellFormed.
(self isMarriedOrWidowedContext: thisCtx)
ifTrue:
[self assert: (self checkIsStillMarriedContext: thisCtx currentFP: framePointer).
self assert: (self isBaseFrame: (self frameOfMarriedContext: thisCtx)).
theFP := self frameOfMarriedContext: thisCtx.
self frameCallerContext: theFP put: aContextOrNil]
ifFalse: [objectMemory storePointer: SenderIndex ofObject: thisCtx withValue: aContextOrNil].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: StackInterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') -----
clipboardWrite: sz From: actualDataAddress At: ignored
+ Clipboard clipboardText: (self stringOf: actualDataAddress - objectMemory baseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)!
Item was changed:
----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') -----
shortPrint: oop
| name classOop |
(objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString ,
' (' , (objectMemory integerValueOf: oop) hex , ')'].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^' is not on the heap'].
+ (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[^' is misaligned'].
classOop := objectMemory fetchClassOf: oop.
(objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [
^ 'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^ (self stringOf: oop) printString].
name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf:
(objectMemory fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^ 'nil'].
name = 'False' ifTrue: [^ 'false'].
name = 'True' ifTrue: [^ 'true'].
name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString].
name = 'Association' ifTrue: [^ '(' ,
+ (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
' -> ' ,
+ (self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerWord) hex8 , ')'].
- (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
('AEIOU' includes: name first)
ifTrue: [^ 'an ' , name]
ifFalse: [^ 'a ' , name]!
Item was changed:
----- Method: StackInterpreterSimulator>>shortPrintRelative: (in category 'debug support') -----
shortPrintRelative: oop
| name classOop |
(objectMemory isIntegerObject: oop) ifTrue:
[^'=' , (objectMemory integerValueOf: oop) printString ,
' (' , (objectMemory integerValueOf: oop) hex , ')'].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^' is not on the heap'].
+ (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[^' is misaligned'].
classOop := objectMemory fetchClassOfNonInt: oop.
(objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [
^'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^(self stringOf: oop) printString].
name = 'ByteString' ifTrue: [^(self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)].
name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)].
name = 'Character' ifTrue: [^'=' , (Character value: (objectMemory integerValueOf:
(objectMemory fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^'nil'].
name = 'False' ifTrue: [^'false'].
name = 'True' ifTrue: [^'true'].
name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString].
name = 'Association' ifTrue:
[| valOop |
+ valOop := self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerWord.
- valOop := self longAt: oop + BaseHeaderSize + BytesPerWord.
^'(' ,
+ (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
' -> ' ,
((objectMemory isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - objectMemory startOfMemory]) hex8 , ')'].
^(('AEIOU' includes: name first)
ifTrue: ['an ']
ifFalse: ['a ']) , name!
Item was changed:
----- Method: StackInterpreterSimulator>>stringOf: (in category 'debug support') -----
stringOf: oop
| size long nLongs chars |
^ String streamContents:
[:strm |
size := 100 min: (self stSizeOf: oop).
+ nLongs := size-1//objectMemory bytesPerWord+1.
- nLongs := size-1//BytesPerWord+1.
1 to: nLongs do:
+ [:i | long := self longAt: oop + objectMemory baseHeaderSize + (i-1*objectMemory bytesPerWord).
- [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord).
chars := self charsOfLong: long.
strm nextPutAll: (i=nLongs
+ ifTrue: [chars copyFrom: 1 to: size-1\\objectMemory bytesPerWord+1]
- ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1]
ifFalse: [chars])]]!
Item was changed:
----- Method: StackInterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - BaseHeaderSize. "Due to C call in Interp"
1 to: stringSize do:
[:i | objectMemory storeByte: i-1 ofObject: stringOop
withValue: (pathName at: i) asciiValue].
!
Item was changed:
----- Method: StackInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
+ objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
[
file := (FileStream fileNamed: imageName) binary.
file == nil ifTrue: [^nil].
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
objectMemory startOfMemory.
(objectMemory getSpecialObjectsOop).
(objectMemory getLastHash).
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
{ desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
[:short| self putShort: short toFile: file].
self putLong: desiredEdenBytes toFile: file.
{ maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
[:short| self putShort: short toFile: file].
"Pad the rest of the header."
4 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
objectMemory startOfMemory // 4 + 1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (objectMemory getMemory at: index)
toFile: file].
self success: true
]
ensure: [file close]!
Item was changed:
----- Method: StackInterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: objectMemory bytesPerWord!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was added:
+ ----- Method: TMethod>>superExpansionNodeFor:args: (in category 'inlining') -----
+ superExpansionNodeFor: aSelector args: argumentNodes
+ "Answer the expansion of a super send. Merge the super expansion's
+ locals, properties and comment into this method's properties."
+ (definingClass superclass lookupSelector: aSelector)
+ ifNil: [self error: 'superclass does not define super method']
+ ifNotNil:
+ [:superMethod| | superTMethod commonVars varMap |
+ superTMethod := superMethod methodNode asTranslationMethodOfClass: self class.
+ ((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode])
+ and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse:
+ [self error: definingClass name, '>>',selector, ' args ~= ',
+ superTMethod definingClass name, '>>', aSelector,
+ (String with: $. with: Character cr),
+ 'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.'].
+ self mergePropertiesOfSuperMethod: superTMethod.
+ (commonVars := superTMethod locals intersection: self locals) notEmpty ifTrue:
+ [varMap := Dictionary new.
+ commonVars do:
+ [:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)].
+ superTMethod renameVariablesUsing: varMap].
+ self assert: (superTMethod locals allSatisfy: [:var| (self locals includes: var) not]).
+ locals addAll: superTMethod locals.
+ superTMethod declarations keysAndValuesDo:
+ [:var :decl|
+ self declarationAt: var put: decl].
+ superTMethod comment ifNotNil:
+ [:superComment|
+ comment := comment
+ ifNil: [superComment]
+ ifNotNil: [superComment, comment]].
+ superTMethod extraVariableNumber ifNotNil:
+ [:scvn|
+ extraVariableNumber := extraVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]].
+ superTMethod elideAnyFinalReturn.
+ ^superTMethod parseTree]!
Item was changed:
----- Method: VMMaker class>>versionString (in category 'version testing') -----
versionString
"VMMaker versionString"
+ ^'4.13.12'!
- ^'4.13.10'!
Item was changed:
----- Method: VMStackFrameOffsets class>>initializeFrameIndices (in category 'class initialization') -----
initializeFrameIndices
"Format of a stack frame. Word-sized indices relative to the frame pointer.
Terminology
Frames are either single (have no context) or married (have a context).
Contexts are either single (exist on the heap), married (have a context) or widowed (had a frame that has exited).
Stacks grow down:
receiver for method activations/closure for block activations
arg0
...
argN
caller's method ip/base frame's sender context
fp-> saved fp
method
frame flags
context (uninitialized)
receiver
first temp
...
sp-> Nth temp
frame flags holds the number of arguments (since argument temporaries are above the frame)
the flag for a block activation
and the flag indicating if the context field is valid (whether the frame is married).
The first frame in a stack page is the baseFrame and is marked as such by a null saved fp,
in which case the saved method ip is actually the context (possibly hybrid) beneath the base frame"
| fxCallerSavedIP fxSavedFP fxMethod fxFrameFlags fxThisContext fxReceiver |
fxCallerSavedIP := 1.
fxSavedFP := 0.
fxMethod := -1.
fxFrameFlags := -2. "Can find numArgs, needed for fast temp access. args are above fxCallerSavedIP.
Can find ``is block'' bit
Can find ``has context'' bit"
fxThisContext := -3.
fxReceiver := -4.
FrameSlots := fxCallerSavedIP - fxReceiver + 1.
+ FoxCallerSavedIP := fxCallerSavedIP * self bytesPerWord.
- FoxCallerSavedIP := fxCallerSavedIP * BytesPerWord.
"In base frames the caller saved ip field holds the caller context."
FoxCallerContext := FoxCallerSavedIP.
+ FoxSavedFP := fxSavedFP * self bytesPerWord.
+ FoxMethod := fxMethod * self bytesPerWord.
+ FoxFrameFlags := fxFrameFlags * self bytesPerWord.
+ FoxThisContext := fxThisContext * self bytesPerWord.
+ FoxReceiver := fxReceiver * self bytesPerWord!
- FoxSavedFP := fxSavedFP * BytesPerWord.
- FoxMethod := fxMethod * BytesPerWord.
- FoxFrameFlags := fxFrameFlags * BytesPerWord.
- FoxThisContext := fxThisContext * BytesPerWord.
- FoxReceiver := fxReceiver * BytesPerWord!
1
0
Tim Felgentreff uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-tfel.362.mcz
==================== Summary ====================
Name: VMMaker-tfel.362
Author: tfel
Time: 30 April 2015, 12:24:19.119 am
UUID: 9aa35714-bf9e-5a47-a06f-b8b5c9c08520
Ancestors: VMMaker-MattSpr.361
Refactor InterpreterProxy to always go through primitiveFailFor: to set the primFailCode. In primitiveFailFor: primitive 255 is called to indicate that we are currently simulating a primitive that is about to fail for VMs (like RSqueakVM) that need to handle that case
=============== Diff against VMMaker-tfel.360 ===============
Item was changed:
SystemOrganization addCategory: #'VMMaker-Building'!
SystemOrganization addCategory: #'VMMaker-Interpreter'!
SystemOrganization addCategory: #'VMMaker-InterpreterSimulation'!
SystemOrganization addCategory: #'VMMaker-Plugins'!
SystemOrganization addCategory: #'VMMaker-SmartSyntaxPlugins'!
SystemOrganization addCategory: #'VMMaker-Translation to C'!
SystemOrganization addCategory: #'VMMaker-Tests'!
SystemOrganization addCategory: #'VMMaker-Support'!
SystemOrganization addCategory: #'VMMaker-JIT'!
- SystemOrganization addCategory: #'VMMaker-JITSimulation'!
Item was changed:
----- Method: BalloonEngineSimulation class>>simulatePrimitive:receiver:args: (in category 'simulation') -----
simulatePrimitive: aString receiver: rcvr args: args
| proxy bb |
proxy := InterpreterProxy new.
proxy synthesizeStackFor: rcvr with: args.
bb := self simulatorClass new.
bb setInterpreter: proxy.
bb initialiseModule.
"rendering state is loaded in the primitive implementations"
+ [bb perform: aString asSymbol] on: Exception do: [:ex|
+ RSqueak log: 'got an error trying to simulate ', aString.
+ RSqueak log: ex messageText.
+ RSqueak log: ex signalerContext shortStack].
- [bb perform: aString asSymbol] on: Exception do: [:ex |
- proxy success: false].
^ proxy stackValue: 0
!
Item was changed:
Object subclass: #CCodeGenerator
+ instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations uncheckedAbstractMethods selectorTranslations breakSrcInlineSelector breakDestInlineSelector inlineReturnTypes'
- instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations uncheckedAbstractMethods selectorTranslations breakSrcInlineSelector breakDestInlineSelector inlineReturnTypes'
classVariableNames: 'UseRightShiftForDivide'
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.
See VMMaker for more useful info!
Item was removed:
- ReadStream subclass: #FakeStdinStream
- instanceVariableNames: 'atEnd simulator'
- classVariableNames: ''
- poolDictionaries: 'VMBasicConstants'
- category: 'VMMaker-JITSimulation'!
-
- !FakeStdinStream commentStamp: '<historical>' prior: 0!
- Fake Standard input using a dialog to prompt for a line of input at a time.!
Item was removed:
- ----- Method: FakeStdinStream class>>for: (in category 'instance creation') -----
- for: aCogVMSimulator
- ^(self basicNew simulator: aCogVMSimulator)
- on: (String new: 80) from: 1 to: 0
-
- "self new next"!
Item was removed:
- ----- Method: FakeStdinStream class>>new (in category 'instance creation') -----
- new
- ^super on: (String new: 80) from: 1 to: 0
-
- "self new next"!
Item was removed:
- ----- Method: FakeStdinStream>>atEnd (in category 'testing') -----
- atEnd
- ^atEnd ifNil: [atEnd := false]!
Item was removed:
- ----- Method: FakeStdinStream>>atEnd: (in category 'accessing') -----
- atEnd: aBoolean
- atEnd := aBoolean!
Item was removed:
- ----- Method: FakeStdinStream>>close (in category 'accessing') -----
- close
- atEnd := true!
Item was removed:
- ----- Method: FakeStdinStream>>next (in category 'accessing') -----
- next
- "Answer the next object in the Stream represented by the receiver.
- If there are no more elements in the stream fill up the buffer by prompting for input"
- | sem inputLine next |
- position >= readLimit ifTrue:
- [simulator isThreadedVM
- ifTrue:
- ["(simulator cogit singleStep not
- and: [UIManager confirm: 'Single step?']) ifTrue:
- [simulator cogit singleStep: true]."
- "threadIndex := simulator disownVM: DisownVMLockOutFullGC." self flag: #FIXME. "oscog"
- simulator forceInterruptCheckFromHeartbeat.
- sem := Semaphore new.
- WorldState addDeferredUIMessage:
- [inputLine := UIManager default request: 'Input please!!'.
- sem signal].
- sem wait]
- ifFalse:
- [inputLine := UIManager default request: 'Input please!!'].
- collection size <= inputLine size ifTrue:
- [collection := collection species new: inputLine size + 1].
- collection
- replaceFrom: 1 to: inputLine size with: inputLine startingAt: 1;
- at: (readLimit := inputLine size + 1) put: Character lf.
- position := 0.
- "simulator isThreadedVM ifTrue:
- [simulator ownVM: threadIndex]" self flag: #FiXME "oscog"].
- next := collection at: (position := position + 1).
- "This is set temporarily to allow (FilePluginSimulator>>#sqFile:Read:Into:At:
- to brwak out of its loop. sqFile:Read:Into:At: resets it on the way out."
- atEnd := position >= readLimit.
- ^next
-
-
- " This does it with workspaces:
- | ws r s |
- s := Semaphore new.
- ws := Workspace new contents: ''.
- ws acceptAction: [:t| r := t asString. s signal].
- [ws openLabel: 'Yo!!'; shouldStyle: false.
- (ws dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil]) ifNotNil:
- [:textMorph| textMorph acceptOnCR: true; hasUnacceptedEdits: true]] fork.
- Processor activeProcess == Project uiProcess
- ifTrue: [[r isNil] whileTrue: [World doOneCycle]]
- ifFalse: [s wait].
- ws topView delete.
- s wait. s signal.
- r"!
Item was removed:
- ----- Method: FakeStdinStream>>simulator: (in category 'initialize-release') -----
- simulator: aCogVMSimulator
- simulator := aCogVMSimulator.
- atEnd := false!
Item was changed:
----- Method: FilePlugin class>>requiredMethodNames (in category 'translation') -----
requiredMethodNames
+ "fileValueOf: is called (questionably so) by support code for DropPlugin"
- "fileValueOf: nd fileRecordSize are called (questionably so) by support code for DropPlugin"
+ ^ super requiredMethodNames, #( fileValueOf: )!
- ^ super requiredMethodNames, #( fileValueOf: fileRecordSize )!
Item was changed:
----- Method: FilePlugin>>fileRecordSize (in category 'file primitives') -----
fileRecordSize
"Return the size of a Smalltalk file record in bytes."
<static: false>
+ ^ self cCode: 'sizeof(SQFile)'.!
- ^self sizeof: #SQFile!
Item was changed:
FilePlugin subclass: #FilePluginSimulator
+ instanceVariableNames: 'openFiles'
- instanceVariableNames: 'openFiles states'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-InterpreterSimulation'!
!FilePluginSimulator commentStamp: 'tpr 5/5/2003 12:02' prior: 0!
File plugin simulation for the VM simulator!
Item was removed:
- ----- Method: FilePluginSimulator>>createDirectory: (in category 'simulation') -----
- createDirectory: aString
- ^[FileDirectory default primCreateDirectory: aString.
- true]
- on: Error
- do: [:ex| false]
- !
Item was changed:
----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') -----
fileValueOf: objectPointer
+ | index |
- | index file |
index := (interpreterProxy isIntegerObject: objectPointer)
ifTrue: [interpreterProxy integerValueOf: objectPointer]
ifFalse:
[((interpreterProxy isBytes: objectPointer)
+ and: [(interpreterProxy byteSizeOf: objectPointer) = self bytesPerWord]) ifFalse:
- and: [(interpreterProxy byteSizeOf: objectPointer) = (self sizeof: #SQFile)]) ifFalse:
[interpreterProxy primitiveFail.
^nil].
+ interpreterProxy longAt: objectPointer + self baseHeaderSize].
+ ^openFiles at: index!
- interpreterProxy longAt: objectPointer + interpreterProxy baseHeaderSize].
- file := openFiles at: index.
- "this attempts to preserve file positions across snapshots when debugging the VM
- requires saving an image in full flight and pushing it over the cliff time after time..."
- (file closed and: [states includesKey: file]) ifTrue:
- [[:pos :isBinary|
- file reopen; position: pos.
- isBinary ifTrue:
- [file binary]] valueWithArguments: (states at: file)].
- ^file!
Item was changed:
----- Method: FilePluginSimulator>>initialiseModule (in category 'initialize-release') -----
initialiseModule
"See FilePluginSimulator>>sqFileStdioHandlesInto:"
(openFiles := Dictionary new)
at: 0 put: (FakeStdinStream for: interpreterProxy interpreter); "stdin"
at: 1 put: Transcript; "stdout"
at: 2 put: Transcript. "stderr"
- states := IdentityDictionary new.
^super initialiseModule!
Item was removed:
- ----- Method: FilePluginSimulator>>recordStateOf: (in category 'simulation') -----
- recordStateOf: file
- ([file position]
- on: Error
- do: [:ex| nil]) ifNotNil:
- [:position|
- states at: file put: {position. file isBinary}]!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:Read:Into:At: (in category 'simulation') -----
sqFile: file Read: count Into: byteArrayIndex At: startIndex
| interpreter |
interpreter := interpreterProxy interpreter.
+ startIndex to: startIndex + count - 1 do:
- [[startIndex to: startIndex + count - 1 do:
[ :i |
+ file atEnd ifTrue: [^i - startIndex].
+ interpreter byteAt: byteArrayIndex + i put: file next asInteger].
- file atEnd ifTrue:
- [(file isKindOf: FakeStdinStream) ifTrue: [file atEnd: false].
- ^i - startIndex].
- interpreter
- byteAt: byteArrayIndex + i
- put: file next asInteger]]
- on: Error
- do: [:ex|
- (file isKindOf: TranscriptStream) ifFalse: [ex pass].
- ^0]]
- ensure: [self recordStateOf: file].
^count!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:SetPosition: (in category 'simulation') -----
sqFile: file SetPosition: newPosition
+ file position: newPosition!
- file position: newPosition.
- self recordStateOf: file!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:Truncate: (in category 'simulation') -----
sqFile: file Truncate: truncatePosition
+ file truncate: truncatePosition!
- file truncate: truncatePosition.
- self recordStateOf: file!
Item was changed:
----- Method: FilePluginSimulator>>sqFile:Write:From:At: (in category 'simulation') -----
sqFile: file Write: count From: byteArrayIndex At: startIndex
| interpreter |
interpreter := interpreterProxy interpreter.
file isBinary
ifTrue:
[startIndex to: startIndex + count - 1 do:
[ :i | file nextPut: (interpreter byteAt: byteArrayIndex + i)]]
ifFalse:
[startIndex to: startIndex + count - 1 do:
[ :i | | byte |
byte := interpreter byteAt: byteArrayIndex + i.
file nextPut: (Character value: (byte == 12 "lf" ifTrue: [15"cr"] ifFalse: [byte]))]].
- self recordStateOf: file.
^count!
Item was changed:
----- Method: FilePluginSimulator>>sqFileClose: (in category 'simulation') -----
sqFileClose: file
+ file close!
- file close.
- self recordStateOf: file!
Item was added:
+ ----- Method: Interpreter>>isBigEnder (in category 'plugin support') -----
+ isBigEnder
+ "Answer true (non-zero) if running on a big endian machine."
+ | endianness anInt cString len i |
+ <var: 'cString' type: 'char *'>
+ <var: 'endianness' declareC: 'static sqInt endianness = -1'>
+ (endianness == -1) ifFalse: [^ endianness]. "answer cached value"
+ len := self cCode: 'sizeof(anInt)'
+ inSmalltalk: [^ (Smalltalk endianness == #little) not].
+ cString := self cCode: '(char *) &anInt' inSmalltalk: [].
+ i := 0.
+ [i < len] whileTrue:
+ [cString at: i put: i.
+ i := i + 1].
+ endianness := anInt bitAnd: 255.
+ ^ endianness
+ !
Item was removed:
- ----- Method: InterpreterPlugin class>>newFor: (in category 'simulation') -----
- newFor: anUnsimulatedInterpreterPluginClass
- "Overridden by SmartSyntaxPluginSimulator to wrap a specific plugin class."
- ^self new!
Item was changed:
+ ----- Method: InterpreterPlugin class>>simulatorClass (in category 'accessing') -----
- ----- Method: InterpreterPlugin class>>simulatorClass (in category 'simulation') -----
simulatorClass
"For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code. By default every non-TestInterpreterPlugin can simulate itself."
^ self!
Item was changed:
----- Method: InterpreterPrimitives class>>requiredMethodNames (in category 'translation') -----
requiredMethodNames
+ "return the list of method names that should be retained for export or other support reasons"
- "Return the list of method names that should be retained for export or other support reasons.
- Include all of the selectors for primitives to ensure translation in slang browser."
+ ^super requiredMethodNames, #(floatArg: integerArg: methodArg: methodReturnValue: objectArg: primitiveMethod)!
- ^super requiredMethodNames,
- #(floatArg: integerArg: methodArg: methodReturnValue: objectArg: primitiveMethod),
- (self selectors select: [:e | 'primitive*' match: e])!
Item was removed:
- ----- Method: InterpreterPrimitives>>isBigEnder (in category 'primitive support') -----
- isBigEnder
- "Answer true (non-zero) if running on a big endian machine."
- | endianness anInt cString len i |
- <var: 'cString' type: 'char *'>
- <var: 'endianness' declareC: 'static sqInt endianness = -1'>
- (endianness == -1) ifFalse: [^ endianness]. "answer cached value"
- len := self cCode: 'sizeof(anInt)'
- inSmalltalk: [^ (Smalltalk endianness == #little) not].
- cString := self cCode: '(char *) &anInt' inSmalltalk: [].
- i := 0.
- [i < len] whileTrue:
- [cString at: i put: i.
- i := i + 1].
- endianness := anInt bitAnd: 255.
- ^ endianness
- !
Item was removed:
- ----- Method: InterpreterPrimitives>>primitiveIsBigEnder (in category 'other primitives') -----
- primitiveIsBigEnder
- "Answer true if running on a big endian machine."
- <export: true>
- self isBigEnder
- ifTrue: [self pop: 1 thenPush: objectMemory trueObject]
- ifFalse: [self pop: 1 thenPush: objectMemory falseObject]
- !
Item was changed:
----- Method: InterpreterPrimitives>>success: (in category 'primitive support') -----
success: successBoolean
"Set the state of the primitive failure code/success flag, iff successBoolean
is false. If primFailCode is non-zero a primitive has failed. If primFailCode
is greater than one then its value indicates the reason for failure."
"Use returnTypeC: #sqInt because that's the way it is defined in sq.h.
+ Use no explicit return so that Slang doesn't fail an inlin ingtype-check when
- Use no explicit return so that Slang doesn't fail an inlining type-check when
a primitive with return type void uses ^self success: false to exit."
<returnTypeC: #sqInt>
<inline: true>
successBoolean ifFalse:
["Don't overwrite an error code that has already been set."
self successful ifTrue:
[primFailCode := 1]]!
Item was changed:
----- Method: InterpreterProxy>>initialize (in category 'initialize') -----
initialize
+ successFlag := true.
remapBuffer := OrderedCollection new.
stack := OrderedCollection new.
primFailCode := 0.
!
Item was changed:
----- Method: InterpreterProxy>>primitiveFailFor: (in category 'other') -----
primitiveFailFor: reasonCode
+ "Set specific primitive failure. N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode.
+ Primitive 255 is called to indicate that we are currently simulating a primitive that should fail and the VM should handle that case appropriately (if supported by the VM)."
+ <primitive: 255>
+ ^ primFailCode := reasonCode!
- "Set specific primitive failure.
- N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode."
- (self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt].
- ^primFailCode := reasonCode!
Item was changed:
----- Method: InterpreterProxy>>success: (in category 'other') -----
success: aBoolean
+ self failed ifTrue: [^ self].
- self failed ifTrue:[^self].
aBoolean ifFalse: [
+ self primitiveFailFor: 1.
+ (self confirm: 'A primitive is failing -- Stop simulation?') ifTrue: [self halt]].!
- primFailCode := 1.
- (self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt]]
- !
Item was changed:
----- Method: InterpreterProxy>>synthesizeStackFor:with: (in category 'initialize') -----
synthesizeStackFor: receiver with: args
- <doNotGenerate>
self push: receiver.
argumentCount := args size.
1 to: argumentCount do: [:i | self push: (args at: i)].!
Item was removed:
- ----- Method: InterpreterSimulator>>interpreter (in category 'interpreter shell') -----
- interpreter
- ^self!
Item was removed:
- ----- Method: InterpreterSimulator>>isIntegerObject: (in category 'interpreter access') -----
- isIntegerObject: objectPointer
- "In simulation, an interpreter simulator serves as the interpreter proxy"
- ^ objectMemory isIntegerObject: objectPointer!
Item was changed:
----- Method: InterpreterSimulator>>loadNewPlugin: (in category 'plugin support') -----
loadNewPlugin: pluginString
+ | plugin simClass |
+ transcript cr; show:'Looking for module ', pluginString.
+ (#('FloatArrayPlugin' 'Matrix2x3Plugin')
+ includes: pluginString) ifTrue:
+ [transcript show: ' ... defeated'. ^ nil].
+ plugin := simClass := nil.
+ InterpreterPlugin allSubclassesDo:[:plg|
+ plg moduleName asString = pluginString asString ifTrue:[
+ simClass := plg simulatorClass.
+ plugin ifNil:[plugin := simClass]
+ ifNotNil:[plugin == simClass ifFalse:[^self error:'This won''t work...']].
+ ].
+ ].
+ plugin ifNil:[transcript show: ' ... not found'. ^nil].
+ plugin := plugin new.
- | plugin plugins simulatorClasses |
- transcript cr; show: 'Looking for module ', pluginString.
- "but *why*??"
- (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: pluginString) ifTrue:
- [transcript show: ' ... defeated'. ^nil].
- plugins := InterpreterPlugin allSubclasses select: [:psc| psc moduleName asString = pluginString asString].
- simulatorClasses := (plugins
- select: [:psc| psc simulatorClass notNil]
- thenCollect: [:psc| psc simulatorClass]) asSet.
- simulatorClasses isEmpty ifTrue: [transcript show: ' ... not found'. ^nil].
- simulatorClasses size > 1 ifTrue: [^self error: 'This won''t work...'].
- plugins size > 1 ifTrue:
- [transcript show: '...multiple plugin classes; choosing ', plugins last name].
- plugin := simulatorClasses anyOne newFor: plugins last. "hopefully lowest in the hierarchy..."
plugin setInterpreter: self. "Ignore return value from setInterpreter"
+ (plugin respondsTo: #initialiseModule) ifTrue:[
+ plugin initialiseModule ifFalse:[transcript show: ' ... initialiser failed'.^nil]. "module initialiser failed"
+ ].
- (plugin respondsTo: #initialiseModule) ifTrue:
- [plugin initialiseModule ifFalse:
- [transcript show: ' ... initialiser failed'. ^nil]]. "module initialiser failed"
pluginList := pluginList copyWith: (pluginString asString -> plugin).
+ transcript show:' ... loaded'.
- transcript show: ' ... loaded'.
^pluginList last!
Item was changed:
----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
makeDirEntryName: entryName size: entryNameSize
createDate: createDate modDate: modifiedDate
isDir: dirFlag fileSize: fileSize
| modDateOop createDateOop nameString results |
+ self var: 'entryName' type: 'char *'.
- <var: 'entryName' type: 'char *'>
"allocate storage for results, remapping newly allocated
oops in case GC happens during allocation"
+ objectMemory pushRemappableOop:
+ (objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5).
+ objectMemory pushRemappableOop:
+ (objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: entryNameSize)..
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: createDate).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassArray) indexableSize: 5).
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassByteString) indexableSize: entryNameSize).
- self pushRemappableOop: (self positive32BitIntegerFor: createDate).
- self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
+ modDateOop := objectMemory popRemappableOop.
+ createDateOop := objectMemory popRemappableOop.
+ nameString := objectMemory popRemappableOop.
+ results := objectMemory popRemappableOop.
- modDateOop := self popRemappableOop.
- createDateOop := self popRemappableOop.
- nameString := self popRemappableOop.
- results := self popRemappableOop.
1 to: entryNameSize do: [ :i |
+ objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
- self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
].
+ objectMemory storePointer: 0 ofObject: results withValue: nameString.
+ objectMemory storePointer: 1 ofObject: results withValue: createDateOop.
+ objectMemory storePointer: 2 ofObject: results withValue: modDateOop.
- self storePointer: 0 ofObject: results withValue: nameString.
- self storePointer: 1 ofObject: results withValue: createDateOop.
- self storePointer: 2 ofObject: results withValue: modDateOop.
dirFlag
+ ifTrue: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getTrueObj ]
+ ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getFalseObj ].
+ objectMemory storePointer: 4 ofObject: results
+ withValue: (objectMemory integerObjectOf: fileSize).
- ifTrue: [ self storePointer: 3 ofObject: results withValue: objectMemory trueObject ]
- ifFalse: [ self storePointer: 3 ofObject: results withValue: objectMemory falseObject ].
- self storePointer: 4 ofObject: results
- withValue: (self integerObjectOf: fileSize).
^ results
!
Item was removed:
- ----- Method: InterpreterSimulator>>primitiveDirectoryEntry (in category 'file primitives') -----
- primitiveDirectoryEntry
- | name pathName array result |
- name := self stringOf: self stackTop.
- pathName := self stringOf: (self stackValue: 1).
-
- self successful ifFalse:
- [^self primitiveFail].
-
- array := FileDirectory default primLookupEntryIn: pathName name: name.
- array == nil ifTrue:
- [self pop: 3 thenPush: objectMemory nilObj.
- ^array].
- array == #badDirectoryPath ifTrue:
- [self halt.
- ^self primitiveFail].
- array == #primFailed ifTrue:
- [self halt.
- ^self primitiveFail].
-
- result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
- createDate: (array at: 2) modDate: (array at: 3)
- isDir: (array at: 4) fileSize: (array at: 5).
- self pop: 3.
- self push: result!
Item was changed:
----- Method: InterpreterSimulator>>primitiveDirectoryLookup (in category 'file primitives') -----
primitiveDirectoryLookup
| index pathName array result |
index := self stackIntegerValue: 0.
pathName := (self stringOf: (self stackValue: 1)).
self successful ifFalse: [
^self primitiveFail.
].
array := FileDirectory default primLookupEntryIn: pathName index: index.
array == nil ifTrue: [
self pop: 3.
+ self push: objectMemory getNilObj.
- self push: objectMemory nilObj.
^array.
].
array == #badDirectoryPath ifTrue: [self halt.
^self primitiveFail.
].
result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
createDate: (array at: 2) modDate: (array at: 3)
isDir: (array at: 4) fileSize: (array at: 5).
self pop: 3.
self push: result.
!
Item was changed:
----- Method: InterpreterSimulator>>writeImageFile:size:screenSize: (in category 'image save/restore') -----
writeImageFile: file size: numberOfBytesToWrite screenSize: screenSize
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize |
objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
+ headerSize := 16 * self bytesPerWord.
- headerSize := 16 * objectMemory bytesPerWord.
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
objectMemory startOfMemory.
objectMemory getSpecialObjectsOop.
objectMemory getLastHash.
screenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1 to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (objectMemory getMemory at: index)
toFile: file].
self success: true
!
Item was changed:
----- Method: InterpreterStackPages>>extraStackBytes (in category 'initialization') -----
extraStackBytes
"See initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom:
``Because stack pages grow down...''"
+ ^self cCode: 'BytesPerWord' inSmalltalk: [0]!
- ^self cCode: 'BYTES_PER_WORD' inSmalltalk: [0]!
Item was added:
+ ----- Method: NewObjectMemory>>objectRepresentationClass (in category 'cog jit support') -----
+ objectRepresentationClass
+ <doNotGenerate>
+ ^CogObjectRepresentationForSqueakV3!
Item was changed:
InterpreterPlugin subclass: #SmartSyntaxInterpreterPlugin
+ instanceVariableNames: ''
- instanceVariableNames: 'simulator'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-SmartSyntaxPlugins'!
!SmartSyntaxInterpreterPlugin commentStamp: '<historical>' prior: 0!
Subclass of InterpreterPlugin, used in connection with TestCodeGenerator for named primitives with type coercion specifications!
Item was changed:
+ ----- Method: SmartSyntaxInterpreterPlugin class>>simulatorClass (in category 'instance creation') -----
- ----- Method: SmartSyntaxInterpreterPlugin class>>simulatorClass (in category 'simulation') -----
simulatorClass
"For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code.
By default SmartSyntaxInterpreterPlugin answers nil because methods in these plugins are intended to be embedded in code that pushes and pops from the stack and therefore cannot be run independently. This wrapper code is generated when translated to C. But, unfortunately, this code is missing during simulation. There was an attempt to simulate this, but only the prologue code (getting arg from the stack) is simulated (see simulatePrologInContext:). The epologue code (popping args and pushing result) is not. So I am making this nil until this can be fixed.
Also, beware that primitive methods that take no args exactly match their primitive name (faking out InterpreterSimulator>>callExternalPrimitive:). They should only be called from within wrapper code that simulates the prologue and epilogue. Primitive method that take args don't have this accidental matching problem since their names contain colons while their primitive names do not. - ajh 8/21/2002"
^ nil!
Item was removed:
- ----- Method: SmartSyntaxInterpreterPlugin>>simulator (in category 'accessing') -----
- simulator
- <doNotGenerate>
- ^simulator!
Item was removed:
- ----- Method: SmartSyntaxInterpreterPlugin>>simulator: (in category 'accessing') -----
- simulator: aSmartSyntaxPluginSimulator
- <doNotGenerate>
- simulator := aSmartSyntaxPluginSimulator!
Item was changed:
----- Method: SmartSyntaxPluginSimulator>>setInterpreter: (in category 'initialize') -----
setInterpreter: anInterpreterProxy
interpreterProxy := anInterpreterProxy.
actualPlugin setInterpreter: anInterpreterProxy.
+ self computeSignatureMap!
- "self computeSignatureMap" self flag: #FIXME "part of the oscog type inferencing"!
Item was changed:
----- Method: SocketPlugin>>socketRecordSize (in category 'primitives') -----
socketRecordSize
"Return the size of a Smalltalk socket record in bytes."
+
+ ^ self cCode: 'sizeof(SQSocket)' inSmalltalk: [12]!
- <inline: true>
- ^ self sizeof: #SQSocket!
Item was changed:
----- Method: StackInterpreter>>activateNewClosureMethod:numArgs:mayContextSwitch: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: mayContextSwitch
"Similar to activateNewMethod but for Closure and newMethod."
| numCopied outerContext theMethod closureIP |
<inline: true>
outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
numCopied := self copiedValueCountOfClosure: blockClosure.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
self push: instructionPointer.
self push: framePointer.
framePointer := stackPointer.
self push: theMethod.
self push: (self encodeFrameFieldHasContext: false isBlock: true numArgs: numArgs).
self push: objectMemory nilObject. "FxThisContext field"
self push: (objectMemory fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the copied values..."
0 to: numCopied - 1 do:
[:i|
self push: (objectMemory
fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: blockClosure)].
self assert: (self frameIsBlockActivation: framePointer).
self assert: (self frameHasContext: framePointer) not.
"The initial instructions in the block nil-out remaining temps."
"the instruction pointer is a pointer variable equal to
+ method oop + ip + BaseHeaderSize
- method oop + ip + objectMemory baseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
closureIP := self quickFetchInteger: ClosureStartPCIndex ofObject: blockClosure.
+ instructionPointer := theMethod + closureIP + self baseHeaderSize - 2.
- instructionPointer := theMethod + closureIP + objectMemory baseHeaderSize - 2.
self setMethod: theMethod.
"Now check for stack overflow or an event (interrupt, must scavenge, etc)"
stackPointer < stackLimit ifTrue:
[self handleStackOverflowOrEventAllowContextSwitch: mayContextSwitch]!
Item was changed:
----- Method: StackInterpreter>>arrayValueOf: (in category 'utilities') -----
arrayValueOf: arrayOop
"Return the address of first indexable field of resulting array object, or fail if
the instance variable does not contain an indexable bytes or words object."
"Note: May be called by translated primitive code."
<returnTypeC: #'void *'>
((objectMemory isNonIntegerObject: arrayOop)
and: [objectMemory isWordsOrBytes: arrayOop]) ifTrue:
+ [^self cCoerceSimple: (self pointerForOop: arrayOop + self baseHeaderSize) to: #'void *'].
- [^self cCoerceSimple: (self pointerForOop: arrayOop + objectMemory baseHeaderSize) to: #'void *'].
self primitiveFail!
Item was changed:
----- Method: StackInterpreter>>checkStackIntegrity (in category 'object memory support') -----
checkStackIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccesibleObjects has set a bit at each
object's header. Scan all objects accessible from the stack
checking that every pointer points to a header. Answer if no
dangling pointers were detected."
| ok |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP oop |
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage = stackPage
ifTrue:
[theSP := stackPointer.
theFP := framePointer]
ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP].
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + self bytesPerWord].
- [theSP := theSP + objectMemory bytesPerWord].
[[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' at: theSP; cr.
ok := false].
+ theSP := theSP + self bytesPerWord].
- theSP := theSP + objectMemory bytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' at: theFP + FoxThisContext; cr.
ok := false].
(self isContext: oop) ifFalse:
[self printFrameThing: 'frame ctxt should be context' at: theFP + FoxThisContext; cr.
ok := false]].
oop := self frameMethod: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame mthd' at: theFP + FoxMethod; cr.
ok := false].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + self bytesPerWord.
- [theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext "a.k.a. FoxCallerSavedIP".
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' at: theSP; cr.
ok := false].
+ theSP := theSP + self bytesPerWord]]].
- theSP := theSP + objectMemory bytesPerWord]]].
^ok!
Item was changed:
----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:copiedValues: (in category 'control primitives') -----
closureIn: context numArgs: numArgs instructionPointer: initialIP copiedValues: copiedValues
| newClosure numCopied |
<inline: true>
"numCopied should be zero for nil"
numCopied := objectMemory fetchWordLengthOf: copiedValues.
newClosure := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
- sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context.
objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
0 to: numCopied - 1 do:
[:i|
objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (objectMemory fetchPointer: i ofObject: copiedValues)].
^newClosure!
Item was changed:
----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
closureIn: context numArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
| newClosure |
<inline: true>
+ self assert: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize <= 252.
- self assert: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize <= 252.
newClosure := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
- sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context.
objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
^newClosure!
Item was changed:
----- Method: StackInterpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Note: Assumed to be inlined into the dispatch loop."
| closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage |
<var: #frameToReturnTo type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
<sharedCodeNamed: 'commonReturn' inCase: 120>
"If this is a method simply return to the sender/caller."
(self frameIsBlockActivation: localFP) ifFalse:
[^self commonCallerReturn].
"Since this is a block activation the closure is on the stack above any args and the frame."
closure := self pushedReceiverOrClosureOfFrame: localFP.
home := nil.
"Walk the closure's lexical chain to find the context or frame to return from (home)."
[closure ~~ objectMemory nilObject] whileTrue:
[home := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory fetchPointer: ClosureIndex ofObject: home].
"home is to be returned from provided there is no unwind-protect activation between
this frame and home's sender. Search for an unwind. findUnwindThroughContext:
will answer either the context for an unwind-protect activation or nilObj if the sender
cannot be found or 0 if no unwind is found but the sender is. We must update the
current page's headFrame pointers to enable the search to identify widowed contexts
correctly."
self writeBackHeadFramePointers.
unwindContextOrNilOrZero := self internalFindUnwindThroughContext: home.
unwindContextOrNilOrZero = objectMemory nilObject ifTrue:
["error: can't find home on chain; cannot return"
^self internalCannotReturn: localReturnValue].
unwindContextOrNilOrZero ~~ 0 ifTrue:
[^self internalAboutToReturn: localReturnValue through: unwindContextOrNilOrZero].
"Now we know home is on the sender chain.
We could be returning to either a context or a frame. Find out which."
contextToReturnTo := nil.
(self isMarriedOrWidowedContext: home)
ifTrue:
[self assert: (self checkIsStillMarriedContext: home currentFP: localFP).
theFP := self frameOfMarriedContext: home.
(self isBaseFrame: theFP)
ifTrue:
[contextToReturnTo := self frameCallerContext: theFP]
ifFalse:
[frameToReturnTo := self frameCallerFP: theFP]]
ifFalse:
[contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home.
((self isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
frameToReturnTo := self frameOfMarriedContext: contextToReturnTo.
contextToReturnTo := nil]].
"If returning to a context we must make a frame for it unless it is dead."
contextToReturnTo ~= nil ifTrue:
[frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo.
frameToReturnTo == 0 ifTrue:
["error: home's sender is dead; cannot return"
^self internalCannotReturn: localReturnValue]].
"Now we have a frame to return to. If it is on a different page we must free intervening pages and
nil out intervening contexts. We must free intervening stack pages because if we leave the pages
to be divorced then their contexts will be divorced with intact senders and instruction pointers. This
code is similar to primitiveTerminateTo. We must move any frames on itervening pages above the
frame linked to because these may be in use, e.g. via co-routining (see baseFrameReturn)."
self assert: stackPages pageListIsWellFormed.
newPage := stackPages stackPageFor: frameToReturnTo.
newPage ~~ stackPage ifTrue:
[| currentCtx thePage nextCntx |
currentCtx := self frameCallerContext: stackPage baseFP.
self assert: (self isContext: currentCtx).
stackPages freeStackPage: stackPage.
[self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse:
[(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
theFP ~= thePage headFP ifTrue:
["Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
self moveFramesIn: thePage through: (self findFrameAbove: theFP inPage: thePage) toPage: self newStackPage].
currentCtx := self frameCallerContext: thePage baseFP.
self freeStackPage: thePage]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]].
self setStackPageAndLimit: newPage.
localSP := stackPage headSP.
localFP := stackPage headFP].
"Two cases. Returning to the top frame on a new page or an interior frame on the current page.
The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer
in the caller frame. We need to peel back any frames on the page until we get to the correct frame."
localFP = frameToReturnTo
ifTrue: "pop the saved IP, push the return value and continue."
[localIP := self pointerForOop: self internalStackTop]
ifFalse:
[[callerFP := localFP.
localFP := self frameCallerFP: localFP.
localFP ~~ frameToReturnTo] whileTrue.
localIP := self frameCallerSavedIP: callerFP.
+ localSP := (self frameCallerSP: callerFP) - self bytesPerWord].
- localSP := (self frameCallerSP: callerFP) - objectMemory bytesPerWord].
self internalStackTopPut: localReturnValue.
self setMethod: (self frameMethod: localFP).
^self fetchNextBytecode!
Item was changed:
----- Method: StackInterpreter>>commonSend (in category 'message sending') -----
commonSend
"Send a message, starting lookup with the receiver's class."
"Assume: messageSelector and argumentCount have been set, and that
the receiver and arguments have been pushed onto the stack,"
"Note: This method is inlined into the interpreter dispatch loop."
<sharedCodeNamed: 'commonSend' inCase: 131>
+ self sendBreak: messageSelector + self baseHeaderSize
- self sendBreak: messageSelector + objectMemory baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: (self internalStackValue: argumentCount).
self internalFindNewMethod.
self internalExecuteNewMethod.
self fetchNextBytecode!
Item was changed:
----- Method: StackInterpreter>>contextInstructionPointer:frame: (in category 'frame access') -----
contextInstructionPointer: theIP frame: theFP
<var: #theFP type: #'char *'>
self assert: (self validInstructionPointer: theIP inFrame: theFP).
+ ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - self baseHeaderSize + 2!
- ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - objectMemory baseHeaderSize + 2!
Item was changed:
----- Method: StackInterpreter>>convertFloatsToPlatformOrderFrom:to: (in category 'image save/restore') -----
convertFloatsToPlatformOrderFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part.
Ensure floats are in platform-order."
| oop temp |
objectMemory vmEndianness = imageFloatsBigEndian ifTrue:
[^self].
self assert: ClassFloatCompactIndex ~= 0.
oop := startOop.
[self oop: oop isLessThan: stopAddr] whileTrue:
[(objectMemory isFreeObject: oop) ifFalse:
[(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex ifTrue:
+ [temp := self longAt: oop + self baseHeaderSize.
+ self longAt: oop + self baseHeaderSize put: (self longAt: oop + self baseHeaderSize + 4).
+ self longAt: oop + self baseHeaderSize + 4 put: temp]].
- [temp := self longAt: oop + objectMemory baseHeaderSize.
- self longAt: oop + objectMemory baseHeaderSize put: (self longAt: oop + objectMemory baseHeaderSize + 4).
- self longAt: oop + objectMemory baseHeaderSize + 4 put: temp]].
oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: StackInterpreter>>createActualMessageTo: (in category 'message sending') -----
createActualMessageTo: lookupClass
"Bundle up the selector, arguments and lookupClass into a Message object.
In the process it pops the arguments off the stack, and pushes the message object.
This can then be presented as the argument of e.g. #doesNotUnderstand:"
| argumentArray message |
<inline: false> "This is a useful break-point"
self assert: ((objectMemory isIntegerObject: messageSelector) or: [objectMemory addressCouldBeObj: messageSelector]).
argumentArray := objectMemory eeInstantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
message := objectMemory eeInstantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
"Since the array is new can use unchecked stores."
+ (argumentCount - 1) * self bytesPerWord to: 0 by: self bytesPerWord negated do:
- (argumentCount - 1) * objectMemory bytesPerWord to: 0 by: objectMemory bytesPerWord negated do:
[:i|
+ self longAt: argumentArray + self baseHeaderSize + i put: self popStack].
- self longAt: argumentArray + objectMemory baseHeaderSize + i put: self popStack].
"Since message is new can use unchecked stores."
objectMemory storePointerUnchecked: MessageSelectorIndex ofObject: message withValue: messageSelector.
objectMemory storePointerUnchecked: MessageArgumentsIndex ofObject: message withValue: argumentArray.
objectMemory storePointerUnchecked: MessageLookupClassIndex ofObject: message withValue: lookupClass.
self push: message.
argumentCount := 1.!
Item was changed:
----- Method: StackInterpreter>>dbgFloatValueOf: (in category 'utilities') -----
dbgFloatValueOf: oop
"This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh."
| result |
<returnTypeC: #double>
<var: #result type: #double>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
((objectMemory isNonIntegerObject: oop)
and: [(objectMemory fetchClassOfNonInt: oop) = (objectMemory splObj: ClassFloat)]) ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: oop + self baseHeaderSize into: result.
- objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result.
^result].
^nil!
Item was changed:
----- Method: StackInterpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') -----
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
displayObj := objectMemory splObj: TheDisplay.
aForm = displayObj ifFalse: [^ nil].
self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]).
self successful ifTrue: [
dispBits := objectMemory fetchPointer: 0 ofObject: displayObj.
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
d := self fetchInteger: 3 ofObject: displayObj.
].
l < 0 ifTrue:[left := 0] ifFalse: [left := l].
r > w ifTrue: [right := w] ifFalse: [right := r].
t < 0 ifTrue: [top := 0] ifFalse: [top := t].
b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
((left <= right) and: [top <= bottom]) ifFalse: [^nil].
self successful ifTrue: [
(objectMemory isIntegerObject: dispBits) ifTrue: [
surfaceHandle := objectMemory integerValueOf: dispBits.
showSurfaceFn = 0 ifTrue: [
showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
showSurfaceFn = 0 ifTrue: [^self success: false]].
self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
] ifFalse: [
+ dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array"
- dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array"
self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
inSmalltalk: [self showDisplayBits: dispBitsIndex
w: w h: h d: d
left: left right: right top: top bottom: bottom]
].
]!
Item was changed:
----- Method: StackInterpreter>>divorceFramesIn: (in category 'frame access') -----
divorceFramesIn: aStackPage
| theFP calleeFP theSP theIP calleeContext theContext |
<inline: false>
<var: #aStackPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #calleeFP type: #'char *'>
<var: #theSP type: #'char *'>
statStackPageDivorce := statStackPageDivorce + 1.
theFP := aStackPage headFP.
theSP := aStackPage headSP.
theIP := stackPages longAt: theSP.
+ theSP := theSP + self bytesPerWord. "theSP points at hottest item on frame's stack"
- theSP := theSP + objectMemory bytesPerWord. "theSP points at hottest item on frame's stack"
calleeContext := nil.
[theContext := self ensureFrameIsMarried: theFP SP: theSP.
self updateStateOfSpouseContextForFrame: theFP WithSP: theSP.
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self contextInstructionPointer: theIP frame: theFP).
self assert: (self frameReceiver: theFP)
= (objectMemory fetchPointer: ReceiverIndex ofObject: theContext).
calleeContext ~~ nil ifTrue:
[objectMemory storePointer: SenderIndex
ofObject: calleeContext
withValue: theContext].
calleeContext := theContext.
calleeFP := theFP.
theIP := (self frameCallerSavedIP: theFP) asInteger.
theFP := self frameCallerFP: theFP.
theFP ~= 0] whileTrue:
["theSP points at stacked hottest item on frame's stack"
theSP := self frameCallerSP: calleeFP].
objectMemory storePointer: SenderIndex
ofObject: theContext
withValue: (self frameCallerContext: calleeFP).
"The page is now free; mark it so."
aStackPage baseFP: 0!
Item was changed:
----- Method: StackInterpreter>>encodeFrameFieldHasContext:isBlock:numArgs: (in category 'frame access') -----
encodeFrameFieldHasContext: hasContext "<Boolean>" isBlock: isBlock "<Boolean>" numArgs: numArgs
"For ``fast'' temporary access (ok, to mitigate slower temp access) we need
fast access to a method's numArgs. Could have a variable set on save and return.
We'll investigate this. For the moment we just use a byte in the frameFlags
field. This is endian dependent. Store numArgs in byte at FoxFrameFields + 1.
Store hasContext flag in top bit (allows for 64-bit tags) of byte at FoxFrameFields.
Make frameFields look like a SmallInteger for the benefit of gc (dubious)."
"bitsPerWord := BytesPerWord * 8"
<inline: true>
^VMBIGENDIAN
ifTrue: [1
+ + (numArgs << ((self bytesPerWord * 8) - 8))
+ + (hasContext ifTrue: [1 << ((self bytesPerWord * 8) - 16)] ifFalse: [0])
+ + (isBlock ifTrue: [1 << ((self bytesPerWord * 8) - 24)] ifFalse: [0])]
- + (numArgs << ((objectMemory bytesPerWord * 8) - 8))
- + (hasContext ifTrue: [1 << ((objectMemory bytesPerWord * 8) - 16)] ifFalse: [0])
- + (isBlock ifTrue: [1 << ((objectMemory bytesPerWord * 8) - 24)] ifFalse: [0])]
ifFalse: [1
+ (numArgs << 8)
+ (hasContext ifTrue: [1 << 16] ifFalse: [0])
+ (isBlock ifTrue: [1 << 24] ifFalse: [0])]!
Item was changed:
----- Method: StackInterpreter>>externalDivorceFrame:andContext: (in category 'frame access') -----
externalDivorceFrame: theFP andContext: ctxt
"Divorce a single frame and its context. If it is not the top frame of a stack this means splitting its stack."
| thePage onCurrent theSP callerCtx newPage frameAbove callerFP callerSP callerIP theIP |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #callerSP type: #'char *'>
"stackPage needs to have current head pointers to avoid confusion."
self assert: theFP ~= framePointer.
self assert: (stackPage = 0 or: [stackPage = stackPages mostRecentlyUsedPage]).
thePage := stackPages stackPageFor: theFP.
(onCurrent := thePage = stackPage) ifFalse:
[stackPages markStackPageNextMostRecentlyUsed: thePage].
theSP := self findSPOf: theFP on: thePage.
self updateStateOfSpouseContextForFrame: theFP WithSP: theSP.
callerCtx := self ensureCallerContext: theFP.
(frameAbove := self findFrameAbove: theFP inPage: thePage) == 0
ifTrue: "If we're divorcing the top frame we can simply peel it off."
[theIP := stackPages longAt: thePage headSP]
ifFalse: "othewise move all frames above to a new stack and then peel the frame off."
[newPage := self newStackPage.
theIP := self oopForPointer: (self frameCallerSavedIP: frameAbove).
frameAbove := self moveFramesIn: thePage through: frameAbove toPage: newPage.
onCurrent
ifTrue:
[self setStackPageAndLimit: newPage.
framePointer := stackPage headFP.
stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: newPage].
self assert: (self frameCallerContext: frameAbove) = ctxt].
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: ctxt
withValue: (self contextInstructionPointer: theIP frame: theFP).
objectMemory storePointer: SenderIndex
ofObject: ctxt
withValue: callerCtx.
callerFP := self frameCallerFP: theFP.
callerFP == 0 "theFP is a base frame; it is now alone; free the entire page"
ifTrue: [stackPages freeStackPage: thePage]
ifFalse:
[callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
+ callerSP := (self frameCallerSP: theFP) - self bytesPerWord.
- callerSP := (self frameCallerSP: theFP) - objectMemory bytesPerWord.
stackPages longAt: callerSP put: callerIP.
self setHeadFP: callerFP andSP: callerSP inPage: thePage]
!
Item was changed:
----- Method: StackInterpreter>>findSPOrNilOf:on:startingFrom: (in category 'frame access') -----
findSPOrNilOf: theFP on: thePage startingFrom: startFrame
"Search for the stack pointer for theFP. This points to the hottest item on the frame's stack.
DO NOT CALL THIS WITH theFP == localFP OR theFP == framePointer!!"
<var: #aFrame type: #'char *'>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<returnTypeC: #'char *'>
| aFrame theSP |
<inline: true>
<asmLabel: false>
<var: #startFrame type: #'char *'>
<var: #theSP type: #'char *'>
self assert: (stackPages isFree: thePage) not.
aFrame := startFrame.
theSP := thePage headSP.
aFrame = theFP ifTrue:
[theSP >= aFrame ifTrue:
["If the SP is invalid return the pointer to the receiver field."
^self frameReceiverOffset: aFrame].
"Skip the instruction pointer on top of stack of inactive pages."
^thePage = stackPage
ifTrue: [theSP]
+ ifFalse: [theSP + self bytesPerWord]].
- ifFalse: [theSP + objectMemory bytesPerWord]].
[theSP := self frameCallerSP: aFrame.
aFrame := self frameCallerFP: aFrame.
aFrame ~= 0] whileTrue:
[theFP = aFrame ifTrue:
[^theSP]].
^nil!
Item was changed:
----- Method: StackInterpreter>>floatObjectOf: (in category 'object format') -----
floatObjectOf: aFloat
| newFloatObj |
<inline: false>
<var: #aFloat type: #double>
self flag: #Dan.
+ newFloatObj := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize.
+ objectMemory storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
- newFloatObj := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + objectMemory baseHeaderSize.
- objectMemory storeFloatAt: newFloatObj + objectMemory baseHeaderSize from: aFloat.
^ newFloatObj.
!
Item was changed:
----- Method: StackInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
"Note: May be called by translated primitive code."
| result |
<returnTypeC: #double>
<var: #result type: #double>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
(because assertClassOf:is:compactClassIndex: has an inline: pragma) the
phrase (self splObj: ClassArray) is expanded in-place and is _not_
evaluated if ClassArrayCompactIndex is non-zero."
self assertClassOf: oop
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: oop + self baseHeaderSize into: result.
- objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result.
^result].
^0.0!
Item was changed:
----- Method: StackInterpreter>>frameCallerSP: (in category 'frame access') -----
frameCallerSP: theFP
"Answer the SP of the caller provided theFP is not a base frame.
This points to the hottest item on the caller frame's stack."
<var: #theFP type: #'char *'>
<returnTypeC: 'char *'>
<asmLabel: false>
self assert: (self isBaseFrame: theFP) not.
+ ^theFP + (self frameStackedReceiverOffset: theFP) + self bytesPerWord!
- ^theFP + (self frameStackedReceiverOffset: theFP) + objectMemory bytesPerWord!
Item was changed:
----- Method: StackInterpreter>>frameCallerStackPointer: (in category 'frame access') -----
frameCallerStackPointer: theFP
"Answer the stack pointer of the caller frame."
<var: #theFP type: #'char *'>
<returnTypeC: #'char *'>
<inline: true>
<asmLabel: false>
self assert: (self isBaseFrame: theFP) not.
+ ^theFP + (self frameStackedReceiverOffset: theFP) + self bytesPerWord!
- ^theFP + (self frameStackedReceiverOffset: theFP) + objectMemory bytesPerWord!
Item was changed:
----- Method: StackInterpreter>>frameInstructionPointerForContext:method: (in category 'frame access') -----
frameInstructionPointerForContext: aContext method: aMethod
"Answer the instruction pointer for usage in a frame (a pointer to a bytecode)
from the index instructionPointer in the given context."
^aMethod
+ (self quickFetchInteger: InstructionPointerIndex ofObject: aContext)
+ + self baseHeaderSize
- + objectMemory baseHeaderSize
- 2!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiver:numArgs: (in category 'frame access') -----
frameStackedReceiver: theFP numArgs: numArgs
"Answer the stacked receiver given the frame's argument count.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
+ ^stackPages longAt: theFP + FoxCallerSavedIP + self bytesPerWord + (numArgs << self shiftForWord)!
- ^stackPages longAt: theFP + FoxCallerSavedIP + objectMemory bytesPerWord + (numArgs << self shiftForWord)!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiverOffset: (in category 'frame access') -----
frameStackedReceiverOffset: theFP
"Answer the offset in bytes from the a frame pointer to its stacked receiver.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
+ ^FoxCallerSavedIP + self bytesPerWord + ((self frameNumArgs: theFP) << self shiftForWord)!
- ^FoxCallerSavedIP + objectMemory bytesPerWord + ((self frameNumArgs: theFP) << self shiftForWord)!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiverOffset:numArgs: (in category 'frame access') -----
frameStackedReceiverOffset: theFP numArgs: numArgs
"Answer the offset in bytes from the a frame pointer to its stacked receiver.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
+ ^FoxCallerSavedIP + self bytesPerWord + (numArgs << self shiftForWord)!
- ^FoxCallerSavedIP + objectMemory bytesPerWord + (numArgs << self shiftForWord)!
Item was changed:
----- Method: StackInterpreter>>getErrorObjectFromPrimFailCode (in category 'message sending') -----
getErrorObjectFromPrimFailCode
"Answer the errorCode object to supply to a failing primitive method that accepts one.
If there is a primitive error table and the primFailCode is a valid index there-in answer
the coprresponding entry in the table, otherwise simply answer the code as an integer."
| table |
primFailCode > 0 ifTrue:
[table := objectMemory splObj: PrimErrTableIndex.
+ primFailCode <= ((objectMemory lastPointerOf: table) // self bytesPerWord) ifTrue:
- primFailCode <= ((objectMemory lastPointerOf: table) // objectMemory bytesPerWord) ifTrue:
[^objectMemory fetchPointer: primFailCode - 1 ofObject: table]].
^objectMemory integerObjectOf: primFailCode!
Item was changed:
----- Method: StackInterpreter>>highBit: (in category 'stack pages') -----
highBit: anUnsignedValue
"This is a C implementation needed by stackPageByteSize when translated."
| shifted bitNo |
<var: #anUnsignedValue type: #usqInt>
<var: #shifted type: #usqInt>
shifted := anUnsignedValue.
bitNo := 0.
+ self cppIf: [self bytesPerWord > 4]
- self cppIf: [objectMemory bytesPerWord > 4]
ifTrue:
[shifted < (1 << 32) ifFalse:
[shifted := shifted >> 32.
bitNo := bitNo + 32]].
shifted < (1 << 16) ifFalse:
[shifted := shifted >> 16.
bitNo := bitNo + 16].
shifted < (1 << 8) ifFalse:
[shifted := shifted >> 8.
bitNo := bitNo + 8].
shifted < (1 << 4) ifFalse:
[shifted := shifted >> 4.
bitNo := bitNo + 4].
shifted < (1 << 2) ifFalse:
[shifted := shifted >> 2.
bitNo := bitNo + 2].
shifted < (1 << 1) ifFalse:
[shifted := shifted >> 1.
bitNo := bitNo + 1].
"shifted 0 or 1 now"
^bitNo + shifted!
Item was changed:
----- Method: StackInterpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') -----
imageFormatCompatibilityVersion
"This VM is backward-compatible with the immediately preceeding version."
+ ^self bytesPerWord == 4 ifTrue: [6504] ifFalse: [68002]!
- ^objectMemory bytesPerWord == 4 ifTrue: [6504] ifFalse: [68002]!
Item was changed:
----- Method: StackInterpreter>>imageFormatVersion (in category 'image save/restore') -----
imageFormatVersion
"Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."
+ ^self bytesPerWord == 4 ifTrue: [6505] ifFalse: [68003]!
- ^objectMemory bytesPerWord == 4 ifTrue: [6505] ifFalse: [68003]!
Item was changed:
----- Method: StackInterpreter>>initStackPages (in category 'initialization') -----
initStackPages
"Initialize the stackPages. This version is only for simulation
because Slang refuses to inline it, which makes the alloca invalid."
| stackPageBytes stackPagesBytes theStackMemory |
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: 'alloca(stackPagesBytes)'
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / self bytesPerWord
+ pageSize: stackPageBytes / self bytesPerWord
- numSlots: stackPagesBytes / objectMemory bytesPerWord
- pageSize: stackPageBytes / objectMemory bytesPerWord
stackLimitOffset: self stackLimitOffset
stackPageHeadroom: self stackPageHeadroom!
Item was changed:
----- Method: StackInterpreter>>initStackPagesAndInterpret (in category 'initialization') -----
initStackPagesAndInterpret
"Initialize the stack pages and enter interpret. Use alloca'ed memory so that when
we have a JIT its stack pointer will be on the native stack since alloca allocates
memory on the stack. Certain thread systems use the native stack pointer as the
frame ID so putting the stack anywhere else can confuse the thread system."
"This should be in its own initStackPages method but Slang can't inline
C code strings."
| stackPageBytes stackPagesBytes theStackMemory |
<var: #theStackMemory type: #'void *'>
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: 'alloca(stackPagesBytes)'
inSmalltalk:
[stackPages := self stackPagesClass new.
stackPages initializeWithByteSize: stackPagesBytes for: self].
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / self bytesPerWord
+ pageSize: stackPageBytes / self bytesPerWord
- numSlots: stackPagesBytes / objectMemory bytesPerWord
- pageSize: stackPageBytes / objectMemory bytesPerWord
stackLimitOffset: self stackLimitOffset
stackPageHeadroom: self stackPageHeadroom.
"Once the stack pages are initialized we can continue to bootstrap the system."
self loadInitialContext.
"We're ready for the heartbeat (poll interrupt)"
self ioInitHeartbeat.
self interpret.
^nil!
Item was changed:
----- Method: StackInterpreter>>initialPCForHeader:method: (in category 'compiled methods') -----
initialPCForHeader: methodHeader method: theMethod
+ ^theMethod + ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + self baseHeaderSize!
- ^theMethod + ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + objectMemory baseHeaderSize!
Item was changed:
----- Method: StackInterpreter>>internalPop: (in category 'internal interpreter access') -----
internalPop: nItems
"In the StackInterpreter stacks grow down."
+ localSP := localSP + (nItems * self bytesPerWord)!
- localSP := localSP + (nItems * objectMemory bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>internalPop:thenPush: (in category 'internal interpreter access') -----
internalPop: nItems thenPush: oop
"In the StackInterpreter stacks grow down."
+ stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * self bytesPerWord)) put: oop!
- stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * objectMemory bytesPerWord)) put: oop!
Item was changed:
----- Method: StackInterpreter>>internalPopStack (in category 'internal interpreter access') -----
internalPopStack
"In the StackInterpreter stacks grow down."
| top |
top := stackPages longAt: localSP.
+ localSP := localSP + self bytesPerWord.
- localSP := localSP + objectMemory bytesPerWord.
^top!
Item was changed:
----- Method: StackInterpreter>>internalPush: (in category 'internal interpreter access') -----
internalPush: object
"In the StackInterpreter stacks grow down."
+ stackPages longAtPointer: (localSP := localSP - self bytesPerWord) put: object!
- stackPages longAtPointer: (localSP := localSP - objectMemory bytesPerWord) put: object!
Item was changed:
----- Method: StackInterpreter>>internalStackValue: (in category 'internal interpreter access') -----
internalStackValue: offset
"In the StackInterpreter stacks grow down."
+ ^stackPages longAtPointer: localSP + (offset * self bytesPerWord)!
- ^stackPages longAtPointer: localSP + (offset * objectMemory bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>interpreterAllocationReserveBytes (in category 'stack pages') -----
interpreterAllocationReserveBytes
"At a rough approximation we may need to allocate up to a couple
of page's worth of contexts when switching stack pages, assigning
to senders, etc. But the snapshot primitive voids all stack pages.
So a safe margin is the size of a large context times the maximum
number of frames per page times the number of pages."
| availableBytesPerPage maxFramesPerPage |
availableBytesPerPage := self stackPageByteSize - self stackLimitOffset - self stackPageHeadroom.
+ maxFramesPerPage := availableBytesPerPage / self bytesPerWord // FrameSlots.
- maxFramesPerPage := availableBytesPerPage / objectMemory bytesPerWord // FrameSlots.
^2 raisedTo: (maxFramesPerPage * LargeContextSize * numStackPages) highBit!
Item was changed:
----- Method: StackInterpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
If it is a Float, then load its value and return it.
Otherwise fail -- ie return with primErrorCode non-zero."
| result |
<inline: true>
<asmLabel: false>
<returnTypeC: #double>
<var: #result type: #double>
(objectMemory isIntegerObject: floatOrInt) ifTrue:
[^(objectMemory integerValueOf: floatOrInt) asFloat].
self assertClassOf: floatOrInt
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self cCode: '' inSmalltalk: [result := Float new: 2].
self successful ifTrue:
+ [objectMemory fetchFloatAt: floatOrInt + self baseHeaderSize into: result].
- [objectMemory fetchFloatAt: floatOrInt + objectMemory baseHeaderSize into: result].
^result!
Item was changed:
----- Method: StackInterpreter>>lookupMethodInClass: (in category 'message sending') -----
lookupMethodInClass: class
| currentClass dictionary found |
<inline: false>
self assert: class ~~ objectMemory nilObject.
currentClass := class.
[currentClass ~= objectMemory nilObject]
whileTrue:
[dictionary := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currentClass.
dictionary = objectMemory nilObject ifTrue:
["MethodDict pointer is nil (hopefully due a swapped out stub)
-- raise exception #cannotInterpret:."
self createActualMessageTo: class.
messageSelector := objectMemory splObj: SelectorCannotInterpret.
+ self sendBreak: messageSelector + self baseHeaderSize
- self sendBreak: messageSelector + objectMemory baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: nil.
^self lookupMethodInClass: (self superclassOf: currentClass)].
found := self lookupMethodInDictionary: dictionary.
found ifTrue: [^currentClass].
currentClass := self superclassOf: currentClass].
"Could not find #doesNotUnderstand: -- unrecoverable error."
messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
[self error: 'Recursive not understood error encountered'].
"Cound not find a normal message -- raise exception #doesNotUnderstand:"
self createActualMessageTo: class.
messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
+ self sendBreak: messageSelector + self baseHeaderSize
- self sendBreak: messageSelector + objectMemory baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: nil.
^self lookupMethodInClass: class!
Item was changed:
----- Method: StackInterpreter>>makeBaseFrameFor: (in category 'frame access') -----
makeBaseFrameFor: aContext "<Integer>"
"Marry aContext with the base frame of a new stack page. Build
the base frame to reflect the context's state. Answer the new page."
| page pointer theMethod numArgs stackPtrIndex maybeClosure |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
<returnTypeC: 'StackPage *'>
self assert: (self isSingleContext: aContext).
page := self newStackPage.
pointer := page baseAddress.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext.
"If the frame is a closure activation then the closure should be on the stack in
the pushed receiver position (closures receiver the value[:value:] messages).
Otherwise it should be the receiver proper."
maybeClosure := (objectMemory fetchPointer: ClosureIndex ofObject: aContext).
maybeClosure ~= objectMemory nilObject
ifTrue: [numArgs := self argumentCountOfClosure: maybeClosure.
stackPages longAt: pointer put: maybeClosure]
ifFalse:
[numArgs := self argumentCountOf: theMethod.
stackPages longAt: pointer put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is sender context in base frame"
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"base frame's saved fp is null"
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: 0.
page baseFP: pointer; headFP: pointer.
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: theMethod.
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: aContext.
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext).
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"last thing on stack is the instruction pointer"
(objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)) ifFalse:
[self error: 'context is not resumable'].
stackPages
+ longAt: (pointer := pointer - self bytesPerWord)
- longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (self frameInstructionPointerForContext: aContext method: theMethod).
self assert: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)
= (self contextInstructionPointer: (stackPages longAt: pointer) frame: page baseFP).
page headSP: pointer.
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity)"
objectMemory storePointerUnchecked: SenderIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: page baseFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: 0).
self assert: (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)).
self assert: (self frameOfMarriedContext: aContext) = page baseFP.
^page!
Item was changed:
----- Method: StackInterpreter>>makePointwithxValue:yValue: (in category 'utilities') -----
makePointwithxValue: xValue yValue: yValue
"make a Point xValue@yValue.
We know both will be integers so no value nor root checking is needed"
| pointResult |
+ pointResult := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord.
- pointResult := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * objectMemory bytesPerWord.
objectMemory storePointerUnchecked: XIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: xValue).
objectMemory storePointerUnchecked: YIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: yValue).
^ pointResult!
Item was changed:
----- Method: StackInterpreter>>mapStackPages (in category 'object memory support') -----
mapStackPages
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #'char *'>
"Need to write back the frame pointers unless all pages are free (as in snapshot)"
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP theIPPtr theIP oop |
thePage := stackPages stackPageAt: i.
thePage isFree ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage
ifTrue: [theIPPtr := 0]
ifFalse:
[theIPPtr := theSP.
+ theSP := theSP + self bytesPerWord].
- theSP := theSP + objectMemory bytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (thePage addressIsInPage: theSP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theFP]).
[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[stackPages longAt: theSP put: (objectMemory remap: oop)].
+ theSP := theSP + self bytesPerWord].
- theSP := theSP + objectMemory bytesPerWord].
(self frameHasContext: theFP) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory remap: (self frameContext: theFP))].
theIPPtr ~= 0 ifTrue:
[self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
stackPages
longAt: theFP + FoxMethod
put: (objectMemory remap: (self frameMethod: theFP)).
theIPPtr ~= 0 ifTrue:
[stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + self bytesPerWord.
- [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory bytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext. "a.k.a. FoxCallerSavedIP"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[stackPages longAt: theSP put: (objectMemory remap: oop)].
+ theSP := theSP + self bytesPerWord]]]!
- theSP := theSP + objectMemory bytesPerWord]]]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + self bytesPerWord].
- [theSP := theSP + objectMemory bytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + self bytesPerWord].
- theSP := theSP + objectMemory bytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (self isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + self bytesPerWord.
- [theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord.
theFP := callerFP].
theSP := self isCog
+ ifTrue: [theFP + FoxCallerSavedIP + self bytesPerWord] "caller ip is ceBaseReturnPC"
- ifTrue: [theFP + FoxCallerSavedIP + objectMemory bytesPerWord] "caller ip is ceBaseReturnPC"
ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + self bytesPerWord]!
- theSP := theSP + objectMemory bytesPerWord]!
Item was changed:
----- Method: StackInterpreter>>marriedContext:pointsTo:stackDeltaForCurrentFrame: (in category 'frame access') -----
marriedContext: spouseContext pointsTo: anOop stackDeltaForCurrentFrame: stackDeltaForCurrentFrame
"This is a helper for primitiveObjectPointsTo so it *does not* check the frameContext field because that is an implicit self-reference not present in the stale ."
| theFP thePage theSP rcvrOffset |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #rcvrOffset type: #'char *'>
theFP := self frameOfMarriedContext: spouseContext.
theFP = framePointer
+ ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * self bytesPerWord)]
- ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * objectMemory bytesPerWord)]
ifFalse:
[thePage := stackPages stackPageFor: theFP.
theSP := self findSPOf: theFP on: thePage].
(objectMemory isIntegerObject: anOop)
ifTrue: "Check stack and instruction pointer fields."
[(anOop = (objectMemory integerObjectOf: (self stackPointerIndexForFrame: theFP WithSP: theSP))
or: [anOop = (self externalInstVar: InstructionPointerIndex ofContext: spouseContext)]) ifTrue:
[^true]]
ifFalse: "Check method and sender fields, avoiding unnecessarily reifying sender context."
[anOop = (self frameMethodObject: theFP) ifTrue:
[^true].
(self isBaseFrame: theFP)
ifTrue: [anOop = (self frameCallerContext: theFP) ifTrue:
[^true]]
ifFalse: [((self frameHasContext: (self frameCallerFP: theFP))
and: [anOop = (self frameContext: (self frameCallerFP: theFP))]) ifTrue:
[^true]]].
"Now check receiver, temps and stack contents"
rcvrOffset := self frameReceiverOffset: theFP.
[theSP <= rcvrOffset] whileTrue:
[anOop = (stackPages longAt: theSP) ifTrue:
[^true].
+ theSP := theSP + self bytesPerWord].
- theSP := theSP + objectMemory bytesPerWord].
"Finally check stacked receiver (closure field or duplicate of receiver) and arguments"
+ theSP := theFP + FoxCallerSavedIP + self bytesPerWord.
- theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord.
rcvrOffset := theFP + (self frameStackedReceiverOffset: theFP).
[theSP <= rcvrOffset] whileTrue:
[anOop = (stackPages longAt: theSP) ifTrue:
[^true].
+ theSP := theSP + self bytesPerWord].
- theSP := theSP + objectMemory bytesPerWord].
^false!
Item was changed:
----- Method: StackInterpreter>>marryFrame:SP: (in category 'frame access') -----
marryFrame: theFP SP: theSP
"Marry an unmarried frame. This means creating a spouse context
initialized with a subset of the frame's state (state through the last argument)
that references the frame."
| theContext methodHeader byteSize numArgs numStack closureOrNil |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
self assert: (self frameHasContext: theFP) not.
methodHeader := self headerOf: (self frameMethod: theFP).
"Decide how much of the stack to preserve in widowed contexts. Preserving too much
state will potentially hold onto garbage. Holding onto too little may mean that a dead
context isn't informative enough in a debugging situation. We compromise, retaining
only the arguments with no temporaries. Note that we still set the stack pointer to its
current value, but stack contents other than the arguments are nil."
numArgs := self frameNumArgs: theFP.
numStack := self stackPointerIndexForFrame: theFP WithSP: theSP.
closureOrNil := (self frameIsBlockActivation: theFP)
ifTrue: [self pushedReceiverOrClosureOfFrame: theFP]
ifFalse: [objectMemory nilObject].
byteSize := (methodHeader bitAnd: LargeContextBit) ~= 0
ifTrue: [LargeContextSize]
ifFalse: [SmallContextSize].
theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize.
+ self assert: numStack + ReceiverIndex << self shiftForWord + self baseHeaderSize <= byteSize.
- self assert: numStack + ReceiverIndex << self shiftForWord + objectMemory baseHeaderSize <= byteSize.
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity)"
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: theFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: numStack).
objectMemory storePointerUnchecked: MethodIndex
ofObject: theContext
withValue: (self frameMethod: theFP).
objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil.
objectMemory storePointerUnchecked: ReceiverIndex
ofObject: theContext
withValue: (self frameReceiver: theFP).
"Store just the arguments. If the frame is divorced the context
will have valid arguments but all temporaries will be nil."
1 to: numArgs do:
[:i|
objectMemory storePointerUnchecked: ReceiverIndex + i
ofObject: theContext "inline self temporary: i - 1 in:theFP"
withValue: (stackPages longAt: theFP
+ FoxCallerSavedIP
+ + ((numArgs - i + 1) * self bytesPerWord))].
- + ((numArgs - i + 1) * objectMemory bytesPerWord))].
numArgs + 1 to: numStack do:
[:i|
objectMemory storePointerUnchecked: ReceiverIndex + i
ofObject: theContext
withValue: objectMemory nilObject].
stackPages longAt: theFP + FoxThisContext put: theContext.
stackPages byteAt: theFP + FoxFrameFlags + 2 put: 1.
self assert: (self frameHasContext: theFP).
self assert: (self frameOfMarriedContext: theContext) = theFP.
self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext).
^theContext
!
Item was changed:
----- Method: StackInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') -----
moveFramesIn: oldPage through: theFP toPage: newPage
"Move frames from the hot end of oldPage through to theFP to newPage.
This has the effect of making theFP a base frame which can be stored into.
Answer theFP's new location."
| newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext |
<inline: false>
<var: #oldPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #newSP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #fpInNewPage type: #'char *'>
<var: #offsetCallerFP type: #'char *'>
<var: #source type: #'char *'>
<returnTypeC: 'char *'>
+ newSP := newPage baseAddress + self bytesPerWord.
- newSP := newPage baseAddress + objectMemory bytesPerWord.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
+ by: self bytesPerWord negated
- by: objectMemory bytesPerWord negated
do: [:source|
+ newSP := newSP - self bytesPerWord.
- newSP := newSP - objectMemory bytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
newFP := newPage baseAddress - stackedReceiverOffset.
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
newPage baseFP: newFP.
callerFP := self frameCallerFP: theFP.
self assert: (self isBaseFrame: theFP) not.
self assert: (self frameHasContext: callerFP).
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
oldPage
headFP: callerFP;
headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page (FoxCallerContext a.k.a. FoxCallerSavedIP)"
stackPages longAt: newFP + FoxCallerContext put: (self frameContext: callerFP).
stackPages longAt: newFP + FoxSavedFP put: 0.
"Now relocate frame pointers, updating married contexts to refer to their moved spouse frames."
fpInNewPage := newPage headFP.
[offsetCallerFP := self frameCallerFP: fpInNewPage.
offsetCallerFP ~= 0 ifTrue:
[offsetCallerFP := offsetCallerFP + delta].
stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP).
(self frameHasContext: fpInNewPage) ifTrue:
[theContext := self frameContext: fpInNewPage.
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: fpInNewPage).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: offsetCallerFP)].
fpInNewPage := offsetCallerFP.
fpInNewPage ~= 0] whileTrue.
^newFP!
Item was changed:
----- Method: StackInterpreter>>pop: (in category 'internal interpreter access') -----
pop: nItems
<inline: true>
"In the StackInterpreter stacks grow down."
+ stackPointer := stackPointer + (nItems * self bytesPerWord).
- stackPointer := stackPointer + (nItems * objectMemory bytesPerWord).
^nil!
Item was changed:
----- Method: StackInterpreter>>pop:thenPush: (in category 'internal interpreter access') -----
pop: nItems thenPush: oop
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
+ stackPages longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord)) put: oop.
- stackPages longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pop:thenPushBool: (in category 'internal interpreter access') -----
pop: nItems thenPushBool: trueOrFalse
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
stackPages
+ longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord))
- longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord))
put: (trueOrFalse ifTrue: [objectMemory trueObject] ifFalse: [objectMemory falseObject]).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pop:thenPushFloat: (in category 'internal interpreter access') -----
pop: nItems thenPushFloat: f
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #f type: #double>
<var: #sp type: #'char *'>
stackPages
+ longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord))
- longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord))
put: (self floatObjectOf: f).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pop:thenPushInteger: (in category 'internal interpreter access') -----
pop: nItems thenPushInteger: integerVal
"lots of places pop a few items off the stack and then push an integer. Make it convenient.
In the StackInterpreter stacks grow down."
| sp |
<var: #sp type: #'char *'>
stackPages
+ longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord))
- longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord))
put: (objectMemory integerObjectOf: integerVal).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>popFloat (in category 'stack bytecodes') -----
popFloat
"Note: May be called by translated primitive code."
| top result |
<returnTypeC: #double>
<var: #result type: #double>
top := self popStack.
"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
(because assertClassOf:is:compactClassIndex: has an inline: pragma) the
phrase (self splObj: ClassArray) is expanded in-place and is _not_
evaluated if ClassArrayCompactIndex is non-zero."
self assertClassOf: top
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: top + self baseHeaderSize into: result].
- objectMemory fetchFloatAt: top + objectMemory baseHeaderSize into: result].
^ result!
Item was changed:
----- Method: StackInterpreter>>popStack (in category 'internal interpreter access') -----
popStack
"In the StackInterpreter stacks grow down."
| top |
<inline: true>
top := stackPages longAt: stackPointer.
+ stackPointer := stackPointer + self bytesPerWord.
- stackPointer := stackPointer + objectMemory bytesPerWord.
^top!
Item was changed:
----- Method: StackInterpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
positive32BitIntegerFor: integerValue
| newLargeInteger |
"Note - integerValue is interpreted as POSITIVE, eg, as the result of
Bitmap>at:, or integer>bitAnd:."
integerValue >= 0
ifTrue: [(objectMemory isIntegerValue: integerValue)
ifTrue: [^ objectMemory integerObjectOf: integerValue]].
+ self cppIf: self bytesPerWord = 4
- self cppIf: objectMemory bytesPerWord = 4
ifTrue: "Faster instantiateSmallClass: currently only works with integral word size."
[newLargeInteger := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassLargePositiveInteger)
+ sizeInBytes: self baseHeaderSize + 4]
- sizeInBytes: objectMemory baseHeaderSize + 4]
ifFalse: "Cant use instantiateSmallClass: due to integral word requirement."
[newLargeInteger := objectMemory
eeInstantiateClass: (objectMemory splObj: ClassLargePositiveInteger)
indexableSize: 4].
objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
^newLargeInteger!
Item was changed:
----- Method: StackInterpreter>>primitiveObject:perform:withArguments:lookedUpIn: (in category 'control primitives') -----
primitiveObject: actualReceiver perform: selector withArguments: argumentArray lookedUpIn: lookupClass
"Common routine used by perform:withArgs:, perform:withArgs:inSuperclass:,
object:perform:withArgs:inClass: et al. Answer nil on success.
NOTE: The case of doesNotUnderstand: is not a failure to perform.
The only failures are arg types and consistency of argumentCount.
Since we're in the stack VM we can assume there is space to push the arguments
provided they are within limits (max argument count is 15). We can therefore deal
with the arbitrary amount of state to remove from the stack (lookup class, selector,
mirror receiver) and arbitrary argument orders by deferring popping anything until
we know whether the send has succeeded. So on failure we merely have to remove
the actual receiver and arguments pushed, and on success we have to slide the actual
receiver and arguments down to replace the original ones."
| arraySize performArgCount delta |
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
"Check if number of arguments is reasonable; MaxNumArgs isn't available
so just use LargeContextSize"
arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ arraySize > (LargeContextSize / self bytesPerWord) ifTrue:
- arraySize > (LargeContextSize / objectMemory bytesPerWord) ifTrue:
[^self primitiveFailFor: PrimErrBadNumArgs].
performArgCount := argumentCount.
"Push newMethod to save it in case of failure,
then push the actual receiver and args out of the array."
self push: newMethod.
self push: actualReceiver.
"Copy the arguments to the stack, and execute"
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
argumentCount := arraySize.
messageSelector := selector.
+ self sendBreak: messageSelector + self baseHeaderSize
- self sendBreak: messageSelector + objectMemory baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: actualReceiver.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
((objectMemory isOopCompiledMethod: newMethod)
and: [(self argumentCountOf: newMethod) ~= argumentCount]) ifTrue:
["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
self pop: arraySize + 1.
newMethod := self popStack.
^self primitiveFailFor: PrimErrBadNumArgs].
"Cannot fail this primitive from here-on. Slide the actual receiver and arguments down
to replace the perform arguments and saved newMethod and then execute the new
method. Use argumentCount not arraySize because an MNU may have changed it."
+ delta := self bytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod"
+ argumentCount * self bytesPerWord to: 0 by: self bytesPerWord negated do:
- delta := objectMemory bytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod"
- argumentCount * objectMemory bytesPerWord to: 0 by: objectMemory bytesPerWord negated do:
[:offset|
stackPages
longAt: stackPointer + offset + delta
put: (stackPages longAt: stackPointer + offset)].
self pop: performArgCount + 2.
self executeNewMethod.
self initPrimCall. "Recursive xeq affects primErrorCode"
^nil!
Item was changed:
----- Method: StackInterpreter>>printFrame:WithSP: (in category 'debug printing') -----
printFrame: theFP WithSP: theSP
| theMethod numArgs topThing |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #addr type: #'char *'>
self cCode: '' inSmalltalk: [self transcript ensureCr].
theMethod := self frameMethod: theFP.
numArgs := self frameNumArgs: theFP.
self shortPrintFrame: theFP.
self printFrameOop: 'rcvr/clsr'
+ at: theFP + FoxCallerSavedIP + ((numArgs + 1) * self bytesPerWord).
- at: theFP + FoxCallerSavedIP + ((numArgs + 1) * objectMemory bytesPerWord).
numArgs to: 1 by: -1 do:
+ [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * self bytesPerWord)].
- [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * objectMemory bytesPerWord)].
self printFrameThing: 'cllr ip/ctxt' at: theFP + FoxCallerSavedIP.
self printFrameThing: 'saved fp' at: theFP + FoxSavedFP.
self printFrameOop: 'method' at: theFP + FoxMethod.
self printFrameFlagsForFP: theFP.
self printFrameThing: 'context' at: theFP + FoxThisContext.
self printFrameOop: 'receiver' at: theFP + FoxReceiver.
topThing := stackPages longAt: theSP.
(topThing >= theMethod
and: [topThing <= (theMethod + (objectMemory sizeBitsOfSafe: theMethod))])
ifTrue:
+ [theFP + FoxReceiver - self bytesPerWord to: theSP + self bytesPerWord by: self bytesPerWord negated do:
- [theFP + FoxReceiver - objectMemory bytesPerWord to: theSP + objectMemory bytesPerWord by: objectMemory bytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr].
self printFrameThing: 'frame ip' at: theSP]
ifFalse:
+ [theFP + FoxReceiver - self bytesPerWord to: theSP by: self bytesPerWord negated do:
- [theFP + FoxReceiver - objectMemory bytesPerWord to: theSP by: objectMemory bytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr]]!
Item was changed:
----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
printNameOfClass: classOop count: cnt
"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
<inline: false>
(classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class'].
((objectMemory sizeBitsOf: classOop) = metaclassSizeBytes
+ and: [metaclassSizeBytes > (thisClassIndex * self bytesPerWord)]) "(Metaclass instSize * 4)"
- and: [metaclassSizeBytes > (thisClassIndex * objectMemory bytesPerWord)]) "(Metaclass instSize * 4)"
ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
self print: ' class']
ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine |
<inline: false>
self printHex: oop.
(objectMemory isIntegerObject: oop) ifTrue:
[^self
cCode: 'printf("=%ld\n", integerValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[self printHex: oop; print: ' is not on the heap'; cr.
^nil].
+ (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'; cr.
^nil].
(objectMemory isFreeObject: oop) ifTrue:
[self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
self cr.
(fmt > 4 and: [fmt < 12]) ifTrue:
["This will answer false if splObj: ClassAlien is nilObject"
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
[self print: ' datasize '; printNum: (self sizeOfAlienData: oop).
self print: ((self isIndirectAlien: oop)
ifTrue: [' indirect @ ']
ifFalse:
[(self isPointerAlien: oop)
ifTrue: [' pointer @ ']
ifFalse: [' direct @ ']]).
self printHex: (self startOfAlienData: oop); cr.
^nil].
(objectMemory isWords: oop) ifTrue:
+ [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / self bytesPerWord).
- [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / objectMemory bytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop).
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
^nil].
^self printStringOf: oop; cr].
+ lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / self bytesPerWord).
- lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / objectMemory bytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')'
inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
+ [startIP := startIP * self bytesPerWord + 1.
- [startIP := startIP * objectMemory bytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 10.
startIP to: lastIndex do:
[:index| | byte |
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue:
[self cr]].
((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') -----
printOopShortInner: oop
| classOop name nameLen |
<var: #name type: #'char *'>
<inline: true>
self printChar: $=.
(objectMemory isIntegerObject: oop) ifTrue:
[self printNum: (objectMemory integerValueOf: oop);
printChar: $(;
printHex: (objectMemory integerValueOf: oop);
printChar: $).
^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[self printHex: oop; print: ' is not on the heap'.
^nil].
+ (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'.
^nil].
(self isFloatObject: oop) ifTrue:
[self printFloat: (self dbgFloatValueOf: oop).
^nil].
classOop := objectMemory fetchClassOf: oop.
(objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue:
[self printNameOfClass: oop count: 5.
^nil].
oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil].
oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil].
oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil].
nameLen := self lengthOfNameOfClass: classOop.
nameLen = 0 ifTrue: [self print: 'a ??'. ^nil].
name := self nameOfClass: classOop.
nameLen = 10 ifTrue:
[(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue:
[self printChar: $"; printStringOf: oop; printChar: $".
^nil].
(self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue:
[self printChar: $#; printStringOf: oop.
^nil]].
(nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue:
[self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)).
^nil].
self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name]
inSmalltalk: [self print: 'a(n) '; print: name]!
Item was changed:
----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt cnt i |
<inline: false>
(objectMemory isIntegerObject: oop) ifTrue:
[^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^nil].
+ (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
[^nil].
fmt := objectMemory formatOf: oop.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (objectMemory lengthOf: oop).
i := 0.
((objectMemory is: oop
instanceOf: (objectMemory splObj: ClassByteArray)
compactClassIndex: classByteArrayCompactIndex)
or: [(objectMemory is: oop
instanceOf: (objectMemory splObj: ClassLargePositiveInteger)
compactClassIndex: ClassLargePositiveIntegerCompactIndex)
or: [(objectMemory is: oop
instanceOf: (objectMemory splObj: ClassLargeNegativeInteger)
compactClassIndex: ClassLargeNegativeIntegerCompactIndex)]])
ifTrue:
[[i < cnt] whileTrue: [
self printHex: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]]
ifFalse:
[[i < cnt] whileTrue: [
self printChar: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]].
self flush!
Item was changed:
----- Method: StackInterpreter>>push: (in category 'internal interpreter access') -----
push: object
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
+ stackPages longAt: (sp := stackPointer - self bytesPerWord) put: object.
- stackPages longAt: (sp := stackPointer - objectMemory bytesPerWord) put: object.
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
pushClosureCopyCopiedValuesBytecode
"The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following.
Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
| newClosure numArgsNumCopied numArgs numCopied blockSize context |
numArgsNumCopied := self fetchByte.
numArgs := numArgsNumCopied bitAnd: 16rF.
numCopied := numArgsNumCopied bitShift: -4.
"Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
blockSize := self fetchByte << 8.
blockSize := blockSize + self fetchByte.
"No need to record the pushed copied values in the outerContext."
+ context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * self bytesPerWord).
- context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * objectMemory bytesPerWord).
newClosure := self
closureIn: context
numArgs: numArgs
+ instructionPointer: (self oopForPointer: localIP) + 2 - (method+self baseHeaderSize)
- instructionPointer: (self oopForPointer: localIP) + 2 - (method+objectMemory baseHeaderSize)
numCopiedValues: numCopied.
numCopied > 0 ifTrue:
[0 to: numCopied - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self internalStackValue: numCopied - i - 1)].
self internalPop: numCopied].
localIP := localIP + blockSize.
self fetchNextBytecode.
self internalPush: newClosure!
Item was changed:
----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages
minimumMemory memStart bytesRead bytesToShift heapSize hdrEdenBytes
headerFlags hdrMaxExtSemTabSize |
<var: #f type: 'sqImageFile '>
<var: #memStart type: 'usqInt'>
<var: #desiredHeapSize type: 'usqInt'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #dataSize type: 'size_t '>
<var: #imageOffset type: 'squeakFileOffsetType '>
+ metaclassSizeBytes := 6 * self bytesPerWord. "guess (Metaclass instSize * BPW)"
- metaclassSizeBytes := 6 * objectMemory bytesPerWord. "guess (Metaclass instSize * BPW)"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - self bytesPerWord. "record header start position"
- headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used."
savedWindowSize := self getLongFromFile: f swap: swapBytes.
headerFlags := self getLongFromFile: f swap: swapBytes.
self setImageHeaderFlagsFrom: headerFlags.
extraVMMemory := self getLongFromFile: f swap: swapBytes.
hdrNumStackPages := self getShortFromFile: f swap: swapBytes.
"4 stack pages is small. Should be able to run with as few as
three. 4 should be comfortable but slow. 8 is a reasonable
default. Can be changed via vmParameterAt: 43 put: n.
Can be set as a preference (Info.plist, VM.ini, command line etc).
If desiredNumStackPages is already non-zero then it has been
set as a preference. Ignore (but preserve) the header's default."
numStackPages := desiredNumStackPages ~= 0
ifTrue: [desiredNumStackPages]
ifFalse: [hdrNumStackPages = 0
ifTrue: [self defaultNumStackPages]
ifFalse: [hdrNumStackPages]].
desiredNumStackPages := hdrNumStackPages.
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to images run on Cog."
theUnknownShort := self getShortFromFile: f swap: swapBytes.
hdrEdenBytes := self getLongFromFile: f swap: swapBytes.
objectMemory setEdenBytes: (desiredEdenBytes ~= 0
ifTrue: [desiredEdenBytes]
ifFalse:
[hdrEdenBytes = 0
ifTrue: [objectMemory defaultEdenBytes]
ifFalse: [hdrEdenBytes]]).
desiredEdenBytes := hdrEdenBytes.
hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes.
hdrMaxExtSemTabSize ~= 0 ifTrue:
[self setMaxExtSemSizeTo: hdrMaxExtSemTabSize].
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
"compare memory requirements with availability".
minimumMemory := dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes.
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
objectMemory setMemory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)').
objectMemory getMemory = nil ifTrue: [self insufficientMemoryAvailableError].
memStart := objectMemory startOfMemory.
objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
objectMemory setEndOfMemory: memStart + dataSize.
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := memStart - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
^dataSize
!
Item was changed:
----- Method: StackInterpreter>>reestablishContextPriorToCallback: (in category 'callback support') -----
reestablishContextPriorToCallback: callbackContext
"callbackContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
Its sender is the VM's state prior to the callback. Reestablish that state,
and mark calloutContext as dead."
| calloutContext theFP thePage |
<export: true>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
self flag: #obsolete.
(self isLiveContext: callbackContext) ifFalse:
[^false].
calloutContext := self externalInstVar: SenderIndex ofContext: callbackContext.
(self isLiveContext: calloutContext) ifFalse:
[^false].
"Mark callbackContext as dead; the common case is that it is the current frame.
We go the extra mile for the debugger."
(self isSingleContext: callbackContext)
ifTrue: [self markContextAsDead: callbackContext]
ifFalse:
[theFP := self frameOfMarriedContext: callbackContext.
framePointer = theFP "common case"
ifTrue:
[(self isBaseFrame: theFP)
ifTrue: [stackPages freeStackPage: stackPage]
ifFalse: "calloutContext is immediately below on the same page. Make it current."
[instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
+ stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + self bytesPerWord.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord.
framePointer := self frameCallerFP: framePointer.
^true]]
ifFalse:
[self externalDivorceFrame: theFP andContext: callbackContext.
self markContextAsDead: callbackContext]].
"Make the calloutContext the active frame. The case where calloutContext
is immediately below callbackContext on the same page is handled above."
(self isStillMarriedContext: calloutContext)
ifTrue:
[theFP := self frameOfMarriedContext: calloutContext.
thePage := stackPages stackPageFor: theFP.
"findSPOf:on: points to the word beneath the instructionPointer, but
there is no instructionPointer on the top frame of the current page."
self assert: thePage ~= stackPage.
+ stackPointer := (self findSPOf: theFP on: thePage) - self bytesPerWord.
- stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord.
framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutContext.
framePointer := thePage headFP.
stackPointer := thePage headSP].
instructionPointer := self popStack.
self setStackPageAndLimit: thePage.
^true!
Item was changed:
----- Method: StackInterpreter>>returnAs:ThroughCallback:Context: (in category 'callback support') -----
returnAs: returnTypeOop ThroughCallback: vmCallbackContext Context: callbackMethodContext
"callbackMethodContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
Its sender is the VM's state prior to the callback. Reestablish that state (via longjmp),
and mark callbackMethodContext as dead."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
| calloutMethodContext theFP thePage |
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
((self isIntegerObject: returnTypeOop)
and: [self isLiveContext: callbackMethodContext]) ifFalse:
[^false].
calloutMethodContext := self externalInstVar: SenderIndex ofContext: callbackMethodContext.
(self isLiveContext: calloutMethodContext) ifFalse:
[^false].
"Mark callbackMethodContext as dead; the common case is that it is the current frame.
We go the extra mile for the debugger."
(self isSingleContext: callbackMethodContext)
ifTrue: [self markContextAsDead: callbackMethodContext]
ifFalse:
[theFP := self frameOfMarriedContext: callbackMethodContext.
framePointer = theFP "common case"
ifTrue:
[(self isBaseFrame: theFP)
ifTrue: [stackPages freeStackPage: stackPage]
ifFalse: "calloutMethodContext is immediately below on the same page. Make it current."
[instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
+ stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + self bytesPerWord.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord.
framePointer := self frameCallerFP: framePointer.
self restoreCStackStateForCallbackContext: vmCallbackContext.
"N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
This matches the use of _setjmp in ia32abicc.c."
self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
^true]]
ifFalse:
[self externalDivorceFrame: theFP andContext: callbackMethodContext.
self markContextAsDead: callbackMethodContext]].
"Make the calloutMethodContext the active frame. The case where calloutMethodContext
is immediately below callbackMethodContext on the same page is handled above."
(self isStillMarriedContext: calloutMethodContext)
ifTrue:
[theFP := self frameOfMarriedContext: calloutMethodContext.
thePage := stackPages stackPageFor: theFP.
"findSPOf:on: points to the word beneath the instructionPointer, but
there is no instructionPointer on the top frame of the current page."
self assert: thePage ~= stackPage.
+ stackPointer := (self findSPOf: theFP on: thePage) - self bytesPerWord.
- stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord.
framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutMethodContext.
framePointer := thePage headFP.
stackPointer := thePage headSP].
instructionPointer := self popStack.
self setStackPageAndLimit: thePage.
self restoreCStackStateForCallbackContext: vmCallbackContext.
"N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
This matches the use of _setjmp in ia32abicc.c."
self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
"NOTREACHED"
^true!
Item was changed:
----- Method: StackInterpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
reverseDisplayFrom: startIndex to: endIndex
"Reverse the given range of Display words (at different bit
depths, this will reverse different numbers of pixels). Used to
give feedback during VM activities such as garbage
collection when debugging. It is assumed that the given
word range falls entirely within the first line of the Display."
| displayObj displayBits w wordStartIndex wordEndIndex primFailCodeValue |
displayObj := objectMemory splObj: TheDisplay.
((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
w := objectMemory fetchPointer: 1 ofObject: displayObj.
displayBits := objectMemory fetchPointer: 0 ofObject: displayObj.
((objectMemory isIntegerObject: displayBits)
or: [(objectMemory isNonIntegerObject: w)
or: [objectMemory isPointersNonInt: displayBits]]) ifTrue: [^ nil].
wordStartIndex := startIndex * 4.
wordEndIndex := endIndex * 4 min: (objectMemory sizeBitsOf: displayBits).
+ displayBits := displayBits + self baseHeaderSize.
- displayBits := displayBits + objectMemory baseHeaderSize.
displayBits + wordStartIndex to: displayBits + wordEndIndex by: 4 do:
[:ptr | | reversed |
reversed := (objectMemory long32At: ptr) bitXor: 16rFFFFFFFF.
objectMemory longAt: ptr put: reversed].
primFailCodeValue := primFailCode.
self initPrimCall.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: (objectMemory integerValueOf: w) Bottom: 1.
self ioForceDisplayUpdate.
primFailCode := primFailCodeValue!
Item was changed:
----- Method: StackInterpreter>>roomToPushNArgs: (in category 'primitive support') -----
roomToPushNArgs: n
"Answer if there is room to push n arguments onto the current stack.
There may be room in this stackPage but there may not be room if
the frame were converted into a context."
| cntxSize |
self assert: method = (stackPages longAt: framePointer + FoxMethod).
cntxSize := ((self headerOf: method) bitAnd: LargeContextBit) ~= 0
+ ifTrue: [LargeContextSize / self bytesPerWord - ReceiverIndex]
+ ifFalse: [SmallContextSize / self bytesPerWord - ReceiverIndex].
- ifTrue: [LargeContextSize / objectMemory bytesPerWord - ReceiverIndex]
- ifFalse: [SmallContextSize / objectMemory bytesPerWord - ReceiverIndex].
^self stackPointerIndex + n <= cntxSize!
Item was changed:
----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') -----
sendInvokeCallbackContext: vmCallbackContext
"Send the calllback message to Alien class with the supplied arg(s). Use either the
1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
message, depending on what selector is installed in the specialObjectsArray.
Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
The arguments are raw C addresses and are converted to integer objects on the way."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien).
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[^false]].
primitiveFunctionPointer ~= 0 ifTrue:
[^false].
self saveCStackStateForCallbackContext: vmCallbackContext.
self push: (self splObj: ClassAlien). "receiver"
+ self cppIf: [self bytesPerWord = 8]
- self cppIf: [objectMemory bytesPerWord = 8]
ifTrue:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)]
ifFalse:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)].
self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
self justActivateNewMethod.
(self isMachineCodeFrame: framePointer) ifFalse:
[self maybeFlagMethodAsInterpreted: newMethod].
self externalWriteBackHeadFramePointers.
self handleStackOverflow.
self enterSmalltalkExecutiveFromCallback.
"not reached"
^true!
Item was changed:
----- Method: StackInterpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
sizeOfSTArrayFromCPrimitive: cPtr
"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
"Note: Only called by translated primitive code."
| oop |
<var: #cPtr type: 'void *'>
+ oop := (self oopForPointer: cPtr) - self baseHeaderSize.
- oop := (self oopForPointer: cPtr) - objectMemory baseHeaderSize.
(objectMemory isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
^objectMemory lengthOf: oop
!
Item was changed:
----- Method: StackInterpreter>>slowPrimitiveResponse (in category 'primitive support') -----
slowPrimitiveResponse
"Called under the assumption that primFunctionPtr has been preloaded"
| nArgs savedFramePointer savedStackPointer |
<inline: true>
<asmLabel: false>
<var: #savedFramePointer type: #'char *'>
<var: #savedStackPointer type: #'char *'>
FailImbalancedPrimitives ifTrue:
[nArgs := argumentCount.
savedStackPointer := stackPointer.
savedFramePointer := framePointer].
self initPrimCall.
self dispatchFunctionPointer: primitiveFunctionPointer.
(FailImbalancedPrimitives
and: [self successful
and: [framePointer = savedFramePointer]]) ifTrue:"Don't fail if primitive has done something radical, e.g. perform:"
+ [stackPointer ~= (savedStackPointer + (nArgs * self bytesPerWord)) ifTrue:
- [stackPointer ~= (savedStackPointer + (nArgs * objectMemory bytesPerWord)) ifTrue:
[self flag: 'Would be nice to make this a message send of e.g. unbalancedPrimitive to the current process or context'.
"This is necessary but insufficient; the result may still have been written to the stack.
At least we'll know something is wrong."
stackPointer := savedStackPointer.
self failUnbalancedPrimitive]].
"If we are profiling, take accurate primitive measures"
nextProfileTick > 0 ifTrue:
[self checkProfileTick: newMethod].
^self successful!
Item was changed:
----- Method: StackInterpreter>>snapshotCleanUp (in category 'image save/restore') -----
snapshotCleanUp
"Clean up right before saving an image, sweeping memory and:
* nilling out all fields of contexts above the stack pointer.
* flushing external primitives
* clearing the root bit of any object in the root table
* bereaving widowed contexts.
By ensuring that all contexts are single in a snapshot (i.e. that no married contexts
exist) we can maintain the invariant that a married or widowed context's frame
reference (in its sender field) must point into the stack pages since no married or
widowed contexts are present from older runs of the system."
| oop header fmt sz |
oop := objectMemory firstObject.
[self oop: oop isLessThan: objectMemory freeStart] whileTrue:
[(objectMemory isFreeObject: oop) ifFalse:
[header := self longAt: oop.
fmt := objectMemory formatOfHeader: header.
"Clean out context"
(fmt = 3 and: [self isContextHeader: header]) ifTrue:
["All contexts have been divorced. Bereave remaining widows."
(self isMarriedOrWidowedContext: oop) ifTrue:
[self markContextAsDead: oop].
sz := objectMemory sizeBitsOf: oop.
+ (objectMemory lastPointerOf: oop) + self bytesPerWord
+ to: sz - self baseHeaderSize by: self bytesPerWord
- (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord
- to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord
do: [:i | self longAt: oop + i put: objectMemory nilObject]].
"Clean out external functions"
fmt >= 12 ifTrue:
["This is a compiled method"
(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex ifTrue:
["Its primitiveExternalCall"
self flushExternalPrimitiveOf: oop]]].
oop := objectMemory objectAfter: oop].
objectMemory clearRootsTable!
Item was changed:
----- Method: StackInterpreter>>stackFloatValue: (in category 'internal interpreter access') -----
stackFloatValue: offset
"In the StackInterpreter stacks grow down."
| result floatPointer |
<returnTypeC: #double>
<var: #result type: #double>
+ floatPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord).
- floatPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
(because assertClassOf:is:compactClassIndex: has an inline: pragma) the
phrase (self splObj: ClassArray) is expanded in-place and is _not_
evaluated if ClassArrayCompactIndex is non-zero."
self assertClassOf: floatPointer
is: (objectMemory splObj: ClassFloat)
compactClassIndex: ClassFloatCompactIndex.
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: floatPointer + self baseHeaderSize into: result.
- objectMemory fetchFloatAt: floatPointer + objectMemory baseHeaderSize into: result.
^result].
^0.0!
Item was changed:
----- Method: StackInterpreter>>stackLimitOffset (in category 'stack pages') -----
stackLimitOffset
"Answer the amount of slots needed to fit a new frame at the point the stack
limit is checked. A frame looks like this at the point the stack limit is checked:
stacked receiver/closure
arg0
...
argN
caller's method ip/base frame's sender context
fp-> saved fp
method
method header fields
context (uninitialized)
receiver
first temp
...
sp-> Nth temp
So the amount of headroom is
the maximum number of arguments + 1 (for stacked receiver and arguments)
+ the frame size
+ the max number of temps.
Since a method's number of temps includes its arguments the actual offset is:"
+ ^(FrameSlots + 64) * self bytesPerWord!
- ^(FrameSlots + 64) * objectMemory bytesPerWord!
Item was changed:
----- Method: StackInterpreter>>stackPositiveMachineIntegerValue: (in category 'internal interpreter access') -----
stackPositiveMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord).
- integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
^self positiveMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'internal interpreter access') -----
stackSignedMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord).
- integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackValue: (in category 'internal interpreter access') -----
stackValue: offset
<api>
"In the StackInterpreter stacks grow down."
+ ^stackPages longAt: stackPointer + (offset * self bytesPerWord)!
- ^stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>stackValue:put: (in category 'internal interpreter access') -----
stackValue: offset put: oop
"In the StackInterpreter stacks grow down."
^stackPages
+ longAt: stackPointer + (offset * self bytesPerWord)
- longAt: stackPointer + (offset * objectMemory bytesPerWord)
put: oop!
Item was changed:
----- Method: StackInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
sufficientSpaceToInstantiate: classOop indexableSize: size
"Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
"Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
| format atomSize|
<inline: true>
format := self instSpecOfClass: classOop.
"fail if attempting to call new: on non-indexable class"
((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2])
ifTrue: [^ false].
format < 8
+ ifTrue: ["indexable fields are words or pointers" atomSize := self bytesPerWord]
- ifTrue: ["indexable fields are words or pointers" atomSize := objectMemory bytesPerWord]
ifFalse: ["indexable fields are bytes" atomSize := 1].
^objectMemory sufficientSpaceToAllocate: 2500 + (size * atomSize)!
Item was changed:
----- Method: StackInterpreter>>temporary:in: (in category 'internal interpreter access') -----
temporary: offset in: theFP
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
^offset < (frameNumArgs := self frameNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * self bytesPerWord)]
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory bytesPerWord)]
ifFalse: [stackPages longAt: theFP + FoxReceiver - self bytesPerWord + ((frameNumArgs - offset) * self bytesPerWord)]!
Item was changed:
----- Method: StackInterpreter>>temporary:in:put: (in category 'internal interpreter access') -----
temporary: offset in: theFP put: valueOop
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
offset < (frameNumArgs := self frameNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * self bytesPerWord) put: valueOop]
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory bytesPerWord) put: valueOop]
ifFalse: [stackPages longAt: theFP + FoxReceiver - self bytesPerWord + ((frameNumArgs - offset) * self bytesPerWord) put: valueOop]!
Item was changed:
----- Method: StackInterpreter>>temporaryLocation:in:numArgs: (in category 'internal interpreter access') -----
temporaryLocation: offset in: theFP numArgs: numArgs
"Answer the pointer to a given temporary (for debug frame printing in odd circumstances)"
<var: #theFP type: #'char *'>
<returnTypeC: #'char *'>
<asmLabel: false>
^offset < numArgs
+ ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * self bytesPerWord)]
- ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * objectMemory bytesPerWord)]
ifFalse: [theFP + FoxReceiver - self bytesPerWord + ((numArgs - offset) * self bytesPerWord)]!
Item was changed:
----- Method: StackInterpreter>>unPop: (in category 'internal interpreter access') -----
unPop: nItems
"In the StackInterpreter stacks grow down."
+ stackPointer := stackPointer - (nItems * self bytesPerWord)!
- stackPointer := stackPointer - (nItems * objectMemory bytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>updateObjectsPostByteSwapFrom:to: (in category 'image save/restore') -----
updateObjectsPostByteSwapFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part.
Ensure floats are in platform-order."
| oop fmt wordAddr methodHeader swapFloatWords temp |
swapFloatWords := objectMemory vmEndianness ~= imageFloatsBigEndian.
self assert: ClassFloatCompactIndex ~= 0.
oop := startOop.
[self oop: oop isLessThan: stopAddr] whileTrue:
[(objectMemory isFreeObject: oop) ifFalse:
[fmt := objectMemory formatOf: oop.
fmt >= 8 ifTrue: "oop contains bytes"
+ [wordAddr := oop + self baseHeaderSize.
- [wordAddr := oop + objectMemory baseHeaderSize.
fmt >= 12 ifTrue: "compiled method; start after methodHeader and literals"
+ [methodHeader := self longAt: oop + self baseHeaderSize.
+ wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)].
- [methodHeader := self longAt: oop + objectMemory baseHeaderSize.
- wordAddr := wordAddr + objectMemory bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * objectMemory bytesPerWord)].
objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)].
fmt = 6 ifTrue: "Bitmap, Float etc"
[(swapFloatWords
and: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex])
ifTrue:
+ [temp := self longAt: oop + self baseHeaderSize.
+ self longAt: oop + self baseHeaderSize put: (self longAt: oop + self baseHeaderSize + 4).
+ self longAt: oop + self baseHeaderSize + 4 put: temp]
- [temp := self longAt: oop + objectMemory baseHeaderSize.
- self longAt: oop + objectMemory baseHeaderSize put: (self longAt: oop + objectMemory baseHeaderSize + 4).
- self longAt: oop + objectMemory baseHeaderSize + 4 put: temp]
ifFalse:
+ [self bytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words."
+ [wordAddr := oop + self baseHeaderSize.
- [objectMemory bytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words."
- [wordAddr := oop + objectMemory baseHeaderSize.
objectMemory reverseWordsFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)]]]].
oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: StackInterpreter>>updateStateOfSpouseContextForFrame:WithSP: (in category 'frame access') -----
updateStateOfSpouseContextForFrame: theFP WithSP: theSP
"Update the frame's spouse context with the frame's current state except for the
sender and instruction pointer, which are used to mark the context as married."
| theContext tempIndex pointer |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #pointer type: #'char *'>
self assert: (self frameHasContext: theFP).
theContext := self frameContext: theFP.
self assert: (self frameReceiver: theFP)
= (objectMemory fetchPointer: ReceiverIndex ofObject: theContext).
tempIndex := self frameNumArgs: theFP.
+ pointer := theFP + FoxReceiver - self bytesPerWord.
- pointer := theFP + FoxReceiver - objectMemory bytesPerWord.
[pointer >= theSP] whileTrue:
[self assert: (objectMemory addressCouldBeOop: (stackPages longAt: pointer)).
tempIndex := tempIndex + 1.
objectMemory storePointer: ReceiverIndex + tempIndex
ofObject: theContext
withValue: (stackPages longAt: pointer).
+ pointer := pointer - self bytesPerWord].
- pointer := pointer - objectMemory bytesPerWord].
self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') -----
validInstructionPointer: instrPointer inMethod: aMethod framePointer: fp
<var: #instrPointer type: #usqInt>
<var: #aMethod type: #usqInt>
^instrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + self bytesPerWord - 1)
+ and: [instrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + self baseHeaderSize)]!
- and: [instrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + objectMemory baseHeaderSize)]!
Item was changed:
----- Method: StackInterpreter>>withSmallIntegerTags: (in category 'frame access') -----
withSmallIntegerTags: value
<inline: true>
<var: #value type: #'char *'>
+ self assert: ((self oopForPointer: value) bitAnd: self bytesPerWord - 1) = 0.
- self assert: ((self oopForPointer: value) bitAnd: objectMemory bytesPerWord - 1) = 0.
^(self oopForPointer: value) + 1!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure numArgs |
numArgs := self stackIntegerValue: 1.
self successful ifFalse:
[^self primitiveFail].
newClosure := self
closureIn: (self stackValue: 2)
numArgs: numArgs
"greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method + objectMemory baseHeaderSize)
copiedValues: self stackTop.
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') -----
primitiveDoNamedPrimitiveWithArgs
"Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything.
e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments"
| argumentArray arraySize methodArg methodHeader
moduleName functionName moduleLength functionLength
spec addr primRcvr ctxtRcvr |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
arraySize := objectMemory fetchWordLengthOf: argumentArray.
self success: (self roomToPushNArgs: arraySize).
methodArg := self stackObjectValue: 2.
self successful ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
(objectMemory isOopCompiledMethod: methodArg) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
methodHeader := self headerOf: methodArg.
(self literalCountOfHeader: methodHeader) > 2 ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
(self assertClassOf: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg)
is: (objectMemory splObj: ClassArray)
compactClassIndex: ClassArrayCompactIndex).
(self successful
and: [(objectMemory lengthOf: spec) = 4
and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
[^self primitiveFailFor: -2]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: spec.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [self success: (objectMemory isBytes: moduleName).
moduleLength := objectMemory lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := objectMemory fetchPointer: 1 ofObject: spec.
self success: (objectMemory isBytes: functionName).
functionLength := objectMemory lengthOf: functionName.
self successful ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state"
+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + self baseHeaderSize
- FromModule: moduleName + objectMemory baseHeaderSize
OfLength: moduleLength.
addr = 0 ifTrue:
[^self primitiveFailFor: -1]. "could not find function; answer generic failure (see below)"
"Cannot fail this primitive from now on. Can only fail the external primitive."
objectMemory pushRemappableOop: (argumentArray := self popStack).
objectMemory pushRemappableOop: (primRcvr := self popStack).
objectMemory pushRemappableOop: self popStack. "the method"
objectMemory pushRemappableOop: self popStack. "the context receiver"
self push: primRcvr. "replace context receiver with actual receiver"
argumentCount := arraySize.
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
"Run the primitive (sets primFailCode)"
lkupClass := objectMemory nilObject.
self callExternalPrimitive: addr.
ctxtRcvr := objectMemory popRemappableOop.
methodArg := objectMemory popRemappableOop.
primRcvr := objectMemory popRemappableOop.
argumentArray := objectMemory popRemappableOop.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize + 1.
self push: ctxtRcvr.
self push: methodArg.
self push: primRcvr.
self push: argumentArray.
argumentCount := 3.
"Hack. A nil prim error code (primErrorCode = 1) is interpreted by the image
as meaning this primitive is not implemented. So to pass back nil as an error
code we use -1 to indicate generic failure."
primFailCode = 1 ifTrue:
[primFailCode := -1]]!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveExternalCall (in category 'plugin primitives') -----
primitiveExternalCall
"Call an external primitive. External primitive methods first literals are an array of
* The module name (String | Symbol)
* The function name (String | Symbol)
* The session ID (SmallInteger) [OBSOLETE]
* The function index (Integer) in the externalPrimitiveTable
For fast interpreter dispatch in subsequent invocations the primitiveFunctionPointer
in the method cache is rewritten, either to the function itself, or to zero if the external
function is not found. This allows for fast responses as long as the method stays in
the cache. The cache rewrite relies on lastMethodCacheProbeWrite which is set in
addNewMethodToCache:.
Now that the VM flushes function addresses from its tables, the session ID is obsolete,
but it is kept for backward compatibility. Also, a failed lookup is reported specially. If a
method has been looked up and not been found, the function address is stored as -1
(i.e., the SmallInteger -1 to distinguish from 16rFFFFFFFF which may be returned from
lookup), and the primitive fails with PrimErrNotFound."
| lit addr moduleName functionName moduleLength functionLength index |
<var: #addr declareC: 'void (*addr)()'>
"Fetch the first literal of the method"
(self literalCountOf: newMethod) > 0 ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
lit := self literal: 0 ofMethod: newMethod.
"Check if it's an array of length 4"
((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]) ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
"Look at the function index in case it has been loaded before"
index := objectMemory fetchPointer: 3 ofObject: lit.
(objectMemory isIntegerObject: index) ifFalse:
[^self primitiveFailFor: PrimErrBadMethod].
index := objectMemory integerValueOf: index.
"Check if we have already looked up the function and failed."
index < 0 ifTrue:
["Function address was not found in this session,
Void the primitive function."
self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
^self primitiveFailFor: PrimErrNotFound].
"Try to call the function directly"
(index > 0 and: [index <= MaxExternalPrimitiveTableSize]) ifTrue:
[addr := externalPrimitiveTable at: index - 1.
addr ~= 0 ifTrue:
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: 'addr' inSmalltalk: [1000 + index]).
self callExternalPrimitive: addr.
^nil].
"if we get here, then an index to the external prim was
kept on the ST side although the underlying prim
table was already flushed"
^self primitiveFailFor: PrimErrNamedInternal].
"Clean up session id and external primitive index"
objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: lit.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [(objectMemory isBytes: moduleName) ifFalse:
[self primitiveFailFor: PrimErrBadMethod].
moduleLength := objectMemory lengthOf: moduleName].
functionName := objectMemory fetchPointer: 1 ofObject: lit.
(objectMemory isBytes: functionName) ifFalse:
[self primitiveFailFor: PrimErrBadMethod].
functionLength := objectMemory lengthOf: functionName.
+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + self baseHeaderSize
- FromModule: moduleName + objectMemory baseHeaderSize
OfLength: moduleLength.
addr = 0
ifTrue: [index := -1]
ifFalse: ["add the function to the external primitive table"
index := self addToExternalPrimitiveTable: addr].
"Store the index (or -1 if failure) back in the literal"
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
"If the function has been successfully loaded cache and call it"
index >= 0
ifTrue:
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: [addr] inSmalltalk: [1000 + index]).
self callExternalPrimitive: addr]
ifFalse: ["Otherwise void the primitive function and fail"
self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
^self primitiveFailFor: PrimErrNotFound]!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitivePerform (in category 'control primitives') -----
primitivePerform
<returnTypeC: #void>
| performSelector newReceiver lookupClass performMethod |
performSelector := messageSelector.
performMethod := newMethod.
messageSelector := self stackValue: argumentCount - 1.
newReceiver := self stackValue: argumentCount.
"NOTE: the following lookup may fail and be converted to #doesNotUnderstand:,
so we must adjust argumentCount and slide args now, so that will work."
"Slide arguments down over selector"
argumentCount := argumentCount - 1.
argumentCount to: 1 by: -1 do:
[:i|
stackPages
+ longAt: stackPointer + (i * BytesPerWord)
+ put: (stackPages longAt: stackPointer + ((i - 1) * BytesPerWord))].
- longAt: stackPointer + (i * objectMemory bytesPerWord)
- put: (stackPages longAt: stackPointer + ((i - 1) * objectMemory bytesPerWord))].
self pop: 1.
lookupClass := objectMemory fetchClassOf: newReceiver.
+ self sendBreak: messageSelector + self baseHeaderSize
- self sendBreak: messageSelector + objectMemory baseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: newReceiver.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - other objects will have to take their chances"
((objectMemory isOopCompiledMethod: newMethod)
and: [(self argumentCountOf: newMethod) = argumentCount]) ifFalse:
["Slide the args back up (sigh) and re-insert the selector."
self unPop: 1.
1 to: argumentCount by: 1 do:
[:i |
+ stackPages longAt: stackPointer + ((i - 1) * BytesPerWord)
+ put: (stackPages longAt: stackPointer + (i * BytesPerWord))].
+ stackPages longAt: stackPointer + (argumentCount * BytesPerWord) put: messageSelector.
- stackPages longAt: stackPointer + ((i - 1) * objectMemory bytesPerWord)
- put: (stackPages longAt: stackPointer + (i * objectMemory bytesPerWord))].
- stackPages longAt: stackPointer + (argumentCount * objectMemory bytesPerWord) put: messageSelector.
argumentCount := argumentCount + 1.
newMethod := performMethod.
messageSelector := performSelector.
^self primitiveFail].
self executeNewMethod.
"Recursive xeq affects primErrorCode"
self initPrimCall!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveTerminateTo (in category 'control primitives') -----
primitiveTerminateTo
"Primitive. Terminate up the context stack from the receiver up to but not including
the argument, if previousContext is on my Context stack. Make previousContext my
sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct."
| thisCtx currentCtx aContextOrNil contextsFP contextsSP contextsIP nextCntx stackedReceiverOffset
theFP newFP newSP pageToStopOn thePage frameAbove |
<var: #contextsFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #newSP type: #'char *'>
<var: #contextsIP type: #usqInt>
<var: #frameAbove type: #'char *'>
<var: #contextsSP type: #'char *'>
<var: #source type: #'char *'>
<var: #pageToStopOn type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
aContextOrNil := self stackTop.
(aContextOrNil = objectMemory nilObject or: [self isContext: aContextOrNil]) ifFalse:
[^self primitiveFail].
thisCtx := self stackValue: 1.
thisCtx = aContextOrNil ifTrue:
[^self primitiveFail].
"All stackPages need to have current head pointers to avoid confusion."
self externalWriteBackHeadFramePointers.
"If we're searching for aContextOrNil it might be on a stack page. Helps to know
if we can free a whole page or not, or if we can short-cut the termination."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0].
"if thisCtx is married ensure it is a base frame. Then we can assign its sender."
(self isStillMarriedContext: thisCtx)
ifTrue:
[theFP := self frameOfMarriedContext: thisCtx.
"Optimize terminating thisContext. Move its frame down to be next to
aContextOrNil's frame. Common in the exception system and so helps to be fast."
(theFP = framePointer
and: [pageToStopOn = stackPage]) ifTrue:
[(self frameCallerFP: theFP) ~= contextsFP ifTrue:
[stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
frameAbove := self findFrameAbove: contextsFP inPage: pageToStopOn.
contextsIP := self frameCallerSavedIP: frameAbove.
newSP := self frameCallerSP: frameAbove.
+ newFP := newSP - stackedReceiverOffset - BytesPerWord.
- newFP := newSP - stackedReceiverOffset - objectMemory bytesPerWord.
theFP + stackedReceiverOffset
to: stackPointer
+ by: BytesPerWord negated
- by: objectMemory bytesPerWord negated
do: [:source|
+ newSP := newSP - BytesPerWord.
- newSP := newSP - objectMemory bytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
stackPages longAt: newFP + FoxSavedFP put: contextsFP.
stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP.
self assert: (self isContext: thisCtx).
objectMemory storePointerUnchecked: SenderIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: newFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: contextsFP).
framePointer := newFP.
stackPointer := newSP].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil].
theFP := self externalEnsureIsBaseFrame: theFP. "May cause a GC!!!!"
currentCtx := self frameCallerContext: theFP.
"May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[currentCtx := objectMemory fetchPointer: SenderIndex ofObject: thisCtx].
(self context: thisCtx hasSender: aContextOrNil) ifTrue:
["Need to walk the stack freeing stack pages and nilling contexts."
[currentCtx = aContextOrNil
or: [currentCtx = objectMemory nilObject]] whileFalse:
[self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[theFP := self frameOfMarriedContext: currentCtx.
thePage := stackPages stackPageFor: theFP.
"If externalEnsureIsBaseFrame: above has moved thisContext to its own stack
then we will always terminate to a frame on a different page. But if we are
terminating some other context to a context somewhere on the current page
we must save the active frames above that context. Things will look e.g. like this:
thisCtx 499383332 s MethodContext(ContextPart)>resume:
499380484 s BlockClosure>ensure:
499377320 s MethodContext(ContextPart)>handleSignal:
499373760 s MethodContext(ContextPart)>handleSignal:
499372772 s MessageNotUnderstood(Exception)>signal
499369068 s CodeSimulationTests(Object)>doesNotUnderstand: absentMethod
499368708 s [] in CodeSimulationTests>testDNU
(sender is 0xbffc2480 I CodeSimulationTests>runSimulated:)
------------
framePointer 0xbffc234c M MethodContext(ContextPart)>doPrimitive:method:receiver:args:
0xbffc2378 M MethodContext(ContextPart)>tryPrimitiveFor:receiver:args:
0xbffc23ac M MethodContext(ContextPart)>send:to:with:super:
0xbffc23e4 M MethodContext(ContextPart)>send:super:numArgs:
0xbffc2418 M MethodContext(InstructionStream)>interpretNextInstructionFor:
0xbffc2434 M MethodContext(ContextPart)>step
0xbffc2458 I MethodContext(ContextPart)>runSimulated:contextAtEachStep:
------------
(499368708's sender) 0xbffc2480 I CodeSimulationTests>runSimulated:
0xbffc249c M CodeSimulationTests>testDNU
0xbffc24bc I CodeSimulationTests(TestCase)>performTest
0xbffc24dc I [] in CodeSimulationTests(TestCase)>runCase
aContextOrNil 0xbffc24fc M BlockClosure>ensure:
0xbffc2520 I CodeSimulationTests(TestCase)>runCase
0xbffc253c M [] in TestResult>runCase:
When we find this case we move the frames above to a new page by making the
frame above currentCtx a base frame, i.e. making 0xbffc2458 in the above example
a base frame. But in this iteration of the loop we don't move down a frame i.e. currentCtx
doesn't change on this iteration."
thePage = stackPage
ifTrue:
[frameAbove := self findFrameAbove: theFP inPage: thePage.
self assert: frameAbove ~= 0.
frameAbove := self externalEnsureIsBaseFrame: frameAbove. "May cause a GC!!!! May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[thePage = pageToStopOn
ifTrue:
["We're here. Cut back the stack to aContextOrNil's frame,
push its instructionPointer if it's not already a head frame,
and we're done."
frameAbove := self findFrameAbove: contextsFP inPage: thePage.
frameAbove ~= 0 ifTrue:
+ [contextsSP := (self frameCallerSP: frameAbove) - BytesPerWord.
- [contextsSP := (self frameCallerSP: frameAbove) - objectMemory bytesPerWord.
stackPages longAt: contextsSP put: (self frameCallerSavedIP: frameAbove).
self setHeadFP: contextsFP andSP: contextsSP inPage: thePage].
currentCtx := aContextOrNil]
ifFalse:
["We can free the entire page without further ado."
currentCtx := self frameCallerContext: thePage baseFP.
"for a short time invariant is violated; assert follows"
stackPages freeStackPageNoAssert: thePage]]]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]]].
self assert: stackPages pageListIsWellFormed.
(self isMarriedOrWidowedContext: thisCtx)
ifTrue:
[self assert: (self checkIsStillMarriedContext: thisCtx currentFP: framePointer).
self assert: (self isBaseFrame: (self frameOfMarriedContext: thisCtx)).
theFP := self frameOfMarriedContext: thisCtx.
self frameCallerContext: theFP put: aContextOrNil]
ifFalse: [objectMemory storePointer: SenderIndex ofObject: thisCtx withValue: aContextOrNil].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: StackInterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') -----
clipboardWrite: sz From: actualDataAddress At: ignored
+ Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - objectMemory baseHeaderSize)!
Item was changed:
----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') -----
shortPrint: oop
| name classOop |
(objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString ,
' (' , (objectMemory integerValueOf: oop) hex , ')'].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^' is not on the heap'].
+ (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
[^' is misaligned'].
classOop := objectMemory fetchClassOf: oop.
(objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [
^ 'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^ (self stringOf: oop) printString].
name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf:
(objectMemory fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^ 'nil'].
name = 'False' ifTrue: [^ 'false'].
name = 'True' ifTrue: [^ 'true'].
name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString].
name = 'Association' ifTrue: [^ '(' ,
+ (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) ,
' -> ' ,
+ (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
- (self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerWord) hex8 , ')'].
('AEIOU' includes: name first)
ifTrue: [^ 'an ' , name]
ifFalse: [^ 'a ' , name]!
Item was changed:
----- Method: StackInterpreterSimulator>>shortPrintRelative: (in category 'debug support') -----
shortPrintRelative: oop
| name classOop |
(objectMemory isIntegerObject: oop) ifTrue:
[^'=' , (objectMemory integerValueOf: oop) printString ,
' (' , (objectMemory integerValueOf: oop) hex , ')'].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^' is not on the heap'].
+ (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
- (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue:
[^' is misaligned'].
classOop := objectMemory fetchClassOfNonInt: oop.
(objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [
^'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^(self stringOf: oop) printString].
name = 'ByteString' ifTrue: [^(self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)].
name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)].
name = 'Character' ifTrue: [^'=' , (Character value: (objectMemory integerValueOf:
(objectMemory fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^'nil'].
name = 'False' ifTrue: [^'false'].
name = 'True' ifTrue: [^'true'].
name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString].
name = 'Association' ifTrue:
[| valOop |
+ valOop := self longAt: oop + BaseHeaderSize + BytesPerWord.
- valOop := self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerWord.
^'(' ,
+ (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) ,
' -> ' ,
((objectMemory isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - objectMemory startOfMemory]) hex8 , ')'].
^(('AEIOU' includes: name first)
ifTrue: ['an ']
ifFalse: ['a ']) , name!
Item was changed:
----- Method: StackInterpreterSimulator>>stringOf: (in category 'debug support') -----
stringOf: oop
| size long nLongs chars |
^ String streamContents:
[:strm |
size := 100 min: (self stSizeOf: oop).
+ nLongs := size-1//BytesPerWord+1.
- nLongs := size-1//objectMemory bytesPerWord+1.
1 to: nLongs do:
+ [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord).
- [:i | long := self longAt: oop + objectMemory baseHeaderSize + (i-1*objectMemory bytesPerWord).
chars := self charsOfLong: long.
strm nextPutAll: (i=nLongs
+ ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1]
- ifTrue: [chars copyFrom: 1 to: size-1\\objectMemory bytesPerWord+1]
ifFalse: [chars])]]!
Item was changed:
----- Method: StackInterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - BaseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
1 to: stringSize do:
[:i | objectMemory storeByte: i-1 ofObject: stringOop
withValue: (pathName at: i) asciiValue].
!
Item was changed:
----- Method: StackInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
+ BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
[
file := (FileStream fileNamed: imageName) binary.
file == nil ifTrue: [^nil].
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
objectMemory startOfMemory.
(objectMemory getSpecialObjectsOop).
(objectMemory getLastHash).
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
{ desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
[:short| self putShort: short toFile: file].
self putLong: desiredEdenBytes toFile: file.
{ maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
[:short| self putShort: short toFile: file].
"Pad the rest of the header."
4 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
objectMemory startOfMemory // 4 + 1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (objectMemory getMemory at: index)
toFile: file].
self success: true
]
ensure: [file close]!
Item was changed:
----- Method: StackInterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: BytesPerWord!
- ^ aStream nextLittleEndianNumber: objectMemory bytesPerWord!
Item was removed:
- ----- Method: TMethod>>superExpansionNodeFor:args: (in category 'inlining') -----
- superExpansionNodeFor: aSelector args: argumentNodes
- "Answer the expansion of a super send. Merge the super expansion's
- locals, properties and comment into this method's properties."
- (definingClass superclass lookupSelector: aSelector)
- ifNil: [self error: 'superclass does not define super method']
- ifNotNil:
- [:superMethod| | superTMethod commonVars varMap |
- superTMethod := superMethod methodNode asTranslationMethodOfClass: self class.
- ((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode])
- and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse:
- [self error: definingClass name, '>>',selector, ' args ~= ',
- superTMethod definingClass name, '>>', aSelector,
- (String with: $. with: Character cr),
- 'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.'].
- self mergePropertiesOfSuperMethod: superTMethod.
- (commonVars := superTMethod locals intersection: self locals) notEmpty ifTrue:
- [varMap := Dictionary new.
- commonVars do:
- [:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)].
- superTMethod renameVariablesUsing: varMap].
- self assert: (superTMethod locals allSatisfy: [:var| (self locals includes: var) not]).
- locals addAll: superTMethod locals.
- superTMethod declarations keysAndValuesDo:
- [:var :decl|
- self declarationAt: var put: decl].
- superTMethod comment ifNotNil:
- [:superComment|
- comment := comment
- ifNil: [superComment]
- ifNotNil: [superComment, comment]].
- superTMethod extraVariableNumber ifNotNil:
- [:scvn|
- extraVariableNumber := extraVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]].
- superTMethod elideAnyFinalReturn.
- ^superTMethod parseTree]!
Item was changed:
----- Method: VMMaker class>>versionString (in category 'version testing') -----
versionString
"VMMaker versionString"
+ ^'4.13.10'!
- ^'4.13.12'!
Item was changed:
----- Method: VMStackFrameOffsets class>>initializeFrameIndices (in category 'class initialization') -----
initializeFrameIndices
"Format of a stack frame. Word-sized indices relative to the frame pointer.
Terminology
Frames are either single (have no context) or married (have a context).
Contexts are either single (exist on the heap), married (have a context) or widowed (had a frame that has exited).
Stacks grow down:
receiver for method activations/closure for block activations
arg0
...
argN
caller's method ip/base frame's sender context
fp-> saved fp
method
frame flags
context (uninitialized)
receiver
first temp
...
sp-> Nth temp
frame flags holds the number of arguments (since argument temporaries are above the frame)
the flag for a block activation
and the flag indicating if the context field is valid (whether the frame is married).
The first frame in a stack page is the baseFrame and is marked as such by a null saved fp,
in which case the saved method ip is actually the context (possibly hybrid) beneath the base frame"
| fxCallerSavedIP fxSavedFP fxMethod fxFrameFlags fxThisContext fxReceiver |
fxCallerSavedIP := 1.
fxSavedFP := 0.
fxMethod := -1.
fxFrameFlags := -2. "Can find numArgs, needed for fast temp access. args are above fxCallerSavedIP.
Can find ``is block'' bit
Can find ``has context'' bit"
fxThisContext := -3.
fxReceiver := -4.
FrameSlots := fxCallerSavedIP - fxReceiver + 1.
+ FoxCallerSavedIP := fxCallerSavedIP * BytesPerWord.
- FoxCallerSavedIP := fxCallerSavedIP * self bytesPerWord.
"In base frames the caller saved ip field holds the caller context."
FoxCallerContext := FoxCallerSavedIP.
+ FoxSavedFP := fxSavedFP * BytesPerWord.
+ FoxMethod := fxMethod * BytesPerWord.
+ FoxFrameFlags := fxFrameFlags * BytesPerWord.
+ FoxThisContext := fxThisContext * BytesPerWord.
+ FoxReceiver := fxReceiver * BytesPerWord!
- FoxSavedFP := fxSavedFP * self bytesPerWord.
- FoxMethod := fxMethod * self bytesPerWord.
- FoxFrameFlags := fxFrameFlags * self bytesPerWord.
- FoxThisContext := fxThisContext * self bytesPerWord.
- FoxReceiver := fxReceiver * self bytesPerWord!
1
0
Before I forget it, I have this trick ready for a year or so that
might serve in my LargeInteger plugin which use int64 a lot.
If SmallInteger are on 31 bits, then the 34 most significant bits of
the int64 must be the same...
since we are tricky, we just test 33 bits:
(((usqLong)(x)) + 0x40000000ULL) & 0xFFFFFFFF80000000ULL == 0
And when SmallInt is 61bits long (Spur64), the 4 most significant bits
must be the same
we just test 3 bits:
(((usqLong)(x)) + 0x1000000000000000UL) & 0xE000000000000000UL == 0
Indeed:
2r0000 + 1 -> 0001
2r1111 + 1 -> 0000
Any other combination will be > 1 and have one of the most significant
3 bits != 0
So we just have to test the first 3 bits
It's almost how #isIntegerValue: is done currently in Spur 64 but with
one more op and a test on 4 most significant bits...
(intValue >> 60 + 1 bitAnd: 16rF) <= 1
Nicolas
2
1
Hello,
I would like to trace (as in using SystemTracer2) a non-Spur image
into a new Spur image. Can you tell me which packages/classes I need
or what the procedure is, please? I have not been lucky searching for
something like a SpurSystemTracer yet...
Best regards,
Jakob
3
3
Hi Clément,
but what happens if the counter trips on a #==? There are two cases, with and without the callback installed. AFAICT the code will continue after the jump and so won't reflect the values compared. Can you explain what actually happens?
Eliot (phone)
On Apr 29, 2015, at 7:33 AM, commits(a)source.squeak.org wrote:
>
> Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
> http://source.squeak.org/VMMaker/VMMaker.oscog-cb.1271.mcz
>
> ==================== Summary ====================
>
> Name: VMMaker.oscog-cb.1271
> Author: cb
> Time: 29 April 2015, 10:33:32.261 am
> UUID: d1d8e36f-01bc-4d38-b9a2-6a5188c5e3cc
> Ancestors: VMMaker.oscog-eem.1270
>
> In fact in genJumpIf we always reload the counterReg after the trampoline after the jump back to retry. No need to add logic there.
>
> Fix the bug that #== was marked as mapped whereas it should not thanks to Eliot.
>
> The SistaSimulator runs without assertion failures. I'm going to try to recompile it now.
>
> =============== Diff against VMMaker.oscog-eem.1270 ===============
>
> Item was removed:
> - ----- Method: SistaStackToRegisterMappingCogit class>>generatorTableFrom: (in category 'class initialization') -----
> - generatorTableFrom: anArray
> - "Override to replace the unmapped, non-counting inlined #== with a mapped counting inlined #==."
> - | table |
> - table := super generatorTableFrom: anArray.
> - table object do:
> - [:descriptor|
> - descriptor generator == #genSpecialSelectorEqualsEquals ifTrue:
> - [descriptor
> - isMapped: true;
> - isMappedInBlock: true;
> - needsFrameFunction: nil]].
> - ^table!
>
> Item was changed:
> ----- Method: SistaStackToRegisterMappingCogit>>genJumpIf:to: (in category 'bytecode generator support') -----
> genJumpIf: boolean to: targetBytecodePC
> "The heart of performance counting in Sista. Conditional branches are 6 times less
> frequent than sends and can provide basic block frequencies (send counters can't).
> Each conditional has a 32-bit counter split into an upper 16 bits counting executions
> and a lower half counting untaken executions of the branch. Executing the branch
> decrements the upper half, tripping if the count goes negative. Not taking the branch
> decrements the lower half. N.B. We *do not* eliminate dead branches (true ifTrue:/true ifFalse:)
> so that scanning for send and branch data is simplified and that branch data is correct."
> <inline: false>
> | desc ok counterAddress countTripped retry counterReg |
> <var: #ok type: #'AbstractInstruction *'>
> <var: #desc type: #'CogSimStackEntry *'>
> <var: #retry type: #'AbstractInstruction *'>
> <var: #countTripped type: #'AbstractInstruction *'>
>
> (coInterpreter isOptimizedMethod: methodObj) ifTrue: [ ^ super genJumpIf: boolean to: targetBytecodePC ].
>
> self ssFlushTo: simStackPtr - 1.
> desc := self ssTop.
> self ssPop: 1.
> desc popToReg: TempReg.
>
> "We prefer calleeSaved to avoid saving it across the trap trip trampoline"
> counterReg := self allocateRegPreferringCalleeSavedNotConflictingWith: 0.
> retry := self Label.
> self
> genExecutionCountLogicInto: [ :cAddress :countTripBranch |
> counterAddress := cAddress.
> countTripped := countTripBranch ]
> counterReg: counterReg.
> counterIndex := counterIndex + 1.
>
> "Cunning trick by LPD. If true and false are contiguous subtract the smaller.
> Correct result is either 0 or the distance between them. If result is not 0 or
> their distance send mustBeBoolean."
> self assert: (objectMemory objectAfter: objectMemory falseObject) = objectMemory trueObject.
> self annotate: (self SubCw: boolean R: TempReg) objRef: boolean.
> self JumpZero: (self ensureFixupAt: targetBytecodePC - initialPC).
>
> self genFallsThroughCountLogicCounterReg: counterReg counterAddress: counterAddress.
>
> self CmpCq: (boolean == objectMemory falseObject
> ifTrue: [objectMemory trueObject - objectMemory falseObject]
> ifFalse: [objectMemory falseObject - objectMemory trueObject])
> R: TempReg.
> ok := self JumpZero: 0.
> self MoveCq: 0 R: counterReg. "if counterReg is 0 this is a mustBeBoolean, not a counter trip."
>
> - self flag: 'Hi Clément. You can''t just save things to the Smalltalk stack. You can /only/ save things that execution expects to be there on a context''s stack, because this frame may get mapped to a context object and then back, and gc''ed etc. The counter reg does not contain an object so is a complete no-no on the Smalltalk stack. On the C stack in the trampoline is OK, not on the Smalltalk stack in method execution. So instead of saving and restoring the counterReg around the call, something we can''t do, we can reload it after the call'.
> - false ifTrue:
> - ["If counterReg is caller saved then save it"
> - (self register: counterReg isInMask: callerSavedRegMask) ifTrue: [ self PushR: counterReg ]].
> -
> countTripped jmpTarget:
> (self CallRT: (boolean == objectMemory falseObject
> ifTrue: [ceSendMustBeBooleanAddFalseTrampoline]
> ifFalse: [ceSendMustBeBooleanAddTrueTrampoline])).
>
> "If we're in an image which hasn't got the Sista code loaded then the ceCounterTripped:
> trampoline will return directly to machine code, returning the boolean. So the code should
> jump back to the retry point. The trampoline makes sure that TempReg has been reloaded."
> self annotateBytecode: self Label.
>
> - self flag: 'see above'.
> - false ifTrue:
> - ["If counterReg is caller saved then restore it"
> - (self register: counterReg isInMask: callerSavedRegMask) ifTrue: [ self PopR: counterReg ]].
> -
> - "Note we /can't/ save and restore the counterReg's contents around the call since the stack can
> - only contain what an interpreted context's stack would contain at the corresponding point. The
> - counter is not an object, so can't be written to the stack. Hence we reload it after the call."
> - self MoveAw: counterAddress R: counterReg.
> -
> self Jump: retry.
> +
> ok jmpTarget: self Label.
> ^0!
>
2
2