[Vm-dev] VM Maker: VMMaker.oscog-eem.484.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Oct 31 07:57:41 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.484.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.484
Author: eem
Time: 31 October 2013, 12:52:30.541 am
UUID: 3e476e6f-ab05-4256-b992-f12a827f20ed
Ancestors: VMMaker.oscog-eem.483
Deal with the issue of typing variables that get assigned the result of
longLongAt: by adding rudimentary type inference, determining the
types of implicitly-typed local variables from assignments in the
parse tree. This in turn forces adding type inference of return types
since types propagate from sends through assignments to variables.
The code is orchestrated by CCodeGenerator>>
inferTypesForImplicitlyTypedVariablesAndMethods. The
removeFinalSelfReturn & recordDeclarations processing is
postponed to the type inference phase.
Add kernelReturnTypes to CCodeGenerator to hold the return types
of longAt: et al. Add implicitReturnTypeFor: implementations for
the Spur classes.
Deal with the issue of optional use of interpreter proxy protocol,
as in FilePlugin>>primitiveDirectoryDelimitor's use of
characterObjectOf:, by adding an option: scheme that can evaluate
e.g. atLeastVMProxyMajor:minor:. This is used to ifdef assignments
to the local function pointers in a plugin. See e.g.
InterpreterProxy>>characterObjectOf:. Dispatch to the
objectMemoryClass to simulate some of the new protocol.
Abstract out the option: pragma processing into
CCodeGenerator>>shouldIncludeMethodFor:selector:. Use it
to correctly filter the export api. Add a vmMaker inst var to
CCodeGenerator to avoid the silly use of exceptions to get hold of
the current VMMaker, at least in the code generator. Still need to
refactor additionalSelectorTables & requiredMethodNames to take
the CCodeGenerator as an argument. Change all
createCodeGenerator implementations to set the VMMaker.
Mostly drop, but in some cases add, returnTypeC: pragmas now that
return types are inferred in most circumstances (still don't infer
through ifTrue:ifFalse: or through arithmetic, i.e. infer only through
direct return.
Change some ^nil occurrences to ^self occurrences to avoid
multiple return types.
Fix slip in mapObjectReferencesInMachineCode: and provide a stub
mapObjectReferencesInMachineCodeForScavenge.
Fix super expansions to eliminate bogus self; statements being
introduced from the implicit ^self at the end of a method.
Refactor the stack page tracing management, abstracting out
into initStackPageGC and using this in the scavenger.
=============== Diff against VMMaker.oscog-eem.483 ===============
Item was changed:
Object subclass: #CCodeGenerator
+ instanceVariableNames: 'vmClass structClasses translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods kernelReturnTypes currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors logger suppressAsmLabels asmLabelCounts pools selectorTranslations optionsDictionary breakSrcInlineSelector breakDestInlineSelector vmMaker'
- instanceVariableNames: 'vmClass structClasses translationDict asArgumentTranslationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods currentMethod headerFiles globalVariableUsage useSymbolicConstants generateDeadCode requiredSelectors logger suppressAsmLabels asmLabelCounts pools selectorTranslations optionsDictionary breakSrcInlineSelector breakDestInlineSelector'
classVariableNames: 'UseRightShiftForDivide'
poolDictionaries: 'VMBasicConstants'
category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.
See VMMaker for more useful info!
Item was changed:
----- Method: CCodeGenerator>>addMethodFor:selector: (in category 'utilities') -----
addMethodFor: aClass selector: selector
"Add the given method to the code base and answer its translation
or nil if it shouldn't be translated."
| method tmethod |
selector == #initialize ifTrue:
[^nil].
method := aClass compiledMethodAt: selector.
(method pragmaAt: #doNotGenerate) ifNotNil:
[^nil].
+ (self shouldIncludeMethodFor: aClass selector: selector) ifFalse:
+ [^nil].
- "process optional methods by interpreting the argument to the option: pragma as either
- a Cogit class name or a class variable name or a variable name in VMBasicConstants."
- (method pragmaAt: #option:) ifNotNil:
- [:pragma| | key |
- key := pragma argumentAt: 1.
- VMClass getVMMaker ifNotNil:
- [:vmMaker|
- ((Cogit withAllSubclasses anySatisfy: [:c| c name = key])
- and: [vmMaker cogitClassName ~= key]) ifTrue:
- [^nil].
- (vmMaker options at: key ifAbsent: []) ifNotNil:
- [:option| option == false ifTrue: [^nil]]].
- (aClass bindingOf: key) ifNotNil:
- [:binding|
- binding value == false ifTrue: [^nil]].
- (VMBasicConstants bindingOf: key) ifNotNil:
- [:binding|
- binding value == false ifTrue: [^nil]]].
tmethod := self addMethod: (self compileToTMethodSelector: selector in: aClass).
"If the method has a macro then add the macro. But keep the method
for analysis purposes (e.g. its variable accesses)."
(method pragmaAt: #cmacro:) ifNotNil:
[:pragma|
self addMacro: (pragma argumentAt: 1) for: selector.
tmethod inline: false].
(method propertyValueAt: #cmacro:) ifNotNil:
[:macro|
self addMacro: macro for: selector.
tmethod inline: false].
^tmethod!
Item was added:
+ ----- Method: CCodeGenerator>>computeKernelReturnTypes (in category 'public') -----
+ computeKernelReturnTypes
+ ^Dictionary newFromPairs:
+ #(oopAt: #sqInt oopAt:put: #sqInt
+ oopAtPointer: #sqInt oopAtPointer:put: #sqInt
+ byteAt: #sqInt byteAt:put: #sqInt
+ byteAtPointer: #sqInt byteAtPointer:put: #sqInt
+ shortAt: #sqInt shortAt:put: #sqInt
+ shortAtPointer: #sqInt shortAtPointer:put: #sqInt
+ intAt: #sqInt intAt:put: #sqInt
+ intAtPointer: #sqInt intAtPointer:put: #sqInt
+ longAt: #sqInt longAt:put: #sqInt
+ longAtPointer: #sqInt longAtPointer:put: #sqInt
+
+ longLongAt: #sqLong longLongAt:put: #sqLong
+ longLongAtPointer: #sqLong longLongAtPointer:put: #sqLong
+
+ fetchFloatAt:into: #float storeFloatAt:from: #float
+ fetchFloatAtPointer:into: #float storeFloatAtPointer:from: #float
+ fetchSingleFloatAt:into: #float storeSingleFloatAt:from: #float
+ fetchSingleFloatAtPointer:into: #float storeSingleFloatAtPointer:from: #float
+
+ pointerForOop: #'char *' oopForPointer: #sqInt)!
Item was changed:
----- Method: CCodeGenerator>>emitCAPIExportHeaderOn: (in category 'C code generator') -----
emitCAPIExportHeaderOn: aStream
"Store prototype declarations for all non-inlined methods on the given stream."
| api methodList |
api := (vmClass translationClass exportAPISelectors: self options).
+ methodList := api
+ select:
- methodList := api select: [:s| (methods includesKey: s) or: [(vmClass whichClassIncludesSelector: s) notNil]]
- thenCollect:
[:s|
+ (methods includesKey: s)
+ or: [(vmClass whichClassIncludesSelector: s)
+ ifNil: [false]
+ ifNotNil: [:c|self shouldIncludeMethodFor: c selector: s]]]
+ thenCollect:
+ [:s|
methods
at: s
ifAbsent: [self compileToTMethodSelector: s
in: (vmClass whichClassIncludesSelector: s)]].
methodList := self sortMethods: methodList.
methodList do:
[:m|
m static ifTrue:
[logger ensureCr; show: m selector, ' excluded from export API because it is static'; cr]].
self emitCFunctionPrototypes: methodList on: aStream.
self emitGlobalCVariablesOn: aStream.
self emitCMacros: methodList on: aStream!
Item was added:
+ ----- Method: CCodeGenerator>>implicitReturnTypeFor: (in category 'type inference') -----
+ implicitReturnTypeFor: aSelector
+ "Answer the default return type for mthods of the defining class of
+ aSelector. Default to #sqInt if there is no method, or if the method's
+ defining class doesn't understand implicitReturnTypeFor:."
+ | m |
+ m := methods at: aSelector ifAbsent: [^#sqInt].
+ ^[m definingClass implicitReturnTypeFor: aSelector]
+ on: MessageNotUnderstood
+ do: [:ex|
+ ex message selector ~~ #implicitReturnTypeFor: ifTrue:
+ [ex pass].
+ #sqInt]!
Item was added:
+ ----- 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."
+ [| changedReturnType |
+ changedReturnType := false.
+ methods do:
+ [:m|
+ m inferTypesForImplicitlyTypedVariablesIn: self.
+ (m inferReturnTypeIn: self) ifTrue:
+ [changedReturnType := true]].
+ 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>>initialize (in category 'public') -----
initialize
translationDict := Dictionary new.
inlineList := Array new.
constants := Dictionary new: 100.
variables := Set new: 100.
variableDeclarations := Dictionary new: 100.
methods := Dictionary new: 500.
+ kernelReturnTypes := self computeKernelReturnTypes.
macros := Dictionary new.
self initializeCTranslationDictionary.
headerFiles := OrderedCollection new.
globalVariableUsage := Dictionary new.
useSymbolicConstants := true.
generateDeadCode := true.
scopeStack := OrderedCollection new.
logger := (ProvideAnswerNotification new tag: #logger; signal) ifNil: [Transcript].
pools := IdentitySet new.
selectorTranslations := IdentityDictionary new.
suppressAsmLabels := false!
Item was changed:
----- Method: CCodeGenerator>>isKernelSelector: (in category 'utilities') -----
isKernelSelector: sel
"Answer true if the given selector is one of the kernel selectors that are implemented as macros."
^(#(error:
oopAt: oopAt:put: oopAtPointer: oopAtPointer:put:
byteAt: byteAt:put: byteAtPointer: byteAtPointer:put:
shortAt: shortAt:put: shortAtPointer: shortAtPointer:put:
intAt: intAt:put: intAtPointer: intAtPointer:put:
longAt: longAt:put: longAtPointer: longAtPointer:put:
+ longLongAt: longLongAt:put: longLongAtPointer: longLongAtPointer:put:
fetchFloatAt:into: storeFloatAt:from:
fetchFloatAtPointer:into: storeFloatAtPointer:from:
fetchSingleFloatAt:into: storeSingleFloatAt:from:
fetchSingleFloatAtPointer:into: storeSingleFloatAtPointer:from:
pointerForOop: oopForPointer:
cCoerce:to: cCoerceSimple:to:)
includes: sel)!
Item was added:
+ ----- 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:
+ [(#(cCoerce:to: cCoerceSimple:to:) includes: sel)
+ ifTrue: [aTSendNode args last value]
+ ifFalse: [#sqInt]]]
+ ifNotNil: [:m| m returnType]!
Item was added:
+ ----- Method: CCodeGenerator>>shouldIncludeMethodFor:selector: (in category 'utilities') -----
+ shouldIncludeMethodFor: aClass selector: selector
+ "process optional methods by interpreting the argument to the option: pragma as either
+ a Cogit class name or a class variable name or a variable name in VMBasicConstants."
+ (aClass >> selector pragmaAt: #option:) ifNotNil:
+ [:pragma| | key |
+ key := pragma argumentAt: 1.
+ vmMaker ifNotNil:
+ [((Cogit withAllSubclasses anySatisfy: [:c| c name = key])
+ and: [vmMaker cogitClassName ~= key]) ifTrue:
+ [^false].
+ (vmMaker options at: key ifAbsent: []) ifNotNil:
+ [:option| option == false ifTrue: [^false]]].
+ (aClass bindingOf: key) ifNotNil:
+ [:binding|
+ binding value == false ifTrue: [^false]].
+ (VMBasicConstants bindingOf: key) ifNotNil:
+ [:binding|
+ binding value == false ifTrue: [^false]]].
+ ^true!
Item was changed:
----- Method: CCodeGenerator>>structClassesForTranslationClasses: (in category 'utilities') -----
structClassesForTranslationClasses: classes
"Answer in superclass order (any superclass precedes any subclass)
the ancilliaryClasses that are struct classes for all the given classes."
+ | theStructClasses |
+ theStructClasses := OrderedCollection new.
- | structClasses |
- structClasses := OrderedCollection new.
classes do:
[:aTranslationClass|
([aTranslationClass ancilliaryClasses: self options]
on: MessageNotUnderstood
do: [:ex|
ex message selector == #ancilliaryClasses:
ifTrue: [#()]
ifFalse: [ex pass]]) do:
[:class|
(class isStructClass
and: [(vmClass isNil or: [vmClass isAcceptableAncilliaryClass: class])
+ and: [(theStructClasses includes: class) not]]) ifTrue:
+ [theStructClasses addLast: class]]].
+ ^ChangeSet superclassOrder: theStructClasses!
- and: [(structClasses includes: class) not]]) ifTrue:
- [structClasses addLast: class]]].
- ^ChangeSet superclassOrder: structClasses!
Item was added:
+ ----- Method: CCodeGenerator>>vmMaker (in category 'accessing') -----
+ vmMaker
+ ^vmMaker!
Item was added:
+ ----- Method: CCodeGenerator>>vmMaker: (in category 'accessing') -----
+ vmMaker: aVMMaker
+ vmMaker := aVMMaker!
Item was changed:
----- Method: CoInterpreter>>cogMethodOf: (in category 'compiled methods') -----
cogMethodOf: aMethodOop
<api>
- <returnTypeC: #'CogMethod *'>
| methodHeader |
methodHeader := self rawHeaderOf: aMethodOop.
self assert: ((objectMemory isNonImmediate: methodHeader)
and: [methodHeader asUnsignedInteger < objectMemory startOfMemory]).
^self cCoerceSimple: methodHeader to: #'CogMethod *'!
Item was changed:
----- Method: CoInterpreter>>mframeCogMethod: (in category 'frame access') -----
mframeCogMethod: theFP
"Answer the Cog method for a machine code frame. This may be
either a full CogMethod or merely a CogBlockMethod rump header."
<var: #theFP type: #'char *'>
- <returnTypeC: #'CogBlockMethod *'>
^self cCoerceSimple: (self mframeMethod: theFP) to: #'CogBlockMethod *'!
Item was changed:
----- Method: CoInterpreter>>mframeNumArgs: (in category 'frame access') -----
mframeNumArgs: theFP
+ <returnTypeC: #sqInt>
^(self mframeCogMethod: theFP) cmNumArgs!
Item was changed:
----- Method: CogAbstractInstruction>>getJmpTarget (in category 'accessing') -----
getJmpTarget
"Get the target of a jump instruction. Jumps have the target in the first operand."
- <returnTypeC: #'AbstractInstruction *'>
^cogit cCoerceSimple: (operands at: 0) to: #'AbstractInstruction *'!
Item was changed:
----- Method: CogAbstractInstruction>>jumpTargetAddress (in category 'generate machine code') -----
jumpTargetAddress
- <returnTypeC: #'AbstractInstruction *'>
<inline: true> "Since it's an extraction from other methods."
| jumpTarget |
<var: #jumpTarget type: #'AbstractInstruction *'>
jumpTarget := cogit cCoerceSimple: (operands at: 0) to: #'AbstractInstruction *'.
cogit assertSaneJumpTarget: jumpTarget.
(self isAnInstruction: jumpTarget) ifTrue:
[jumpTarget := cogit cCoerceSimple: jumpTarget address to: #'AbstractInstruction *'].
self assert: jumpTarget ~= 0.
^jumpTarget!
Item was changed:
----- Method: CogAbstractInstruction>>longJumpTargetAddress (in category 'generate machine code') -----
longJumpTargetAddress
- <returnTypeC: #'AbstractInstruction *'>
<inline: true> "Since it's an extraction from other methods."
"This needs to be digfferent from jumpTargetAddress because long jumps can
be to absolute addresses and hence we can't assert that the jump target is sane."
| jumpTarget |
<var: #jumpTarget type: #'AbstractInstruction *'>
jumpTarget := cogit cCoerceSimple: (operands at: 0) to: #'AbstractInstruction *'.
(self isAnInstruction: jumpTarget) ifTrue:
[jumpTarget := cogit cCoerceSimple: jumpTarget address to: #'AbstractInstruction *'].
self assert: jumpTarget ~= 0.
^jumpTarget!
Item was changed:
----- Method: CogBlockMethod>>cmHomeMethod (in category 'accessing') -----
cmHomeMethod
- <returnTypeC: #'CogMethod *'>
^self cCoerceSimple: self asUnsignedInteger - self homeOffset to: #'CogMethod *'!
Item was changed:
----- Method: CogIA32Compiler>>genDivR:R:Quo:Rem: (in category 'abstract instructions') -----
genDivR: abstractRegDivisor R: abstractRegDividend Quo: abstractRegQuotient Rem: abstractRegRemainder
| rDividend rDivisor rQuotient rRemainder saveRestoreEAX saveRestoreEDX saveRestoreExchanged |
self assert: abstractRegDividend ~= abstractRegDivisor.
self assert: abstractRegQuotient ~= abstractRegRemainder.
rDividend := self concreteRegister: abstractRegDividend.
rDivisor := self concreteRegister: abstractRegDivisor.
rQuotient := self concreteRegister: abstractRegQuotient.
rRemainder := self concreteRegister: abstractRegRemainder.
"IDIV r does a signed divide of EDX:EAX by r, EAX := Quotient, EDX := Remainder.
Since we must sign extend the dividend into EDX we must substitute another register if EDX is an input"
(rDividend = EDX or: [rDivisor = EDX]) ifTrue:
[| rUnused |
"Slang, sigh..."
rUnused := EAX.
[rUnused <= EDI] whileTrue:
[(rUnused ~= ESP and: [rUnused ~= EBP and: [rUnused ~= EDX
and: [rUnused ~= rDividend and: [rUnused ~= rDivisor
and: [rUnused ~= rQuotient and: [rUnused ~= rRemainder]]]]]]) ifTrue:
[cogit PushR: rUnused.
cogit MoveR: EDX R: rUnused.
rDividend = EDX
ifTrue: [self genDivR: rDivisor R: rUnused Quo: rQuotient Rem: rRemainder]
ifFalse: [self genDivR: rUnused R: rDividend Quo: rQuotient Rem: rRemainder].
cogit PopR: rUnused.
+ ^self].
- ^nil].
rUnused := rUnused + 1].
self error: 'couldn''t find unused register in genDivR:R:Quo:Rem:'].
"If either output does not include EAX or EDX we must save and restore EAX and/or EDX."
(saveRestoreEAX := rQuotient ~= EAX and: [rRemainder ~= EAX]) ifTrue:
[cogit PushR: EAX].
(saveRestoreEDX := rQuotient ~= EDX and: [rRemainder ~= EDX]) ifTrue:
[cogit PushR: EDX].
saveRestoreExchanged := -1.
rDividend ~= EAX ifTrue:
[rDivisor = EAX
ifTrue: [((rDividend ~= rQuotient and: [rDividend ~= rRemainder])
and: [rDividend ~= EDX or: [saveRestoreEDX not]]) ifTrue:
[cogit PushR: (saveRestoreExchanged := rDividend)].
cogit gen: XCHGRR operand: rDivisor operand: rDividend]
ifFalse: [cogit MoveR: rDividend R: EAX]].
"CDQ sign-extends EAX into EDX as required for IDIV"
cogit gen: CDQ.
cogit gen: IDIVR operand: (rDivisor = EAX ifTrue: [rDividend] ifFalse: [rDivisor]).
"Must not overwrite result while juggling"
(rQuotient = EDX and: [rRemainder = EAX])
ifTrue: [cogit gen: XCHGRR operand: rQuotient operand: rRemainder]
ifFalse:
[rQuotient = EDX
ifTrue:
[rRemainder ~= EDX ifTrue:
[cogit MoveR: EDX R: rRemainder].
rQuotient ~= EAX ifTrue:
[cogit MoveR: EAX R: rQuotient]]
ifFalse:
[rQuotient ~= EAX ifTrue:
[cogit MoveR: EAX R: rQuotient].
rRemainder ~= EDX ifTrue:
[cogit MoveR: EDX R: rRemainder]]].
saveRestoreExchanged >= 0 ifTrue:
[cogit PopR: saveRestoreExchanged].
saveRestoreEDX ifTrue:
[cogit PopR: EDX].
saveRestoreEAX ifTrue:
[cogit PopR: EAX]!
Item was changed:
----- Method: CogIA32Compiler>>generateLowLevelTryLock: (in category 'multi-threading') -----
generateLowLevelTryLock: vmOwnerLockAddress
"Generate a function that attempts to lock the vmOwnerLock and answers
true if it succeeded."
vmOwnerLockAddress = 0 ifTrue:
[cogit
MoveCq: 1 R: EAX;
RetN: 0.
+ ^self].
- ^nil].
cogit
MoveCq: 1 R: EAX;
gen: MFENCE; "make the XCHG globally consistent"
gen: XCHGAwR operand: vmOwnerLockAddress operand: EAX;
gen: SFENCE; "make the store globally visible"
SubCq: 1 R: EAX; "Since we only ever set the lock to 1 or 0, subtracting 1 sets
EAX to 0 if the lock was already locked and non-zero if it wasn't."
RetN: 0!
Item was changed:
----- Method: CogMethodZone>>methodAfter: (in category 'accessing') -----
methodAfter: cogMethod
- <returnTypeC: #'CogMethod *'>
<var: #cogMethod type: #'CogMethod *'>
^coInterpreter
cCoerceSimple: (self roundUpLength: cogMethod asInteger + cogMethod blockSize)
to: #'CogMethod *'!
Item was added:
+ ----- Method: Cogit class>>isAcceptableAncilliaryClass: (in category 'translation') -----
+ isAcceptableAncilliaryClass: aClass
+ ^aClass ~~ CogSSBytecodeFixup!
Item was changed:
----- Method: Cogit>>mapObjectReferencesInMachineCode: (in category 'jit - api') -----
mapObjectReferencesInMachineCode: gcMode
<api>
"Update all references to objects in machine code."
gcMode caseOf: {
+ [GCModeScavenge] -> [self mapObjectReferencesInMachineCodeForScavenge].
+ [GCModeIncr] -> [self mapObjectReferencesInMachineCodeForIncrementalGC].
- [GCModeScavenge] -> [self mapObjectReferencesInMachineCodeForIncrementalGC].
- [GCModeIncr] -> [self mapObjectReferencesInMachineCodeForScavenge].
[GCModeFull] -> [self mapObjectReferencesInMachineCodeForFullGC].
[GCModeBecome] -> [self mapObjectReferencesInMachineCodeForBecome] }.
(self asserta: methodZone freeStart <= methodZone youngReferrers) ifFalse:
[self error: 'youngReferrers list overflowed']!
Item was added:
+ ----- Method: Cogit>>mapObjectReferencesInMachineCodeForScavenge (in category 'garbage collection') -----
+ mapObjectReferencesInMachineCodeForScavenge
+ self shouldBeImplemented!
Item was changed:
----- Method: Cogit>>unlinkSendsOf:isMNUSelector: (in category 'jit - api') -----
unlinkSendsOf: selector isMNUSelector: isMNUSelector
<api>
"Unlink all sends in cog methods."
| cogMethod |
<var: #cogMethod type: #'CogMethod *'>
methodZoneBase isNil ifTrue: [^self].
cogMethod := self cCoerceSimple: methodZoneBase to: #'CogMethod *'.
"First check if any method actually has the selector; if not there can't
be any linked send to it."
[cogMethod < methodZone limitZony
and: [cogMethod selector ~= selector]] whileTrue:
[cogMethod := methodZone methodAfter: cogMethod].
cogMethod >= methodZone limitZony ifTrue:
+ [^self].
- [^nil].
codeModified := false.
cogMethod := self cCoerceSimple: methodZoneBase to: #'CogMethod *'.
[cogMethod < methodZone limitZony] whileTrue:
[cogMethod cmType = CMMethod
ifTrue:
[self mapFor: cogMethod
performUntil: #unlinkIfLinkedSend:pc:of:
arg: selector]
ifFalse:
[(cogMethod cmType ~= CMFree
and: [(isMNUSelector and: [cogMethod cpicHasMNUCase])
or: [cogMethod selector = selector]]) ifTrue:
[methodZone freeMethod: cogMethod]].
cogMethod := methodZone methodAfter: cogMethod].
codeModified ifTrue: "After possibly updating inline caches we need to flush the icache."
[processor flushICacheFrom: methodZoneBase to: methodZone limitZony asInteger]!
Item was changed:
----- Method: CrossPlatformVMMaker>>createCodeGenerator (in category 'initialize') -----
createCodeGenerator
"Set up a CCodeGenerator for this VMMaker - A cross platform tree leaves it up to the makefiles to decide whether to use the global struct or not."
+ ^CCodeGeneratorGlobalStructure new
+ vmMaker: self;
- ^CCodeGeneratorGlobalStructure new initialize;
structDefDefine: 'USE_GLOBAL_STRUCT';
logger: logger;
options: optionsDictionary;
yourself!
Item was changed:
----- Method: InterpreterPlugin class>>translateInDirectory:doInlining: (in category 'translation') -----
translateInDirectory: directory doInlining: inlineFlag
"This is the default method for writing out sources for a plugin. Several classes need special handling, so look at all implementors of this message"
| cg fname fstat |
fname := self moduleName, '.c'.
"don't translate if the file is newer than my timeStamp"
fstat := directory entryAt: fname ifAbsent:[nil].
fstat ifNotNil:
[((self pluginClassesUpTo: self) allSatisfy:
[:aPluginClass| aPluginClass timeStamp < fstat modificationTime]) ifTrue:
[^nil]].
self initialize.
cg := self buildCodeGeneratorUpTo: self.
+ cg inferTypesForImplicitlyTypedVariablesAndMethods.
cg storeCodeOnFile: (directory fullNameFor: fname) doInlining: inlineFlag.
^cg exportedPrimitiveNames asArray!
Item was added:
+ ----- Method: InterpreterProxy>>characterObjectOf: (in category 'object access') -----
+ characterObjectOf: characterCode
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^StackInterpreter objectMemoryClass characterObjectOf: characterCode!
Item was added:
+ ----- Method: InterpreterProxy>>characterValueOf: (in category 'object access') -----
+ characterValueOf: aCharacter
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^aCharacter asInteger!
Item was added:
+ ----- Method: InterpreterProxy>>isCharacterObject: (in category 'testing') -----
+ isCharacterObject: oop
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^oop isCharacter!
Item was added:
+ ----- Method: InterpreterProxy>>isCharacterValue: (in category 'testing') -----
+ isCharacterValue: anInteger
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^(self isIntegerValue: anInteger) and: [anInteger >= 0]!
Item was added:
+ ----- Method: InterpreterProxy>>isImmediate: (in category 'testing') -----
+ isImmediate: anObject
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^StackInterpreter objectMemoryClass isImmediate: anObject!
Item was added:
+ ----- Method: InterpreterProxy>>isPinned: (in category 'testing') -----
+ isPinned: anObject
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^self shouldBeImplemented!
Item was added:
+ ----- Method: InterpreterProxy>>pinObject: (in category 'object access') -----
+ pinObject: anObject
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^self shouldBeImplemented!
Item was changed:
----- Method: InterpreterProxy>>primitiveFail (in category 'other') -----
primitiveFail
+ <returnTypeC: #sqInt>
"Set general (unspecified) primitive failure."
self primitiveFailFor: 1!
Item was changed:
----- Method: MacOSPowerPCOS9VMMaker>>createCodeGenerator (in category 'initialize') -----
createCodeGenerator
"Set up a CCodeGenerator for this VMMaker - Mac OS uses the global struct and local def of the
structure. The global struct/loca def regime appears to be about 10% faster than the default
regime for Smalltalk-intensive macro benchmarks for both the Intel and gcc 4.0 compiler on x86.
eem 12/10/2008 14:34 2.16 GHz Intel Core Duo MacBook Pro Mac OS X 10.4.11"
+ ^CCodeGeneratorGlobalStructure new
+ vmMaker: self;
- ^CCodeGeneratorGlobalStructure new initialize;
structDefDefine: '1';
"structDefDefine: 'defined(PPC) || defined(_POWER) || defined(__powerpc__) || defined(__ppc__)';"
logger: logger;
yourself!
Item was changed:
----- Method: NewspeakCogMethodSurrogate32 class>>alignedByteSize (in category 'accessing') -----
alignedByteSize
+ ^24 + self baseHeaderSize!
- ^28!
Item was changed:
----- Method: NewspeakCogMethodSurrogate32>>nextMethod (in category 'accessing') -----
nextMethod
| v |
+ ^(v := memory unsignedLongAt: address + 21 + baseHeaderSize) ~= 0 ifTrue:
- ^(v := memory unsignedLongAt: address + 25) ~= 0 ifTrue:
[cogit cCoerceSimple: v to: #'CogMethod *']!
Item was changed:
----- Method: NewspeakCogMethodSurrogate32>>nextMethod: (in category 'accessing') -----
nextMethod: aValue
^memory
+ unsignedLongAt: address + baseHeaderSize + 21
- unsignedLongAt: address + 25
put: ((aValue ifNotNil: [aValue asUnsignedInteger] ifNil: [0]))!
Item was changed:
----- Method: NewspeakCogMethodSurrogate64 class>>alignedByteSize (in category 'accessing') -----
alignedByteSize
+ ^40 + self baseHeaderSize!
- ^48!
Item was changed:
----- Method: NewspeakCogMethodSurrogate64>>nextMethod (in category 'accessing') -----
nextMethod
| v |
+ ^(v := memory unsignedLongLongAt: address + 33 + baseHeaderSize) ~= 0 ifTrue:
- ^(v := memory unsignedLongLongAt: address + 41) ~= 0 ifTrue:
[cogit cCoerceSimple: v to: #'CogMethod *']!
Item was changed:
----- Method: NewspeakCogMethodSurrogate64>>nextMethod: (in category 'accessing') -----
nextMethod: aValue
^memory
+ unsignedLongLongAt: address + baseHeaderSize + 33
- unsignedLongLongAt: address + 41
put: ((aValue ifNotNil: [aValue asUnsignedInteger] ifNil: [0]))!
Item was added:
+ ----- Method: ObjectMemory class>>characterObjectOf: (in category 'simulation only') -----
+ characterObjectOf: characterCode
+ ^(characterCode between: 0 and: 255) ifTrue:
+ [characterCode asCharacter]!
Item was added:
+ ----- Method: ObjectMemory class>>isImmediate: (in category 'simulation only') -----
+ isImmediate: anObject
+ ^anObject class == SmallInteger!
Item was changed:
----- Method: ObjectMemory>>integerObjectOf: (in category 'interpreter access') -----
integerObjectOf: value
"Convert the integer value, assumed to be in SmallInteger range, into a tagged SmallInteger object.
In C, use a shift and an add to set the tag bit.
In Smalltalk we have to work harder because the simulator works with strictly positive bit patterns."
+ <returnTypeC: #sqInt>
-
^self
cCode: [(value << 1) + 1]
inSmalltalk: [value >= 0
ifTrue: [(value << 1) + 1]
ifFalse: [((16r80000000 + value) << 1) + 1]]!
Item was changed:
----- Method: RiscOSVMMaker>>createCodeGenerator (in category 'initialize') -----
createCodeGenerator
"set up a CCodeGenerator for this VMMaker - RiscOS uses the global struct and no local def of the structure because of the global register trickery"
+ ^CCodeGeneratorGlobalStructure new
+ vmMaker: self;
- ^CCodeGeneratorGlobalStructure new initialize;
logger: logger;
yourself!
Item was changed:
----- Method: SmartSyntaxPluginTMethod>>extractPrimitiveDirectives (in category 'specifying primitives') -----
extractPrimitiveDirectives
"Save selector in fullSelector and args in fullArgs. Scan top-level statements for a directive of the form:
self
primitive: <string>
or
self
primitive: <string>
parameters: <list of class names>
or
self
primitive: <string>
parameters: <list of class names>
receiver: <class name>
or an assignment of that expression to a local, and manipulate the state and parse tree accordingly."
parseTree setStatements: (Array streamContents:
[:sStream |
parseTree statements do:
[:stmt |
(self primitiveDirectiveWasHandled: stmt on: sStream)
ifFalse: [sStream nextPut: stmt]]]).
isPrimitive
ifTrue:
[export := true.
parseTree
setStatements: self namedPrimitiveProlog,
parseTree statements.
self fixUpReturns.
self replaceSizeMessages.
^true]
+ ifFalse: [self removeFinalSelfReturnIn: nil].
- ifFalse: [self removeFinalSelfReturn].
^false!
Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>runLeakCheckerForFullGC: (in category 'debug support') -----
+ runLeakCheckerForFullGC: fullGCFlag
+ (fullGCFlag
+ ifTrue: [self leakCheckFullGC]
+ ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush]!
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>runLeakCheckerForFullGC: (in category 'debug support') -----
+ runLeakCheckerForFullGC: fullGCFlag
+ (fullGCFlag
+ ifTrue: [self leakCheckFullGC]
+ ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush]!
Item was added:
+ ----- Method: Spur32BitMemoryManager class>>isImmediate: (in category 'simulation only') -----
+ isImmediate: anObject
+ ^anObject class == SmallInteger
+ or: [anObject class == Character]!
Item was changed:
----- Method: Spur32BitMemoryManager>>integerObjectOf: (in category 'immediates') -----
integerObjectOf: value
"Convert the integer value, assumed to be in SmallInteger range, into a tagged SmallInteger object.
In C, use a shift and an add to set the tag bit.
In Smalltalk we have to work harder because the simulator works with strictly positive bit patterns."
+ <returnTypeC: #sqInt>
-
^self
cCode: [value << 1 + 1]
inSmalltalk: [value >= 0
ifTrue: [value << 1 + 1]
ifFalse: [16r80000000 + value << 1 + 1]]!
Item was added:
+ ----- Method: Spur64BitMemoryManager class>>isImmediate: (in category 'simulation only') -----
+ isImmediate: anObject
+ self flag: 'The float range is close but probably wrong. Revisit when immediate floats are implemented'.
+ ^anObject class == SmallInteger
+ or: [anObject class == Character
+ or: [anObject class == Float and: [anObject exponent between: -128 and: 127]]]!
Item was changed:
----- Method: Spur64BitMemoryManager>>integerObjectOf: (in category 'immediates') -----
integerObjectOf: value
"Convert the integer value, assumed to be in SmallInteger range, into a tagged SmallInteger object.
In C, use a shift and an add to set the tag bit.
In Smalltalk we have to work harder because the simulator works with strictly positive bit patterns."
+ <returnTypeC: #sqInt>
-
^self
cCode: [value << self numTagBits + 1]
inSmalltalk: [value << self numTagBits
+ (value >= 0
ifTrue: [1]
ifFalse: [16r8000000000000001])]!
Item was added:
+ ----- Method: SpurGenerationScavenger class>>implicitReturnTypeFor: (in category 'translation') -----
+ implicitReturnTypeFor: aSelector
+ "Answer the return type for methods that don't have an explicit return."
+ ^#void!
Item was changed:
----- Method: SpurGenerationScavenger>>fireEphemeronsOnEphemeronList (in category 'weakness and ephemerality') -----
fireEphemeronsOnEphemeronList
"There are ephemerons to be fired in the remembered set.
Fire them and scavenge their keys. Be careful since copyAndForward:
can remember ephemerons (ephemerons pointing to ephemerons)."
- <returnTypeC: #void>
| ephemeron ephemeronCorpse |
ephemeronList ifNil:
[^self].
ephemeronCorpse := self firstCorpse: ephemeronList.
"Reset the list head so that new ephemerons will get added
to a new list, not concatenated on the one we are scanning."
ephemeronList := nil.
[ephemeronCorpse notNil] whileTrue:
[self assert: (manager isForwarded: ephemeronCorpse).
ephemeron := manager followForwarded: ephemeronCorpse.
self assert: (self isScavengeSurvivor: (manager keyOfEphemeron: ephemeron)) not.
coInterpreter fireEphemeron: ephemeron.
self copyAndForward: (manager keyOfEphemeron: ephemeron).
self cCoerceSimple: (self scavengeReferentsOf: ephemeron) to: #void.
ephemeronCorpse := self nextCorpseOrNil: ephemeronCorpse]!
Item was changed:
----- Method: SpurGenerationScavenger>>scavengeLoop (in category 'scavenger') -----
scavengeLoop
"This is the inner loop of the main routine, scavenge. It first scavenges the new objects immediately
reachable from old ones. Then it scavenges those that are transitively reachable. If this results in a
promotion, the promotee gets remembered, and it first scavenges objects adjacent to the promotee,
then scavenges the ones reachable from the promoted. This loop continues until no more reachable
objects are left. At that point, pastSurvivorSpace is exchanged with futureSurvivorSpace.
Notice that each pointer in a live object is inspected once and only once. The previousRememberedSetSize
and previousFutureSurvivorSpaceLimit variables ensure that no object is scanned twice, as well as
detecting closure. If this were not true, some pointers might get forwarded twice.
An extension of the algorithm presented in David's original paper is to handle weak arrays and ephemerons.
Weak arrays should not have their weak referents scavenged unless there are strong references to them.
Ephemerons should fire if their key is not reachable other than from ephemerons and weak arrays.
Handle this by maintaining a list for weak arrays and a list for ephemerons, which allow scavenging these
objects once all other objects in new space have been scavenged, hence allowing the scavenger to
detect which referents in new space of weak arrays are dead and of ephemeron keys are only live due to
ephemerons. Read the class comment for a more in-depth description of the algorithm."
<inline: false>
- <returnTypeC: #void>
| previousFutureSurvivorStart firstTime |
self assert: futureSurvivorStart = futureSpace start. "future space should be empty at the start"
weakList := ephemeronList := nil.
numRememberedEphemerons := 0.
firstTime := true.
previousRememberedSetSize := 0.
previousFutureSurvivorStart := futureSurvivorStart.
+ coInterpreter initStackPageGC.
+
[self scavengeRememberedSetStartingAt: previousRememberedSetSize.
previousRememberedSetSize := rememberedSetSize.
firstTime ifTrue:
[coInterpreter mapInterpreterOops.
manager mapExtraRoots.
firstTime := false].
"if nothing more copied and forwarded (or remembered by mapInterpreterOops)
to scavenge, and no ephemerons to process, scavenge is done."
(previousRememberedSetSize = rememberedSetSize
and: [previousFutureSurvivorStart = futureSurvivorStart
and: [numRememberedEphemerons = 0
and: [ephemeronList isNil]]]) ifTrue:
[^self].
self scavengeFutureSurvivorSpaceStartingAt: previousFutureSurvivorStart.
previousFutureSurvivorStart := futureSurvivorStart.
"no more roots created to scavenge..."
previousRememberedSetSize = rememberedSetSize ifTrue:
[(numRememberedEphemerons = 0
and: [ephemeronList isNil]) ifTrue:
[^self]. "no ephemerons to process, scavenge is done."
"all reachable objects in this cycle have been promoted to futureSpace.
ephemerons can now be processed."
self processEphemerons]] repeat!
Item was added:
+ ----- Method: SpurMemoryManager class>>characterObjectOf: (in category 'simulation only') -----
+ characterObjectOf: characterCode
+ ^characterCode asCharacter!
Item was added:
+ ----- Method: SpurMemoryManager class>>implicitReturnTypeFor: (in category 'translation') -----
+ implicitReturnTypeFor: aSelector
+ "Answer the return type for methods that don't have an explicit return."
+ ^#void!
Item was added:
+ ----- Method: SpurMemoryManager class>>isImmediate: (in category 'simulation only') -----
+ isImmediate: anObject
+ self subclassResponsibility!
Item was changed:
----- Method: SpurMemoryManager>>addFreeSubTree: (in category 'free space') -----
addFreeSubTree: freeTree
"Add a freeChunk sub tree back into the large free chunk tree.
This is for allocateOldSpaceChunkOf[Exactly]Bytes:."
- <returnTypeC: #void>
| slotsInArg treeNode slotsInNode subNode |
slotsInArg := self numSlotsOfAny: freeTree.
self assert: slotsInArg / (self allocationUnit / self wordSize) >= self numFreeLists.
treeNode := freeLists at: 0.
self assert: treeNode ~= 0.
[slotsInNode := self numSlotsOfAny: treeNode.
self assert: slotsInArg ~= slotsInNode.
slotsInNode > slotsInArg
ifTrue:
[subNode := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode.
subNode = 0 ifTrue:
[self storePointer: self freeChunkSmallerIndex ofFreeChunk: treeNode withValue: freeTree.
self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode.
^self]]
ifFalse:
[subNode := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode.
subNode = 0 ifTrue:
[self storePointer: self freeChunkLargerIndex ofFreeChunk: treeNode withValue: freeTree.
self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode.
^self]].
treeNode := subNode] repeat!
Item was changed:
----- Method: SpurMemoryManager>>bestFitCompact (in category 'compaction') -----
bestFitCompact
"Compact all of memory using best-fit, assuming free space is sorted
and that the highest objects are recorded in highestObjects."
- <returnTypeC: #void>
<inline: false>
| freePriorToExactFit |
self checkFreeSpace.
freePriorToExactFit := totalFreeOldSpace.
self exactFitCompact.
self checkFreeSpace.
highestObjects isEmpty ifTrue:
[^self]. "either no high objects, or no misfits."
statCompactPassCount := statCompactPassCount + 1.
highestObjects reverseDo:
[:o| | b |
self assert: ((self isForwarded: o) or: [self isPinned: o]) not.
b := self bytesInObject: o.
(self allocateOldSpaceChunkOfBytes: b suchThat: [:f| f < o]) ifNotNil:
[:f| self copyAndForward: o withBytes: b toFreeChunk: f]].
self checkFreeSpace.
self flag: 'this should perhaps be a loop, recharging highestObjects as per exactFitCompact, but for now we assume the number of misfits not in highestObjects is very small'.
self allOldSpaceObjectsFrom: firstFreeChunk
do: [:o| | b |
((self isForwarded: o)
or: [self isPinned: o]) ifFalse:
[b := self bytesInObject: o.
(self allocateOldSpaceChunkOfBytes: b suchThat: [:f| f < o]) ifNotNil:
[:f| self copyAndForward: o withBytes: b toFreeChunk: f]]].
self checkFreeSpace.
self touch: freePriorToExactFit!
Item was changed:
----- Method: SpurMemoryManager>>checkOkayOop: (in category 'debug support') -----
checkOkayOop: oop
"Verify that the given oop is legitimate. Check address, header, and size but not class.
Answer true if OK. Otherwise print reason and answer false."
<api>
<var: #oop type: #usqInt>
| classIndex fmt unusedBits unusedBitsInYoungObjects |
+ <var: #unusedBits type: #usqLong>
"address and size checks"
(self isImmediate: oop) ifTrue: [^true].
(self addressCouldBeObjWhileScavenging: oop) ifFalse:
[self print: 'oop '; printHex: oop; print: ' is not a valid address'. ^false].
(self addressAfter: oop) <= freeOldSpaceStart ifFalse:
[self print: 'oop '; printHex: oop; print: ' size would make it extend beyond the end of memory'. ^false].
"header type checks"
(classIndex := self classIndexOf: oop) >= self firstClassIndexPun ifFalse:
[self print: 'oop '; printHex: oop; print: ' is a free chunk, or bridge, not an object'. ^false].
((self rawNumSlotsOf: oop) = self numSlotsMask
and: [(self rawNumSlotsOf: oop) - self baseHeaderSize ~= self numSlotsMask]) ifTrue:
[self print: 'oop '; printHex: oop; print: ' header has overflow header word, but overflow word does not have a saturated numSlots field'. ^false].
"format check"
fmt := self formatOf: oop.
(fmt = 6) | (fmt = 8) ifTrue:
[self print: 'oop '; printHex: oop; print: ' has an unknown format type'. ^false].
(fmt = self forwardedFormat) ~= (classIndex = self isForwardedObjectClassIndexPun) ifTrue:
[self print: 'oop '; printHex: oop; print: ' has mismached format/classIndex fields; only one of them is the isForwarded value'. ^false].
"specific header bit checks"
unusedBits := (1 << self classIndexFieldWidth)
| (1 << (self identityHashFieldWidth + 32)).
((self longLongAt: oop) bitAnd: unusedBits) ~= 0 ifTrue:
[self print: 'oop '; printHex: oop; print: ' has some unused header bits set; should be zero'. ^false].
unusedBitsInYoungObjects := self newSpaceRefCountMask.
((self longAt: oop) bitAnd: unusedBitsInYoungObjects) ~= 0 ifTrue:
[self print: 'oop '; printHex: oop; print: ' has some header bits unused in young objects set; should be zero'. ^false].
^true!
Item was changed:
----- Method: SpurMemoryManager>>countNumClassPagesPreSwizzle: (in category 'class table') -----
countNumClassPagesPreSwizzle: bytesToShift
"Compute the used size of the class table before swizzling. Needed to
initialize the classTableBitmap which is populated during adjustAllOopsBy:"
- <returnTypeC: #void>
| firstObj classTableRoot nilObjPreSwizzle |
firstObj := self objectStartingAt: newSpaceLimit. "a.k.a. nilObj"
"first five objects are nilObj, falseObj, trueObj, freeListsObj, classTableRootObj"
classTableRoot := self objectAfter:
(self objectAfter:
(self objectAfter:
(self objectAfter: firstObj
limit: freeOldSpaceStart)
limit: freeOldSpaceStart)
limit: freeOldSpaceStart)
limit: freeOldSpaceStart.
nilObjPreSwizzle := newSpaceLimit - bytesToShift.
numClassTablePages := self numSlotsOf: classTableRoot.
self assert: numClassTablePages = (self classTableRootSlots + self hiddenRootSlots).
2 to: numClassTablePages - 1 do:
[:i|
(self fetchPointer: i ofObject: classTableRoot) = nilObjPreSwizzle ifTrue:
[numClassTablePages := i.
^self]]
!
Item was changed:
----- Method: SpurMemoryManager>>doBecome:and:copyHash: (in category 'become implementation') -----
doBecome: obj1 and: obj2 copyHash: copyHashFlag
"Inner dispatch for two-way become"
- <returnTypeC: #void>
| o1ClassIndex o2ClassIndex |
copyHashFlag ifFalse:
["in-lined
clasIndex := (self isInClassTable: obj) ifTrue: [self rawHashBitsOf: obj] ifFalse: [0]
for speed."
o1ClassIndex := self rawHashBitsOf: obj1.
(o1ClassIndex ~= 0 and: [(self classAtIndex: o1ClassIndex) ~= obj1]) ifTrue:
[o1ClassIndex := 0].
o2ClassIndex := self rawHashBitsOf: obj2.
(o2ClassIndex ~= 0 and: [(self classAtIndex: o2ClassIndex) ~= obj2]) ifTrue:
[o2ClassIndex := 0]].
(self numSlotsOf: obj1) = (self numSlotsOf: obj2)
ifTrue:
[self inPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag]
ifFalse:
[self outOfPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag].
"if copyHashFlag then nothing changes, since hashes were also swapped."
copyHashFlag ifTrue:
[^self].
"if copyHash is false then the classTable entries must be updated."
o1ClassIndex ~= 0
ifTrue:
[o2ClassIndex ~= 0
ifTrue: "both were in the table; just swap entries"
[| tmp |
tmp := self classAtIndex: o1ClassIndex.
self classAtIndex: o1ClassIndex put: obj2.
self classAtIndex: o2ClassIndex put: tmp]
ifFalse: "o2 wasn't in the table; put it there"
[| newObj2 |
newObj2 := self followForwarded: obj2.
self assert: (self rawHashBitsOf: newObj2) = 0.
self setHashBitsOf: newObj2 to: o1ClassIndex.
self classAtIndex: o1ClassIndex put: newObj2]]
ifFalse:
[o2ClassIndex ~= 0 ifTrue:
[| newObj1 |
newObj1 := self followForwarded: obj1.
self assert: (self rawHashBitsOf: newObj1) = 0.
self setHashBitsOf: newObj1 to: o2ClassIndex.
self classAtIndex: o2ClassIndex put: newObj1]]!
Item was changed:
----- Method: SpurMemoryManager>>exactFitCompact (in category 'compaction') -----
exactFitCompact
"Compact all of memory above firstFreeChunk using exact-fit, assuming free
space is sorted and that the highest objects are recorded in highestObjects.
Note that we don't actually move; we merely copy and forward. Eliminating
forwarders will be done in a final pass.
Leave the objects that don't fit exactly, and hence aren't moved, in highestObjects."
- <returnTypeC: #void>
<inline: false>
| misfits first |
<var: #misfits type: #usqInt>
+ totalFreeOldSpace = 0 ifTrue: [^self].
- totalFreeOldSpace = 0 ifTrue: [^0].
misfits := highestObjects last + self wordSize.
[statCompactPassCount := statCompactPassCount + 1.
highestObjects from: misfits - self wordSize reverseDo:
[:o| | b |
o < firstFreeChunk ifTrue:
[misfits = (highestObjects last + self wordSize)
ifTrue: [highestObjects resetAsEmpty]
ifFalse: [highestObjects first: misfits].
^self].
((self isForwarded: o) or: [self isPinned: o]) ifFalse:
[b := self bytesInObject: o.
(self allocateOldSpaceChunkOfExactlyBytes: b suchThat: [:f| f < o])
ifNil:
[misfits := misfits - self wordSize.
misfits < highestObjects start ifTrue:
[misfits := highestObjects limit].
self longAt: misfits put: o]
ifNotNil:
[:f| self copyAndForward: o withBytes: b toFreeChunk: f]]].
"now highestObjects contains only misfits, if any, from misfits to last.
set first to first failure and refill buffer. next cycle will add more misfits.
give up on exact-fit when half of the highest objects fail to fit."
first := self longAt: highestObjects first.
first > firstFreeChunk ifTrue:
[| highestObjBytes failureBytes savedLimit |
highestObjBytes := highestObjects limit - highestObjects start.
failureBytes := highestObjects last >= misfits
ifTrue: [highestObjects last - misfits]
ifFalse: [highestObjBytes - (misfits - highestObjects last)].
failureBytes >= (highestObjBytes // 2) ifTrue:
[highestObjects first: misfits.
^self].
savedLimit := self moveMisfitsToTopOfHighestObjects: misfits.
self fillHighestObjectsWithMovableObjectsFrom: firstFreeChunk upTo: first.
misfits := self moveMisfitsInHighestObjectsBack: savedLimit]] repeat!
Item was changed:
----- Method: SpurMemoryManager>>fillHighestObjectsWithMovableObjectsFrom:upTo: (in category 'compaction') -----
fillHighestObjectsWithMovableObjectsFrom: startObj upTo: limitObj
"Refill highestObjects with movable objects up to, but not including limitObj.
c.f. the loop in freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoalesceFreeSpace."
| lastHighest highestObjectsWraps |
lastHighest := highestObjects last.
highestObjectsWraps := 0.
self allOldSpaceObjectsFrom: startObj do:
[:o|
o >= limitObj ifTrue:
[highestObjects last: lastHighest.
+ ^self].
- ^nil].
((self isForwarded: o) or: [self isPinned: o]) ifFalse:
[false "conceptually...: "
ifTrue: [highestObjects addLast: o]
ifFalse: "but we inline so we can use the local lastHighest"
[(lastHighest := lastHighest + self wordSize) >= highestObjects limit ifTrue:
[highestObjectsWraps := highestObjectsWraps + 1].
self longAt: lastHighest put: o]]].
highestObjects last: lastHighest!
Item was changed:
----- Method: SpurMemoryManager>>inPlaceBecome:and:copyHashFlag: (in category 'become implementation') -----
inPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag
"Do become in place by swapping object contents."
| headerTemp temp1 temp2 o1HasYoung o2HasYoung |
- <var: 'headerTemp' type: #usqLong>
self assert: (self numSlotsOf: obj1) = (self numSlotsOf: obj2).
"swap headers, but swapping headers swaps remembered bits;
these need to be unswapped."
temp1 := self isRemembered: obj1.
temp2 := self isRemembered: obj2.
headerTemp := self longLongAt: obj1.
self longLongAt: obj1 put: (self longLongAt: obj2).
self longLongAt: obj2 put: headerTemp.
self setIsRememberedOf: obj1 to: temp1.
self setIsRememberedOf: obj2 to: temp2.
"swapping headers swaps hash; if !!copyHashFlag undo hash copy"
copyHashFlag ifFalse:
[temp1 := self rawHashBitsOf: obj1.
self setHashBitsOf: obj1 to: (self rawHashBitsOf: obj2).
self setHashBitsOf: obj2 to: temp1].
o1HasYoung := o2HasYoung := false.
0 to: (self numSlotsOf: obj1) - 1 do:
[:i|
temp1 := self fetchPointer: i ofObject: obj1.
temp2 := self fetchPointer: i ofObject: obj2.
self storePointerUnchecked: i
ofObject: obj1
withValue: temp2.
self storePointerUnchecked: i
ofObject: obj2
withValue: temp1.
((self isNonImmediate: temp2) and: [self isYoung: temp2]) ifTrue:
[o1HasYoung := true].
((self isNonImmediate: temp1) and: [self isYoung: temp1]) ifTrue:
[o2HasYoung := true]].
(self isYoung: obj1) ifFalse:
[o1HasYoung ifTrue:
[self possibleRootStoreInto: obj1]].
(self isYoung: obj2) ifFalse:
[o2HasYoung ifTrue:
[self possibleRootStoreInto: obj2]]!
Item was changed:
----- Method: SpurMemoryManager>>markAndFireEphemerons (in category 'gc - global') -----
markAndFireEphemerons
- <returnTypeC: #void>
"After the initial scan-mark is complete ephemerons can be processed."
[coInterpreter markAndTraceUntracedReachableStackPages.
self noUnscannedEphemerons ifTrue:
[^self].
self markInactiveEphemerons ifFalse:
[self fireAllUnscannedEphemerons].
self markAllUnscannedEphemerons]
repeat!
Item was changed:
----- Method: SpurMemoryManager>>markAndTrace: (in category 'gc - global') -----
markAndTrace: objOop
"Mark the argument, and all objects reachable from it, and any remaining objects on the mark stack.
Follow forwarding pointers in the scan."
- <returnTypeC: #void>
| objToScan index field |
self assert: (self isNonImmediate: objOop).
"if markAndTrace: is to follow and eliminate forwarding pointers
in its scan it cannot be handed an r-value which is forwarded."
self assert: (self isForwarded: objOop) not.
(self isMarked: objOop) ifTrue:
[^self].
"self setIsMarkedOf: objOop to: false" "for debugging"
self setIsMarkedOf: objOop to: true.
"Now scan the object, and any remaining objects on the mark stack."
objToScan := objOop.
"To avoid overflowing the mark stack when we encounter large objects, we
push the obj, then its numStrongSlots, and then index the object from the stack."
[| numStrongSlots |
((self isImmediate: objToScan)
or: [numStrongSlots := self numStrongSlotsOf: objToScan ephemeronInactiveIf: #inactiveOrFailedToDeferScan:.
numStrongSlots > self traceImmediatelySlotLimit])
ifTrue: "scanning a large object. scan until hitting an unmarked object, then switch to it, if any."
[(self isImmediate: objToScan)
ifTrue:
[index := self integerValueOf: objToScan.
objToScan := self topOfObjStack: markStack]
ifFalse:
[index := numStrongSlots].
[index > 0] whileTrue:
[index := index - 1.
field := self fetchPointer: index ofObject: objToScan.
(self isOopForwarded: field) ifTrue:
[field := self followForwarded: field.
self storePointerUnchecked: index ofObject: objToScan withValue: field].
((self isImmediate: field)
or: [self isMarked: field]) ifFalse:
[self setIsMarkedOf: field to: true.
(self topOfObjStack: markStack) ~= objToScan ifTrue:
[self push: objToScan onObjStack: markStack].
self push: (self integerObjectOf: index) onObjStack: markStack.
objToScan := field.
index := -1]].
index >= 0 ifTrue: "if loop terminated without finding an unmarked referent, switch to top of stack."
[objToScan := self popObjStack: markStack.
objToScan = objOop ifTrue:
[objToScan := self popObjStack: markStack]]]
ifFalse: "scanning a small object. scan, marking, pushing unmarked referents, then switch to the top of the stack."
[index := numStrongSlots.
[index > 0] whileTrue:
[index := index - 1.
field := self fetchPointer: index ofObject: objToScan.
(self isOopForwarded: field) ifTrue:
[field := self followForwarded: field.
self storePointerUnchecked: index ofObject: objToScan withValue: field].
((self isImmediate: field)
or: [self isMarked: field]) ifFalse:
[self setIsMarkedOf: field to: true.
self push: field onObjStack: markStack.
numStrongSlots := self numStrongSlotsOf: field ephemeronInactiveIf: #inactiveOrFailedToDeferScan:.
numStrongSlots > self traceImmediatelySlotLimit ifTrue:
[self push: (self integerObjectOf: numStrongSlots) onObjStack: markStack]]].
objToScan := self popObjStack: markStack].
objToScan notNil] whileTrue!
Item was changed:
----- Method: SpurMemoryManager>>markAndTraceObjStack:andContents: (in category 'obj stacks') -----
markAndTraceObjStack: stackOrNil andContents: markAndTraceContents
"An obj stack is a stack of objects stored in a hidden root slot, such
as the markStack or the ephemeronQueue. It is a linked list of
segments, with the hot end at the head of the list. It is a word object.
The stack pointer is in ObjStackTopx and 0 means empty."
- <returnTypeC: #void>
<inline: false>
| index field |
stackOrNil = nilObj ifTrue:
[^self].
self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots.
field := self fetchPointer: ObjStackNextx ofObject: stackOrNil.
field ~= 0 ifTrue:
[self markAndTraceObjStack: field andContents: markAndTraceContents].
field := stackOrNil.
[field := self fetchPointer: ObjStackFreex ofObject: stackOrNil.
field ~= 0] whileTrue:
[self setIsMarkedOf: field to: true].
markAndTraceContents ifFalse:
[^self].
"There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so
if there were 6 slots in an oop stack, full would be 2, and the last 0-rel index is 5."
index := (self fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx.
[index >= ObjStackFixedSlots] whileTrue:
[field := self fetchPointer: index ofObject: stackOrNil.
(self isImmediate: field) ifFalse:
[self markAndTrace: field].
index := index - 1]!
Item was changed:
----- Method: SpurMemoryManager>>okayOop: (in category 'debug support') -----
okayOop: signedOop
"Verify that the given oop is legitimate. Check address, header, and size but not class."
| oop classIndex fmt unusedBits unusedBitsInYoungObjects |
<var: #oop type: #usqInt>
+ <var: #unusedBits type: #usqLong>
oop := self cCoerce: signedOop to: #usqInt.
"address and size checks"
(self isImmediate: oop) ifTrue: [^true].
(self addressCouldBeObjWhileScavenging: oop) ifFalse:
[self error: 'oop is not a valid address'. ^false].
(self addressAfter: oop) <= freeOldSpaceStart ifFalse:
[self error: 'oop size would make it extend beyond the end of memory'. ^false].
"header type checks"
(classIndex := self classIndexOf: oop) >= self firstClassIndexPun ifFalse:
[self error: 'oop is a free chunk, or bridge, not an object'. ^false].
((self rawNumSlotsOf: oop) = self numSlotsMask
and: [(self rawNumSlotsOf: oop) - self baseHeaderSize ~= self numSlotsMask]) ifTrue:
[self error: 'oop header has overflow header word, but overflow word does not have a saturated numSlots field'. ^false].
"format check"
fmt := self formatOf: oop.
(fmt = 6) | (fmt = 8) ifTrue:
[self error: 'oop has an unknown format type'. ^false].
(fmt = self forwardedFormat) ~= (classIndex = self isForwardedObjectClassIndexPun) ifTrue:
[self error: 'oop has mismached format/classIndex fields; only one of them is the isForwarded value'. ^false].
"specific header bit checks"
unusedBits := (1 << self classIndexFieldWidth)
| (1 << (self identityHashFieldWidth + 32)).
((self longLongAt: oop) bitAnd: unusedBits) ~= 0 ifTrue:
[self error: 'some unused header bits are set; should be zero'. ^false].
unusedBitsInYoungObjects := (1 << self greyBitShift)
| (1 << self pinnedBitShift)
| (1 << self rememberedBitShift).
((self longAt: oop) bitAnd: unusedBitsInYoungObjects) ~= 0 ifTrue:
[self error: 'some header bits unused in young objects are set; should be zero'. ^false].
^true
!
Item was changed:
----- Method: SpurMemoryManager>>postBecomeOrCompactScanClassTable: (in category 'become implementation') -----
postBecomeOrCompactScanClassTable: effectsFlags
"Scan the class table post-become (iff a pointer object or compiled method was becommed),
or post-compact.
Note that one-way become can cause duplications in the class table.
When can these be eliminated? We use the classTableBitmap to mark classTable entries
(not the classes themselves, since marking a class doesn't help in knowing if its index is used).
On image load, and during incrememtal scan-mark and full GC, classIndices are marked.
We can somehow avoid following classes from the classTable until after this mark phase."
-
self assert: self validClassTableRootPages.
(effectsFlags anyMask: BecamePointerObjectFlag+BecameCompiledMethodFlag) ifFalse: [^self].
0 to: numClassTablePages - 1 do:
[:i| | page |
page := self fetchPointer: i ofObject: hiddenRootsObj.
0 to: (self numSlotsOf: page) - 1 do:
[:j| | classOrNil |
classOrNil := self fetchPointer: j ofObject: page.
classOrNil ~= nilObj ifTrue:
[(self isForwarded: classOrNil) ifTrue:
[classOrNil := self followForwarded: classOrNil.
self storePointer: j ofObject: page withValue: classOrNil].
self scanClassPostBecome: classOrNil effects: effectsFlags]]]!
Item was added:
+ ----- Method: SpurSegmentManager class>>implicitReturnTypeFor: (in category 'translation') -----
+ implicitReturnTypeFor: aSelector
+ "Answer the return type for methods that don't have an explicit return."
+ ^#void!
Item was changed:
----- Method: SpurSegmentManager>>allocateOrExtendSegmentInfos (in category 'private') -----
allocateOrExtendSegmentInfos
"Increase the number of allocated segInfos by 16."
- <returnTypeC: #void>
| 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: 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: SpurSegmentManager>>collapseSegmentsPostSwizzle (in category 'snapshot') -----
collapseSegmentsPostSwizzle
"The image has been loaded, old segments reconstructed, and the heap
swizzled into a single contiguous segment. Collapse the segments into one."
<inline: false>
| bridge |
canSwizzle := false.
firstSegmentSize ifNil: "true when used by SpurBootstrap to transform an image"
+ [^self].
- [^nil].
numSegments := 1.
(segments at: 0)
segStart: manager newSpaceLimit;
segSize: manager endOfMemory - manager newSpaceLimit.
"finally plant a bridge at the end of the coalesced segment and cut back the
manager's notion of the end of memory to immediately before the bridge."
bridge := manager endOfMemory - manager bridgeSize.
self assert: bridge = ((segments at: 0) segStart
+ (segments at: 0) segSize
- manager bridgeSize).
manager
initSegmentBridgeWithBytes: manager bridgeSize at: bridge;
setEndOfMemory: bridge!
Item was changed:
----- Method: StackInterpreter>>addNewMethodToCache: (in category 'method lookup cache') -----
addNewMethodToCache: classObj
"Add the given entry to the method cache.
The policy is as follows:
Look for an empty entry anywhere in the reprobe chain.
If found, install the new entry there.
If not found, then install the new entry at the first probe position
and delete the entries in the rest of the reprobe chain.
This has two useful purposes:
If there is active contention over the first slot, the second
or third will likely be free for reentry after ejection.
Also, flushing is good when reprobe chains are getting full."
| probe hash primitiveIndex |
<inline: false>
hash := messageSelector bitXor: (objectMemory classTagForClass: classObj). "drop low-order zeros from addresses (if classObj not classTag)"
(objectMemory isOopCompiledMethod: newMethod)
ifTrue:
[primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: classObj]
ifFalse:
[primitiveFunctionPointer := #primitiveInvokeObjectAsMethod].
0 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
(methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
["Found an empty entry -- use it"
methodCache at: probe + MethodCacheSelector put: messageSelector.
methodCache at: probe + MethodCacheClass put: (objectMemory classTagForClass: classObj).
methodCache at: probe + MethodCacheMethod put: newMethod.
methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #long).
lastMethodCacheProbeWrite := probe. "this for primitiveExternalMethod"
+ ^self]].
- ^ nil]].
"OK, we failed to find an entry -- install at the first slot..."
probe := hash bitAnd: MethodCacheMask. "first probe"
methodCache at: probe + MethodCacheSelector put: messageSelector.
methodCache at: probe + MethodCacheClass put: (objectMemory classTagForClass: classObj).
methodCache at: probe + MethodCacheMethod put: newMethod.
methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #long).
lastMethodCacheProbeWrite := probe. "this for primitiveExternalMethod"
"...and zap the following entries"
1 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
methodCache at: probe + MethodCacheSelector put: 0]!
Item was changed:
----- Method: StackInterpreter>>doubleExtendedDoAnythingBytecode (in category 'send bytecodes') -----
doubleExtendedDoAnythingBytecode
"Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count.
Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed.
The last byte give access to 256 instVars or literals.
See also secondExtendedSendBytecode"
| byte2 byte3 opType top lit |
byte2 := self fetchByte.
byte3 := self fetchByte.
opType := byte2 >> 5.
opType = 0 ifTrue:
[messageSelector := self literal: byte3.
argumentCount := byte2 bitAnd: 31.
^self normalSend].
opType = 1 ifTrue:
[messageSelector := self literal: byte3.
argumentCount := byte2 bitAnd: 31.
^self superclassSend].
self fetchNextBytecode.
opType = 2 ifTrue: [^self pushMaybeContextReceiverVariable: byte3].
opType = 3 ifTrue: [^self pushLiteralConstant: byte3].
opType = 4 ifTrue: [^self pushLiteralVariable: byte3].
top := self internalStackTop.
opType = 7 ifTrue:
[lit := self literal: byte3.
+ objectMemory storePointer: ValueIndex ofObject: lit withValue: top.
+ ^self].
- ^objectMemory storePointer: ValueIndex ofObject: lit withValue: top].
"opType = 5 is store; opType = 6 = storePop"
opType = 6 ifTrue:
[self internalPop: 1].
^self storeMaybeContextReceiverVariable: byte3 withValue: top!
Item was added:
+ ----- Method: StackInterpreter>>initStackPageGC (in category 'object memory support') -----
+ initStackPageGC
+ "GC of pages. Throwing away all stack pages on full GC is simple but dangerous
+ because it causes us to allocate lots of contexts immediately before a GC.
+ Reclaiming pages whose top context is not referenced is poor because it would
+ take N incrementalGCs to reclaim N unused pages. Only the page whose top
+ context is not referred to by the bottom context of any other page would be
+ reclaimed. Not until the next GC would the page whose top contect is the
+ previously reclaimed page's base frame's bottom context be reclaimed.
+
+ Better is to not mark stack pages until their contexts are encountered. We can
+ eagerly trace the active page and the page reachable from its bottom context
+ if any, and so on. Other pages can be marked when we encounter a married
+ context."
+ <var: #thePage type: #'StackPage *'>
+ <inline: true>
+ "Need to write back the frame pointers unless all pages are free (as in snapshot)"
+ stackPage ~= 0 ifTrue:
+ [self externalWriteBackHeadFramePointers].
+
+ 0 to: numStackPages - 1 do:
+ [:i| | thePage |
+ thePage := stackPages stackPageAt: i.
+ thePage trace: 0]!
Item was changed:
----- Method: StackInterpreter>>integerArg: (in category 'plugin primitive support') -----
integerArg: index
"Like #stackIntegerValue: but access method arguments left-to-right"
| oop |
oop := self methodArg: index.
+ oop = 0 ifTrue:[^0]. "methodArg: failed"
- oop = 0 ifTrue:[^0.0]. "methodArg: failed"
^self checkedIntegerValueOf: oop!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isImmediate: oop)
or: [(objectMemory addressCouldBeObj: oop) not
or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
or: [(objectMemory isFreeObject: oop)
or: [objectMemory isForwarded: oop]]]]) ifTrue:
+ [self printOop: oop.
+ ^self].
- [^self printOop: oop].
self printHex: oop.
(objectMemory fetchClassOfNonImm: oop)
ifNil: [self print: ' has a nil class!!!!']
ifNotNil: [:class|
self print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('; printHex: class; print: ')'].
fmt := objectMemory formatOf: oop.
self print: ' format '; printHexnp: fmt.
fmt > objectMemory lastPointerFormat
ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)]
ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue:
[| len |
len := objectMemory lengthOf: oop.
self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
objectMemory printHeaderTypeOf: oop.
self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
self cr.
(fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
[^self].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self cCode: [self printOopShort: fieldOop]
inSmalltalk: [self print: (self shortPrint: fieldOop)]].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPages: (in category 'object memory support') -----
markAndTraceStackPages: fullGCFlag
"GC of pages. Throwing away all stack pages on full GC is simple but dangerous
because it causes us to allocate lots of contexts immediately before a GC.
Reclaiming pages whose top context is not referenced is poor because it would
take N incrementalGCs to reclaim N unused pages. Only the page whose top
context is not referred to by the bottom context of any other page would be
reclaimed. Not until the next GC would the page whose top contect is the
previously reclaimed page's base frame's bottom context be reclaimed.
Better is to not mark stack pages until their contexts are encountered. We can
eagerly trace the active page and the page reachable from its bottom context
if any, and so on. Other pages can be marked when we encounter a married
context."
| thePage context |
<var: #thePage type: #'StackPage *'>
<inline: false>
+ self initStackPageGC.
- "Need to write back the frame pointers unless all pages are free (as in snapshot)"
- stackPage ~= 0 ifTrue:
- [self externalWriteBackHeadFramePointers].
- 0 to: numStackPages - 1 do:
- [:i|
- thePage := stackPages stackPageAt: i.
- thePage trace: 0].
-
"On an incremental GC simply consider all non-free stack pages to be roots."
fullGCFlag ifFalse:
[0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage trace: 2.
self markAndTraceStackPage: thePage]].
^nil].
"On a full GC only eagerly trace pages referenced from the active page."
stackPage = 0 ifTrue: [^nil].
thePage := stackPage.
[thePage trace: 2.
self markAndTraceStackPage: thePage.
context := self frameCallerContext: thePage baseFP.
((objectMemory isContext: context)
and: [(self isMarriedOrWidowedContext: context)
and: [self isStillMarriedContext: context]]) ifTrue:
[thePage := stackPages stackPageFor: (self frameOfMarriedContext: context).
self assert: (stackPages isFree: thePage) not].
thePage trace = 0] whileTrue!
Item was changed:
----- Method: StackInterpreter>>objectArg: (in category 'plugin primitive support') -----
objectArg: index
"Like #stackObjectValue: but access method arguments left-to-right"
| oop |
oop := self methodArg: index.
+ oop = 0 ifTrue:[^0]. "methodArg: failed"
- oop = 0 ifTrue:[^0.0]. "methodArg: failed"
(objectMemory isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
^oop!
Item was changed:
----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
printNameOfClass: classOop count: cnt
"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
<inline: false>
| numSlots |
classNameIndex ifNil:
[self print: '??nil cnidx??'.
^self].
+ (classOop isNil or: [classOop = 0 or: [cnt <= 0]]) ifTrue:
+ [self print: 'bad class'.
+ ^self].
- (classOop isNil or: [classOop = 0 or: [cnt <= 0]]) ifTrue: [^self print: 'bad class'].
numSlots := objectMemory numSlotsOf: classOop.
(numSlots = metaclassNumSlots
and: [metaclassNumSlots > thisClassIndex])
ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
self print: ' class']
ifFalse:
[numSlots <= classNameIndex
ifTrue: [self print: 'bad class']
ifFalse:
[self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]]!
Item was changed:
----- Method: StackToRegisterMappingCogit class>>ancilliaryClasses: (in category 'translation') -----
ancilliaryClasses: options
+ ^(super ancilliaryClasses: options),
- ^((super ancilliaryClasses: options) copyWithout: CogBytecodeFixup),
{ CogSSBytecodeFixup. CogSimStackEntry. CogSSOptStatus }!
Item was added:
+ ----- Method: StackToRegisterMappingCogit class>>isAcceptableAncilliaryClass: (in category 'translation') -----
+ isAcceptableAncilliaryClass: aClass
+ ^true!
Item was added:
+ ----- Method: StackToRegisterMappingCogit class>>shouldGenerateTypedefFor: (in category 'translation') -----
+ shouldGenerateTypedefFor: aStructClass
+ "Hack to work-around mutliple definitions. Sometimes a type has been defined in an include."
+ ^aStructClass ~~ CogBytecodeFixup "overridden by CogSSBytecodeFixup"
+ and: [super shouldGenerateTypedefFor: aStructClass]!
Item was changed:
----- Method: StackToRegisterMappingCogit>>compileFrameBuild (in category 'compile abstract instructions') -----
compileFrameBuild
"Build a frame for a CogMethod activation. See CoInterpreter class>>initializeFrameIndices.
Override to push the register receiver and register arguments, if any."
needsFrame ifFalse:
[self initSimStackForFramelessMethod: initialPC.
+ ^0].
- ^self].
self genPushRegisterArgs.
super compileFrameBuild.
self initSimStackForFramefulMethod: initialPC!
Item was changed:
----- Method: TMethod>>elideAnyFinalReturn (in category 'transformations') -----
elideAnyFinalReturn
"For super expansions we need to eliminate any final return to prevent premature exit.
Anything meaningful in the returned expression must be retained."
+ | stmtList expr |
- | stmtList lastStmt |
stmtList := parseTree statements asOrderedCollection.
+ stmtList last isReturn ifTrue:
+ [expr := stmtList last expression.
+ (expr isVariable and: [expr name = 'self'])
+ ifTrue: [stmtList := stmtList allButLast]
+ ifFalse: [stmtList at: stmtList size put: expr].
- (lastStmt := stmtList last) isReturn ifTrue:
- [stmtList at: stmtList size put: lastStmt expression.
parseTree setStatements: stmtList]!
Item was added:
+ ----- Method: TMethod>>harmonizeSignedAndUnsignedTypesIn: (in category 'type inference') -----
+ harmonizeSignedAndUnsignedTypesIn: aSetOfTypes
+ "Eliminate signed/unsigned conflicts in aSetOfTypes"
+ | sqs usqs |
+ sqs := aSetOfTypes select: [:t| t beginsWith: 'sq'].
+ usqs := aSetOfTypes select: [:t| t beginsWith: 'usq'].
+ ^(sqs size + usqs size = aSetOfTypes size
+ and: [sqs notEmpty
+ and: [sqs allSatisfy: [:t| usqs includes: 'u', t]]])
+ ifTrue: [sqs]
+ ifFalse: [aSetOfTypes]!
Item was added:
+ ----- 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 isNil ifTrue:"the initial default"
+ [aCodeGen
+ pushScope: declarations
+ while:
+ [| hasReturn returnTypes |
+ hasReturn := false.
+ returnTypes := Set new.
+ parseTree nodesDo:
+ [:node|
+ node isReturn ifTrue:
+ [| 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 added:
+ ----- 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 added:
+ ----- Method: TMethod>>inferTypesForImplicitlyTypedVariablesIn: (in category 'type inference') -----
+ inferTypesForImplicitlyTypedVariablesIn: aCodeGen
+ parseTree nodesDo:
+ [:node| | var m |
+ (node isAssignment
+ and: [(locals includes: (var := node variable name))
+ and: [(declarations includesKey: var) not
+ and: [node expression isSend
+ and: [(m := aCodeGen methodNamed: node expression selector) notNil]]]]) ifTrue:
+ [(#(sqInt void nil) includes: m returnType) ifFalse:
+ ["the $: is to map things like unsigned field : 3 to usqInt"
+ declarations
+ at: var
+ put: ((m returnType includes: $:) ifTrue: [#usqInt] ifFalse: [m returnType]), ' ', var]]]!
Item was changed:
----- Method: TMethod>>isFunctional (in category 'inlining') -----
isFunctional
"Answer true if the receiver is a functional method. That is, if it
consists of a single return statement of an expression that contains
no other returns.
Answer false for methods with return types other than the simple
integer types to work around bugs in the inliner."
(parseTree statements size = 1 and:
[parseTree statements last isReturn]) ifFalse: [ ^false ].
parseTree statements last expression nodesDo: [ :n | n isReturn ifTrue: [ ^false ]].
+ ^#(sqInt usqInt sqLong usqLong #'sqInt *') includes: returnType!
- ^#(sqInt usqInt sqLong usqLong) includes: returnType!
Item was changed:
----- 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].
- [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 removed:
- ----- Method: TMethod>>removeFinalSelfReturn (in category 'transformations') -----
- removeFinalSelfReturn
- "The Smalltalk parser automatically adds the statement '^self' to the end of methods
- without explicit returns. This method removes such statements, since in most VMMaker
- classes (except struct classes) the generated code has no notion of 'self' anyway.
- If the statement is removed and no return type has yet been specified asnd the class
- specifies a default return type (e.g. #void) for methods that don't return, then set the
- return type accordingly."
-
- | lastStmt |
- ((lastStmt := parseTree statements last) isReturn
- and: [lastStmt expression isVariable
- and: ['self' = lastStmt expression name]]) ifTrue:
- [| tokens |
- tokens := Scanner new scanTokens: (definingClass sourceCodeAt: selector ifAbsent: ['']).
- (tokens size < 2
- or: [(tokens last: 2) ~= #(#'^' 'self')]) ifTrue:
- [parseTree setStatements: parseTree statements allButLast.
- returnType = #sqInt ifTrue:
- [([definingClass implicitReturnTypeFor: selector]
- on: MessageNotUnderstood
- do: [:ex| nil]) ifNotNil:
- [:defaultReturnType|
- returnType := defaultReturnType]]]]!
Item was added:
+ ----- Method: TMethod>>removeFinalSelfReturnIn: (in category 'transformations') -----
+ removeFinalSelfReturnIn: aCodeGenOrNil
+ "The Smalltalk parser automatically adds the statement '^self' to the end of methods
+ without explicit returns. This method removes such statements, since in most VMMaker
+ classes (except struct classes) the generated code has no notion of 'self' anyway.
+ If the statement is removed and no return type has yet been specified and the class
+ specifies a default return type (e.g. #void) for methods that don't return, then set the
+ return type accordingly."
+
+ | lastStmt |
+ parseTree statements isEmpty ifTrue: [^self].
+ ((lastStmt := parseTree statements last) isReturn
+ and: [lastStmt expression isVariable
+ and: ['self' = lastStmt expression name]]) ifTrue:
+ [| tokens |
+ tokens := Scanner new scanTokens: (definingClass sourceCodeAt: selector ifAbsent: ['']).
+ (tokens size < 2
+ or: [(tokens last: 2) ~= #(#'^' 'self')]) ifTrue:
+ [parseTree setStatements: parseTree statements allButLast.
+ (returnType isNil
+ and: [aCodeGenOrNil notNil
+ and: [parseTree noneSatisfy: [:node| node isReturn and: [node expression isVariable not or: [node expression name ~= 'self']]]]]) ifTrue:
+ [self returnType: (aCodeGenOrNil implicitReturnTypeFor: selector)]]]!
Item was changed:
----- Method: TMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initialization') -----
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 long for now"
args := argList asOrderedCollection collect: [:arg | arg key].
locals := (localList collect: [:arg | arg key]) asSet.
declarations := Dictionary new.
self addTypeForSelf.
primitive := aNumber.
properties := methodProperties.
comment := aComment.
parseTree := aBlockNode. "hack; allows nodes to find their parent, etc"
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.
- self removeFinalSelfReturn. "must preceed recordDeclarations because this may set returnType"
- self recordDeclarations.
globalStructureBuildMethodHasFoo := false!
Item was added:
+ ----- Method: TMethod>>transformVoidReturns (in category 'type inference') -----
+ transformVoidReturns
+ "Once the return type has been found or inferred to be #void,
+ any occurrences of ^expr must be replaced with expr. ^self."
+ self assert: returnType == #void.
+ parseTree nodesWithParentsDo:
+ [:node :parent|
+ (node isReturn
+ and: [node expression isVariable not
+ or: [node expression name ~= 'self']]) ifTrue:
+ [parent
+ replaceChild: node
+ with: (TStmtListNode new
+ setArguments: #()
+ statements: {node expression.
+ TReturnNode new
+ setExpression: (TVariableNode new setName: 'self')
+ yourself})]]!
Item was added:
+ ----- Method: TParseNode>>allSatisfy: (in category 'enumerating') -----
+ allSatisfy: aBlock
+ self nodesDo: [:n| (aBlock value: n) ifFalse: [^false]].
+ ^true!
Item was added:
+ ----- Method: TParseNode>>allSatisfy:unless: (in category 'enumerating') -----
+ allSatisfy: aBlock unless: cautionaryBlock
+ self
+ nodesDo: [:n| (aBlock value: n) ifFalse: [^false]]
+ unless: cautionaryBlock.
+ ^true!
Item was added:
+ ----- Method: TStmtListNode>>replaceChild:with: (in category 'transformations') -----
+ replaceChild: aNode with: bNode
+ statements := Array streamContents:
+ [:s|
+ statements do:
+ [:node|
+ node == aNode
+ ifTrue:
+ [bNode isStmtList
+ ifTrue: [s nextPutAll: bNode statements]
+ ifFalse: [s nextPut: bNode]]
+ ifFalse: [s nextPut: node]]]!
Item was changed:
----- Method: UnixVMMaker>>createCodeGenerator (in category 'initialisation') -----
createCodeGenerator
+ ^CCodeGeneratorGlobalStructure new
+ vmMaker: self;
- ^CCodeGeneratorGlobalStructure new initialize;
logger: logger;
yourself!
Item was changed:
----- Method: VMMaker>>createCodeGenerator (in category 'initialize') -----
createCodeGenerator
"set up a CCodeGenerator for this VMMaker"
+ ^CCodeGenerator new
+ vmMaker: self;
- ^CCodeGenerator new initialize
logger: logger;
options: optionsDictionary;
yourself!
Item was changed:
----- Method: VMMaker>>createCogitCodeGenerator (in category 'initialize') -----
createCogitCodeGenerator
+ ^CCodeGenerator new
+ vmMaker: self;
- ^CCodeGenerator new initialize
logger: logger;
options: optionsDictionary;
yourself!
Item was changed:
----- Method: VMMaker>>generateCogitFile (in category 'generate sources') -----
generateCogitFile
"Translate the Smalltalk description of the virtual machine into C. If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. Subclasses can use specialised versions of CCodeGenerator and interpreterClass."
| cg cogitClass |
self interpreterClass needsCogit ifFalse: [^nil].
cg := [self buildCodeGeneratorForCogit]
on: Notification
do: [:ex|
ex tag == #getVMMaker
ifTrue: [ex resume: self]
ifFalse: [(ex respondsTo: #rearmHandlerDuring:)
ifTrue: [ex rearmHandlerDuring: [ex pass]]
ifFalse: [ex pass]]].
self needsToRegenerateCogitFile ifFalse: [^nil].
cogitClass := self cogitClass.
cg removeUnneededBuiltins.
cg vmClass preGenerationHook: cg.
+
+ cg inferTypesForImplicitlyTypedVariablesAndMethods.
+
cg storeCodeOnFile: (self sourceFilePathFor: cogitClass sourceFileName) doInlining: cogitClass doInlining.
cg vmClass additionalHeadersDo:
[:headerName :headerContents| | filePath |
filePath := self coreVMDirectory fullNameFor: headerName.
(cg needToGenerateHeader: headerName file: filePath contents: headerContents) ifTrue:
[cg storeHeaderOnFile: filePath contents: headerContents]].
cogitClass apiExportHeaderName ifNotNil:
[cg storeAPIExportHeader: cogitClass apiExportHeaderName
OnFile: (self sourceFilePathFor: cogitClass apiExportHeaderName)]!
Item was changed:
----- Method: VMMaker>>generateInterpreterFile (in category 'generate sources') -----
generateInterpreterFile
"Translate the Smalltalk description of the virtual machine into C. If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. Subclasses can use specialised versions of CCodeGenerator and interpreterClass."
| cg vmHeaderContents |
cg := [self buildCodeGeneratorForInterpreter]
on: Notification
do: [:ex|
ex tag == #getVMMaker
ifTrue: [ex resume: self]
ifFalse: [(ex respondsTo: #rearmHandlerDuring:)
ifTrue: [ex rearmHandlerDuring: [ex pass]]
ifFalse: [ex pass]]].
self needsToRegenerateInterpreterFile ifFalse: [^nil].
cg removeUnneededBuiltins.
self interpreterClass preGenerationHook: cg.
+ cg inferTypesForImplicitlyTypedVariablesAndMethods.
+
vmHeaderContents := cg vmHeaderContentsWithBytesPerWord: self wordSize.
(cg needToGenerateHeader: self interpreterHeaderName file: self interpreterHeaderPath contents: vmHeaderContents) ifTrue:
[cg storeHeaderOnFile: self interpreterHeaderPath contents: vmHeaderContents].
cg storeCodeOnFile: (self sourceFilePathFor: self interpreterClass sourceFileName) doInlining: self doInlining.
self interpreterClass additionalHeadersDo:
[:headerName :headerContents| | filePath |
filePath := self coreVMDirectory fullNameFor: headerName.
(cg needToGenerateHeader: headerName file: filePath contents: headerContents) ifTrue:
[cg storeHeaderOnFile: filePath contents: headerContents]].
self interpreterClass apiExportHeaderName ifNotNil:
[cg storeAPIExportHeader: self interpreterClass apiExportHeaderName
OnFile: (self sourceFilePathFor: self interpreterClass apiExportHeaderName)].
self gnuifyInterpreterFile!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>atLeastVMProxyMajor:minor: (in category 'C translation') -----
+ atLeastVMProxyMajor: major minor: minor
+ ^String streamContents:
+ [:s|
+ s nextPutAll: 'VM_PROXY_MAJOR > '; print: major;
+ nextPutAll: ' || (VM_PROXY_MAJOR == '; print: major;
+ nextPutAll: ' && VM_PROXY_MINOR >= '; print: minor;
+ nextPutAll: ')']!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>compileToTMethodSelector:in: (in category 'utilities') -----
+ compileToTMethodSelector: selector in: aClass
+ "Compile a method to a TMethod"
+
+ | m |
+ m := (Compiler new
+ parse: (aClass sourceCodeAt: selector)
+ in: aClass
+ notifying: nil)
+ asTranslationMethodOfClass: self translationMethodClass.
+ m inferReturnTypeIn: self.
+ m returnType ifNil:
+ [m returnType: (self implicitReturnTypeFor: selector)].
+ ^m!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>emitIfdefForPluginFunctionOption:on: (in category 'C translation') -----
+ emitIfdefForPluginFunctionOption: anArray on: aStream
+ aStream nextPutAll: '#if '; nextPutAll: (self perform: anArray first withArguments: anArray allButFirst)!
Item was changed:
----- Method: VMPluginCodeGenerator>>generateInterpreterProxyFunctionDeference:on:indent: (in category 'C translation') -----
generateInterpreterProxyFunctionDeference: aNode on: aStream indent: anInteger
| pluginsToClone |
(pluginsToClone := self pluginFunctionsToClone) isEmpty ifTrue:
[^self].
aStream cr; nextPutAll: '#if !!defined(SQUEAK_BUILTIN_PLUGIN)'.
pluginsToClone do:
[:s| | cs |
cs := self cFunctionNameFor: s.
+ self withOptionalVerbiageFor: s
+ on: aStream
+ do: [aStream crtab: anInteger; nextPutAll: cs; nextPutAll: ' = interpreterProxy->'; nextPutAll: cs; nextPut: $;]
+ ifOptionalDo: [aStream crtab: anInteger; nextPutAll: cs; nextPutAll: ' = 0;']].
- aStream crtab: anInteger; nextPutAll: cs; nextPutAll: ' = interpreterProxy->'; nextPutAll: cs; nextPut: $;].
aStream cr; nextPutAll: '#endif /* !!defined(SQUEAK_BUILTIN_PLUGIN) */'.!
Item was changed:
----- Method: VMPluginCodeGenerator>>preDeclareInterpreterProxyOn: (in category 'C code generator') -----
preDeclareInterpreterProxyOn: aStream
"Put the necessary #defines needed before interpreterProxy. Basically
internal plugins use the VM's interpreterProxy variable and external plugins
use their own. Override to keep local copies of all functions in external
prims, and link directly in internal plugins."
"| pcc |
pcc := self new.
(InterpreterProxy selectors reject: [:s| #(initialize private) includes: (InterpreterProxy whichCategoryIncludesSelector: s)]) do:
[:s| pcc noteUsedPluginFunction: s].
pcc preDeclareInterpreterProxyOn: Transcript.
Transcript flush"
| pluginsToClone |
(pluginsToClone := self pluginFunctionsToClone) isEmpty ifTrue:
[^super preDeclareInterpreterProxyOn: aStream].
aStream cr; nextPutAll: '#if !!defined(SQUEAK_BUILTIN_PLUGIN)'; cr.
pluginsToClone do:
[:selector| | functionName |
functionName := self cFunctionNameFor: selector.
aStream nextPutAll:
((String streamContents:
[:s|
(self compileToTMethodSelector: selector in: InterpreterProxy)
emitCFunctionPrototype: s generator: self])
copyReplaceAll: functionName
with: '(*', functionName, ')').
aStream nextPut: $;; cr].
+ aStream nextPutAll: '#else /* !!defined(SQUEAK_BUILTIN_PLUGIN) */'.
- aStream nextPutAll: '#else /* !!defined(SQUEAK_BUILTIN_PLUGIN) */'; cr.
pluginsToClone do:
+ [:selector| | m |
+ m := self compileToTMethodSelector: selector in: InterpreterProxy.
+ self withOptionalVerbiageFor: selector
+ on: aStream
+ do: [aStream cr; nextPutAll: 'extern '.
+ m static: false; emitCFunctionPrototype: aStream generator: self.
+ aStream nextPut: $;]
+ ifOptionalDo:
+ [aStream cr; nextPutAll: '# define '.
+ (TSendNode new
+ setSelector: selector
+ receiver: (TVariableNode new setName: 'interpreterProxy')
+ arguments: (m args collect: [:a| TVariableNode new setName: a]))
+ emitCCodeAsArgumentOn: aStream
+ level: 0
+ generator: self.
+ aStream nextPutAll: ' 0']].
- [:selector|
- aStream nextPutAll: 'extern '.
- (self compileToTMethodSelector: selector in: InterpreterProxy)
- static: false;
- emitCFunctionPrototype: aStream generator: self.
- aStream nextPut: $;; cr].
aStream cr; nextPutAll: 'extern'.
aStream cr; nextPutAll: '#endif'; cr!
Item was added:
+ ----- Method: VMPluginCodeGenerator>>withOptionalVerbiageFor:on:do:ifOptionalDo: (in category 'C translation') -----
+ withOptionalVerbiageFor: selector on: aStream do: mainBlock ifOptionalDo: optionalBlock
+ (InterpreterProxy >> selector pragmaAt: #option:)
+ ifNil:
+ [mainBlock value]
+ ifNotNil:
+ [:pragma|
+ aStream cr.
+ self emitIfdefForPluginFunctionOption: pragma arguments first on: aStream.
+ mainBlock value.
+ aStream cr; nextPutAll: '#else'.
+ optionalBlock value.
+ aStream cr; nextPutAll: '#endif']!
Item was changed:
----- Method: Win32VMMaker>>createCodeGenerator (in category 'initialize') -----
createCodeGenerator
"Set up a CCodeGenerator for this VMMaker - On Windows we use the gcc 2.95.x compiler
which does better without the global struct."
+ ^CCodeGeneratorGlobalStructure new
+ vmMaker: self;
- ^CCodeGeneratorGlobalStructure new initialize;
structDefDefine: '0';
"structDefDefine: 'defined(PPC) || defined(_POWER) || defined(__powerpc__) || defined(__ppc__)';"
logger: logger;
yourself!
More information about the Vm-dev
mailing list