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.!