Vm-dev June 2012

vm-dev@lists.squeakfoundation.org

35 participants
74 discussions

VM Maker: VMMaker.oscog-eem.170.mcz
by commits＠source.squeak.org 25 Jun '12

25 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.170.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.170 Author: eem Time: 25 June 2012, 2:10:13.946 pm UUID: e776e9dc-4b1c-4857-b356-91910024d9c8 Ancestors: VMMaker.oscog-eem.169 Fix super expansions of the form e.g. ok := super foo. ... ^ok Parameterise primitive table generastion (for multiple primitive tables). Fix a send of remapOop:in: in the LargeIntegersPlugin. =============== Diff against VMMaker.oscog-eem.169 =============== Item was changed: ----- Method: AssignmentNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') ----- asTranslatorNodeIn: aTMethod "make a CCodeGenerator equivalent of me" + | varNode valueNode | + varNode := variable asTranslatorNodeIn: aTMethod. + valueNode := value asTranslatorNodeIn: aTMethod. + valueNode isStmtList ifFalse: + [^TAssignmentNode new + setVariable: varNode + expression: valueNode; + comment: comment]. + ^TStmtListNode new + setStatements: valueNode statements allButLast, + { TAssignmentNode new + setVariable: varNode + expression: valueNode statements last; + comment: comment }; + yourself! - ^TAssignmentNode new - setVariable: (variable asTranslatorNodeIn: aTMethod) - expression: (value asTranslatorNodeIn: aTMethod); - comment: comment! Item was changed: ----- Method: LargeIntegersPlugin>>digitAddLarge:with: (in category 'oop functions') ----- digitAddLarge: firstInteger with: secondInteger "Does not need to normalize!!" | over firstLen secondLen shortInt shortLen longInt longLen sum newSum resClass | <var: #over type: 'unsigned char '> firstLen := self byteSizeOfBytes: firstInteger. secondLen := self byteSizeOfBytes: secondInteger. resClass := interpreterProxy fetchClassOf: firstInteger. firstLen <= secondLen ifTrue: [shortInt := firstInteger. shortLen := firstLen. longInt := secondInteger. longLen := secondLen] ifFalse: [shortInt := secondInteger. shortLen := secondLen. longInt := firstInteger. longLen := firstLen]. " sum := Integer new: len neg: firstInteger negative." self remapOop: #(shortInt longInt ) in: [sum := interpreterProxy instantiateClass: resClass indexableSize: longLen]. over := self cDigitAdd: (interpreterProxy firstIndexableField: shortInt) len: shortLen with: (interpreterProxy firstIndexableField: longInt) len: longLen into: (interpreterProxy firstIndexableField: sum). over > 0 ifTrue: ["sum := sum growby: 1." + self remapOop: sum in: [newSum := interpreterProxy instantiateClass: resClass indexableSize: longLen + 1]. - interpreterProxy remapOop: sum in: [newSum := interpreterProxy instantiateClass: resClass indexableSize: longLen + 1]. self cBytesCopyFrom: (interpreterProxy firstIndexableField: sum) to: (interpreterProxy firstIndexableField: newSum) len: longLen. sum := newSum. "C index!!" (self cCoerce: (interpreterProxy firstIndexableField: sum) to: 'unsigned char *') at: longLen put: over]. ^ sum! Item was changed: ----- Method: MessageNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') ----- asTranslatorNodeIn: aTMethod "make a CCodeGenerator equivalent of me" "selector is sometimes a Symbol, sometimes a SelectorNode!! On top of this, numArgs is needed due to the (truly grody) use of arguments as a place to store the extra expressions needed to generate code for in-line to:by:do:, etc. see below, where it is used." + | rcvrOrNil sel args | - | rcvrOrNil isReturned sel args | rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod]. (rcvrOrNil notNil and: [rcvrOrNil isVariable and: [rcvrOrNil name = 'super']]) ifTrue: + [^aTMethod superExpansionNodeFor: selector key args: arguments]. - ["hack, hack, hack. should implement parent but that belongs in Compiler-ParseNodes not here" - isReturned := false. - aTMethod parseTree accept: - (ParseNodeEnumerator ofBlock: - [:node| - (node isReturn and: [node expr = self]) ifTrue: - [isReturned := true]]). - ^aTMethod - superExpansionNodeFor: selector key - args: arguments - isReturned: isReturned]. sel := selector isSymbol ifTrue: [selector] ifFalse: [selector key]. (sel = #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block." and: [arguments first isBlockNode]) ifTrue: [| block | ^(block := arguments first asTranslatorNodeIn: aTMethod) statements size = 1 ifTrue: [block statements first] ifFalse: [block]]. args := (1 to: sel numArgs) collect: [:i | (arguments at: i) asTranslatorNodeIn: aTMethod]. (sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]]) ifTrue: ["Restore limit expr that got moved by transformToDo:" args at: 1 put: ((arguments at: 7) value asTranslatorNodeIn: aTMethod)]. (sel = #or: and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: ["Restore argument block that got moved by transformOr:" args at: 1 put: ((arguments at: 2) asTranslatorNodeIn: aTMethod)]. (sel = #ifFalse: and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: ["Restore argument block that got moved by transformIfFalse:" args at: 1 put: ((arguments at: 2) asTranslatorNodeIn: aTMethod)]. ^TSendNode new setSelector: sel receiver: rcvrOrNil arguments: args! Item was changed: ----- Method: StackInterpreter class>>primitiveTableString (in category 'initialization') ----- primitiveTableString "StackInterpreter initializePrimitiveTable primitiveTableString" + ^self primitiveTableStringFor: self primitiveTable! - ^String streamContents: - [:s | - s nextPut: ${. - self primitiveTable withIndexDo: - [:primSpec :index | - s - crtab; - nextPutAll: '/* '; - print: index - 1; - nextPutAll: ' */ '; - nextPutAll: (primSpec isString - ifTrue: [primSpec == #primitiveFail - ifTrue: ['(void (*)(void))0'] - ifFalse: [primSpec]] - ifFalse: ['(void (*)(void))', primSpec printString]); - nextPut: $,]. - s cr; nextPutAll: ' 0 }']! Item was added: + ----- Method: StackInterpreter class>>primitiveTableStringFor: (in category 'initialization') ----- + primitiveTableStringFor: table + "StackInterpreter initializePrimitiveTable primitiveTableString" + ^String streamContents: + [:s | + s nextPut: ${. + table withIndexDo: + [:primSpec :index | + s + crtab; + nextPutAll: '/* '; + print: index - 1; + nextPutAll: ' */ '; + nextPutAll: (primSpec isString + ifTrue: [primSpec == #primitiveFail + ifTrue: ['(void (*)(void))0'] + ifFalse: [primSpec]] + ifFalse: ['(void (*)(void))', primSpec printString]); + nextPut: $,]. + s cr; nextPutAll: ' 0 }']! Item was changed: ----- Method: TMethod>>elideAnyFinalReturn (in category 'transformations') ----- elideAnyFinalReturn + "For super expansions we need to eliminate any final return to prevent premature exit. - "For super exoansions we need to eliminate any final return to prevent premature exit. Anything meaningful in the returned expression must be retained." | stmtList lastStmt | stmtList := parseTree statements asOrderedCollection. (lastStmt := stmtList last) isReturn ifTrue: + [stmtList at: stmtList size put: lastStmt expression. - [lastStmt expression isLeaf - ifTrue: - [stmtList removeLast] - ifFalse: - [stmtList at: stmtList size put: lastStmt expression]. parseTree setStatements: stmtList]! Item was added: + ----- Method: TMethod>>superExpansionNodeFor:args: (in category 'inlining') ----- + superExpansionNodeFor: aSelector args: argumentNodes + "Answer the expansion of a super send. Merge the super expansion's + locals, properties and comment into this method's properties." + (definingClass superclass lookupSelector: aSelector) + ifNil: [self error: 'superclass does not define super method'] + ifNotNil: + [:superMethod| | superTMethod commonVars varMap | + superTMethod := superMethod methodNode asTranslationMethodOfClass: self class. + ((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode]) + and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse: + [self error: definingClass name, '>>',selector, ' args ~= ', + superTMethod definingClass name, '>>', aSelector, + (String with: $. with: Character cr), + 'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.']. + self mergePropertiesOfSuperMethod: superTMethod. + (commonVars := superTMethod allLocals intersection: self allLocals) notEmpty ifTrue: + [varMap := Dictionary new. + commonVars do: + [:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)]. + superTMethod renameVariablesUsing: varMap]. + self assert: (superTMethod allLocals allSatisfy: [:var| (self allLocals includes: var) not]). + locals addAllFirst: superTMethod locals. + superTMethod declarations keysAndValuesDo: + [:var :decl| + self declarationAt: var put: decl]. + superTMethod comment ifNotNil: + [:superComment| + comment := comment + ifNil: [superComment] + ifNotNil: [superComment, comment]]. + superTMethod cascadeVariableNumber ifNotNil: + [:scvn| + cascadeVariableNumber := cascadeVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]]. + superTMethod elideAnyFinalReturn. + ^superTMethod parseTree]! Item was removed: - ----- Method: TMethod>>superExpansionNodeFor:args:isReturned: (in category 'inlining') ----- - superExpansionNodeFor: aSelector args: argumentNodes isReturned: isReturned - "Answer the expansion of a super send. Merge the super expansion's - locals, properties and comment into this method's properties." - (definingClass superclass lookupSelector: aSelector) - ifNil: [self error: 'superclass does not define super method'] - ifNotNil: - [:superMethod| | superTMethod commonVars varMap | - superTMethod := superMethod methodNode asTranslationMethodOfClass: self class. - ((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode]) - and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse: - [self error: definingClass name, '>>',selector, ' args ~= ', - superTMethod definingClass name, '>>', aSelector, - (String with: $. with: Character cr), - 'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.']. - self mergePropertiesOfSuperMethod: superTMethod. - (commonVars := superTMethod allLocals intersection: self allLocals) notEmpty ifTrue: - [varMap := Dictionary new. - commonVars do: - [:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)]. - superTMethod renameVariablesUsing: varMap]. - self assert: (superTMethod allLocals allSatisfy: [:var| (self allLocals includes: var) not]). - locals addAllFirst: superTMethod locals. - superTMethod declarations keysAndValuesDo: - [:var :decl| - self declarationAt: var put: decl]. - superTMethod comment ifNotNil: - [:superComment| - comment := comment - ifNil: [superComment] - ifNotNil: [superComment, comment]]. - superTMethod cascadeVariableNumber ifNotNil: - [:scvn| - cascadeVariableNumber := cascadeVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]]. - isReturned ifFalse: [superTMethod elideAnyFinalReturn]. - ^superTMethod parseTree]!

1 0

VM Maker: VMMaker.oscog-eem.169.mcz
by commits＠source.squeak.org 25 Jun '12

25 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.169.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.169 Author: eem Time: 24 June 2012, 4:41:55.493 pm UUID: 932f0574-1b33-407c-8eb7-130fac92ab8d Ancestors: VMMaker.oscog-eem.168 Add support for in-line literal array constants (currently ByteArray only). gen code of form { static type aLiteralArray = { .... }; var = aLiteralArray; }; for e.g. var = self cCoerce: #[...] to: 'unsigned char *' Add a cutesy development-time MNU for redirecting to cogit and objectMemory if in a doit only. =============== Diff against VMMaker.oscog-eem.168 =============== Item was added: + ----- Method: ByteArray>>coerceTo:sim: (in category '*VMMaker-coercing') ----- + coerceTo: cTypeString sim: interpreterSimulator + ^CLiteralArray on: self! Item was added: + ----- Method: CCodeGenerator>>staticArrayInitializerCalled:for:type: (in category 'utilities') ----- + staticArrayInitializerCalled: varName for: array type: cType + "array is a literal array or a CArray on some array." + | sequence lastLine | + sequence := array isCollection ifTrue: [array] ifFalse: [array object]. + lastLine := 0. + ^String streamContents: + [:s| + s nextPutAll: 'static '; + nextPutAll: cType; + space; + nextPutAll: varName; + nextPutAll: '[] = {'; crtab: 2. + sequence + do: [:element| s nextPutAll: (self cLiteralFor: element)] + separatedBy: + [s nextPut: $,. + (s position - lastLine) > 76 + ifTrue: [s crtab: 2. lastLine := s position] + ifFalse: [s space]]. + s crtab; nextPut: $}; cr]! Item was added: + Object subclass: #CLiteralArray + instanceVariableNames: 'object' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-InterpreterSimulation'! Item was added: + ----- Method: CLiteralArray class>>on: (in category 'instance creation') ----- + on: anArrayLiteral + ^self new setObject: anArrayLiteral; yourself! Item was added: + ----- Method: CLiteralArray>>at: (in category 'accessing') ----- + at: offset + ^object at: offset + 1! Item was added: + ----- Method: CLiteralArray>>at:put: (in category 'accessing') ----- + at: offset put: val + ^object at: offset + 1 put: val! Item was added: + ----- Method: CLiteralArray>>setObject: (in category 'accessing') ----- + setObject: anArrayLiteral + object := anArrayLiteral! Item was changed: ----- Method: CoInterpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator "Override to avoid repeating StackInterpreter's declarations and add our own extensions" | threaded | self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" threaded := aCCodeGenerator vmClass isThreadedVM. aCCodeGenerator addHeaderFile:'"sqCogStackAlignment.h"'; addHeaderFile:'"cogmethod.h"'; addHeaderFile: (threaded ifTrue: ['"cointerpmt.h"'] ifFalse: ['"cointerp.h"']); addHeaderFile:'"cogit.h"'. self declareInterpreterVersionIn: aCCodeGenerator defaultName: (threaded ifTrue: ['Cog MT'] ifFalse: ['Cog']). aCCodeGenerator var: #heapBase declareC: 'static usqInt heapBase'; var: #maxLiteralCountForCompile declareC: 'sqInt maxLiteralCountForCompile = MaxLiteralCountForCompile /* ', MaxLiteralCountForCompile printString, ' */'; var: #minBackwardJumpCountForCompile declareC: 'sqInt minBackwardJumpCountForCompile = MinBackwardJumpCountForCompile /* ', MinBackwardJumpCountForCompile printString, ' */'. aCCodeGenerator var: #reenterInterpreter declareC: 'jmp_buf reenterInterpreter; /* private export */'. aCCodeGenerator var: #statCodeCompactionUsecs type: #usqLong. aCCodeGenerator var: #primTraceLogIndex type: #'unsigned char'; var: #primTraceLog declareC: 'sqInt primTraceLog[256]'; var: #traceLog declareC: 'sqInt traceLog[TraceBufferSize /* ', TraceBufferSize printString, ' */]'; var: #traceSources + declareC: (aCCodeGenerator + staticArrayInitializerCalled: 'traceSources' + for: TraceSources + type: 'char *')! - declareC: (String streamContents: - [:s| - s nextPutAll: 'static char *traceSources[] = {'; crtab: 2. - TraceSources object - do: [:string| s nextPut: $"; nextPutAll: string; nextPut: $"] - separatedBy: [ s crtab: 2; nextPut: $,]. - s crtab; nextPut: $}; cr])! Item was added: + ----- Method: CogVMSimulator>>doesNotUnderstand: (in category 'error handling') ----- + doesNotUnderstand: aMessage + "If this is a doit and the objectMemory understands, pass it on." + (thisContext findContextSuchThat: [:ctxt| ctxt selector == #evaluate:in:to:notifying:ifFail:logged:]) ifNotNil: + [((objectMemory class whichClassIncludesSelector: aMessage selector) inheritsFrom: Object) ifTrue: "i.e. VMClass and below" + [Transcript nextPutAll: 'warning: redirecting to objectMemory'; cr; flush. + aMessage lookupClass: nil. + ^aMessage sentTo: objectMemory]. + ((cogit class whichClassIncludesSelector: aMessage selector) inheritsFrom: Object) ifTrue: "i.e. VMClass and below" + [Transcript nextPutAll: 'warning: redirecting to cogit'; cr; flush. + aMessage lookupClass: nil. + ^aMessage sentTo: cogit]]. + ^super doesNotUnderstand: aMessage! Item was added: + ----- Method: StackInterpreterSimulator>>doesNotUnderstand: (in category 'error handling') ----- + doesNotUnderstand: aMessage + "If this is a doit and the objectMemory understands, pass it on." + (thisContext findContextSuchThat: [:ctxt| ctxt selector == #evaluate:in:to:notifying:ifFail:logged:]) ifNotNil: + [((objectMemory class whichClassIncludesSelector: aMessage selector) inheritsFrom: Object) ifTrue: "i.e. VMClass and below" + [Transcript nextPutAll: 'warning: redirecting to objectMemory'; cr; flush. + aMessage lookupClass: nil. + ^aMessage sentTo: objectMemory]]. + ^super doesNotUnderstand: aMessage! Item was changed: ----- Method: TAssignmentNode>>emitCCodeOn:level:generator: (in category 'C code generation') ----- emitCCodeOn: aStream level: level generator: aCodeGen expression isSwitch ifTrue: [^expression emitCCodeOn: aStream addToEndOfCases: self level: level generator: aCodeGen]. + expression isLiteralArrayDeclaration ifTrue: + [^self emitLiteralArrayDeclarationOn: aStream level: level generator: aCodeGen]. variable emitCCodeOn: aStream level: level generator: aCodeGen. self isVariableUpdatingAssignment ifTrue: [aStream space; nextPutAll: expression selector; "+ or -" nextPut: $=; space. expression args first emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen] ifFalse: [aStream space; nextPut: $=; space. expression emitCCodeAsArgumentOn: aStream level: level generator: aCodeGen]! Item was added: + ----- Method: TAssignmentNode>>emitLiteralArrayDeclarationOn:level:generator: (in category 'C code generation') ----- + emitLiteralArrayDeclarationOn: aStream level: level generator: aCCodeGen + | type | + type := expression args last value. + self assert: type last = $*. + aStream + crtab: level; + nextPutAll: '{ '; + nextPutAll: (aCCodeGen staticArrayInitializerCalled: 'aLiteralArray' for: expression args first value type: type allButLast); + nextPut: $;; + crtab: level + 1; + nextPutAll: variable name; + nextPutAll: ' = aLiteralArray;'; + crtab: level; + nextPut: $}; + cr! Item was added: + ----- Method: TParseNode>>isLiteralArrayDeclaration (in category 'testing') ----- + isLiteralArrayDeclaration + ^false! Item was added: + ----- Method: TSendNode>>isLiteralArrayDeclaration (in category 'testing') ----- + isLiteralArrayDeclaration + ^selector == #cCoerce:to: + and: [arguments first isConstant + and: [arguments first value isLiteral + and: [arguments first value isCollection]]]!

1 0

VM Maker: VMMaker.oscog-eem.168.mcz
by commits＠source.squeak.org 24 Jun '12

24 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.168.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.168 Author: eem Time: 24 June 2012, 12:11:04.735 pm UUID: 9735eb86-c5f3-405e-a4e2-0788c5eca335 Ancestors: VMMaker.oscog-eem.167 Rename metaclassSizeBytes to metaclassSizeBits. Nuke unused shortPrintRelative:. =============== Diff against VMMaker.oscog-eem.167 =============== Item was changed: ----- Method: CoInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory heapSize bytesRead bytesToShift hdrNumStackPages hdrEdenBytes hdrCogCodeSize headerFlags hdrMaxExtSemTabSize | <var: #f type: 'sqImageFile '> <var: #memStart type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> + metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" - metaclassSizeBytes := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. "N.B. not used." hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "This slot holds the size of the native method zone in 1k units. (pad to word boundary)." hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024. cogCodeSize := desiredCogCodeSize ~= 0 ifTrue: [desiredCogCodeSize] ifFalse: [hdrCogCodeSize = 0 ifTrue: [self defaultCogCodeSize] ifFalse: [hdrCogCodeSize]]. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "compare memory requirements with availability" minimumMemory := cogCodeSize "no need to include the stackZone; this is alloca'ed" + dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes. heapSize := cogCodeSize "no need to include the stackZone; this is alloca'ed" + desiredHeapSize "+ edenBytes" "don't include edenBytes; this is part of the heap and so part of desiredHeapSize" + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap and ancilliary data structures" "N.B. If the platform needs to it will redefine this macro to make heapSize an in/out parameter and assign the ammount actually allocated into heapSize. See e.g. platforms/Mac OS/vm/sqPlatformSpecific.h. (I *hate* this. eem 7/23/2009)" "objectMemory memory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)'). " objectMemory memory: (self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize). objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError]. heapBase := objectMemory memory + cogCodeSize. self assert: objectMemory startOfMemory = heapBase. objectMemory setMemoryLimit: objectMemory memory + heapSize - 24. "decrease memoryLimit a tad for safety" objectMemory setEndOfMemory: heapBase + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := self cCode: 'sqImageFileRead(pointerForOop(heapBase), sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. self ensureImageFormatIsUpToDate: swapBytes. "compute difference between old and new memory base addresses" bytesToShift := heapBase - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" self initializeCodeGenerator. ^dataSize! Item was changed: ----- Method: CogVMSimulator>>nameOfClass: (in category 'debug support') ----- nameOfClass: classOop + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [^(self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)) , ' class']. ^self stringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: CogVMSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^' is not on the heap']. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [^' is misaligned']. classOop := objectMemory fetchClassOf: oop. + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [ - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ ^ 'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]! Item was removed: - ----- Method: CogVMSimulator>>shortPrintRelative: (in category 'debug support') ----- - shortPrintRelative: oop - | name classOop | - (objectMemory isIntegerObject: oop) ifTrue: - [^'=' , (objectMemory integerValueOf: oop) printString , - ' (' , (objectMemory integerValueOf: oop) hex , ')']. - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: - [^' is not on the heap']. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [^' is misaligned']. - classOop := objectMemory fetchClassOf: oop. - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ - ^'class ' , (self nameOfClass: oop)]. - name := self nameOfClass: classOop. - name size = 0 ifTrue: [name := '??']. - name = 'String' ifTrue: [^(self stringOf: oop) printString]. - name = 'ByteString' ifTrue: [^(self stringOf: oop) printString]. - name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'Character' ifTrue: [^'=' , (Character value: (objectMemory integerValueOf: - (objectMemory fetchPointer: 0 ofObject: oop))) printString]. - name = 'UndefinedObject' ifTrue: [^'nil']. - name = 'False' ifTrue: [^'false']. - name = 'True' ifTrue: [^'true']. - name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString]. - name = 'Association' ifTrue: - [| valOop | - valOop := self longAt: oop + BaseHeaderSize + BytesPerWord. - ^'(' , - (self shortPrint: (self longAt: oop + BaseHeaderSize)) , - ' -> ' , - ((objectMemory isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - objectMemory startOfMemory]) hex8 , ')']. - ^(('AEIOU' includes: name first) - ifTrue: ['an '] - ifFalse: ['a ']) , name! Item was changed: ObjectMemory subclass: #Interpreter + instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector argumentCount newMethod currentBytecode successFlag primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized extraVMMemory receiverClass interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods profileProcess profileMethod profileSemaphore nextProfileTick metaclassSizeBits statIOProcessEvents statCheckForEvents statQuickCheckForEvents statProcessSwitch statPendingFinalizationSignals gcSemaphoreIndex' - instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector argumentCount newMethod currentBytecode successFlag primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized extraVMMemory receiverClass interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods profileProcess profileMethod profileSemaphore nextProfileTick metaclassSizeBytes statIOProcessEvents statCheckForEvents statQuickCheckForEvents statProcessSwitch statPendingFinalizationSignals gcSemaphoreIndex' classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BlockMethodIndex BytecodeTable CacheProbeMax CallerIndex ClosureMethodIndex CompilerHooksSize CrossedX DirBadPath DirEntryFound DirNoMoreEntries DoBalanceChecks EndOfRun HomeIndex InitialIPIndex JitterTable MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MillisecondClockMask PrimitiveExternalCallIndex PrimitiveTable SemaphoresToSignalSize TempFrameStart' poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices' category: 'VMMaker-Interpreter'! !Interpreter commentStamp: '<historical>' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a copletely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the systemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. ! Item was changed: ----- Method: Interpreter>>initializeInterpreter: (in category 'initialization') ----- initializeInterpreter: bytesToShift "Initialize Interpreter state before starting execution of a new image." interpreterProxy := self sqGetInterpreterProxy. self dummyReferToProxy. self initializeObjectMemory: bytesToShift. self initCompilerHooks. self checkAssumedCompactClasses. + metaclassSizeBits := self sizeBitsOf: (self fetchClassOfNonInt: (self splObj: ClassArray)). "determine actual (Metaclass instSize * 4)" - metaclassSizeBytes := self sizeBitsOf: (self fetchClassOfNonInt: (self splObj: ClassArray)). "determine actual (Metaclass instSize * 4)" activeContext := nilObj. theHomeContext := nilObj. method := nilObj. receiver := nilObj. messageSelector := nilObj. newMethod := nilObj. lkupClass := nilObj. receiverClass := nilObj. self flushMethodCache. self loadInitialContext. self initialCleanup. interruptCheckCounter := 0. interruptCheckCounterFeedBackReset := 1000. interruptChecksEveryNms := 1. nextProfileTick := 0. profileSemaphore := nilObj. profileProcess := nilObj. profileMethod := nilObj. nextPollTick := 0. nextWakeupTick := 0. lastTick := 0. interruptKeycode := 2094. "cmd-. as used for Mac but no other OS" interruptPending := false. semaphoresUseBufferA := true. semaphoresToSignalCountA := 0. semaphoresToSignalCountB := 0. deferDisplayUpdates := false. pendingFinalizationSignals := statPendingFinalizationSignals := 0. globalSessionID := 0. [globalSessionID = 0] whileTrue: [globalSessionID := self cCode: 'time(NULL) + ioMSecs()' inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]]. jmpDepth := 0. jmpMax := MaxJumpBuf. "xxxx: Must match the definition of jmpBuf and suspendedCallbacks" statQuickCheckForEvents := 0. statCheckForEvents := 0. statProcessSwitch := 0. statIOProcessEvents := 0 ! Item was changed: ----- Method: Interpreter>>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." cnt <= 0 ifTrue: [^self print: 'bad class']. + ((self sizeBitsOf: classOop) = metaclassSizeBits + and: [metaclassSizeBits >= (6 * BytesPerWord)]) "(Metaclass instSize * 4)" - ((self sizeBitsOf: classOop) = metaclassSizeBytes - and: [metaclassSizeBytes >= (6 * BytesPerWord)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! Item was changed: ----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize | <var: #f type: 'sqImageFile '> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> + metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" - metaclassSizeBytes := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. specialObjectsOop := self getLongFromFile: f swap: swapBytes. lastHash := self getLongFromFile: f swap: swapBytes. savedWindowSize := self getLongFromFile: f swap: swapBytes. fullScreenFlag := self getLongFromFile: f swap: swapBytes. extraVMMemory := self getLongFromFile: f swap: swapBytes. lastHash = 0 ifTrue: [ "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed" lastHash := 999]. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory := dataSize + 100000. "need at least 100K of breathing room" heapSize < minimumMemory ifTrue: [ self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap" memory := self cCode: 'sqAllocateMemory(minimumMemory, heapSize)'. memory = nil ifTrue: [self insufficientMemoryAvailableError]. memStart := self startOfMemory. self setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety" self setEndOfMemory: memStart + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. swapBytes ifTrue: [self reverseBytesInImage]. "compute difference between old and new memory base addresses" bytesToShift := memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^ dataSize ! Item was removed: - ----- Method: InterpreterSimulator>>shortPrintRelative: (in category 'debug support') ----- - shortPrintRelative: oop - | name classOop | - (self isIntegerObject: oop) ifTrue: - [^'=' , (self integerValueOf: oop) printString , - ' (' , (self integerValueOf: oop) hex , ')']. - (oop between: self startOfMemory and: freeBlock) ifFalse: - [^' is not on the heap']. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [^' is misaligned']. - classOop := self fetchClassOf: oop. - (self sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ - ^'class ' , (self nameOfClass: oop)]. - name := self nameOfClass: classOop. - name size = 0 ifTrue: [name := '??']. - name = 'String' ifTrue: [^(self stringOf: oop) printString]. - name = 'ByteString' ifTrue: [^(self stringOf: oop) printString]. - name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'Character' ifTrue: [^'=' , (Character value: (self integerValueOf: - (self fetchPointer: 0 ofObject: oop))) printString]. - name = 'UndefinedObject' ifTrue: [^'nil']. - name = 'False' ifTrue: [^'false']. - name = 'True' ifTrue: [^'true']. - name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString]. - name = 'Association' ifTrue: - [| valOop | - valOop := self longAt: oop + BaseHeaderSize + BytesPerWord. - ^'(' , - (self shortPrint: (self longAt: oop + BaseHeaderSize)) , - ' -> ' , - ((self isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - self startOfMemory]) hex8 , ')']. - ^(('AEIOU' includes: name first) - ifTrue: ['an '] - ifFalse: ['a ']) , name! Item was changed: ObjectMemory subclass: #NewspeakInterpreter + instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector argumentCount newMethod currentBytecode primFailCode primitiveFunctionPointer inIOProcessEvents methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending gcSemaphoreIndex savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID metaclassSizeBits thisClassIndex classNameIndex statPendingFinalizationSignals breakSelector breakSelectorLength primTraceLog primTraceLogIndex sendTraceLog sendTraceLogIndex' - instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector argumentCount newMethod currentBytecode primFailCode primitiveFunctionPointer inIOProcessEvents methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending gcSemaphoreIndex savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID metaclassSizeBytes thisClassIndex classNameIndex statPendingFinalizationSignals breakSelector breakSelectorLength primTraceLog primTraceLogIndex sendTraceLog sendTraceLogIndex' classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CrossedX DirBadPath DirEntryFound DirNoMoreEntries EnclosingMixinIndex EnclosingObjectIndex EndOfRun FailImbalancedPrimitives HomeIndex InitialIPIndex MaxExternalPrimitiveTableSize MaxPrimitiveIndex MaxQuickPrimitiveIndex MessageDictionaryIndex MillisecondClockMask MixinIndex MixinNameIndex PrimitiveExternalCallIndex PrimitiveTable RecordPrimTrace RecordSendTrace TempFrameStart TraceLogSize' poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices' category: 'VMMaker-Interpreter'! !NewspeakInterpreter commentStamp: 'tpr 4/3/2006 12:46' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. The latest version has been extend to support 64 bit systems in at least a basic manner - it is possible to create a 64 bit image via a special SystemTracer - and much of the core code has been cleaned up so that it works whether the C compiler thinks integers are 32 or 64 bit in size. There is still some cleanup required. In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a copletely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the systemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. ! Item was changed: ----- Method: NewspeakInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices + "Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and - "Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classNameIndex := 6. "default" thisClassIndex := 5. "default" classArrayObj := self splObj: ClassArray. classArrayClass := self fetchClassOfNonInt: classArrayObj. + metaclassSizeBits := self sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" - metaclassSizeBytes := self sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayClass) do: [:i| (self fetchPointer: i ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i]]. InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayObj) do: [:i| | oop | oop := self fetchPointer: i ofObject: classArrayObj. ((self isBytes: oop) and: [(self lengthOf: oop) = 5 and: [(self str: 'Array' n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i]]! Item was changed: ----- Method: NewspeakInterpreter>>lengthOfNameOfClass: (in category 'debug printing') ----- lengthOfNameOfClass: classOop <inline: false> + (self sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (self sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [^self lengthOfNameOfClass: (self fetchPointer: thisClassIndex ofObject: classOop)]. ^self lengthOf: (self fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: NewspeakInterpreter>>nameOfClass: (in category 'debug printing') ----- nameOfClass: classOop "Brain-damaged nameOfClass: for C VM. Does *not* answer Foo class for metaclasses. Use e.g. classIsMeta: to avoid being fooled." <inline: false> <returnTypeC: 'char *'> + (self sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (self sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [^self nameOfClass: (self fetchPointer: thisClassIndex ofObject: classOop)]. ^self firstFixedField: (self fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: NewspeakInterpreter>>printNameOfClass:count: (in category 'debug printing') ----- printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." <inline: false> (classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class']. + ((self sizeBitsOf: classOop) = metaclassSizeBits + and: [metaclassSizeBits > (thisClassIndex * BytesPerWord)]) "(Metaclass instSize * 4)" - ((self sizeBitsOf: classOop) = metaclassSizeBytes - and: [metaclassSizeBytes > (thisClassIndex * BytesPerWord)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (self fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (self fetchPointer: classNameIndex ofObject: classOop)]! Item was changed: ----- Method: NewspeakInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> self printChar: $=. (self isIntegerObject: oop) ifTrue: [self printNum: (self integerValueOf: oop); printChar: $(; printHex: (self integerValueOf: oop); printChar: $). ^nil]. (oop between: self startOfMemory and: freeBlock) ifFalse: [self printHex: oop; print: ' is not on the heap'. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'. ^nil]. (self isFloatObject: oop) ifTrue: [self printFloat: (self dbgFloatValueOf: oop). ^nil]. classOop := self fetchClassOf: oop. + (self sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (self sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [self printNameOfClass: oop count: 5. ^nil]. oop = self nilObject ifTrue: [self print: 'nil'. ^nil]. oop = self trueObject ifTrue: [self print: 'true'. ^nil]. oop = self falseObject ifTrue: [self print: 'false'. ^nil]. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [self print: 'a ??'. ^nil]. name := self nameOfClass: classOop. nameLen = 10 ifTrue: [(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $"; printStringOf: oop; printChar: $". ^nil]. (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^nil]]. (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue: [self printChar: $$; printChar: (self integerValueOf: (self fetchPointer: 0 ofObject: oop)). ^nil]. self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name] inSmalltalk: [self print: 'a(n) '; print: name]! Item was changed: ----- Method: NewspeakInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize | <var: #f type: 'sqImageFile '> <var: #memStart type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> + metaclassSizeBits := 7 * BytesPerWord. "guess (Metaclass instSize+1 * 4)" - metaclassSizeBytes := 7 * BytesPerWord. "guess (Metaclass instSize+1 * 4)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. specialObjectsOop := self getLongFromFile: f swap: swapBytes. lastHash := self getLongFromFile: f swap: swapBytes. savedWindowSize := self getLongFromFile: f swap: swapBytes. fullScreenFlag := self getLongFromFile: f swap: swapBytes. extraVMMemory := self getLongFromFile: f swap: swapBytes. lastHash = 0 ifTrue: [ "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed" lastHash := 999]. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory := dataSize + 100000. "need at least 100K of breathing room" heapSize < minimumMemory ifTrue: [ self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap" memory := self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize. memory = nil ifTrue: [self insufficientMemoryAvailableError]. memStart := self startOfMemory. memoryLimit := (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety" endOfMemory := memStart + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. swapBytes ifTrue: [self reverseBytesInImage]. "compute difference between old and new memory base addresses" bytesToShift := memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^dataSize! Item was removed: - ----- Method: NewspeakInterpreterSimulator>>shortPrintRelative: (in category 'debug support') ----- - shortPrintRelative: oop - | name classOop | - (self isIntegerObject: oop) ifTrue: - [^'=' , (self integerValueOf: oop) printString , - ' (' , (self integerValueOf: oop) hex , ')']. - (oop between: self startOfMemory and: freeBlock) ifFalse: - [^' is not on the heap']. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [^' is misaligned']. - classOop := self fetchClassOf: oop. - (self sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ - ^'class ' , (self nameOfClass: oop)]. - name := self nameOfClass: classOop. - name size = 0 ifTrue: [name := '??']. - name = 'String' ifTrue: [^(self stringOf: oop) printString]. - name = 'ByteString' ifTrue: [^(self stringOf: oop) printString]. - name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'Character' ifTrue: [^'=' , (Character value: (self integerValueOf: - (self fetchPointer: 0 ofObject: oop))) printString]. - name = 'UndefinedObject' ifTrue: [^'nil']. - name = 'False' ifTrue: [^'false']. - name = 'True' ifTrue: [^'true']. - name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString]. - name = 'Association' ifTrue: - [| valOop | - valOop := self longAt: oop + BaseHeaderSize + BytesPerWord. - ^'(' , - (self shortPrint: (self longAt: oop + BaseHeaderSize)) , - ' -> ' , - ((self isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - self startOfMemory]) hex8 , ')']. - ^(('AEIOU' includes: name first) - ifTrue: ['an '] - ifFalse: ['a ']) , name! Item was changed: InterpreterPrimitives subclass: #StackInterpreter + instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBits interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex' - instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBytes interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex' classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BytecodeTable CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MaxQuickPrimitiveIndex MixinIndex PrimitiveExternalCallIndex PrimitiveTable' poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets' category: 'VMMaker-Interpreter'! !StackInterpreter commentStamp: '<historical>' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. This VM supports Closures but *not* old-style BlockContexts. It has been modernized with 32-bit pointers, better management of Contexts (see next item), and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. The VM does not use Contexts directly. Instead Contexts serve as proxies for a more conventional stack format that is invisible to the image. There is considerable explanation at http://www.mirandabanda.org/cogblog/2009/01/14/under-cover-contexts-and-the…. The VM maintains a fixed-size stack zone divided into pages, each page being capable of holding several method/block activations. A send establishes a new frame in the current stack page, a return returns to the previous frame. This eliminates allocation/deallocation of contexts and the moving of receiver and arguments from caller to callee on each send/return. Contexts are created lazily when an activation needs a context (creating a block, explicit use of thisContext, access to sender when sender is a frame, or linking of stack pages together). Contexts are either conventional and heap-resident ("single") or "married" and serve as proxies for their corresponding frame or "widowed", meaning that their spouse frame has been returned from (died). A married context is specially marked (more details in the code) and refers to its frame. Likewise a married frame is specially marked and refers to its context. In addition to SmallInteger arithmetic and Floats, the VM supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a completely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the SystemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. 5. Moving to a 2 bit immediate tag and having immediate Characters is a good choice for Unicode and the JIT 6. If Eliot Miranda's 2 word header scheme is acceptable in terms of footprint (we estimate about a 10% increase in image size with about 35 reclaimed by better representation of CompiledMethod - loss of MethodProperties) then the in-line cache for the JIT is simplified, class access is faster and header access is the same in 32-bit and full 64-bit images.! Item was changed: ----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices + "Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and - "Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classArrayObj := objectMemory splObj: ClassArray. classArrayClass := objectMemory fetchClassOfNonInt: classArrayObj. + metaclassSizeBits := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" - metaclassSizeBytes := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" thisClassIndex := 5. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do: [:i| (objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i - 1]]. classNameIndex := 6. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do: [:i| | oop | oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj. ((objectMemory isBytes: oop) and: [(objectMemory lengthOf: oop) = 5 and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i - 1]]! Item was changed: ----- Method: StackInterpreter>>lengthOfNameOfClass: (in category 'debug printing') ----- lengthOfNameOfClass: classOop <inline: false> + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [^self lengthOfNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)]. ^objectMemory lengthOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreter>>nameOfClass: (in category 'debug printing') ----- nameOfClass: classOop "Brain-damaged nameOfClass: for C VM. Does *not* answer Foo class for metaclasses. Use e.g. classIsMeta: to avoid being fooled." <inline: false> <returnTypeC: 'char *'> + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [^self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)]. ^objectMemory firstFixedField: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') ----- printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." <inline: false> (classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class']. + ((objectMemory sizeBitsOf: classOop) = metaclassSizeBits + and: [metaclassSizeBits > (thisClassIndex * BytesPerWord)]) "(Metaclass instSize * 4)" - ((objectMemory sizeBitsOf: classOop) = metaclassSizeBytes - and: [metaclassSizeBytes > (thisClassIndex * BytesPerWord)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]! Item was changed: ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> (objectMemory isIntegerObject: oop) ifTrue: [self printNum: (objectMemory integerValueOf: oop); printChar: $(; printHex: (objectMemory integerValueOf: oop); printChar: $). ^nil]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'. ^nil]. (self isFloatObject: oop) ifTrue: [self printFloat: (self dbgFloatValueOf: oop). ^nil]. classOop := objectMemory fetchClassOfNonInt: oop. (objectMemory addressCouldBeObj: classOop) ifFalse: [self print: 'a ??'. ^nil]. + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [self printNameOfClass: oop count: 5. ^nil]. oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil]. oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil]. oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil]. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [self print: 'a ??'. ^nil]. name := self nameOfClass: classOop. nameLen = 10 ifTrue: [(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $'; printStringOf: oop; printChar: $'. ^nil]. (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^nil]]. (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue: [self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)). ^nil]. self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name] inSmalltalk: [self print: 'a(n) '; print: name]. "Try to spot association-like things; they're all subclasses of LookupKey" ((objectMemory instanceSizeOf: classOop) = (ValueIndex + 1) and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonInt: (objectMemory splObj: SchedulerAssociation))) and: [self isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop)]]) ifTrue: [self space; printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop); print: ' -> '; printHex: (objectMemory fetchPointer: ValueIndex ofObject: oop)]! Item was changed: ----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages minimumMemory memStart bytesRead bytesToShift heapSize hdrEdenBytes headerFlags hdrMaxExtSemTabSize | <var: #f type: 'sqImageFile '> <var: #memStart type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> + metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" - metaclassSizeBytes := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to images run on Cog." theUnknownShort := self getShortFromFile: f swap: swapBytes. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory := dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap" objectMemory memory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)'). objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError]. memStart := objectMemory startOfMemory. objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety" objectMemory setEndOfMemory: memStart + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. self ensureImageFormatIsUpToDate: swapBytes. "compute difference between old and new memory base addresses" bytesToShift := memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^dataSize ! Item was changed: ----- Method: StackInterpreterSimulator>>nameOfClass: (in category 'debug support') ----- nameOfClass: classOop + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [^(self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)) , ' class']. ^self stringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^' is not on the heap']. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [^' is misaligned']. classOop := objectMemory fetchClassOf: oop. + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [ - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ ^ 'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]! Item was removed: - ----- Method: StackInterpreterSimulator>>shortPrintRelative: (in category 'debug support') ----- - shortPrintRelative: oop - | name classOop | - (objectMemory isIntegerObject: oop) ifTrue: - [^'=' , (objectMemory integerValueOf: oop) printString , - ' (' , (objectMemory integerValueOf: oop) hex , ')']. - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: - [^' is not on the heap']. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [^' is misaligned']. - classOop := objectMemory fetchClassOfNonInt: oop. - (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ - ^'class ' , (self nameOfClass: oop)]. - name := self nameOfClass: classOop. - name size = 0 ifTrue: [name := '??']. - name = 'String' ifTrue: [^(self stringOf: oop) printString]. - name = 'ByteString' ifTrue: [^(self stringOf: oop) printString]. - name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)]. - name = 'Character' ifTrue: [^'=' , (Character value: (objectMemory integerValueOf: - (objectMemory fetchPointer: 0 ofObject: oop))) printString]. - name = 'UndefinedObject' ifTrue: [^'nil']. - name = 'False' ifTrue: [^'false']. - name = 'True' ifTrue: [^'true']. - name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString]. - name = 'Association' ifTrue: - [| valOop | - valOop := self longAt: oop + BaseHeaderSize + BytesPerWord. - ^'(' , - (self shortPrint: (self longAt: oop + BaseHeaderSize)) , - ' -> ' , - ((objectMemory isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - objectMemory startOfMemory]) hex8 , ')']. - ^(('AEIOU' includes: name first) - ifTrue: ['an '] - ifFalse: ['a ']) , name!

1 0

VM Maker: VMMaker.oscog-eem.167.mcz
by commits＠source.squeak.org 24 Jun '12

24 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.167.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.167 Author: eem Time: 23 June 2012, 7:36:44.881 pm UUID: 89fa3b26-2b31-41ee-861c-68062ff3e443 Ancestors: VMMaker.oscog-eem.166 Fix but in changeClassFrom:to: if receiver is a compact class instance with a large header. Restore ye olde object printing style. Use bitClear: instead of wrong-for-64-bits bitInvert32 to clear several bit fields. =============== Diff against VMMaker.oscog-eem.166 =============== Item was changed: ----- Method: CoInterpreter>>getImageHeaderFlags (in category 'image save/restore') ----- getImageHeaderFlags "Answer the flags that are contained in the 7th long of the image header." ^fullScreenFlag "0 or 1" + (VMBIGENDIAN ifTrue: [0] ifFalse: [2]) "this is the imageFloatsLittleEndian flag" + (processHasThreadId ifTrue: [4] ifFalse: [0]) + (flagInterpretedMethods ifTrue: [8] ifFalse: [0]) + (preemptionYields ifTrue: [0] ifFalse: [16]) + (noThreadingOfGUIThread ifTrue: [32] ifFalse: [0]) + + (imageHeaderFlags bitClear: 63) "these are any flags we do not recognize"! - + (imageHeaderFlags bitAnd: 63 bitInvert32) "these are any flags we do not recognize"! Item was changed: ----- Method: Cogit>>alignUptoRoutineBoundary: (in category 'generate machine code') ----- alignUptoRoutineBoundary: anAddress + ^anAddress + 7 bitClear: 7! - ^anAddress + 7 bitAnd: 7 bitInvert32! Item was changed: ----- Method: Cogit>>generateMapAt:start: (in category 'method map') ----- generateMapAt: addressOrNull start: startAddress "Generate the method map at addressrNull (or compute it if adressOrNull is null). Answer the length of the map in byes. Each entry in the map is in two parts. In the least signficant bits are a displacement of how far from the start or previous entry. In the most signficant bits are the type of annotation at the point reached. A null byte ends the map." | length location | <var: #annotation type: #'InstructionAnnotation *'> length := 0. location := startAddress. 0 to: annotationIndex - 1 do: [:i| | annotation mcpc delta maxDelta mapEntry | annotation := self addressOf: (annotations at: i). mcpc := annotation instruction address + annotation instruction machineCodeSize. [(delta := mcpc - location) > MaxUnitDisplacement] whileTrue: + [maxDelta := (delta min: MaxX2NDisplacement) bitClear: DisplacementMask. - [maxDelta := (delta min: MaxX2NDisplacement) bitAnd: DisplacementMask bitInvert32. self assert: maxDelta >> AnnotationShift <= DisplacementMask. addressOrNull ~= 0 ifTrue: [objectMemory byteAt: addressOrNull - length put: maxDelta >> AnnotationShift + DisplacementX2N. self traceMap: IsDisplacementX2N byte: maxDelta >> AnnotationShift + DisplacementX2N at: addressOrNull - length for: mcpc]. location := location + maxDelta. length := length + 1]. addressOrNull ~= 0 ifTrue: [mapEntry := delta + (annotation annotation << AnnotationShift). objectMemory byteAt: addressOrNull - length put: mapEntry. self traceMap: annotation byte: mapEntry at: addressOrNull - length for: mcpc]. location := location + delta. length := length + 1]. addressOrNull ~= 0 ifTrue: [objectMemory byteAt: addressOrNull - length put: MapEnd. self traceMap: MapEnd byte: MapEnd at: addressOrNull - length for: 0]. ^length + 1! Item was changed: ----- Method: NewObjectMemory>>sufficientSpaceToAllocate: (in category 'allocation') ----- sufficientSpaceToAllocate: bytes "Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection." | minFree | <inline: true> + minFree := (lowSpaceThreshold + bytes + BaseHeaderSize + BytesPerWord - 1) bitClear: BytesPerWord - 1. - minFree := (lowSpaceThreshold + bytes + BaseHeaderSize + BytesPerWord - 1) bitAnd: (BytesPerWord - 1) bitInvert32. "check for low-space" (self oop: freeStart + minFree isLessThanOrEqualTo: reserveStart) ifTrue: [^true]. ^self sufficientSpaceAfterGC: minFree! Item was changed: ----- Method: ObjectMemory>>changeClassOf:to: (in category 'interpreter access') ----- changeClassOf: rcvr to: argClass "Attempt to change the class of the receiver into the class of the the argument given that the format of the receiver matches the format of the argument. If successful answer 0, otherwise answer an error code indicating the reason for failure. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have." | classHdr sizeHiBits byteSize argFormat rcvrFormat rcvrHdr ccIndex | "Check what the format of the class says" classHdr := self formatOfClass: argClass. "Low 2 bits are 0" "Compute the size of instances of the class (used for fixed field classes only)" sizeHiBits := (classHdr bitAnd: 16r60000) >> 9. classHdr := classHdr bitAnd: 16r1FFFF. byteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0" "Check the receiver's format against that of the class" argFormat := self formatOfHeader: classHdr. rcvrHdr := self baseHeader: rcvr. rcvrFormat := self formatOfHeader: rcvrHdr. "If the receiver is a byte object we need to clear the number of odd bytes from the format." rcvrFormat > 8 ifTrue: [rcvrFormat := rcvrFormat bitAnd: 16rC]. argFormat = rcvrFormat ifFalse: [^PrimErrInappropriate]. "no way" "For fixed field classes, the sizes must match. Note: byteSize-4 because base header is included in class size." argFormat < 2 ifTrue: [(byteSize - BaseHeaderSize) ~= (self byteSizeOf: rcvr) ifTrue: [^PrimErrBadReceiver]] ifFalse: [argFormat = 3 ifTrue: "For indexable plus fixed fields the receiver must be at least big enough." [(byteSize - BaseHeaderSize) > (self byteSizeOf: rcvr) ifTrue: [^PrimErrBadReceiver]]]. (self headerTypeOfHeader: rcvrHdr) = HeaderTypeShort ifTrue: "Compact classes. Check if the arg's class is compact and exchange ccIndex" [ccIndex := classHdr bitAnd: CompactClassMask. ccIndex = 0 ifTrue: [^PrimErrInappropriate]. "class is not compact" self cppIf: IMMUTABILITY ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue: [^PrimErrNoModification]]. + self baseHeader: rcvr + put: (((self longAt: rcvr) bitClear: CompactClassMask) bitOr: ccIndex)] - self longAt: rcvr put: - (((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32) bitOr: ccIndex)] ifFalse: "Exchange the class pointer, which could make rcvr a root for argClass" [self cppIf: IMMUTABILITY ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue: [^PrimErrNoModification]]. + (self compactClassIndexOf: rcvr) ~= 0 ifTrue: + [self baseHeader: rcvr + put: ((self baseHeader: rcvr) bitClear: CompactClassMask)]. self longAt: rcvr-BaseHeaderSize put: (argClass bitOr: (self headerType: rcvr)). (self oop: rcvr isLessThan: youngStart) ifTrue: [self possibleRootStoreInto: rcvr value: argClass]]. "ok" ^0! Item was changed: ----- Method: ObjectMemory>>setHashBitsOf:to: (in category 'header access') ----- setHashBitsOf: oop to: hash self longAt: oop + put: (((self baseHeader: oop) bitClear: HashBits) - put: (((self baseHeader: oop) bitAnd: HashBits bitInvert32) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset)! Item was changed: ----- Method: ObjectMemory>>sufficientSpaceToAllocate: (in category 'allocation') ----- sufficientSpaceToAllocate: bytes "Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection." | minFree | <inline: true> + minFree := (lowSpaceThreshold + bytes + BaseHeaderSize + BytesPerWord - 1) bitClear: BytesPerWord - 1. - minFree := (lowSpaceThreshold + bytes + BaseHeaderSize + BytesPerWord - 1) bitAnd: (BytesPerWord - 1) bitInvert32. "check for low-space" (self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFree) ifTrue: [^true] ifFalse: [^self sufficientSpaceAfterGC: minFree].! Item was changed: ----- Method: StackInterpreter>>elementsPerPrintOopLine (in category 'debug printing') ----- elementsPerPrintOopLine ^5! Item was changed: ----- Method: StackInterpreter>>getImageHeaderFlags (in category 'image save/restore') ----- getImageHeaderFlags "Answer the flags that are contained in the 7th long of the image header." ^fullScreenFlag "0 or 1" + (VMBIGENDIAN ifTrue: [0] ifFalse: [2]) "this is the imageFloatsLittleEndian flag" + + (preemptionYields ifTrue: [0] ifFalse: [16r10]) + + (imageHeaderFlags bitClear: 16r13) "these are any flags we do not recognize"! - + (preemptionYields ifTrue: [0] ifFalse: [16]) - + (imageHeaderFlags bitAnd: 19 bitInvert32) "these are any flags we do not recognize"! Item was changed: ----- Method: StackInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop + | cls fmt lastIndex startIP bytecodesPerLine | - | cls fmt lastIndex startIP bytecodesPerLine column | <inline: false> self printHex: oop. (objectMemory isIntegerObject: oop) ifTrue: [^self cCode: 'printf("=%ld\n", integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'; cr. ^nil]. (objectMemory isFreeObject: oop) ifTrue: [self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr. ^nil]. - " self print: ': a(n) '. - " self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5. cls = (objectMemory splObj: ClassFloat) ifTrue: [self cr; printFloat: (self dbgFloatValueOf: oop); cr. ^nil]. fmt := objectMemory formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)]. self cr. (fmt > 4 and: [fmt < 12]) ifTrue: ["This will answer false if splObj: ClassAlien is nilObject" (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue: [self print: ' datasize '; printNum: (self sizeOfAlienData: oop). self print: ((self isIndirectAlien: oop) ifTrue: [' indirect @ '] ifFalse: [(self isPointerAlien: oop) ifTrue: [' pointer @ '] ifFalse: [' direct @ ']]). self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr. ^nil]. (objectMemory isWords: oop) ifTrue: [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop). (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. ^nil]. ^self printStringOf: oop; cr]. lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')' inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space. self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))]. (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: [startIP := startIP * BytesPerWord + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. + bytecodesPerLine := 10. - bytecodesPerLine := 8. - column := 1. startIP to: lastIndex do: [:index| | byte | - (column = 1) ifTrue:[ - self cCode: 'printf("%08x: ", oop+index-1)' - inSmalltalk: [self print: (oop+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]. + ((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue: + [self cr]]. + ((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse: - column := column + 1. - (column > bytecodesPerLine) ifTrue: - [column := 1. self cr]]. - (column = 1) ifFalse: [self cr]]! Item was changed: ----- Method: ThreadedFFIPlugin>>ffiCall:ArgArrayOrNil:NumArgs: (in category 'callout support') ----- ffiCall: externalFunction ArgArrayOrNil: argArrayOrNil NumArgs: nArgs "Generic callout. Does the actual work. If argArrayOrNil is nil it takes args from the stack and the spec from the method. If argArrayOrNil is not nil takes args from argArrayOrNil and the spec from the receiver." | flags argTypeArray address argType oop argSpec argClass err theCalloutState calloutState requiredStackSize stackSize allocation result | <inline: true> <var: #theCalloutState type: #'CalloutState'> <var: #calloutState type: #'CalloutState *'> <var: #allocation type: #'char *'> (interpreterProxy is: externalFunction KindOfClass: interpreterProxy classExternalFunction) ifFalse: [^self ffiFail: FFIErrorNotFunction]. "Load and check the values in the externalFunction before we call out" flags := interpreterProxy fetchInteger: ExternalFunctionFlagsIndex ofObject: externalFunction. interpreterProxy failed ifTrue: [^self ffiFail: FFIErrorBadArgs]. "This must come early for compatibility with the old FFIPlugin. Image-level code may assume the function pointer is loaded eagerly. Thanks to Nicolas Cellier." address := self ffiLoadCalloutAddress: externalFunction. interpreterProxy failed ifTrue: [^0 "error code already set by ffiLoadCalloutAddress:"]. argTypeArray := interpreterProxy fetchPointer: ExternalFunctionArgTypesIndex ofObject: externalFunction. "must be array of arg types" ((interpreterProxy isArray: argTypeArray) and: [(interpreterProxy slotSizeOf: argTypeArray) = (nArgs + 1)]) ifFalse: [^self ffiFail: FFIErrorBadArgs]. "check if the calling convention is supported" self cppIf: COGMTVM ifTrue: [(self ffiSupportsCallingConvention: (flags bitAnd: FFICallTypesMask)) ifFalse: [^self ffiFail: FFIErrorCallType]] ifFalse: "not masking causes threaded calls to fail, which is as they should if the plugin is not threaded." [(self ffiSupportsCallingConvention: flags) ifFalse: [^self ffiFail: FFIErrorCallType]]. requiredStackSize := self externalFunctionHasStackSizeSlot ifTrue: [interpreterProxy fetchInteger: ExternalFunctionStackSizeIndex ofObject: externalFunction] ifFalse: [-1]. interpreterProxy failed ifTrue: [^interpreterProxy primitiveFailFor: (argArrayOrNil isNil ifTrue: [PrimErrBadMethod] ifFalse: [PrimErrBadReceiver])]. stackSize := requiredStackSize < 0 ifTrue: [DefaultMaxStackSize] ifFalse: [requiredStackSize]. self cCode: [] inSmalltalk: [theCalloutState := self class calloutStateClass new]. calloutState := self addressOf: theCalloutState. self cCode: [self me: calloutState ms: 0 et: (self sizeof: #CalloutState asSymbol)]. calloutState callFlags: flags. "Fetch return type and args" argType := interpreterProxy fetchPointer: 0 ofObject: argTypeArray. argSpec := interpreterProxy fetchPointer: 0 ofObject: argType. argClass := interpreterProxy fetchPointer: 1 ofObject: argType. (err := self ffiCheckReturn: argSpec With: argClass in: calloutState) ~= 0 ifTrue: [^self ffiFail: err]. "cannot return" "alloca the outgoing stack frame, leaving room for register args while marshalling, and including space for the return struct, if any." allocation := self alloca: stackSize + calloutState structReturnSize + self registerArgsSlop + self cStackAlignment. self allocaLiesSoUseGetsp ifTrue: [allocation := self getsp]. self cStackAlignment ~= 0 ifTrue: + [allocation := self cCoerce: (allocation asUnsignedInteger bitClear: self cStackAlignment - 1) - [allocation := self cCoerce: (allocation asUnsignedInteger bitAnd: (self cStackAlignment - 1) bitInvert32) to: #'char *']. calloutState argVector: allocation; currentArg: allocation + self registerArgsSlop; limit: allocation + stackSize + self registerArgsSlop. (calloutState structReturnSize > 0 and: [self nonRegisterStructReturnIsViaImplicitFirstArgument and: [(self returnStructInRegisters: calloutState structReturnSize) not]]) ifTrue: [self ffiPushPointer: calloutState limit in: calloutState]. 1 to: nArgs do: [:i| argType := interpreterProxy fetchPointer: i ofObject: argTypeArray. argSpec := interpreterProxy fetchPointer: 0 ofObject: argType. argClass := interpreterProxy fetchPointer: 1 ofObject: argType. oop := argArrayOrNil isNil ifTrue: [interpreterProxy stackValue: nArgs - i] ifFalse: [interpreterProxy fetchPointer: i - 1 ofObject: argArrayOrNil]. err := self ffiArgument: oop Spec: argSpec Class: argClass in: calloutState. err ~= 0 ifTrue: [self cleanupCalloutState: calloutState. self cppIf: COGMTVM ifTrue: [err = PrimErrObjectMayMove negated ifTrue: [^PrimErrObjectMayMove]]. "N.B. Do not fail if object may move because caller will GC and retry." ^self ffiFail: err]]. "coercion failed or out of stack space" "Failures must be reported back from ffiArgument:Spec:Class:in:. Should not fail from here on in." self assert: interpreterProxy failed not. self ffiLogCallout: externalFunction. (requiredStackSize < 0 and: [self externalFunctionHasStackSizeSlot]) ifTrue: [stackSize := calloutState currentArg - calloutState argVector. interpreterProxy storeInteger: ExternalFunctionStackSizeIndex ofObject: externalFunction withValue: stackSize]. "Go out and call this guy" result := self ffiCalloutTo: address SpecOnStack: argArrayOrNil notNil in: calloutState. self cleanupCalloutState: calloutState. ^result! Item was changed: ----- Method: ThreadedIA32FFIPlugin>>ffiPushStructure:ofSize:typeSpec:ofLength:in: (in category 'marshalling') ----- ffiPushStructure: pointer ofSize: structSize typeSpec: argSpec ofLength: argSpecSize in: calloutState <var: #pointer type: #'void *'> <var: #argSpec type: #'sqInt *'> <var: #calloutState type: #'CalloutState *'> <inline: true> | roundedSize | + roundedSize := structSize + 3 bitClear: 3. - roundedSize := structSize + 3 bitAnd: 3 bitInvert32. calloutState currentArg + roundedSize > calloutState limit ifTrue: [^FFIErrorCallFrameTooBig]. self mem: calloutState currentArg cp: pointer y: structSize. calloutState currentArg: calloutState currentArg + roundedSize. ^0!

1 0

VM Maker: VMMaker.oscog-eem.166.mcz
by commits＠source.squeak.org 24 Jun '12

24 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.166.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.166 Author: eem Time: 23 June 2012, 5:15:11.135 pm UUID: 3cf5bdaf-bad3-46dd-9836-33e806128aa1 Ancestors: VMMaker.oscog-eem.165 Nuke bogus strlen: siumulations. The one in VMClass is the true one. =============== Diff against VMMaker.oscog-eem.165 =============== Item was removed: - ----- Method: CogVMSimulator>>strlen: (in category 'debug printing') ----- - strlen: aString - ^aString size! Item was removed: - ----- Method: NewCoObjectMemorySimulator>>strlen: (in category 'debug printing') ----- - strlen: aString - ^aString size! Item was removed: - ----- Method: StackInterpreterSimulator>>strlen: (in category 'debug printing') ----- - strlen: aString - ^aString size!

1 0

VM Maker: VMMaker.oscog-eem.165.mcz
by commits＠source.squeak.org 23 Jun '12

23 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.165.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.165 Author: eem Time: 23 June 2012, 2:18:33.789 pm UUID: 4e4f16aa-51e6-4806-8764-613b5d38d7df Ancestors: VMMaker.oscog-eem.164 Nuke tempCountOfMethodHeader: in favour of temporaryCountOfMethodHeader:. Refactor frame marriage to allow subclasses to specify saving of temps. =============== Diff against VMMaker.oscog-eem.164 =============== Item was changed: ----- Method: CoInterpreter class>>exportAPISelectors (in category 'translation') ----- exportAPISelectors "Yes this is a mess. When all exportAPI methods are marked with the <api> pragma this can go away." | omExports | omExports := (self objectMemoryClass withAllSuperclasses copyUpTo: VMClass) inject: Set new into: [:api :c| api addAll: c exportAPISelectors; yourself]. ^((self withAllSuperclasses copyUpTo: VMClass), self ancilliaryClasses inject: omExports into: [:set :class| set addAll: (self exportAPISelectorsFor: class); yourself]) addAll: #( argumentCountOfMethodHeader: canContextSwitchIfActivating: classHeader: compactClassIndexOf: fetchByte:ofObject: functionPointerFor:inClass: isNonIntegerObject: lastPointerOf: literal:ofMethod: popStack primitiveClosureValueNoContextSwitch specialSelector: stackTop + tempCountOf:); - tempCountOf: - tempCountOfMethodHeader:); yourself! Item was added: + ----- Method: CoInterpreter>>frameNumTemps: (in category 'trampolines') ----- + frameNumTemps: theFP + "For subclasses to redefine to implement different closure semantics." + <var: #theFP type: #'char *'> + ^0! Item was changed: ----- Method: CoInterpreter>>internalActivateNewMethod (in category 'message sending') ----- internalActivateNewMethod | methodHeader numTemps rcvr errorCode switched | <inline: true> methodHeader := self rawHeaderOf: newMethod. self assert: (self isCogMethodReference: methodHeader) not. + numTemps := self temporaryCountOfMethodHeader: methodHeader. - numTemps := self tempCountOfMethodHeader: methodHeader. rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self internalPush: localIP. self internalPush: localFP. localFP := localSP. self internalPush: newMethod. self setMethod: newMethod. self internalPush: objectMemory nilObject. "FxThisContext field" self internalPush: (self encodeFrameFieldHasContext: false isBlock: false numArgs: (self argumentCountOfMethodHeader: methodHeader)). self internalPush: 0. "FoxIFSavedIP" self internalPush: rcvr. "Initialize temps..." argumentCount + 1 to: numTemps do: [:i | self internalPush: objectMemory nilObject]. "-1 to account for pre-increment in fetchNextBytecode" localIP := self pointerForOop: (self initialPCForHeader: methodHeader method: newMethod) - 1. "Pass primitive error code to last temp if method receives it (indicated by an initial long store temp bytecode). We don't need to check that newMethod actually has a primitive because the initial 129 only occurs if there is one." primFailCode ~= 0 ifTrue: [(objectMemory byteAtPointer: localIP + 1) = 129 "long store temp" ifTrue: [errorCode := self getErrorObjectFromPrimFailCode. self internalStackTopPut: errorCode "nil if primFailCode == 1, or primFailCode"]. primFailCode := 0]. self assert: (self frameNumArgs: localFP) == argumentCount. self assert: (self frameIsBlockActivation: localFP) not. self assert: (self frameHasContext: localFP) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." localSP < stackLimit ifTrue: [self externalizeIPandSP. switched := self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: methodHeader). self returnToExecutive: true postContextSwitch: switched. self internalizeIPandSP]! Item was removed: - ----- Method: CoInterpreter>>marryFrame:SP: (in category 'frame access') ----- - marryFrame: theFP SP: theSP - "Marry an unmarried frame. This means creating a spouse context initialized with - a subset of the frame's state (state through the last argument) that references the - frame. This is important enough for performance to be worth streamlining. - - Override to set the ``has context'' flag appropriately for both machine code and interpreter frames - and to streamline the machine code/interpreter differences.." - | theContext methodFieldOrObj closureOrNil rcvr byteSize numArgs numStack | - <inline: false> - <var: #theFP type: #'char *'> - <var: #theSP type: #'char *'> - <var: #cogMethod type: #'CogMethod *'> - self assert: (self frameHasContext: theFP) not. - self assert: (self isBaseFrame: theFP) not. "base frames must aready be married for cannotReturn: processing" - - "Decide how much of the stack to preserve in widowed contexts. Preserving too much - state will potentially hold onto garbage. Holding onto too little may mean that a dead - context isn't informative enough in a debugging situation. We compromise, retaining - only the arguments with no temporaries. Note that we still set the stack pointer to its - current value, but stack contents other than the arguments are nil." - methodFieldOrObj := self frameMethodField: theFP. - methodFieldOrObj asUnsignedInteger < objectMemory startOfMemory "inline (self isMachineCodeFrame: theFP)" - ifTrue: - [| cogMethod | - stackPages - longAt: theFP + FoxMethod - put: methodFieldOrObj + MFMethodFlagHasContextFlag. - cogMethod := self cCoerceSimple: (methodFieldOrObj bitAnd: MFMethodMask) to: #'CogMethod *'. - numArgs := cogMethod cmNumArgs. - cogMethod cmType = CMMethod - ifTrue: - [closureOrNil := objectMemory nilObject] - ifFalse: - [cogMethod := (self cCoerceSimple: cogMethod to: #'CogBlockMethod *') cmHomeMethod. - closureOrNil := self frameStackedReceiver: theFP numArgs: numArgs]. - byteSize := (cogMethod methodHeader bitAnd: LargeContextBit) ~= 0 - ifTrue: [LargeContextSize] - ifFalse: [SmallContextSize]. - methodFieldOrObj := cogMethod methodObject. - rcvr := self mframeReceiver: theFP. - numStack := self stackPointerIndexForMFrame: theFP WithSP: theSP numArgs: numArgs] - ifFalse: - [self setIFrameHasContext: theFP. - numArgs := self iframeNumArgs: theFP. - byteSize := ((self headerOf: methodFieldOrObj) bitAnd: LargeContextBit) ~= 0 - ifTrue: [LargeContextSize] - ifFalse: [SmallContextSize]. - closureOrNil := (self iframeIsBlockActivation: theFP) - ifTrue: [self frameStackedReceiver: theFP numArgs: numArgs] - ifFalse: [objectMemory nilObject]. - rcvr := self iframeReceiver: theFP. - numStack := self stackPointerIndexForIFrame: theFP WithSP: theSP numArgs: numArgs]. - theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize. - self setFrameContext: theFP to: theContext. - "Mark context as married by setting its sender to the frame pointer plus SmallInteger - tags and the InstructionPointer to the saved fp (which ensures correct alignment - w.r.t. the frame when we check for validity)" - objectMemory storePointerUnchecked: SenderIndex - ofObject: theContext - withValue: (self withSmallIntegerTags: theFP). - objectMemory storePointerUnchecked: InstructionPointerIndex - ofObject: theContext - withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)). - objectMemory storePointerUnchecked: StackPointerIndex - ofObject: theContext - withValue: (objectMemory integerObjectOf: numStack). - objectMemory storePointerUnchecked: MethodIndex - ofObject: theContext - withValue: methodFieldOrObj. - objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil. - objectMemory storePointerUnchecked: ReceiverIndex - ofObject: theContext - withValue: rcvr. - 1 to: numArgs do: - [:i| - objectMemory storePointerUnchecked: ReceiverIndex + i - ofObject: theContext - withValue: (self temporary: i - 1 in: theFP)]. - numArgs + 1 to: numStack do: - [:i| - objectMemory storePointerUnchecked: ReceiverIndex + i - ofObject: theContext - withValue: objectMemory nilObject]. - - self assert: (self frameHasContext: theFP). - self assert: (self frameOfMarriedContext: theContext) = theFP. - self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext). - - ^theContext! Item was added: + ----- Method: CoInterpreter>>marryFrame:SP:copyTemps: (in category 'frame access') ----- + marryFrame: theFP SP: theSP copyTemps: copyTemps + "Marry an unmarried frame. This means creating a spouse context + initialized with a subset of the frame's state that references the frame. + For the default closure implementation we do not need to copy temps. + Different closure implementations may require temps to be copied. + + This method is important enough for performance to be worth streamlining. + + Override to set the ``has context'' flag appropriately for both machine code and interpreter frames + and to streamline the machine code/interpreter differences.." + | theContext methodFieldOrObj closureOrNil rcvr byteSize numArgs numStack numTemps | + <inline: true> + <var: #theFP type: #'char *'> + <var: #theSP type: #'char *'> + <var: #cogMethod type: #'CogMethod *'> + self assert: (self frameHasContext: theFP) not. + self assert: (self isBaseFrame: theFP) not. "base frames must aready be married for cannotReturn: processing" + + "Decide how much of the stack to preserve in widowed contexts. Preserving too much + state will potentially hold onto garbage. Holding onto too little may mean that a dead + context isn't informative enough in a debugging situation. If copyTemps is false (as it + is in the default closure implementation) compromise, retaining only the arguments with + no temporaries. Note that we still set the stack pointer to its current value, but stack + contents other than the arguments are nil." + methodFieldOrObj := self frameMethodField: theFP. + methodFieldOrObj asUnsignedInteger < objectMemory startOfMemory "inline (self isMachineCodeFrame: theFP)" + ifTrue: + [| cogMethod | + stackPages + longAt: theFP + FoxMethod + put: methodFieldOrObj + MFMethodFlagHasContextFlag. + cogMethod := self cCoerceSimple: (methodFieldOrObj bitAnd: MFMethodMask) to: #'CogMethod *'. + numArgs := cogMethod cmNumArgs. + cogMethod cmType = CMMethod + ifTrue: + [closureOrNil := objectMemory nilObject] + ifFalse: + [cogMethod := (self cCoerceSimple: cogMethod to: #'CogBlockMethod *') cmHomeMethod. + closureOrNil := self frameStackedReceiver: theFP numArgs: numArgs]. + byteSize := (cogMethod methodHeader bitAnd: LargeContextBit) ~= 0 + ifTrue: [LargeContextSize] + ifFalse: [SmallContextSize]. + methodFieldOrObj := cogMethod methodObject. + rcvr := self mframeReceiver: theFP. + numStack := self stackPointerIndexForMFrame: theFP WithSP: theSP numArgs: numArgs] + ifFalse: + [self setIFrameHasContext: theFP. + numArgs := self iframeNumArgs: theFP. + byteSize := ((self headerOf: methodFieldOrObj) bitAnd: LargeContextBit) ~= 0 + ifTrue: [LargeContextSize] + ifFalse: [SmallContextSize]. + closureOrNil := (self iframeIsBlockActivation: theFP) + ifTrue: [self frameStackedReceiver: theFP numArgs: numArgs] + ifFalse: [objectMemory nilObject]. + rcvr := self iframeReceiver: theFP. + numStack := self stackPointerIndexForIFrame: theFP WithSP: theSP numArgs: numArgs]. + theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize. + self setFrameContext: theFP to: theContext. + "Mark context as married by setting its sender to the frame pointer plus SmallInteger + tags and the InstructionPointer to the saved fp (which ensures correct alignment + w.r.t. the frame when we check for validity)" + objectMemory storePointerUnchecked: SenderIndex + ofObject: theContext + withValue: (self withSmallIntegerTags: theFP). + objectMemory storePointerUnchecked: InstructionPointerIndex + ofObject: theContext + withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)). + objectMemory storePointerUnchecked: StackPointerIndex + ofObject: theContext + withValue: (objectMemory integerObjectOf: numStack). + objectMemory storePointerUnchecked: MethodIndex + ofObject: theContext + withValue: methodFieldOrObj. + objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil. + objectMemory storePointerUnchecked: ReceiverIndex + ofObject: theContext + withValue: rcvr. + 1 to: numArgs do: + [:i| + objectMemory storePointerUnchecked: ReceiverIndex + i + ofObject: theContext + withValue: (self temporary: i - 1 in: theFP)]. + copyTemps ifTrue: + [numTemps := self frameNumTemps: theFP. + 1 to: numTemps do: + [:i| + objectMemory storePointerUnchecked: ReceiverIndex + i + numArgs + ofObject: theContext + withValue: (self temporary: i - 1 in: theFP)]. + numArgs := numArgs + numTemps]. + + numArgs + 1 to: numStack do: + [:i| + objectMemory storePointerUnchecked: ReceiverIndex + i + ofObject: theContext + withValue: objectMemory nilObject]. + + self assert: (self frameHasContext: theFP). + self assert: (self frameOfMarriedContext: theContext) = theFP. + self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext). + + ^theContext! Item was changed: ----- Method: CoInterpreter>>printFrame:WithSP: (in category 'debug printing') ----- printFrame: theFP WithSP: theSP | theMethod theMethodEnd numArgs numTemps rcvrAddress topThing | <inline: false> <var: #theFP type: #'char *'> <var: #theSP type: #'char *'> <var: #addr type: #'char *'> <var: #rcvrAddress type: #'char *'> <var: #cogMethod type: #'CogBlockMethod *'> <var: #homeMethod type: #'CogMethod *'> self cCode: '' inSmalltalk: [self transcript ensureCr]. (self isMachineCodeFrame: theFP) ifTrue: [| cogMethod homeMethod | cogMethod := self mframeCogMethod: theFP. homeMethod := self mframeHomeMethod: theFP. theMethod := homeMethod asInteger. theMethodEnd := homeMethod asInteger + homeMethod blockSize. numArgs := cogMethod cmNumArgs. + numTemps := self temporaryCountOfMethodHeader: homeMethod methodHeader] - numTemps := self tempCountOfMethodHeader: homeMethod methodHeader] ifFalse: [theMethod := self frameMethodObject: theFP. theMethodEnd := theMethod + (objectMemory sizeBitsOfSafe: theMethod). numArgs := self iframeNumArgs: theFP. numTemps := self tempCountOf: theMethod]. (self frameIsBlockActivation: theFP) ifTrue: [| rcvrOrClosure | rcvrOrClosure := self pushedReceiverOrClosureOfFrame: theFP. ((objectMemory isNonIntegerObject: rcvrOrClosure) and: [(objectMemory addressCouldBeObj: rcvrOrClosure) and: [(objectMemory fetchClassOfNonInt: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]]) ifTrue: [numTemps := numArgs + (self stSizeOf: rcvrOrClosure)] ifFalse: [numTemps := 0]]. self shortPrintFrame: theFP. (self isBaseFrame: theFP) ifTrue: [self printFrameOop: '(caller ctxt' at: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord). self printFrameOop: '(saved ctxt' at: theFP + (self frameStackedReceiverOffset: theFP) + (1 * BytesPerWord)]. self printFrameOop: 'rcvr/clsr' at: theFP + FoxCallerSavedIP + ((numArgs + 1) * BytesPerWord). numArgs to: 1 by: -1 do: [:i| self printFrameOop: 'arg' index: numArgs - i at: theFP + FoxCallerSavedIP + (i * BytesPerWord)]. self printFrameThing: 'caller ip' at: theFP + FoxCallerSavedIP. self printFrameThing: 'saved fp' at: theFP + FoxSavedFP. self printFrameMethodFor: theFP. (self isMachineCodeFrame: theFP) ifFalse: [self printFrameFlagsForFP: theFP]. self printFrameOop: 'context' at: theFP + FoxThisContext. (self isMachineCodeFrame: theFP) ifTrue: [self printFrameFlagsForFP: theFP]. (self isMachineCodeFrame: theFP) ifTrue: [rcvrAddress := theFP + FoxMFReceiver] ifFalse: [self printFrameThing: 'saved ip' at: theFP + FoxIFSavedIP extra: ((self iframeSavedIP: theFP) = 0 ifTrue: [0] ifFalse: [(self iframeSavedIP: theFP) - theMethod + 2 - BaseHeaderSize]). rcvrAddress := theFP + FoxIFReceiver]. self printFrameOop: 'receiver' at: rcvrAddress. topThing := stackPages longAt: theSP. (topThing between: theMethod and: theMethodEnd) ifTrue: [rcvrAddress - BytesPerWord to: theSP + BytesPerWord by: BytesPerWord negated do: [:addr| | index | index := rcvrAddress - addr / BytesPerWord + numArgs. index <= numTemps ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr] ifFalse: [self printFrameOop: 'stck' at: addr]]. self printFrameThing: 'frame ip' at: theSP extra: ((self isMachineCodeFrame: theFP) ifTrue: [topThing - theMethod] ifFalse: [topThing - theMethod + 2 - BaseHeaderSize])] ifFalse: [rcvrAddress - BytesPerWord to: theSP by: BytesPerWord negated do: [:addr| | index | index := rcvrAddress - addr / BytesPerWord + numArgs. index <= numTemps ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr] ifFalse: [self printFrameOop: 'stck' at: addr]]]! Item was changed: ----- Method: StackInterpreter>>internalActivateNewMethod (in category 'message sending') ----- internalActivateNewMethod | methodHeader numTemps rcvr errorCode | <inline: true> methodHeader := self headerOf: newMethod. + numTemps := self temporaryCountOfMethodHeader: methodHeader. - numTemps := self tempCountOfMethodHeader: methodHeader. rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?" self internalPush: localIP. self internalPush: localFP. localFP := localSP. self internalPush: newMethod. self setMethod: newMethod. self internalPush: (self encodeFrameFieldHasContext: false isBlock: false numArgs: (self argumentCountOfMethodHeader: methodHeader)). self internalPush: objectMemory nilObject. "FxThisContext field" self internalPush: rcvr. "Initialize temps..." argumentCount + 1 to: numTemps do: [:i | self internalPush: objectMemory nilObject]. "-1 to account for pre-increment in fetchNextBytecode" localIP := self pointerForOop: (self initialPCForHeader: methodHeader method: newMethod) - 1. "Pass primitive error code to last temp if method receives it (indicated by an initial long store temp bytecode). Protect against obsolete values in primFailCode by checking that newMethod actually has a primitive?" primFailCode ~= 0 ifTrue: [((self methodHeaderHasPrimitive: methodHeader) and: [(objectMemory byteAtPointer: localIP + 1) = 129 "long store temp"]) ifTrue: [errorCode := self getErrorObjectFromPrimFailCode. self internalStackTopPut: errorCode "nil if primFailCode == 1, or primFailCode"]. primFailCode := 0]. self assert: (self frameNumArgs: localFP) == argumentCount. self assert: (self frameIsBlockActivation: localFP) not. self assert: (self frameHasContext: localFP) not. "Now check for stack overflow or an event (interrupt, must scavenge, etc)." localSP < stackLimit ifTrue: [self externalizeIPandSP. self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: methodHeader). self internalizeIPandSP]! Item was changed: ----- Method: StackInterpreter>>marryFrame:SP: (in category 'frame access') ----- marryFrame: theFP SP: theSP "Marry an unmarried frame. This means creating a spouse context initialized with a subset of the frame's state (state through the last argument) that references the frame." - | theContext methodHeader byteSize numArgs numStack closureOrNil | <inline: false> + ^self marryFrame: theFP SP: theSP copyTemps: false! - <var: #theFP type: #'char *'> - <var: #theSP type: #'char *'> - self assert: (self frameHasContext: theFP) not. - - methodHeader := self headerOf: (self frameMethod: theFP). - "Decide how much of the stack to preserve in widowed contexts. Preserving too much - state will potentially hold onto garbage. Holding onto too little may mean that a dead - context isn't informative enough in a debugging situation. We compromise, retaining - only the arguments with no temporaries. Note that we still set the stack pointer to its - current value, but stack contents other than the arguments are nil." - numArgs := self frameNumArgs: theFP. - numStack := self stackPointerIndexForFrame: theFP WithSP: theSP. - - closureOrNil := (self frameIsBlockActivation: theFP) - ifTrue: [self pushedReceiverOrClosureOfFrame: theFP] - ifFalse: [objectMemory nilObject]. - - byteSize := (methodHeader bitAnd: LargeContextBit) ~= 0 - ifTrue: [LargeContextSize] - ifFalse: [SmallContextSize]. - theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize. - self assert: numStack + ReceiverIndex << ShiftForWord + BaseHeaderSize <= byteSize. - "Mark context as married by setting its sender to the frame pointer plus SmallInteger - tags and the InstructionPointer to the saved fp (which ensures correct alignment - w.r.t. the frame when we check for validity)" - objectMemory storePointerUnchecked: SenderIndex - ofObject: theContext - withValue: (self withSmallIntegerTags: theFP). - objectMemory storePointerUnchecked: InstructionPointerIndex - ofObject: theContext - withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)). - objectMemory storePointerUnchecked: StackPointerIndex - ofObject: theContext - withValue: (objectMemory integerObjectOf: numStack). - objectMemory storePointerUnchecked: MethodIndex - ofObject: theContext - withValue: (self frameMethod: theFP). - objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil. - objectMemory storePointerUnchecked: ReceiverIndex - ofObject: theContext - withValue: (self frameReceiver: theFP). - "Store just the arguments. If the frame is divorced the context - will have valid arguments but all temporaries will be nil." - 1 to: numArgs do: - [:i| - objectMemory storePointerUnchecked: ReceiverIndex + i - ofObject: theContext "inline self temporary: i - 1 in:theFP" - withValue: (stackPages longAt: theFP - + FoxCallerSavedIP - + ((numArgs - i + 1) * BytesPerWord))]. - numArgs + 1 to: numStack do: - [:i| - objectMemory storePointerUnchecked: ReceiverIndex + i - ofObject: theContext - withValue: objectMemory nilObject]. - - self setFrameContext: theFP to: theContext. - self setFrameHasContext: theFP. - - self assert: (self frameHasContext: theFP). - self assert: (self frameOfMarriedContext: theContext) = theFP. - self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext). - - ^theContext - ! Item was added: + ----- Method: StackInterpreter>>marryFrame:SP:copyTemps: (in category 'frame access') ----- + marryFrame: theFP SP: theSP copyTemps: copyTemps + "Marry an unmarried frame. This means creating a spouse context + initialized with a subset of the frame's state that references the frame. + For the default closure implementation we do not need to copy temps. + Different closure implementations may require temps to be copied." + | theContext methodHeader byteSize numArgs numStack closureOrNil numTemps | + <inline: true> + <var: #theFP type: #'char *'> + <var: #theSP type: #'char *'> + self assert: (self frameHasContext: theFP) not. + + methodHeader := self headerOf: (self frameMethod: theFP). + "Decide how much of the stack to preserve in widowed contexts. Preserving too much + state will potentially hold onto garbage. Holding onto too little may mean that a dead + context isn't informative enough in a debugging situation. If copyTemps is false (as it + is in the default closure implementation) compromise, retaining only the arguments with + no temporaries. Note that we still set the stack pointer to its current value, but stack + contents other than the arguments are nil." + numArgs := self frameNumArgs: theFP. + numStack := self stackPointerIndexForFrame: theFP WithSP: theSP. + + closureOrNil := (self frameIsBlockActivation: theFP) + ifTrue: [self pushedReceiverOrClosureOfFrame: theFP] + ifFalse: [objectMemory nilObject]. + + byteSize := (methodHeader bitAnd: LargeContextBit) ~= 0 + ifTrue: [LargeContextSize] + ifFalse: [SmallContextSize]. + theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize. + self assert: numStack + ReceiverIndex << ShiftForWord + BaseHeaderSize <= byteSize. + "Mark context as married by setting its sender to the frame pointer plus SmallInteger + tags and the InstructionPointer to the saved fp (which ensures correct alignment + w.r.t. the frame when we check for validity)" + objectMemory storePointerUnchecked: SenderIndex + ofObject: theContext + withValue: (self withSmallIntegerTags: theFP). + objectMemory storePointerUnchecked: InstructionPointerIndex + ofObject: theContext + withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)). + objectMemory storePointerUnchecked: StackPointerIndex + ofObject: theContext + withValue: (objectMemory integerObjectOf: numStack). + objectMemory storePointerUnchecked: MethodIndex + ofObject: theContext + withValue: (self frameMethod: theFP). + objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil. + objectMemory storePointerUnchecked: ReceiverIndex + ofObject: theContext + withValue: (self frameReceiver: theFP). + "If copyTemps is false, store just the arguments. If the frame is divorced the context + will have valid arguments but all temporaries will be nil." + 1 to: numArgs do: + [:i| + objectMemory storePointerUnchecked: ReceiverIndex + i + ofObject: theContext "inline self temporary: i - 1 in:theFP" + withValue: (stackPages longAt: theFP + + FoxCallerSavedIP + + ((numArgs - i + 1) * BytesPerWord))]. + copyTemps ifTrue: + [numTemps := self frameNumTemps: theFP. + 1 to: numTemps do: + [:i| + objectMemory storePointerUnchecked: ReceiverIndex + i + numArgs + ofObject: theContext + withValue: (self temporary: i - 1 in: theFP)]. + numArgs := numArgs + numTemps]. + + numArgs + 1 to: numStack do: + [:i| + objectMemory storePointerUnchecked: ReceiverIndex + i + ofObject: theContext + withValue: objectMemory nilObject]. + + self setFrameContext: theFP to: theContext. + self setFrameHasContext: theFP. + + self assert: (self frameHasContext: theFP). + self assert: (self frameOfMarriedContext: theContext) = theFP. + self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext). + + ^theContext + ! Item was changed: ----- Method: StackInterpreter>>tempCountOf: (in category 'compiled methods') ----- tempCountOf: methodPointer + ^self temporaryCountOfMethodHeader: (self headerOf: methodPointer)! - ^self tempCountOfMethodHeader: (self headerOf: methodPointer)! Item was removed: - ----- Method: StackInterpreter>>tempCountOfMethodHeader: (in category 'compiled methods') ----- - tempCountOfMethodHeader: header - <inline: true> - ^ (header >> 19) bitAnd: 16r3F! Item was changed: ----- Method: StackInterpreter>>temporaryCountOfMethodHeader: (in category 'compiled methods') ----- temporaryCountOfMethodHeader: header + <inline: true> ^(header >> 19) bitAnd: 16r3F!

1 0

VM Maker: VMMaker.oscog-eem.164.mcz
by commits＠source.squeak.org 23 Jun '12

23 Jun '12

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.164.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.164 Author: eem Time: 23 June 2012, 11:23:07.021 am UUID: 4d03e08d-186b-4360-8d3b-8d14d8c7db82 Ancestors: VMMaker.oscog-eem.163 Add shortPrintOop: to printReferencesTo:. Fix cascade transformation for same. Add addrtess offset to bytecode printing in printOop. =============== Diff against VMMaker.oscog-eem.163 =============== Item was changed: ----- Method: CascadeNode>>asTranslatorNodeIn: (in category '*VMMaker-C translation') ----- asTranslatorNodeIn: aTMethod + "make a CCodeGenerator equivalent of me." - "make a CCodeGenerator equivalent of me" ^TStmtListNode new setArguments: #() statements: (Array streamContents: [:s| | receiverNode | receiverNode := receiver asTranslatorNodeIn: aTMethod. + "don't expand the receiver if it is a send to get an implicit receiver, + e.g self interpreter printHex: oop => printHex(oop), /not/ printHex(cascade0,oop)." + (receiverNode isSend and: [aTMethod definingClass isNonArgumentImplicitReceiverVariableName: receiverNode selector]) ifTrue: + [receiverNode := TVariableNode new setName: receiverNode selector]. receiverNode isLeaf ifFalse: [| varNode | varNode := aTMethod newCascadeTempFor: receiverNode. s nextPut: (TAssignmentNode new setVariable: varNode expression: receiverNode). receiverNode := varNode]. messages do: [ :msg | s nextPut: ((msg asTranslatorNodeIn: aTMethod) receiver: receiverNode)]]); comment: comment! Item was changed: ----- Method: CoInterpreter class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- isNonArgumentImplicitReceiverVariableName: aString + ^#('self' 'stackPages' 'cogit' 'coInterpreter' 'cogMethodZone' 'objectMemory' 'interpreter') includes: aString! - ^#('self' 'stackPages' 'cogit' 'coInterpreter' 'cogMethodZone' 'objectMemory') includes: aString! Item was added: + ----- Method: ObjectMemory class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- + isNonArgumentImplicitReceiverVariableName: aString + ^#('self' 'interpreter' 'coInterpreter') includes: aString! Item was changed: ----- Method: ObjectMemory>>printReferencesTo: (in category 'debug printing') ----- printReferencesTo: anOop "Scan the heap printing the oops of any and all objects that refer to anOop" | oop i | <api> oop := self firstAccessibleObject. [oop = nil] whileFalse: [((self isPointers: oop) or: [self isCompiledMethod: oop]) ifTrue: [(self isCompiledMethod: oop) ifTrue: [i := (self literalCountOf: oop) - 1] ifFalse: [(self isContext: oop) ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1] ifFalse: [i := (self lengthOf: oop) - 1]]. [i >= 0] whileTrue: [anOop = (self fetchPointer: i ofObject: oop) ifTrue: + [self interpreter printHex: oop; print: ' @ '; printNum: i; space; printOopShort: oop; cr. - [self printHex: oop; print: ' @ '; printNum: i; cr. i := 0]. i := i - 1]]. oop := self accessibleObjectAfter: oop]! Item was changed: ----- Method: StackInterpreter>>elementsPerPrintOopLine (in category 'debug printing') ----- elementsPerPrintOopLine ^5! Item was changed: ----- Method: StackInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop + | cls fmt lastIndex startIP bytecodesPerLine column | - | cls fmt lastIndex startIP bytecodesPerLine | <inline: false> self printHex: oop. (objectMemory isIntegerObject: oop) ifTrue: [^self cCode: 'printf("=%ld\n", integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'; cr. ^nil]. (objectMemory isFreeObject: oop) ifTrue: [self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr. ^nil]. + " self print: ': a(n) '. + " self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5. cls = (objectMemory splObj: ClassFloat) ifTrue: [self cr; printFloat: (self dbgFloatValueOf: oop); cr. ^nil]. fmt := objectMemory formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)]. self cr. (fmt > 4 and: [fmt < 12]) ifTrue: ["This will answer false if splObj: ClassAlien is nilObject" (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue: [self print: ' datasize '; printNum: (self sizeOfAlienData: oop). self print: ((self isIndirectAlien: oop) ifTrue: [' indirect @ '] ifFalse: [(self isPointerAlien: oop) ifTrue: [' pointer @ '] ifFalse: [' direct @ ']]). self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr. ^nil]. (objectMemory isWords: oop) ifTrue: [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop). (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. ^nil]. ^self printStringOf: oop; cr]. lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')' inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space. self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))]. (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: [startIP := startIP * BytesPerWord + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. + bytecodesPerLine := 8. + column := 1. - bytecodesPerLine := 10. startIP to: lastIndex do: [:index| | byte | + (column = 1) ifTrue:[ + self cCode: 'printf("%08x: ", oop+index-1)' + inSmalltalk: [self print: (oop+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: - ((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue: - [self cr]]. - ((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse: [self cr]]!

1 0

Re: [Vm-dev] VM Maker: VMMaker-dtl.275.mcz
by David T. Lewis 23 Jun '12

23 Jun '12

On Sat, Jun 23, 2012 at 06:10:16PM +0000, commits(a)source.squeak.org wrote: > > VMMaker Nothing more expected ->4.9.4 > Ha! I must have accidentally done a doIt in my workspace without noticing ... or was it a freudian slip ? ... ;-)

1 0

Progress changes break VMMaker
by Eliot Miranda 23 Jun '12

23 Jun '12

Hi All, Hi Chris, something in the changes to ProcessInitiationException done in ToolBuilder-Kernel-cmm.48/49/52 breaks the VMMaker. i.e. the following prints nil 5 times to the Transcript instead of printing #caught 5 times. ['Progressing' displayProgressFrom: 1 to: 5 during: [:bar| 1 to: 5 do: [:i| Transcript cr; print: (Notification new tag: #getVMMaker; signal); flush. bar value: i]]] on: Notification do:[:ex| ex tag == #getVMMaker ifTrue: [ex resume: #caught] ifFalse: [ex pass]] Any help in fixing this appreciated! Interestingly in the following count is 1 | count | count := 0. ['Progressing' displayProgressFrom: 1 to: 5 during: [:bar| 1 to: 5 do: [:i| Transcript cr; print: (Notification new tag: #getVMMaker; signal); flush. bar value: i]]] on: Notification do:[:ex| count := count + 1. ex tag == #getVMMaker ifTrue: [ex resume: #caught] ifFalse: [ex pass]]. count 1 -- best, Eliot

2 5

VM Maker: VMMaker-dtl.275.mcz
by commits＠source.squeak.org 23 Jun '12

23 Jun '12

David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-dtl.275.mcz ==================== Summary ==================== Name: VMMaker-dtl.275 Author: dtl Time: 23 June 2012, 2:09:46.042 pm UUID: ffa26536-19b5-42e3-896e-8eb0dd248215 Ancestors: VMMaker-dtl.274 VMMaker Nothing more expected ->4.9.4 Relax restrictions on classes and methods that may be translated to C when browsing (SlangBrowser). Prevent a few of the more obvious runaway recursions for translating inlined C from a browser. CCodeGenerator>>checkAbstractMethods now bypasses checks for methods in #uncheckedAbstractSelectors, attempting to do the right thing throughout a class hierarchy, e.g. an abstract method added to InterpreterPrimitives will produce a warning when translating Interpreter or StackInterpreter with either VMMaker or a slang browser, but no warning when translating InterpreterPrimitives in a slang browser. This allows C code for methods in an abstract class to be viewed in a browser, while unimplemented concrete methods produce warnings in VMMaker. Limit loop count in CCodeGenerator>>doBasicInlining to prevent infinite recursion e.g. when translating Symbol>>asSymbol. Provide TNotImplementedNode>>emitCCodeOn:level:generator: to write a comment on output stream so unimiplemented slang constructs produce readable output. Prevent infinite recursion in TMethod>>renameVariablesUsing: when inlining a method with super send, e.g. WideString>>replaceFrom:to:with:startingAt:. Note, inlining super works in oscog, need to adopt that. =============== Diff against VMMaker-dtl.274 =============== Item was changed: Object subclass: #CCodeGenerator + instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations uncheckedAbstractMethods' - instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations' classVariableNames: 'UseRightShiftForDivide' poolDictionaries: '' category: 'VMMaker-Translation to C'! !CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0! This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter. See VMMaker for more useful info! Item was changed: ----- Method: CCodeGenerator>>checkAbstractMethods (in category 'error notification') ----- checkAbstractMethods "For each method that has been declared abstract, ensure that a concrete implementation has been provided. This check should be performed prior to inlining because methods may be removed during the inlining process." | selectors | + selectors := methods keys, self uncheckedAbstractMethods. - selectors := methods keys, self permittedAbstractMethods. abstractDeclarations do: [:sel | (selectors includes: sel) ifFalse: [self notify: 'missing implementation for ', sel]] ! Item was changed: ----- Method: CCodeGenerator>>doBasicInlining: (in category 'inlining') ----- doBasicInlining: inlineFlag "Inline the bodies of all methods that are suitable for inlining. This method does only the basic inlining suitable for both the core VM and plugins - no bytecode inlining etc" + | pass progress max | - | pass progress | inlineFlag ifFalse: [^self]. self collectInlineList. pass := 0. + max := 12. "More than this is probably due to infinite recursion" progress := true. [progress] whileTrue: [ "repeatedly attempt to inline methods until no further progress is made" progress := false. + pass > max + ifTrue: [self notify: 'too many inlining steps, inlining terminated'] + ifFalse: [('Inlining pass ', (pass := pass + 1) printString, '...') + displayProgressAt: Sensor cursorPoint + from: 0 to: methods size + during: [:bar | + (self sortMethods: methods) doWithIndex: [:m :i | + bar value: i. + currentMethod := m. + (m tryToInlineMethodsIn: self) + ifTrue: [progress := true]]]]]. - ('Inlining pass ', (pass := pass + 1) printString, '...') - displayProgressAt: Sensor cursorPoint - from: 0 to: methods size - during: [:bar | - (self sortMethods: methods) doWithIndex: [:m :i | - bar value: i. - currentMethod := m. - (m tryToInlineMethodsIn: self) - ifTrue: [progress := true]]]]. ! Item was changed: ----- Method: CCodeGenerator>>initialize (in category 'public') ----- initialize translationDict := Dictionary new. inlineList := Array new. constants := Dictionary new: 100. variables := OrderedCollection new: 100. variableDeclarations := Dictionary new: 100. methods := Dictionary new: 500. macros := Dictionary new. self initializeCTranslationDictionary. receiverDict := Dictionary new. headerFiles := OrderedCollection new. globalVariableUsage := Dictionary new. useSymbolicConstants := true. generateDeadCode := true. scopeStack := OrderedCollection new. logger := (ProvideAnswerNotification new tag: #logger; signal) ifNil: [Transcript]. pools := IdentitySet new. + abstractDeclarations := IdentitySet new. + uncheckedAbstractMethods := OrderedCollection new. + ! - abstractDeclarations := IdentitySet new.! Item was removed: - ----- Method: CCodeGenerator>>permittedAbstractMethods (in category 'error notification') ----- - permittedAbstractMethods - "Methods generated directly by the code generator require concrete implementations - only in simulation. These may safely be declared abstract in order to ensure that - implemenations are provided in the simulator classes." - - ^ #( - bytesPerWord. - baseHeaderSize. - byteAt:. - anAbstractMethod "for unit test" - ). - ! Item was added: + ----- Method: CCodeGenerator>>uncheckedAbstractMethods (in category 'accessing') ----- + uncheckedAbstractMethods + "Answer the selectors for methods that should not be checked to ensure existence + of concrete implementations, such as methods that are generated directly by the + code generator itself." + + ^uncheckedAbstractMethods + + ! Item was added: + ----- Method: Object class>>abstractSelectors (in category '*VMMaker-translation') ----- + abstractSelectors + "Selectors for abstract methods in this class" + ^ self selectors + select: [:sel | (self compiledMethodAt: sel) requiresConcreteImplementation]! Item was added: + ----- Method: Object class>>buildCodeGenerator (in category '*VMMaker-translation') ----- + buildCodeGenerator + "Build a CCodeGenerator for this class. By default, generate only the + the methods for aClass." + | cg | + cg := self codeGeneratorClass new initialize. + cg declareModuleName: self name. + cg addClass: self. + cg declareMethodsStatic: true. + cg permitMethodPruning: false. + ^cg + ! Item was added: + ----- Method: Object class>>buildCodeGeneratorInlined: (in category '*VMMaker-translation') ----- + buildCodeGeneratorInlined: doInlining + "Build a CCodeGenerator for this class. By default, generate only the + the methods for aClass. Classes that are normally translated along with + other collaborating classes, such as an object memory and its interpreter, + may include the collaborating classes when doInlining is true, allowing methods + in those classes to be included in the inlining process." + + ^self buildCodeGenerator + ! Item was added: + ----- Method: Object class>>buildCodeGeneratorUpTo: (in category '*VMMaker-translation') ----- + buildCodeGeneratorUpTo: aClass + "Build a CCodeGenerator for this class. By default, generate only the + the methods for aClass." + | cg | + cg := self codeGeneratorClass new initialize. + cg declareModuleName: self name. + cg addClass: aClass. + ^cg + ! Item was changed: ----- Method: Object class>>initializeCodeGenerator: (in category '*VMMaker-translation') ----- initializeCodeGenerator: cg "Load a code generator with classes in a manner suitable for generating code for this class." | cls | cls := self. [cls == Object] whileFalse: [cg addClass: cls. cls := cls superclass]. + cg uncheckedAbstractMethods addAll: self uncheckedAbstractSelectors. ^cg ! Item was added: + ----- Method: Object class>>uncheckedAbstractSelectors (in category '*VMMaker-translation') ----- + uncheckedAbstractSelectors + "Selectors for abstract methods that are not required to have concrete + implementations in a code generator for this class. These may be methods + in this class that send #subclassResponsibility, methods with implementations + supplied directly by the code generator, or methods implemented in the support + code. A code generator for translating this class in a browser should not raise + warnings about missing implementations for these selectors." + + | codeGeneratorMethods | + "methods with implementations provide by the code generator or platform sources and macros" + codeGeneratorMethods := #( + bytesPerWord. + baseHeaderSize. + byteAt:. + anAbstractMethod "for unit test" + ). + "abstract methods in this class are presumed to have implementations in subclasses" + ^ codeGeneratorMethods, self abstractSelectors! Item was removed: - ----- Method: Object>>buildCodeGenerator (in category '*VMMaker-translation support') ----- - buildCodeGenerator - "Build a CCodeGenerator for this class. By default, generate only the - the methods for aClass." - | cg | - cg := self codeGeneratorClass new initialize. - cg declareModuleName: self name. - cg addClass: self. - cg declareMethodsStatic: true. - cg permitMethodPruning: false. - ^cg - ! Item was removed: - ----- Method: Object>>buildCodeGeneratorInlined: (in category '*VMMaker-translation support') ----- - buildCodeGeneratorInlined: doInlining - "Build a CCodeGenerator for this class. By default, generate only the - the methods for aClass. Classes that are normally translated along with - other collaborating classes, such as an object memory and its interpreter, - may include the collaborating classes when doInlining is true, allowing methods - in those classes to be included in the inlining process." - - ^self buildCodeGenerator - ! Item was removed: - ----- Method: Object>>buildCodeGeneratorUpTo: (in category '*VMMaker-translation support') ----- - buildCodeGeneratorUpTo: aClass - "Build a CCodeGenerator for this class. By default, generate only the - the methods for aClass." - | cg | - cg := self codeGeneratorClass new initialize. - cg declareModuleName: self name. - cg addClass: aClass. - ^cg - ! Item was changed: ----- Method: ObjectMemory class>>buildCodeGeneratorInlined: (in category 'translation') ----- buildCodeGeneratorInlined: doInlining "Build a CCodeGenerator for this class. By default, generate only the the methods for aClass. Classes that are normally translated along with other collaborating classes, such as an object memory and its interpreter, may include the collaborating classes when doInlining is true, allowing methods in those classes to be included in the inlining process." | cg | cg := VMMaker new createCodeGenerator. cg declareMethodsStatic: false. cg permitMethodPruning: true. + cg uncheckedAbstractMethods addAll: self abstractSelectors. doInlining ifTrue: ["Include methods from associated classes so that inlining for each method is performed as in normal interp.c generation" ^self interpreterClass initializeCodeGenerator: cg] ifFalse: [^self initializeCodeGenerator: cg] + ! Item was added: + ----- Method: SlangTestSupportInterpreter class>>uncheckedAbstractSelectors (in category 'translation') ----- + uncheckedAbstractSelectors + ^ super uncheckedAbstractSelectors, ObjectMemory uncheckedAbstractSelectors! Item was added: + ----- Method: StackInterpreter class>>uncheckedAbstractSelectors (in category 'translation') ----- + uncheckedAbstractSelectors + "Selectors for abstract methods that are not required to have concrete + implementations in a code generator for this class. These may be methods + in this class that send #subclassResponsibility, methods with implementations + supplied directly by the code generator, or methods implemented in the support + code. A code generator for translating this class in a browser should not raise + warnings about missing implementations for these selectors." + + ^super uncheckedAbstractSelectors, StackInterpreterPrimitives selectors! Item was changed: ----- Method: TMethod>>renameVariablesUsing: (in category 'inlining support') ----- renameVariablesUsing: aDictionary "Rename all variables according to old->new mappings of the given dictionary." | newDecls newKey newValue | "map args and locals" args := args collect: [ :arg | (aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ]. ]. locals := locals collect: [ :v | (aDictionary includesKey: v) ifTrue: [ aDictionary at: v ] ifFalse: [ v ]. ]. + "prevent runaway recursion, e.g. inlining a method with super send" + locals size > 1000 ifTrue: [self error: 'recursive inlining in ', selector asString, ', too many locals']. "map declarations" newDecls := declarations species new. declarations associationsDo: [ :assoc | (aDictionary includesKey: assoc key) ifTrue: [ newKey := aDictionary at: assoc key. newValue := assoc value replaceLastOccurrence: assoc key with: newKey. newDecls at: newKey put: newValue] ifFalse: [ newDecls add: assoc ]. ]. declarations := newDecls. "map variable names in parse tree" parseTree nodesDo: [ :node | (node isVariable and: [aDictionary includesKey: node name]) ifTrue: [ node setName: (aDictionary at: node name). ]. (node isStmtList and: [node args size > 0]) ifTrue: [ node setArguments: (node args collect: [ :arg | (aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ]. ]). ]. ].! Item was added: + ----- Method: TNotImplementedNode>>emitCCodeOn:level:generator: (in category 'C code generation') ----- + emitCCodeOn: aStream level: level generator: aCodeGen + "Emit a comment only" + + aStream cr; nextPutAll: '/*** '; + nextPutAll: self printString; + nextPutAll: ' cannot translate: '; cr; + nextPutAll: parseNode printString; + cr; nextPutAll: ' ***/'; cr + ! Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.9.4'! - ^'4.9.3'!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev June 2012