VM Maker: VMMaker.oscog-eem.400.mcz

 
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.400.mcz

==================== Summary ====================

Name: VMMaker.oscog-eem.400
Author: eem
Time: 21 September 2013, 7:46:26.362 am
UUID: 3481cf9c-80d0-47db-b5c4-07102f7ea255
Ancestors: VMMaker.oscog-eem.399

Make the Inflate/DeflatePlugin simulate.

Simplify loadColorMapShiftOrMaskFrom: & others; isWords:,
isBytes: et al check for immediates already.

Add printHexnp: for unpadded hex printing & use in longPrintOop:.

Add a print stack call stack to print less stack :)

=============== Diff against VMMaker.oscog-eem.399 ===============

Item was changed:
  ----- Method: BitBltSimulation>>loadColorMapShiftOrMaskFrom: (in category 'interpreter interface') -----
  loadColorMapShiftOrMaskFrom: mapOop
  <returnTypeC:'void *'>
  mapOop = interpreterProxy nilObject ifTrue:[^nil].
- (interpreterProxy isIntegerObject: mapOop)
- ifTrue:[interpreterProxy primitiveFail. ^nil].
  ((interpreterProxy isWords: mapOop)
  and:[(interpreterProxy slotSizeOf: mapOop) = 4])
  ifFalse:[interpreterProxy primitiveFail. ^nil].
  ^interpreterProxy firstIndexableField: mapOop!

Item was added:
+ ----- Method: InflatePlugin class>>simulatorClass (in category 'simulation') -----
+ simulatorClass
+ "For running from Smalltalk - answer a class that can be used to simulate the receiver,
+ or nil if you want the primitives in this module to always fail, causing simulation to fall
+ through to the Smalltalk code.  By default every non-TestInterpreterPlugin can simulate itself."
+
+ ^DeflatePlugin!

Item was changed:
  ----- Method: InflatePlugin>>primitiveInflateDecompressBlock (in category 'primitives') -----
  primitiveInflateDecompressBlock
  "Primitive. Inflate a single block."
  | oop rcvr |
  <export: true>
+ interpreterProxy methodArgumentCount = 2 ifFalse:
+ [^interpreterProxy primitiveFail].
- interpreterProxy methodArgumentCount = 2 ifFalse:[^interpreterProxy primitiveFail].
  "distance table"
+ oop := interpreterProxy stackValue: 0.
+ (interpreterProxy isWords: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- oop := interpreterProxy stackObjectValue: 0.
- interpreterProxy failed ifTrue:[^nil].
- (interpreterProxy isWords: oop)
- ifFalse:[^interpreterProxy primitiveFail].
  zipDistTable := interpreterProxy firstIndexableField: oop.
  zipDistTableSize := interpreterProxy slotSizeOf: oop.
 
  "literal table"
+ oop := interpreterProxy stackValue: 1.
+ (interpreterProxy isWords: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- oop := interpreterProxy stackObjectValue: 1.
- interpreterProxy failed ifTrue:[^nil].
- (interpreterProxy isWords: oop)
- ifFalse:[^interpreterProxy primitiveFail].
  zipLitTable := interpreterProxy firstIndexableField: oop.
  zipLitTableSize := interpreterProxy slotSizeOf: oop.
 
 
  "Receiver (InflateStream)"
+ rcvr := interpreterProxy stackValue: 2.
+ (interpreterProxy isPointers: rcvr) ifFalse:
+ [^interpreterProxy primitiveFail].
- rcvr := interpreterProxy stackObjectValue: 2.
- interpreterProxy failed ifTrue:[^nil].
- (interpreterProxy isPointers: rcvr)
- ifFalse:[^interpreterProxy primitiveFail].
  (interpreterProxy slotSizeOf: rcvr) < 9
  ifTrue:[^interpreterProxy primitiveFail].
 
  "All the integer instvars"
  zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
  zipState := interpreterProxy fetchInteger: 3 ofObject: rcvr.
  zipBitBuf := interpreterProxy fetchInteger: 4 ofObject: rcvr.
  zipBitPos := interpreterProxy fetchInteger: 5 ofObject: rcvr.
  zipSourcePos := interpreterProxy fetchInteger: 7 ofObject: rcvr.
  zipSourceLimit := interpreterProxy fetchInteger: 8 ofObject: rcvr.
  interpreterProxy failed ifTrue:[^nil].
  zipReadLimit := zipReadLimit - 1.
  zipSourcePos := zipSourcePos - 1.
  zipSourceLimit := zipSourceLimit - 1.
 
  "collection"
  oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
+ (interpreterProxy isBytes: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^interpreterProxy primitiveFail].
- (interpreterProxy isBytes: oop)
- ifFalse:[^interpreterProxy primitiveFail].
  zipCollection := interpreterProxy firstIndexableField: oop.
  zipCollectionSize := interpreterProxy byteSizeOf: oop.
 
  "source"
  oop := interpreterProxy fetchPointer: 6 ofObject: rcvr.
+ (interpreterProxy isBytes: oop) ifFalse:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy isIntegerObject: oop)
- ifTrue:[^interpreterProxy primitiveFail].
- (interpreterProxy isBytes: oop)
- ifFalse:[^interpreterProxy primitiveFail].
  zipSource := interpreterProxy firstIndexableField: oop.
 
  "do the primitive"
  self zipDecompressBlock.
+ interpreterProxy failed ifFalse: "store modified values back"
+ [interpreterProxy storeInteger: 2 ofObject: rcvr withValue: zipReadLimit + 1.
- interpreterProxy failed ifFalse:[
- "store modified values back"
- interpreterProxy storeInteger: 2 ofObject: rcvr withValue: zipReadLimit + 1.
  interpreterProxy storeInteger: 3 ofObject: rcvr withValue: zipState.
  interpreterProxy storeInteger: 4 ofObject: rcvr withValue: zipBitBuf.
  interpreterProxy storeInteger: 5 ofObject: rcvr withValue: zipBitPos.
  interpreterProxy storeInteger: 7 ofObject: rcvr withValue: zipSourcePos + 1.
+ interpreterProxy pop: 2]!
- interpreterProxy pop: 2.
- ].!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveIntegerAt (in category 'sound primitives') -----
  primitiveIntegerAt
  "Return the 32bit signed integer contents of a words receiver"
 
  | index rcvr sz addr value intValue |
  <var: #intValue type: 'int'>
  index := self stackIntegerValue: 0.
  self successful ifFalse:
  [^self primitiveFailFor: PrimErrBadArgument].
  rcvr := self stackValue: 1.
+ (objectMemory isWords: rcvr) ifFalse:
- ((objectMemory isIntegerObject: rcvr)
- or: [(objectMemory isWords: rcvr) not]) ifTrue:
  [^self primitiveFailFor: PrimErrInappropriate].
  sz := objectMemory lengthOf: rcvr.  "number of fields"
  ((index >= 1) and: [index <= sz]) ifFalse:
  [^self primitiveFailFor: PrimErrBadIndex].
+ "4 = 32 bits / 8"
+ addr := rcvr + objectMemory baseHeaderSize + (index - 1 * 4). "for zero indexing"
+ value := objectMemory intAt: addr.
- addr := rcvr + BaseHeaderSize + (index - 1 * BytesPerWord). "for zero indexing"
- value := self intAt: addr.
  self pop: 2.  "pop rcvr, index"
  "push element value"
  (objectMemory isIntegerValue: value)
  ifTrue: [self pushInteger: value]
  ifFalse: [intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
  self push: (self signed32BitIntegerFor: intValue)] "intValue may be sign extended to 64 bit sqInt"!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveIntegerAtPut (in category 'sound primitives') -----
  primitiveIntegerAtPut
  "Return the 32bit signed integer contents of a words receiver"
  | index rcvr sz addr value valueOop |
  <var: 'value' type: 'int'>
  valueOop := self stackValue: 0.
  index := self stackIntegerValue: 1.
  value := self signed32BitValueOf: valueOop.
  self successful ifFalse:
  [^self primitiveFailFor: PrimErrBadArgument].
  rcvr := self stackValue: 2.
+ (objectMemory isWords: rcvr) ifFalse:
- ((objectMemory isIntegerObject: rcvr)
- or: [(objectMemory isWords: rcvr) not]) ifTrue:
  [^self primitiveFailFor: PrimErrInappropriate].
  sz := objectMemory lengthOf: rcvr.  "number of fields"
  (index >= 1 and: [index <= sz]) ifFalse:
  [^self primitiveFailFor: PrimErrBadIndex].
+ "4 = 32 bits / 8"
+ addr := rcvr + objectMemory baseHeaderSize + (index - 1 * 4). "for zero indexing"
+ value := objectMemory intAt: addr put: value.
- addr := rcvr + BaseHeaderSize + (index - 1 * BytesPerWord). "for zero indexing"
- value := self intAt: addr put: value.
  self pop: 3 thenPush: valueOop "pop all; return value"
  !

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>intAt:put: (in category 'memory access') -----
+ intAt: byteAddress put: a32BitValue
+ ^self longAt: byteAddress put: (a32BitValue bitAnd: 16rFFFFFFFF)!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>storeInteger:ofObject:withValue: (in category 'simulation only') -----
+ storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue
+ "hack around the CoInterpreter/ObjectMemory split refactoring"
+ ^coInterpreter storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue!

Item was changed:
  ----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') -----
  isIntegerObject: oop
  "This list records the valid senders of isIntegerObject: as we replace uses of
   isIntegerObject: by isImmediate: where appropriate."
  | sel |
  sel := thisContext sender method selector.
  (#( DoIt
  DoItIn:
  on:do: "from the debugger"
  makeBaseFrameFor:
  quickFetchInteger:ofObject:
  frameOfMarriedContext:
  objCouldBeClassObj:
  isMarriedOrWidowedContext:
  shortPrint:
  bytecodePrimAt
  bytecodePrimAtPut
  commonAt:
  commonAtPut:
  loadFloatOrIntFrom:
  positive32BitValueOf:
  primitiveExternalCall
  checkedIntegerValueOf:
  bytecodePrimAtPut
  commonAtPut:
  primitiveVMParameter
  checkIsStillMarriedContext:currentFP:
  displayBitsOf:Left:Top:Right:Bottom:
  fetchStackPointerOf:
  primitiveContextAt
  primitiveContextAtPut
  subscript:with:storing:format:
  printContext:
  compare31or32Bits:equal:
  signed64BitValueOf:
  primDigitMultiply:negative:
  digitLength:
  isNegativeIntegerValueOf:
  magnitude64BitValueOf:
  primitiveMakePoint
  primitiveAsCharacter
  primitiveInputSemaphore
  baseFrameReturn
  primitiveExternalCall
  primDigitCompare:
  isLiveContext:
  numPointerSlotsOf:
  fileValueOf:
  loadBitBltDestForm
  fetchIntOrFloat:ofObject:ifNil:
  fetchIntOrFloat:ofObject:
  loadBitBltSourceForm
  loadPoint:from:
  primDigitAdd:
  primDigitSubtract:
+ positive64BitValueOf:
+ digitBitLogic:with:opIndex:
+ signed32BitValueOf:) includes: sel) ifFalse:
- positive64BitValueOf:) includes: sel) ifFalse:
  [self halt].
  ^(oop bitAnd: 1) ~= 0!

Item was changed:
  ----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
  longPrintOop: oop
  <api>
  | class fmt lastIndex startIP bytecodesPerLine column |
  ((objectMemory isImmediate: oop)
  or: [(objectMemory addressCouldBeObj: oop) not
  or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
  or: [(objectMemory isFreeObject: oop)
  or: [objectMemory isForwarded: oop]]]]) ifTrue:
  [^self printOop: oop].
  class := objectMemory fetchClassOfNonImm: oop.
  self printHex: oop;
  print: ': a(n) '; printNameOfClass: class count: 5;
  print: ' ('; printHex: class; print: ')'.
  fmt := objectMemory formatOf: oop.
+ self print: ' format '; printHexnp: fmt.
- self print: ' format '; printHex: fmt.
  fmt > objectMemory lastPointerFormat ifTrue:
  [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
  objectMemory printHeaderTypeOf: oop.
+ self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
- self print: ' hash '; printHex: (objectMemory rawHashBitsOf: oop).
  self cr.
  (fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
  [^self].
  "this is nonsense.  apologies."
  startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
  lastIndex := 256 min: startIP.
  lastIndex > 0 ifTrue:
  [1 to: lastIndex do:
  [:i| | fieldOop |
  fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
  self space; printNum: i - 1; space; printHex: fieldOop; space.
  (i = 1 and: [objectMemory isCompiledMethod: oop])
  ifTrue: [self printMethodHeaderOop: fieldOop]
  ifFalse: [self printOopShort: fieldOop].
  self cr]].
  (objectMemory isCompiledMethod: oop)
  ifFalse:
  [startIP > 64 ifTrue: [self print: '...'; cr]]
  ifTrue:
  [startIP := startIP * BytesPerWord + 1.
  lastIndex := objectMemory lengthOf: oop.
  lastIndex - startIP > 100 ifTrue:
  [lastIndex := startIP + 100].
  bytecodesPerLine := 8.
  column := 1.
  startIP to: lastIndex do:
  [:index| | byte |
  column = 1 ifTrue:
  [self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
  inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
  byte := objectMemory fetchByte: index - 1 ofObject: oop.
  self cCode: 'printf(" %02x/%-3d", byte,byte)'
  inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
  column := column + 1.
  column > bytecodesPerLine ifTrue:
  [column := 1. self cr]].
  column = 1 ifFalse:
  [self cr]]!

Item was changed:
  ----- Method: StackInterpreter>>printCallStackOf: (in category 'debug printing') -----
+ printCallStackOf: aContextOrProcessOrFrame
- printCallStackOf: aContextOrProcess
  <api>
  | context |
  <inline: false>
  <var: #theFP type: #'char *'>
+ (stackPages couldBeFramePointer: aContextOrProcessOrFrame) ifTrue:
+ [^self printCallStackFP: (self cCoerceSimple: aContextOrProcessOrFrame to: #'char *')].
+ ((objectMemory isContext: aContextOrProcessOrFrame) not
+ and: [(objectMemory lengthOf: aContextOrProcessOrFrame) > MyListIndex
- ((objectMemory isContext: aContextOrProcess) not
- and: [(objectMemory lengthOf: aContextOrProcess) > MyListIndex
  and: [objectMemory isContext: (objectMemory
  fetchPointer: SuspendedContextIndex
+ ofObject: aContextOrProcessOrFrame)]]) ifTrue:
- ofObject: aContextOrProcess)]]) ifTrue:
  [^self printCallStackOf: (objectMemory
  fetchPointer: SuspendedContextIndex
+ ofObject: aContextOrProcessOrFrame)].
+ context := aContextOrProcessOrFrame.
- ofObject: aContextOrProcess)].
- context := aContextOrProcess.
  [context = objectMemory nilObject] whileFalse:
  [(self isMarriedOrWidowedContext: context)
  ifTrue:
  [(self checkIsStillMarriedContext: context currentFP: framePointer) ifFalse:
  [self shortPrintContext: context.
  ^nil].
  context := self shortReversePrintFrameAndCallers: (self frameOfMarriedContext: context)]
  ifFalse:
  [context := self printContextCallStackOf: context]]!

Item was added:
+ ----- Method: StackInterpreter>>printHexnp: (in category 'debug printing') -----
+ printHexnp: n
+ "Print n in hex,  in the form '0x1234', unpadded"
+ self print: '0x%x' f: n!

Item was added:
+ ----- Method: StackInterpreter>>printStackCallStack (in category 'debug printing') -----
+ printStackCallStack
+ <doNotGenerate>
+ | theFP context |
+ theFP := localFP.
+ [context := self shortReversePrintFrameAndCallers: theFP.
+ ((self isMarriedOrWidowedContext: context)
+  and: [self checkIsStillMarriedContext: context currentFP: localFP]) ifFalse:
+ [^nil].
+ theFP := self frameOfMarriedContext: context] repeat!

Item was added:
+ ----- Method: StackInterpreterSimulator>>printHexnp: (in category 'debug printing') -----
+ printHexnp: anInteger
+
+ traceOn ifTrue:
+ [transcript nextPutAll: (anInteger storeStringBase: 16)]!

Item was changed:
  ----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
  utilitiesMenu: aMenuMorph
  aMenuMorph
  add: 'toggle transcript' action: #toggleTranscript;
  addLine;
  add: 'print ext head frame' action: #printExternalHeadFrame;
  add: 'print int head frame' action: #printHeadFrame;
  add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
  add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
  add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
  add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP];
  add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
  add: 'print call stack' action: #printCallStack;
+ add: 'print stack call stack' action: #printStackCallStack;
  add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]];
  add: 'print all stacks' action: #printAllStacks;
+ add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP.
+ self writeBackHeadFramePointers];
  addLine;
  add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
  add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]];
  addLine;
  add: 'inspect object memory' target: objectMemory action: #inspect;
  add: 'inspect cointerpreter' action: #inspect;
  addLine;
  add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
  s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
  add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector'.
  s notEmpty ifTrue: [self setBreakSelector: s]];
  add: (printSends
  ifTrue: ['no print sends']
  ifFalse: ['print sends'])
  action: [self ensureDebugAtEachStepBlock.
  printSends := printSends not];
  "currently printReturns does nothing"
  "add: (printReturns
  ifTrue: ['no print returns']
  ifFalse: ['print returns'])
  action: [self ensureDebugAtEachStepBlock.
  printReturns := printReturns not];"
  add: (printBytecodeAtEachStep
  ifTrue: ['no print bytecode each bytecode']
  ifFalse: ['print bytecode each bytecode'])
  action: [self ensureDebugAtEachStepBlock.
  printBytecodeAtEachStep := printBytecodeAtEachStep not];
  add: (printFrameAtEachStep
  ifTrue: ['no print frame each bytecode']
  ifFalse: ['print frame each bytecode'])
  action: [self ensureDebugAtEachStepBlock.
  printFrameAtEachStep := printFrameAtEachStep not].
  ^aMenuMorph!