[Vm-dev] VM Maker: VMMaker.oscog-eem.485.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Oct 31 17:01:08 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.485.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.485
Author: eem
Time: 31 October 2013, 9:58:00.215 am
UUID: dcfdd894-4f6c-4efe-bf1d-9ec24984d622
Ancestors: VMMaker.oscog-eem.484
Fix ordering of removal of final return and recording of declarations.
i.e. move them from TMethod>>inferReturnTypeIn: to
CCodeGenerator>>inferTypesForImplicitlyTypedVariablesAndMethods.
Don't do them more than once. Pass in code generator to both to
allow logging of errors. Check that recorded declarations are for
extant variables. Correct a few methods in which this wasn't true.
Refactor the return typer determination into addTypesFor:to:in:
so it can recurse. Add support for some arithmetic ops.
Add asVoidPointer convenience and use it in several mem:cp:y:/
mem:mo:ve: contexts, as welkl as to replace clumsier
cCoerceSimple:'s.
Force the type of all entries in the primitive table to be void in
StackInterpreter class>>preGenerationHook:.
=============== Diff against VMMaker.oscog-eem.484 ===============
Item was added:
+ ----- Method: CCodeGenerator>>generateAsVoidPointer:on:indent: (in category 'C translation') -----
+ generateAsVoidPointer: msgNode on: aStream indent: level
+ "Generate the C code for this message onto the given stream."
+
+ aStream nextPutAll: '((void *)'.
+ self emitCExpression: msgNode receiver on: aStream.
+ aStream nextPut: $)!
Item was changed:
----- Method: CCodeGenerator>>inferTypesForImplicitlyTypedVariablesAndMethods (in category 'type inference') -----
inferTypesForImplicitlyTypedVariablesAndMethods
"Infer the return tupe and the types of untyped variables.
As far as variables go, for now we try only to infer variables
assigned the result of #longLongAt:, but much more could be
done here."
"Iterate over all methods, inferring #void return types, until we reach a fixed point."
+ | firstTime |
+ firstTime := true.
[| changedReturnType |
changedReturnType := false.
methods do:
[:m|
+ firstTime ifTrue:
+ [m removeFinalSelfReturnIn: self. "must preceed recordDeclarationsIn: because it may set returnType"
+ m recordDeclarationsIn: self].
+ m inferTypesForImplicitlyTypedVariablesIn: self.
+ (m inferReturnTypeIn: self) ifTrue:
- m inferTypesForImplicitlyTypedVariablesIn: self.
- (m inferReturnTypeIn: self) ifTrue:
[changedReturnType := true]].
+ firstTime := false.
changedReturnType] whileTrue.
"Type all as-yet-untyped methods as the default"
methods do:
[:m|
m returnType ifNil:
[m returnType: (self implicitReturnTypeFor: m selector)]]!
Item was changed:
----- Method: CCodeGenerator>>initializeCTranslationDictionary (in category 'C translation') -----
initializeCTranslationDictionary
"Initialize the dictionary mapping message names to actions for C code generation."
| pairs |
translationDict := Dictionary new: 200.
pairs := #(
#& #generateAnd:on:indent:
#| #generateOr:on:indent:
#and: #generateSequentialAnd:on:indent:
#or: #generateSequentialOr:on:indent:
#not #generateNot:on:indent:
#+ #generatePlus:on:indent:
#- #generateMinus:on:indent:
#negated #generateNegated:on:indent:
#* #generateTimes:on:indent:
#/ #generateDivide:on:indent:
#// #generateDivide:on:indent:
#\\ #generateModulo:on:indent:
#<< #generateShiftLeft:on:indent:
#>> #generateShiftRight:on:indent:
#min: #generateMin:on:indent:
#max: #generateMax:on:indent:
#between:and: #generateBetweenAnd:on:indent:
#bitAnd: #generateBitAnd:on:indent:
#bitOr: #generateBitOr:on:indent:
#bitXor: #generateBitXor:on:indent:
#bitShift: #generateBitShift:on:indent:
#signedBitShift: #generateSignedBitShift:on:indent:
#bitInvert32 #generateBitInvert32:on:indent:
#bitClear: #generateBitClear:on:indent:
#truncateTo: #generateTruncateTo:on:indent:
#rounded #generateRounded:on:indent:
#< #generateLessThan:on:indent:
#<= #generateLessThanOrEqual:on:indent:
#= #generateEqual:on:indent:
#> #generateGreaterThan:on:indent:
#>= #generateGreaterThanOrEqual:on:indent:
#~= #generateNotEqual:on:indent:
#== #generateEqual:on:indent:
#~~ #generateNotEqual:on:indent:
#isNil #generateIsNil:on:indent:
#notNil #generateNotNil:on:indent:
#whileTrue: #generateWhileTrue:on:indent:
#whileFalse: #generateWhileFalse:on:indent:
#whileTrue #generateDoWhileTrue:on:indent:
#whileFalse #generateDoWhileFalse:on:indent:
#to:do: #generateToDo:on:indent:
#to:by:do: #generateToByDo:on:indent:
#repeat #generateRepeat:on:indent:
#ifTrue: #generateIfTrue:on:indent:
#ifFalse: #generateIfFalse:on:indent:
#ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent:
#ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent:
#ifNotNil: #generateIfNotNil:on:indent:
#ifNil: #generateIfNil:on:indent:
#ifNotNil:ifNil: #generateIfNotNilIfNil:on:indent:
#ifNil:ifNotNil: #generateIfNilIfNotNil:on:indent:
#at: #generateAt:on:indent:
#at:put: #generateAtPut:on:indent:
#basicAt: #generateAt:on:indent:
#basicAt:put: #generateAtPut:on:indent:
#integerValueOf: #generateIntegerValueOf:on:indent:
#integerObjectOf: #generateIntegerObjectOf:on:indent:
#isIntegerObject: #generateIsIntegerObject:on:indent:
#cCode: #generateInlineCCode:on:indent:
#cCode:inSmalltalk: #generateInlineCCode:on:indent:
#cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent:
#cppIf:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent:
#cppIf:ifTrue: #generateInlineCppIfElse:on:indent:
#cCoerce:to: #generateCCoercion:on:indent:
#cCoerceSimple:to: #generateCCoercion:on:indent:
#addressOf: #generateAddressOf:on:indent:
#signedIntFromLong #generateSignedIntFromLong:on:indent:
#signedIntToLong #generateSignedIntToLong:on:indent:
#signedIntFromShort #generateSignedIntFromShort:on:indent:
#signedIntToShort #generateSignedIntToShort:on:indent:
#preIncrement #generatePreIncrement:on:indent:
#preDecrement #generatePreDecrement:on:indent:
#inline: #generateInlineDirective:on:indent:
#asFloat #generateAsFloat:on:indent:
#asInteger #generateAsInteger:on:indent:
#asUnsignedInteger #generateAsUnsignedInteger:on:indent:
#asLong #generateAsLong:on:indent:
#asUnsignedLong #generateAsUnsignedLong:on:indent:
+ #asVoidPointer #generateAsVoidPointer:on:indent:
#asSymbol #generateAsSymbol:on:indent:
#flag: #generateFlag:on:indent:
#anyMask: #generateBitAnd:on:indent:
#noMask: #generateNoMask:on:indent:
#raisedTo: #generateRaisedTo:on:indent:
#touch: #generateTouch:on:indent:
#bytesPerWord #generateBytesPerWord:on:indent:
#wordSize #generateBytesPerWord:on:indent:
#baseHeaderSize #generateBaseHeaderSize:on:indent:
#sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent:
#perform: #generatePerform:on:indent:
#perform:with: #generatePerform:on:indent:
#perform:with:with: #generatePerform:on:indent:
#perform:with:with:with: #generatePerform:on:indent:
#perform:with:with:with:with: #generatePerform:on:indent:
#perform:with:with:with:with:with: #generatePerform:on:indent:
#value #generateValue:on:indent:
#value: #generateValue:on:indent:
#value:value: #generateValue:on:indent:
#shouldNotImplement #generateSmalltalkMetaError:on:indent:
#shouldBeImplemented #generateSmalltalkMetaError:on:indent:
#subclassResponsibility #generateSmalltalkMetaError:on:indent:
).
1 to: pairs size by: 2 do: [:i |
translationDict at: (pairs at: i) put: (pairs at: i + 1)].
pairs := #(
#ifTrue: #generateIfTrueAsArgument:on:indent:
#ifFalse: #generateIfFalseAsArgument:on:indent:
#ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent:
#ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent:
#ifNotNil: #generateIfNotNilAsArgument:on:indent:
#ifNil: #generateIfNilAsArgument:on:indent:
#ifNotNil:ifNil: #generateIfNotNilIfNilAsArgument:on:indent:
#ifNil:ifNotNil: #generateIfNilIfNotNilAsArgument:on:indent:
#cCode: #generateInlineCCodeAsArgument:on:indent:
#cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent:
#cppIf:ifTrue:ifFalse: #generateInlineCppIfElseAsArgument:on:indent:
#cppIf:ifTrue: #generateInlineCppIfElseAsArgument:on:indent:
#value #generateValueAsArgument:on:indent:
#value: #generateValueAsArgument:on:indent:
#value:value: #generateValueAsArgument:on:indent:
).
asArgumentTranslationDict := Dictionary new: 8.
1 to: pairs size by: 2 do: [:i |
asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
!
Item was changed:
----- Method: CCodeGenerator>>returnTypeForSend: (in category 'type inference') -----
returnTypeForSend: aTSendNode
"Answer the return type for a send. Absent sends default to #sqInt."
| sel |
^(methods at: (sel := aTSendNode selector) ifAbsent: nil)
ifNil: [kernelReturnTypes
at: sel
ifAbsent:
+ [^sel
+ caseOf: {
+ [#asVoidPointer] -> [#'void *'].
+ [#asUnsignedInteger] -> [#usqInt].
+ [#asLong] -> [#long].
+ [#asUnsignedLong] -> [#'unsigned long'].
+ [#signedIntToLong] -> [#usqInt]. "c.f. generateSignedIntToLong:on:indent:"
+ [#signedIntToShort] -> [#usqInt]. "c.f. generateSignedIntToShort:on:indent:"
+ [#cCoerce:to:] -> [aTSendNode args last value].
+ [#cCoerceSimple:to:] -> [aTSendNode args last value] }
+ otherwise: [#sqInt]]]
- [(#(cCoerce:to: cCoerceSimple:to:) includes: sel)
- ifTrue: [aTSendNode args last value]
- ifFalse: [#sqInt]]]
ifNotNil: [:m| m returnType]!
Item was changed:
----- Method: CoInterpreter>>callbackEnter: (in category 'callback support') -----
callbackEnter: callbackID
"Re-enter the interpreter for executing a callback"
| currentCStackPointer currentCFramePointer savedReenterInterpreter
wasInMachineCode calledFromMachineCode |
<volatile>
<export: true>
<var: #currentCStackPointer type: #'void *'>
<var: #currentCFramePointer type: #'void *'>
<var: #callbackID type: #'sqInt *'>
<var: #savedReenterInterpreter type: #'jmp_buf'>
"For now, do not allow a callback unless we're in a primitiveResponse"
(self asserta: primitiveFunctionPointer ~= 0) ifFalse:
[^false].
self assert: primFailCode = 0.
"Check if we've exceeded the callback depth"
(self asserta: jmpDepth < MaxJumpBuf) ifFalse:
[^false].
jmpDepth := jmpDepth + 1.
wasInMachineCode := self isMachineCodeFrame: framePointer.
calledFromMachineCode := instructionPointer <= objectMemory startOfMemory.
"Suspend the currently active process"
suspendedCallbacks at: jmpDepth put: self activeProcess.
"We need to preserve newMethod explicitly since it is not activated yet
and therefore no context has been created for it. If the caller primitive
for any reason decides to fail we need to make sure we execute the correct
method and not the one 'last used' in the call back"
suspendedMethods at: jmpDepth put: newMethod.
self flag: 'need to debug this properly. Conceptually it is the right thing to do but it crashes in practice'.
false
ifTrue:
["Signal external semaphores since a signalSemaphoreWithIndex: request may
have been issued immediately prior to this callback before the VM has any
chance to do a signalExternalSemaphores in checkForEventsMayContextSwitch:"
self signalExternalSemaphores.
"If no process is awakened by signalExternalSemaphores then transfer
to the highest priority runnable one."
(suspendedCallbacks at: jmpDepth) == self activeProcess ifTrue:
[self transferTo: self wakeHighestPriority from: CSCallbackLeave]]
ifFalse:
[self transferTo: self wakeHighestPriority from: CSCallbackLeave].
"Typically, invoking the callback means that some semaphore has been
signaled to indicate the callback. Force an interrupt check as soon as possible."
self forceInterruptCheck.
"Save the previous CStackPointers and interpreter entry jmp_buf."
currentCStackPointer := cogit getCStackPointer.
currentCFramePointer := cogit getCFramePointer.
+ self mem: savedReenterInterpreter asVoidPointer
- self mem: (self cCoerceSimple: savedReenterInterpreter to: #'void *')
cp: reenterInterpreter
y: (self sizeof: #'jmp_buf').
cogit assertCStackWellAligned.
(self setjmp: (jmpBuf at: jmpDepth)) == 0 ifTrue: "Fill in callbackID"
[callbackID at: 0 put: jmpDepth.
self enterSmalltalkExecutive.
self assert: false "NOTREACHED"].
"Restore the previous CStackPointers and interpreter entry jmp_buf."
cogit setCStackPointer: currentCStackPointer.
cogit setCFramePointer: currentCFramePointer.
self mem: reenterInterpreter
cp: (self cCoerceSimple: savedReenterInterpreter to: #'void *')
y: (self sizeof: #'jmp_buf').
"Transfer back to the previous process so that caller can push result"
self putToSleep: self activeProcess yieldingIf: preemptionYields.
self transferTo: (suspendedCallbacks at: jmpDepth) from: CSCallbackLeave.
newMethod := suspendedMethods at: jmpDepth. "see comment above"
argumentCount := self argumentCountOf: newMethod.
self assert: wasInMachineCode = (self isMachineCodeFrame: framePointer).
calledFromMachineCode
ifTrue:
[instructionPointer >= objectMemory startOfMemory ifTrue:
[self iframeSavedIP: framePointer put: instructionPointer.
instructionPointer := cogit ceReturnToInterpreterPC]]
ifFalse:
["Even if the context was flushed to the heap and rebuilt in transferTo:from:
above it will remain an interpreted frame because the context's pc would
remain a bytecode pc. So the instructionPointer must also be a bytecode pc."
self assert: (self isMachineCodeFrame: framePointer) not.
self assert: instructionPointer > objectMemory startOfMemory].
self assert: primFailCode = 0.
jmpDepth := jmpDepth-1.
^true!
Item was removed:
- ----- Method: CoInterpreter>>followForwardedFrameContents:stackPointer: (in category 'lazy become') -----
- followForwardedFrameContents: theFP stackPointer: theSP
- "follow pointers in the current stack frame up to theSP."
- <var: #theFP type: #'char *'>
- <var: #theSP type: #'char *'>
- theFP + (self frameStackedReceiverOffset: theFP)
- to: theFP + FoxCallerSavedIP + BytesPerWord
- by: BytesPerWord
- do: [:ptr| | oop |
- oop := stackPages longAt: ptr.
- ((objectMemory isNonImmediate: oop)
- and: [objectMemory isForwarded: oop]) ifTrue:
- [stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
- theSP
- to: (self frameReceiverOffset: theFP)
- by: BytesPerWord
- do: [:ptr| | oop |
- oop := stackPages longAt: ptr.
- ((objectMemory isNonImmediate: oop)
- and: [objectMemory isForwarded: oop]) ifTrue:
- [stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
- self assert: (objectMemory isForwarded: (self frameMethod: theFP)) not.
- (self frameHasContext: theFP) ifTrue:
- [self assert: (objectMemory isForwarded: (self frameContext: theFP)) not]!
Item was changed:
----- Method: CoInterpreter>>restoreCStackStateForCallbackContext: (in category 'callback support') -----
restoreCStackStateForCallbackContext: vmCallbackContext
<var: #vmCallbackContext type: #'VMCallbackContext *'>
cogit
setCStackPointer: vmCallbackContext savedCStackPointer;
setCFramePointer: vmCallbackContext savedCFramePointer.
self mem: reenterInterpreter
+ cp: vmCallbackContext savedReenterInterpreter asVoidPointer
- cp: (self cCoerceSimple: vmCallbackContext savedReenterInterpreter to: #'void *')
y: (self sizeof: #'jmp_buf')!
Item was changed:
----- Method: CoInterpreter>>saveCStackStateForCallbackContext: (in category 'callback support') -----
saveCStackStateForCallbackContext: vmCallbackContext
<var: #vmCallbackContext type: #'VMCallbackContext *'>
vmCallbackContext
savedCStackPointer: cogit getCStackPointer;
savedCFramePointer: cogit getCFramePointer.
+ self mem: vmCallbackContext savedReenterInterpreter asVoidPointer
- self mem: (self cCoerceSimple: vmCallbackContext savedReenterInterpreter to: #'void *')
cp: reenterInterpreter
y: (self sizeof: #'jmp_buf')!
Item was changed:
----- Method: CoInterpreterMT>>primitiveRelinquishProcessor (in category 'I/O primitives') -----
primitiveRelinquishProcessor
"Relinquish the processor for up to the given number of microseconds.
The exact behavior of this primitive is platform dependent.
Override to check for waiting threads."
| microSecs threadIndexAndFlags currentCStackPointer currentCFramePointer savedReenterInterpreter |
<var: #currentCStackPointer type: #'void *'>
<var: #currentCFramePointer type: #'void *'>
<var: #savedReenterInterpreter type: #'jmp_buf'>
microSecs := self stackTop.
(objectMemory isIntegerObject: microSecs) ifFalse:
[^self primitiveFail].
self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject.
self assert: relinquishing not.
"DO NOT allow relinquishing the processor while we are profiling since this
may skew the time base for our measures (it may reduce processor speed etc).
Instead we go full speed, therefore measuring the precise time we spend in the
inner idle loop as a busy loop."
nextProfileTick = 0 ifTrue:
"Presumably we have nothing to do; this primitive is typically called from the
background process. So we should /not/ try and activate any threads in the
pool; they will waste cycles finding there is no runnable process, and will
cause a VM abort if no runnable process is found. But we /do/ want to allow
FFI calls that have completed, or callbacks a chance to get into the VM; they
do have something to do. DisownVMForProcessorRelinquish indicates this."
[currentCStackPointer := cogit getCStackPointer.
currentCFramePointer := cogit getCFramePointer.
self cCode:
+ [self mem: savedReenterInterpreter asVoidPointer
- [self mem: (self cCoerceSimple: savedReenterInterpreter to: #'void *')
cp: reenterInterpreter
y: (self sizeof: #'jmp_buf')].
threadIndexAndFlags := self disownVM: DisownVMForProcessorRelinquish.
self assert: relinquishing.
self ioRelinquishProcessorForMicroseconds: (objectMemory integerValueOf: microSecs).
self assert: relinquishing.
self ownVM: threadIndexAndFlags.
self assert: relinquishing not.
self assert: cogThreadManager currentVMThread state = CTMAssignableOrInVM.
self assert: currentCStackPointer = cogit getCStackPointer.
self assert: currentCFramePointer = cogit getCFramePointer.
self cCode:
[self assert: (self mem: (self cCoerceSimple: savedReenterInterpreter to: #'void *')
cm: reenterInterpreter
p: (self sizeof: #'jmp_buf')) = 0]].
self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject.
self pop: 1 "microSecs; leave rcvr on stack"!
Item was changed:
----- Method: CoInterpreterMT>>returnToSchedulingLoopAndReleaseVMOrWakeThread:source: (in category 'process primitive support') -----
returnToSchedulingLoopAndReleaseVMOrWakeThread: vmThread source: source
| savedReenterInterpreter |
<var: #savedReenterInterpreter type: #'jmp_buf'>
<var: #vmThread type: #'CogVMThread *'>
<inline: false>
self cCode:
[self flag: 'this is just for debugging. Note the current C stack pointers'.
cogThreadManager currentVMThread
cStackPointer: cogit getCStackPointer;
cFramePointer: cogit getCFramePointer]
inSmalltalk:
[| range |
range := self cStackRangeForThreadIndex: cogThreadManager getVMOwner.
self assert: (range includes: cogit getCStackPointer).
self assert: (range includes: cogit getCFramePointer)].
"We must use a copy of reenterInterpreter since we're giving up the VM to another vmThread."
self cCode:
+ [self mem: savedReenterInterpreter asVoidPointer
- [self mem: (self cCoerceSimple: savedReenterInterpreter to: #'void *')
cp: reenterInterpreter
y: (self sizeof: #'jmp_buf')]
inSmalltalk:
[savedReenterInterpreter := reenterInterpreter].
self recordThreadSwitchTo: (vmThread ifNotNil: [vmThread index] ifNil: [0]) source: source.
vmThread
ifNotNil: [cogThreadManager wakeVMThreadFor: vmThread index]
ifNil: [cogThreadManager releaseVM].
"2 implies returning to the threadSchedulingLoop."
self siglong: savedReenterInterpreter jmp: ReturnToThreadSchedulingLoop!
Item was changed:
----- Method: Cogit>>bytecodePCFor:startBcpc:in: (in category 'method map') -----
bytecodePCFor: mcpc startBcpc: startbcpc in: cogMethod
"Answer the zero-relative bytecode pc matching the machine code pc argument in
cogMethod, given the start of the bytecodes for cogMethod's block or method object."
<api>
<var: #cogMethod type: #'CogBlockMethod *'>
^self
mapFor: cogMethod
bcpc: startbcpc
performUntil: #findMcpc:Bcpc:MatchingMcpc:
+ arg: mcpc asVoidPointer!
- arg: (self cCoerceSimple: mcpc to: #'void *')!
Item was changed:
----- Method: Cogit>>compileCPIC:Case0:Case1Method:tag:isMNUCase:numArgs: (in category 'in-line cacheing') -----
compileCPIC: cPIC Case0: case0CogMethod Case1Method: case1Method tag: case1Tag isMNUCase: isMNUCase numArgs: numArgs
"Compile the code for a two-case PIC for case0CogMethod and case1Method,case1Tag.
The tag for case0CogMethod is at the send site and so doesn't need to be generated.
case1Method may be any of
- a Cog method; jump to its unchecked entry-point
- a CompiledMethod; jump to the ceInterpretFromPIC trampoline
- nil; call ceMNUFromPIC"
<var: #cPIC type: #'CogMethod *'>
| operand targetEntry jumpNext |
<var: #case0CogMethod type: #'CogMethod *'>
<var: #targetEntry type: #'void *'>
<var: #jumpNext type: #'AbstractInstruction *'>
self assert: case1Method notNil.
self compilePICProlog: numArgs.
self assert: (objectRepresentation inlineCacheTagIsYoung: case1Tag) not.
(isMNUCase not
and: [coInterpreter methodHasCogMethod: case1Method])
ifTrue:
[operand := 0.
+ targetEntry := ((coInterpreter cogMethodOf: case1Method) asInteger + cmNoCheckEntryOffset) asVoidPointer]
- targetEntry := self cCoerceSimple: (coInterpreter cogMethodOf: case1Method) asInteger + cmNoCheckEntryOffset
- to: #'void *']
ifFalse:
[self assert: (case1Method isNil or: [(objectMemory isYoung: case1Method) not]).
operand := case1Method.
targetEntry := case1Method isNil ifTrue: [mnuCall] ifFalse: [interpretCall]].
jumpNext := self compileCPICEntry.
self MoveCw: 0 R: SendNumArgsReg.
self JumpLong: case0CogMethod asInteger + cmNoCheckEntryOffset.
endCPICCase0 := self CmpCw: case1Tag R: TempReg.
jumpNext jmpTarget: endCPICCase0.
self MoveCw: operand R: SendNumArgsReg.
self JumpLongZero: (isMNUCase ifTrue: [mnuCall] ifFalse: [targetEntry]) asInteger.
endCPICCase1 := self MoveCw: cPIC asInteger R: ClassReg.
self JumpLong: (self cPICMissTrampolineFor: numArgs).
^0
!
Item was changed:
----- Method: Cogit>>mcPCFor:startBcpc:in: (in category 'method map') -----
mcPCFor: bcpc startBcpc: startbcpc in: cogMethod
"Answer the absolute machine code pc matching the zero-relative bytecode pc argument
in cogMethod, given the start of the bytecodes for cogMethod's block or method object."
<api>
<var: #cogMethod type: #'CogBlockMethod *'>
| absPC |
absPC := self
mapFor: cogMethod
bcpc: startbcpc
performUntil: #findMcpc:Bcpc:MatchingBcpc:
+ arg: bcpc asVoidPointer.
- arg: (self cCoerceSimple: bcpc to: #'void *').
^absPC ~= 0
ifTrue: [absPC asUnsignedInteger - cogMethod asUnsignedInteger]
ifFalse: [absPC]!
Item was added:
+ ----- Method: Integer>>asVoidPointer (in category '*VMMaker-interpreter simulator') -----
+ asVoidPointer
+ ^self!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFloatAtPut (in category 'indexing primitives') -----
primitiveFloatAtPut
"Provide platform-independent access to 32-bit words comprising
a Float. Map index 1 onto the most significant word and index 2
onto the least significant word."
| rcvr index oopToStore valueToStore |
+ <var: #valueToStore type: #usqInt>
- <var: #result type: #usqInt>
self initPrimCall.
oopToStore := self stackTop.
valueToStore := self positive32BitValueOf: oopToStore.
self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 2.
index := self stackValue: 1.
index = ConstOne ifTrue:
[objectMemory storeLong32: (VMBIGENDIAN ifTrue: [0] ifFalse: [1])
ofObject: rcvr
withValue: valueToStore.
^self pop: 3 thenPush: oopToStore].
index = ConstTwo ifTrue:
[objectMemory storeLong32: (VMBIGENDIAN ifTrue: [1] ifFalse: [0])
ofObject: rcvr
withValue: valueToStore.
^self pop: 3 thenPush: oopToStore].
self primitiveFailFor: ((objectMemory isIntegerObject: index)
ifTrue: [PrimErrBadIndex]
ifFalse: [PrimErrBadArgument])!
Item was changed:
----- Method: ObjectMemory>>checkOopHasOkayClass: (in category 'debug support') -----
checkOopHasOkayClass: obj
"Attempt to verify that the given obj has a reasonable behavior. The class must be a
valid, non-integer oop and must not be nilObj. It must be a pointers object with three
or more fields. Finally, the instance specification field of the behavior must match that
of the instance. If OK answer true. If not, print reason and answer false."
<api>
+ <var: #obj type: #usqInt>
- <var: #oop type: #usqInt>
| objClass formatMask behaviorFormatBits objFormatBits |
+ <var: #objClass type: #usqInt>
- <var: #oopClass type: #usqInt>
(self checkOkayOop: obj) ifFalse:
[^false].
objClass := self cCoerce: (self fetchClassOfNonImm: obj) to: #usqInt.
(self isIntegerObject: objClass) ifTrue:
[self print: 'obj '; printHex: obj; print: ' a SmallInteger is not a valid class or behavior'; cr. ^false].
(self okayOop: objClass) ifFalse:
[self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false].
((self isPointersNonInt: objClass) and: [(self lengthOf: objClass) >= 3]) ifFalse:
[self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
formatMask := (self isBytes: obj)
ifTrue: [16rC00] "ignore extra bytes size bits"
ifFalse: [16rF00].
behaviorFormatBits := (self formatOfClass: objClass) bitAnd: formatMask.
objFormatBits := (self baseHeader: obj) bitAnd: formatMask.
behaviorFormatBits = objFormatBits ifFalse:
[self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false].
^true!
Item was changed:
----- Method: ObjectMemory>>firstFixedFieldOfMaybeImmediate: (in category 'debug support') -----
firstFixedFieldOfMaybeImmediate: oop
"for the message send breakpoint; selectors can be immediates."
<inline: false>
^(self isImmediate: oop)
+ ifTrue: [oop asVoidPointer]
- ifTrue: [oop]
ifFalse: [self firstFixedField: oop]!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>bytecodePCFor:startBcpc:in: (in category 'method map') -----
bytecodePCFor: mcpc startBcpc: startbcpc in: cogMethod
"Answer the zero-relative bytecode pc matching the machine code pc argument in
cogMethod, given the start of the bytecodes for cogMethod's block or method object."
<api>
<var: #cogMethod type: #'CogBlockMethod *'>
^self
mapFor: cogMethod
bcpc: startbcpc
performUntil: #find:Mcpc:Bcpc:MatchingMcpc:
+ arg: mcpc asVoidPointer!
- arg: (self cCoerceSimple: mcpc to: #'void *')!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>mcPCFor:startBcpc:in: (in category 'method map') -----
mcPCFor: bcpc startBcpc: startbcpc in: cogMethod
"Answer the absolute machine code pc matching the zero-relative bytecode pc argument
in cogMethod, given the start of the bytecodes for cogMethod's block or method object."
<api>
<var: #cogMethod type: #'CogBlockMethod *'>
| absPC |
absPC := self
mapFor: cogMethod
bcpc: startbcpc
performUntil: #find:Mcpc:Bcpc:MatchingBcpc:
+ arg: bcpc asVoidPointer.
- arg: (self cCoerceSimple: bcpc to: #'void *').
^absPC ~= 0
ifTrue: [absPC asUnsignedInteger - cogMethod asUnsignedInteger]
ifFalse: [absPC]!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>picDataFor:into: (in category 'method introspection') -----
picDataFor: cogMethod into: arrayObj
"Answer the zero-relative bytecode pc matching the machine code pc argument in
cogMethod, given the start of the bytecodes for cogMethod's block or method object."
<api>
<var: #cogMethod type: #'CogMethod *'>
| errCode |
cogMethod stackCheckOffset = 0 ifTrue:
[^0].
picDataIndex := 0.
picData := arrayObj.
errCode := self
mapFor: (self cCoerceSimple: cogMethod to: #'CogBlockMethod *')
bcpc: (coInterpreter startPCOfMethod: cogMethod methodObject)
performUntil: #picDataFor:Mcpc:Bcpc:Method:
+ arg: cogMethod asVoidPointer.
- arg: (self cCoerceSimple: cogMethod to: #'void *').
errCode ~= 0 ifTrue:
[self assert: errCode = PrimErrNoMemory.
^-1].
^picDataIndex!
Item was removed:
- ----- Method: SmartSyntaxPluginTMethod>>recordDeclarations (in category 'transforming') -----
- recordDeclarations
- "Record C type declarations of the forms
-
- self returnTypeC: 'float'.
- self var: #foo declareC: 'float foo'
- self var: #foo as: Class
- self var: #foo type: 'float'.
-
- and remove the declarations from the method body."
-
- | newStatements |
- properties pragmas notEmpty ifTrue:
- [properties pragmas do:
- [:pragma|
- pragma keyword = #var:declareC: ifTrue:
- [self declarationAt: pragma arguments first asString put: pragma arguments last].
- pragma keyword = #var:type: ifTrue:
- [| varName varType |
- varName := pragma arguments first asString.
- varType := pragma arguments last.
- varType last = $* ifFalse: [varType := varType, ' '].
- self declarationAt: varName put: varType, varName].
- pragma keyword = #var:as: ifTrue:
- [| theClass |
- theClass := Smalltalk at: pragma arguments last name asSymbol ifAbsent: [nil].
- (theClass isKindOf: Behavior) ifFalse:
- [^self error: 'declarator must be a Behavior'].
- self declarationAt: pragma arguments first value asString
- put: (theClass ccgDeclareCForVar: pragma arguments first asString)].
- pragma keyword = #returnTypeC: ifTrue:
- [returnType := pragma arguments last].
- pragma keyword = #doNotGenerate: ifTrue:
- [locals removeKey: pragma arguments last]].
- ^self].
- newStatements := OrderedCollection new: parseTree statements size.
- parseTree statements do:
- [:stmt | | isDeclaration |
- isDeclaration := false.
- stmt isSend ifTrue:
- [stmt selector = #var:declareC: ifTrue:
- [isDeclaration := true.
- self declarationAt: stmt args first value asString put: stmt args last value].
- stmt selector = #var:type: ifTrue: [
- | varName varType |
- isDeclaration := true.
- varName := stmt args first value asString.
- varType := stmt args last value.
- varType last = $* ifFalse: [varType := varType, ' '].
- self declarationAt: varName put: varType, varName.
- ].
- stmt selector = #var:as: ifTrue:
- [| theClass |
- isDeclaration := true.
- theClass := Smalltalk at: stmt args last name asSymbol ifAbsent: [nil].
- (theClass isKindOf: Behavior) ifFalse:
- [^self error: 'declarator must be a Behavior'].
- self declarationAt: stmt args first value asString
- put: (theClass ccgDeclareCForVar: stmt args first value asString)].
- stmt selector = #returnTypeC: ifTrue:
- [isDeclaration := true.
- returnType := stmt args last value]].
- isDeclaration ifFalse: [newStatements add: stmt]].
- parseTree setStatements: newStatements asArray!
Item was added:
+ ----- Method: SmartSyntaxPluginTMethod>>recordDeclarationsIn: (in category 'transforming') -----
+ recordDeclarationsIn: aCCodeGen
+ "Record C type declarations of the forms
+ <returnTypeC: 'float'>
+ <var: #foo declareC: 'float foo'>
+ <var: #foo type:'float'>
+ <var: #foo as: Class>
+ or the older, obsolete
+ self returnTypeC: 'float'.
+ self var: #foo declareC: 'float foo'
+ self var: #foo type:'float'.
+ self var: #foo as: Class
+ and remove the declarations from the method body."
+
+ | newStatements |
+ properties pragmas notEmpty ifTrue:
+ [properties pragmas do:
+ [:pragma|
+ pragma keyword = #var:declareC: ifTrue:
+ [self checkedDeclarationAt: pragma arguments first asString
+ put: pragma arguments last
+ in: aCCodeGen].
+ pragma keyword = #var:type: ifTrue:
+ [| varName varType |
+ varName := pragma arguments first asString.
+ varType := pragma arguments last.
+ varType last = $* ifFalse: [varType := varType, ' '].
+ self checkedDeclarationAt: varName
+ put: varType, varName
+ in: aCCodeGen].
+ pragma keyword = #var:as: ifTrue:
+ [| theClass |
+ theClass := Smalltalk at: pragma arguments last name asSymbol ifAbsent: [nil].
+ (theClass isKindOf: Behavior) ifFalse:
+ [^self error: 'declarator must be a Behavior'].
+ self checkedDeclarationAt: pragma arguments first value asString
+ put: (theClass ccgDeclareCForVar: pragma arguments first asString)
+ in: aCCodeGen].
+ pragma keyword = #returnTypeC: ifTrue:
+ [self returnType: pragma arguments last].
+ pragma keyword = #doNotGenerate: ifTrue:
+ [locals removeKey: pragma arguments last]].
+ ^self].
+ newStatements := OrderedCollection new: parseTree statements size.
+ parseTree statements do:
+ [:stmt | | isDeclaration |
+ isDeclaration := false.
+ stmt isSend ifTrue:
+ [stmt selector = #var:declareC: ifTrue:
+ [isDeclaration := true.
+ self declarationAt: stmt args first value asString put: stmt args last value].
+ stmt selector = #var:type: ifTrue: [
+ | varName varType |
+ isDeclaration := true.
+ varName := stmt args first value asString.
+ varType := stmt args last value.
+ varType last = $* ifFalse: [varType := varType, ' '].
+ self declarationAt: varName put: varType, varName.
+ ].
+ stmt selector = #var:as: ifTrue:
+ [| theClass |
+ isDeclaration := true.
+ theClass := Smalltalk at: stmt args last name asSymbol ifAbsent: [nil].
+ (theClass isKindOf: Behavior) ifFalse:
+ [^self error: 'declarator must be a Behavior'].
+ self declarationAt: stmt args first value asString
+ put: (theClass ccgDeclareCForVar: stmt args first value asString)].
+ stmt selector = #returnTypeC: ifTrue:
+ [isDeclaration := true.
+ returnType := stmt args last value]].
+ isDeclaration ifFalse: [newStatements add: stmt]].
+ parseTree setStatements: newStatements asArray!
Item was changed:
----- Method: SmartSyntaxPluginTMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initializing') -----
setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment
"Initialize this method using the given information."
selector := sel.
definingClass := class.
returnType := #sqInt. "assume return type is sqInt for now"
args := argList asOrderedCollection collect: [:arg | arg key].
locals := (localList collect: [:arg | arg key]) asSet.
declarations := Dictionary new.
primitive := aNumber.
properties := methodProperties.
comment := aComment.
parseTree := aBlockNode asTranslatorNodeIn: self.
labels := OrderedCollection new.
complete := false. "set to true when all possible inlining has been done"
export := self extractExportDirective.
static := self extractStaticDirective.
canAsmLabel := self extractLabelDirective.
self extractSharedCase.
isPrimitive := false. "set to true only if you find a primtive direction."
suppressingFailureGuards := self extractSuppressFailureGuardDirective.
+ self recordDeclarationsIn: nil.
- self recordDeclarations.
self extractPrimitiveDirectives.
!
Item was changed:
----- Method: SpurGenerationScavenger>>copyToFutureSpace:bytes: (in category 'scavenger') -----
copyToFutureSpace: survivor bytes: bytesInObject
"Copy survivor to futureSpace. Assume it will fit (checked by sender).
Answer the new oop of the object (it may have an overflow size field)."
<inline: true>
| startOfSurvivor newStart |
self assert: futureSurvivorStart + bytesInObject <= futureSpace limit.
startOfSurvivor := manager startOfObject: survivor.
newStart := futureSurvivorStart.
futureSurvivorStart := futureSurvivorStart + bytesInObject.
+ manager mem: newStart asVoidPointer cp: startOfSurvivor asVoidPointer y: bytesInObject.
- manager mem: newStart cp: startOfSurvivor y: bytesInObject.
^newStart + (survivor - startOfSurvivor)!
Item was changed:
----- Method: SpurGenerationScavenger>>copyToOldSpace: (in category 'scavenger') -----
copyToOldSpace: survivor
"Copy survivor to oldSpace. Answer the new oop of the object."
<inline: true>
| numSlots newOop |
statTenures := statTenures + 1.
self flag: 'why not just pass header??'.
numSlots := manager numSlotsOf: survivor.
newOop := manager
allocateSlotsInOldSpace: numSlots
format: (manager formatOf: survivor)
classIndex: (manager classIndexOf: survivor).
newOop ifNil:
[self error: 'out of memory'].
manager
+ mem: (newOop + manager baseHeaderSize) asVoidPointer
+ cp: (survivor + manager baseHeaderSize) asVoidPointer
- mem: newOop + manager baseHeaderSize
- cp: survivor + manager baseHeaderSize
y: numSlots * manager wordSize.
self remember: newOop.
manager setIsRememberedOf: newOop to: true.
^newOop!
Item was changed:
----- Method: SpurMemoryManager>>checkOopHasOkayClass: (in category 'debug support') -----
checkOopHasOkayClass: obj
"Attempt to verify that the given obj has a reasonable behavior. The class must be a
valid, non-integer oop and must not be nilObj. It must be a pointers object with three
or more fields. Finally, the instance specification field of the behavior must match that
of the instance. If OK answer true. If not, print reason and answer false."
<api>
+ <var: #obj type: #usqInt>
- <var: #oop type: #usqInt>
| objClass objFormat |
+ <var: #objClass type: #usqInt>
- <var: #oopClass type: #usqInt>
(self checkOkayOop: obj) ifFalse:
[^false].
objClass := self cCoerce: (self fetchClassOfNonImm: obj) to: #usqInt.
(self isImmediate: objClass) ifTrue:
[self print: 'obj '; printHex: obj; print: ' an immediate is not a valid class or behavior'; cr. ^false].
(self okayOop: objClass) ifFalse:
[self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false].
((self isPointersNonImm: objClass) and: [(self numSlotsOf: objClass) >= 3]) ifFalse:
[self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
objFormat := (self isBytes: obj)
ifTrue: [(self formatOf: obj) bitClear: 7] "ignore extra bytes size bits"
ifFalse: [self formatOf: obj].
(self instSpecOfClass: objClass) ~= objFormat ifTrue:
[self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false].
^true!
Item was changed:
----- Method: SpurMemoryManager>>copyAndForward:withBytes:toFreeChunk: (in category 'compaction') -----
copyAndForward: objOop withBytes: bytes toFreeChunk: freeChunk
"Copy and forward objOop to freeChunk, the inner operation in
exact and best fit compact."
<inline: true>
| startOfObj freeObj |
startOfObj := self startOfObject: objOop.
+ self mem: freeChunk asVoidPointer cp: startOfObj asVoidPointer y: bytes.
- self mem: freeChunk cp: startOfObj y: bytes.
freeObj := freeChunk + (objOop - startOfObj).
"leave it to followRememberedForwarders to remember..."
"(self isRemembered: objOop) ifTrue:
[scavenger remember: freeObj]."
self forward: objOop to: freeObj!
Item was changed:
----- Method: SpurMemoryManager>>firstFixedFieldOfMaybeImmediate: (in category 'debug support') -----
firstFixedFieldOfMaybeImmediate: oop
"for the message send breakpoint; selectors can be immediates."
<inline: false>
^(self isImmediate: oop)
+ ifTrue: [oop asVoidPointer]
- ifTrue: [oop]
ifFalse: [self firstFixedField: oop]!
Item was changed:
----- Method: SpurMemoryManager>>moveMisfitsInHighestObjectsBack: (in category 'compaction') -----
moveMisfitsInHighestObjectsBack: savedLimit
"After refilling highestObjects move any misfits back to being
adjacent with the new objects, reset the space's limit and
answer the pointer to the lowest failure to resume the scan."
| newMisfitsPosition |
savedLimit = highestObjects limit ifTrue:
[^highestObjects last].
"simple; we didnt fill all the way; just move misfits down."
(highestObjects first = highestObjects start
and: [highestObjects last < highestObjects limit]) ifTrue:
[newMisfitsPosition := highestObjects limit.
+ self mem: newMisfitsPosition asVoidPointer
+ mo: (highestObjects last + self wordSize) asVoidPointer
- self mem: newMisfitsPosition
- mo: highestObjects last + self wordSize
ve: savedLimit - newMisfitsPosition.
highestObjects limit: savedLimit.
^newMisfitsPosition].
"tricky to do unless we have last - start's worth of free space.
we *don't* want to rotate lots and lots of objects. We could push
misfits onto the mark stack, if it is big enough.
limit: | misfits hi <-> lo | lowest candidates | highest candidates | : start
^ last"
self shouldBeImplemented.
^newMisfitsPosition!
Item was changed:
----- Method: SpurMemoryManager>>moveMisfitsToTopOfHighestObjects: (in category 'compaction') -----
moveMisfitsToTopOfHighestObjects: misfits
"After a cycle of exact-fit compaction highestObjects may contain some
number of mobile objects that fail to fit, and more objects may exist to
move. Move existing misfits to top of highestObjects and temporarily
shrink highestObjects to refill it without overwriting misfits. Answer the
old limit. moveMisfitsInHighestObjectsBack: will undo the change."
| oldLimit bytesToMove |
oldLimit := highestObjects limit.
misfits = (highestObjects last + self wordSize) ifTrue:
[highestObjects resetAsEmpty.
^oldLimit].
misfits <= highestObjects last ifTrue:
[bytesToMove := highestObjects last + self wordSize - misfits.
+ self mem: (highestObjects limit - bytesToMove) asVoidPointer
+ mo: misfits asVoidPointer
- self mem: highestObjects limit - bytesToMove
- mo: misfits
ve: bytesToMove.
highestObjects limit: misfits - self wordSize.
^oldLimit].
"misfits wrapped; move in two stages to preserve ordering"
bytesToMove := highestObjects last - highestObjects start.
+ self mem: (misfits - bytesToMove) asVoidPointer
+ mo: misfits asVoidPointer
- self mem: misfits - bytesToMove
- mo: misfits
ve: oldLimit - misfits.
highestObjects limit: misfits - bytesToMove.
+ self mem: (oldLimit - bytesToMove) asVoidPointer
+ mo: highestObjects start asVoidPointer
- self mem: oldLimit - bytesToMove
- mo: highestObjects start
ve: bytesToMove.
^oldLimit!
Item was changed:
----- Method: SpurSegmentManager>>addSegmentOfSize: (in category 'growing/shrinking memory') -----
addSegmentOfSize: ammount
<returnTypeC: #'SpurSegmentInfo *'>
<inline: false>
| allocatedSize |
<var: #newSeg type: #'SpurSegmentInfo *'>
+ <var: #segAddress type: #'void *'>
(manager "sent to the manager so that the simulator can increase memory to simulate a new segment"
sqAllocateMemorySegmentOfSize: ammount
+ Above: ((segments at: 0) segStart + (segments at: 0) segSize) asVoidPointer
- Above: (segments at: 0) segStart + (segments at: 0) segSize
AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize]
inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil:
[:segAddress| | newSegIndex newSeg |
+ newSegIndex := self insertSegmentFor: segAddress asUnsignedLong.
- newSegIndex := self insertSegmentFor: segAddress.
newSeg := self addressOf: (segments at: newSegIndex).
newSeg
segStart: segAddress;
segSize: allocatedSize.
self bridgeFrom: (self addressOf: (segments at: newSegIndex - 1)) to: newSeg.
self bridgeFrom: newSeg to: (newSegIndex = (numSegments - 1) ifFalse:
[self addressOf: (segments at: newSegIndex + 1)]).
"and add the new free chunk to the free list; done here
instead of in assimilateNewSegment: for the assert"
manager addFreeChunkWithBytes: allocatedSize - manager bridgeSize at: newSeg segStart.
self assert: (manager addressAfter: (manager objectStartingAt: newSeg segStart))
= (newSeg segStart + newSeg segSize - manager bridgeSize).
^newSeg].
^nil!
Item was changed:
----- Method: SpurSegmentManager>>allocateOrExtendSegmentInfos (in category 'private') -----
allocateOrExtendSegmentInfos
"Increase the number of allocated segInfos by 16."
| newNumSegs |
numSegInfos = 0 ifTrue:
[numSegInfos := 16.
segments := self
cCode: [self c: numSegInfos alloc: (self sizeof: SpurSegmentInfo)]
inSmalltalk: [CArrayAccessor on: ((1 to: numSegInfos) collect: [:i| SpurSegmentInfo new])].
^self].
newNumSegs := numSegInfos + 16.
segments := self
+ cCode: [self re: segments alloc: newNumSegs * (self sizeof: SpurSegmentInfo)]
- cCode: [self re: newNumSegs * (self sizeof: SpurSegmentInfo) alloc: segments]
inSmalltalk: [CArrayAccessor on: segments object,
((numSegInfos to: newNumSegs) collect: [:i| SpurSegmentInfo new])].
self cCode:
[segments = 0 ifTrue:
[self error: 'out of memory; cannot allocate more segments'].
self
me: segments + numSegInfos
ms: 0
et: newNumSegs - numSegInfos * (self sizeof: SpurSegmentInfo)].
numSegInfos := newNumSegs!
Item was changed:
----- Method: StackInterpreter class>>preGenerationHook: (in category 'translation') -----
+ preGenerationHook: aCCodeGen
- preGenerationHook: aCCodeGenerator
"Perform any last-minute changes to the code generator immediately
before it performs code analysis and generation. In this case, make
all non-exported methods private."
| publicMethodNames |
+ self primitiveTable do:
+ [:s|
+ (s isSymbol and: [s ~~ #primitiveFail]) ifTrue:
+ [(aCCodeGen methodNamed: s) returnType: #void]].
+ publicMethodNames := (self requiredMethodNames: aCCodeGen options)
- publicMethodNames := (self requiredMethodNames: aCCodeGenerator options)
copyWithoutAll: (self primitiveTable
copyWithout: #primitiveFail).
+ aCCodeGen selectorsAndMethodsDo:
- aCCodeGenerator selectorsAndMethodsDo:
[:s :m|
(m export or: [publicMethodNames includes: s]) ifTrue:
[m static: false]]!
Item was changed:
----- Method: StackInterpreter>>followForwardedFrameContents:stackPointer: (in category 'lazy become') -----
followForwardedFrameContents: theFP stackPointer: theSP
"follow pointers in the current stack frame up to theSP."
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
+ <var: #ptr type: #'char *'>
theFP + (self frameStackedReceiverOffset: theFP)
to: theFP + FoxCallerSavedIP + BytesPerWord
by: BytesPerWord
do: [:ptr| | oop |
oop := stackPages longAt: ptr.
((objectMemory isNonImmediate: oop)
and: [objectMemory isForwarded: oop]) ifTrue:
[stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
theSP
+ to: (self frameReceiverOffset: theFP)
- to: theFP + FoxReceiver
by: BytesPerWord
do: [:ptr| | oop |
oop := stackPages longAt: ptr.
((objectMemory isNonImmediate: oop)
and: [objectMemory isForwarded: oop]) ifTrue:
[stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
self assert: (objectMemory isForwarded: (self frameMethod: theFP)) not.
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isForwarded: (self frameContext: theFP)) not]!
Item was changed:
----- Method: StackInterpreter>>handleSpecialSelectorSendFaultFor:fp:sp: (in category 'message sending') -----
handleSpecialSelectorSendFaultFor: obj fp: theFP sp: theSP
"Handle a special send fault that may be due to a special selector
send accessing a forwarded object.
Unforward the object on the stack and in inst vars and answer its target."
<inline: false>
+ <var: #theFP type: #'char *'>
+ <var: #theSP type: #'char *'>
- <var: #fp type: #'char *'>
- <var: #sp type: #'char *'>
self assert: (objectMemory isOopForwarded: obj).
self followForwardedFrameContents: theFP stackPointer: theSP.
(objectMemory isPointers: (self frameReceiver: theFP)) ifTrue:
[objectMemory
followForwardedObjectFields: (self frameReceiver: theFP)
toDepth: 0].
^objectMemory followForwarded: obj!
Item was changed:
----- Method: StackInterpreter>>printCallStackOf: (in category 'debug printing') -----
printCallStackOf: aContextOrProcessOrFrame
<api>
| context |
<inline: false>
- <var: #theFP type: #'char *'>
(stackPages couldBeFramePointer: aContextOrProcessOrFrame) ifTrue:
[^self printCallStackFP: (self cCoerceSimple: aContextOrProcessOrFrame to: #'char *')].
((objectMemory isContext: aContextOrProcessOrFrame) not
and: [(objectMemory lengthOf: aContextOrProcessOrFrame) > MyListIndex
and: [objectMemory isContext: (objectMemory
fetchPointer: SuspendedContextIndex
ofObject: aContextOrProcessOrFrame)]]) ifTrue:
[^self printCallStackOf: (objectMemory
fetchPointer: SuspendedContextIndex
ofObject: aContextOrProcessOrFrame)].
context := aContextOrProcessOrFrame.
[context = objectMemory nilObject] whileFalse:
[(self isMarriedOrWidowedContext: context)
ifTrue:
[(self checkIsStillMarriedContext: context currentFP: framePointer) ifFalse:
[self shortPrintContext: context.
^nil].
context := self shortReversePrintFrameAndCallers: (self frameOfMarriedContext: context)]
ifFalse:
[context := self printContextCallStackOf: context]]!
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 *'>
- <var: #argsPointer 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.
"update the arguments. this would appear not to be strictly necessary, but is for two reasons.
First, the fact that arguments are read-only is only as convention in the Smalltalk compiler;
other languages may choose to modify arguments.
Second, the Squeak runUntilErrorOrReturnFrom: nightmare pops the stack top, which may, in
certain circumstances, be the last argument, and hence the last argument may not have been
stored into the context."
pointer := theFP + (self frameStackedReceiverOffsetNumArgs: tempIndex).
1 to: tempIndex do:
[:i|
pointer := pointer - BytesPerWord.
self assert: (objectMemory addressCouldBeOop: (stackPages longAt: pointer)).
objectMemory storePointer: ReceiverIndex + i
ofObject: theContext
withValue: (stackPages longAt: pointer)].
"now update the non-argument stack contents."
pointer := theFP + FoxReceiver - 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 - BytesPerWord].
self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveVoidReceiver (in category 'system control primitives') -----
primitiveVoidReceiver
"Potentially crash the VM by voiding the receiver. A subsequent inst var
access in the caller's frame should indirect through a null pointer."
<export: true>
+ stackPages longAtPointer: (self frameReceiverOffset: framePointer) put: 0!
- stackPages longAt: (self frameReceiverOffset: framePointer) put: 0!
Item was added:
+ ----- Method: TMethod>>addTypesFor:to:in: (in category 'type inference') -----
+ addTypesFor: node to: typeSet in: aCodeGen
+ | expr |
+ expr := node.
+ [expr isAssignment or: [expr isStmtList]] whileTrue:
+ [expr isAssignment ifTrue:
+ [expr := expr variable].
+ expr isStmtList ifTrue:
+ [expr := expr statements last]].
+ expr isSend ifTrue:
+ [(#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: expr selector) ifTrue:
+ [^expr args do:
+ [:block|
+ self addTypesFor: block to: typeSet in: aCodeGen]].
+ (#(= ~= == ~~ < > <= >= anyMask: noMask:) includes: expr selector) ifTrue:
+ [^typeSet add: #sqInt].
+ (#(+ - * / // \\ mod: quo: bitAnd: bitClear: bitOr: bitXor: bitShift:) includes: expr selector) ifTrue:
+ [| types |
+ types := Set new.
+ self addTypesFor: expr receiver to: types in: aCodeGen.
+ (types size = 1 and: [types anyOne last = $*]) ifTrue: "pointer arithmetic"
+ [^typeSet add: types anyOne].
+ self addTypesFor: expr args first to: types in: aCodeGen.
+ types := self harmonizeSignedAndUnsignedTypesIn: types.
+ types size = 2 ifTrue:
+ [(types includes: #double) ifTrue:
+ [^typeSet add: #double].
+ (types includes: #float) ifTrue:
+ [^typeSet add: #float].
+ ^self]. "don't know; leave unspecified."
+ ^types notEmpty ifTrue:
+ [typeSet add: types anyOne]].
+ ^(aCodeGen returnTypeForSend: expr) ifNotNil:
+ [:type| typeSet add: type]].
+ expr isVariable ifTrue:
+ [(aCodeGen typeOfVariable: expr name)
+ ifNotNil: [:type| typeSet add: type]
+ ifNil: [typeSet add: (expr name = 'self'
+ ifTrue: [#void]
+ ifFalse: [#sqInt])]].
+ expr isConstant ifTrue:
+ [| val |
+ val := expr value.
+ val isInteger ifTrue:
+ [typeSet add: ((val >= 0 ifTrue: [val] ifFalse: [-1 - val]) highBit <= 32
+ ifTrue: [#sqInt]
+ ifFalse: [#sqLong])].
+ (#(nil true false) includes: val) ifTrue:
+ [typeSet add: #sqInt].
+ val isFloat ifTrue:
+ [typeSet add: #float]]!
Item was added:
+ ----- Method: TMethod>>checkedDeclarationAt:put:in: (in category 'accessing') -----
+ checkedDeclarationAt: aVariableName put: aDeclaration in: aCCodeGen
+ ((args includes: aVariableName) or: [locals includes: aVariableName]) ifFalse:
+ [| msg |
+ msg := definingClass name, '>>', selector, ' contains declaration for non-existent variable ', aVariableName.
+ aCCodeGen
+ ifNotNil: [aCCodeGen logger show: msg; cr]
+ ifNil: [self error: msg]].
+ ^self declarationAt: aVariableName "<String>" put: aDeclaration!
Item was changed:
----- Method: TMethod>>inferReturnTypeFromReturnsIn: (in category 'type inference') -----
inferReturnTypeFromReturnsIn: aCodeGen
"Attempt to infer the return type of the receiver from returns in the parse tree."
+ returnType ifNil: "the initial default"
- returnType isNil ifTrue:"the initial default"
[aCodeGen
pushScope: declarations
while:
[| hasReturn returnTypes |
hasReturn := false.
returnTypes := Set new.
parseTree nodesDo:
[:node|
node isReturn ifTrue:
+ [hasReturn := true.
+ self addTypesFor: node expression to: returnTypes in: aCodeGen]].
- [| expr |
- hasReturn := true.
- expr := node expression.
- expr isAssignment ifTrue:
- [expr := expr variable].
- expr isSend ifTrue:
- [(aCodeGen returnTypeForSend: expr) ifNotNil:
- [:type| returnTypes add: type]].
- expr isVariable ifTrue:
- [(aCodeGen typeOfVariable: expr name)
- ifNotNil: [:type| returnTypes add: type]
- ifNil: [returnTypes add: (expr name = 'self'
- ifTrue: [#void]
- ifFalse: [#sqInt])]].
- expr isConstant ifTrue:
- [| val |
- val := expr value.
- val isInteger ifTrue:
- [returnTypes add: ((val >= 0 ifTrue: [val] ifFalse: [-1 - val]) highBit <= 32
- ifTrue: [#sqInt]
- ifFalse: [#sqLong])].
- (val == true or: [val == false]) ifTrue:
- [returnTypes add: #sqInt].
- val isFloat ifTrue:
- [returnTypes add: #float]]]].
returnTypes remove: #implicit ifAbsent: [].
returnTypes := self harmonizeSignedAndUnsignedTypesIn: returnTypes.
hasReturn
ifTrue:
[returnTypes size > 1 ifTrue:
[aCodeGen logger nextPutAll: 'conflicting return types', (String streamContents: [:s| returnTypes do: [:t| s space; nextPutAll: t]]), ' in ', selector; cr; flush].
returnTypes size = 1 ifTrue:
[self returnType: returnTypes anyOne]]
ifFalse:
[self returnType: (aCodeGen implicitReturnTypeFor: selector)]]]!
Item was changed:
----- Method: TMethod>>inferReturnTypeIn: (in category 'type inference') -----
inferReturnTypeIn: aCodeGen
"Attempt to infer the return type of the receiver and answer if it changed."
| existingReturnType |
existingReturnType := returnType.
- self removeFinalSelfReturnIn: aCodeGen. "must preceed recordDeclarations because this may set returnType"
- self recordDeclarations.
self inferReturnTypeFromReturnsIn: aCodeGen.
"If the return type is now void, replace any and all ^expr with expr. ^self"
(existingReturnType ~= returnType and: [returnType = #void]) ifTrue:
[self transformVoidReturns].
^existingReturnType ~= returnType!
Item was removed:
- ----- Method: TMethod>>recordDeclarations (in category 'transformations') -----
- recordDeclarations
- "Record C type declarations of the forms
-
- self returnTypeC: 'float'.
- self var: #foo declareC: 'float foo'
- self var: #foo type:'float'.
-
- and remove the declarations from the method body."
-
- | newStatements |
- properties pragmas notEmpty ifTrue:
- [properties pragmas do:
- [:pragma|
- pragma keyword = #var:declareC: ifTrue:
- [self declarationAt: pragma arguments first asString put: pragma arguments last].
- pragma keyword = #var:type: ifTrue:
- [| varName varType |
- varName := pragma arguments first asString.
- varType := pragma arguments last.
- varType last = $* ifFalse: [varType := varType, ' '].
- self declarationAt: varName put: varType, varName].
- pragma keyword = #returnTypeC: ifTrue:
- [self returnType: pragma arguments last].
- pragma keyword = #doNotGenerate: ifTrue:
- [locals remove: pragma arguments last]].
- ^self].
- newStatements := OrderedCollection new: parseTree statements size.
- parseTree statements do: [ :stmt |
- | isDeclaration |
- isDeclaration := false.
- stmt isSend ifTrue: [
- stmt selector = #var:declareC: ifTrue: [
- isDeclaration := true.
- self declarationAt: stmt args first value asString put: stmt args last value.
- ].
- stmt selector = #var:type: ifTrue: [
- | varName varType |
- isDeclaration := true.
- varName := stmt args first value asString.
- varType := stmt args last value.
- varType last = $* ifFalse: [varType := varType, ' '].
- self declarationAt: varName put: varType, varName.
- ].
- stmt selector = #returnTypeC: ifTrue: [
- isDeclaration := true.
- returnType := stmt args last value.
- ].
- ].
- isDeclaration ifFalse: [
- newStatements add: stmt.
- ].
- ].
- parseTree setStatements: newStatements asArray.!
Item was added:
+ ----- Method: TMethod>>recordDeclarationsIn: (in category 'transformations') -----
+ recordDeclarationsIn: aCCodeGen
+ "Record C type declarations of the forms
+ <returnTypeC: 'float'>
+ <var: #foo declareC: 'float foo'>
+ <var: #foo type:'float'>
+ or the older, obsolete
+ self returnTypeC: 'float'.
+ self var: #foo declareC: 'float foo'
+ self var: #foo type:'float'.
+ and remove the declarations from the method body."
+
+ | newStatements |
+ properties pragmas notEmpty ifTrue:
+ [properties pragmas do:
+ [:pragma|
+ pragma keyword = #var:declareC: ifTrue:
+ [self checkedDeclarationAt: pragma arguments first asString
+ put: pragma arguments last
+ in: aCCodeGen].
+ pragma keyword = #var:type: ifTrue:
+ [| varName varType |
+ varName := pragma arguments first asString.
+ varType := pragma arguments last.
+ varType last = $* ifFalse: [varType := varType, ' '].
+ self checkedDeclarationAt: varName
+ put: varType, varName
+ in: aCCodeGen].
+ pragma keyword = #returnTypeC: ifTrue:
+ [self returnType: pragma arguments last].
+ pragma keyword = #doNotGenerate: ifTrue:
+ [locals remove: pragma arguments last]].
+ ^self].
+ newStatements := OrderedCollection new: parseTree statements size.
+ parseTree statements do: [ :stmt |
+ | isDeclaration |
+ isDeclaration := false.
+ stmt isSend ifTrue: [
+ stmt selector = #var:declareC: ifTrue: [
+ isDeclaration := true.
+ self declarationAt: stmt args first value asString put: stmt args last value.
+ ].
+ stmt selector = #var:type: ifTrue: [
+ | varName varType |
+ isDeclaration := true.
+ varName := stmt args first value asString.
+ varType := stmt args last value.
+ varType last = $* ifFalse: [varType := varType, ' '].
+ self declarationAt: varName put: varType, varName.
+ ].
+ stmt selector = #returnTypeC: ifTrue: [
+ isDeclaration := true.
+ returnType := stmt args last value.
+ ].
+ ].
+ isDeclaration ifFalse: [
+ newStatements add: stmt.
+ ].
+ ].
+ parseTree setStatements: newStatements asArray.!
More information about the Vm-dev
mailing list