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

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

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

Name: VMMaker.oscog-eem.2438
Author: eem
Time: 9 September 2018, 9:16:27.338139 am
UUID: 17aec2b1-c603-430a-bd37-c283e35e864f
Ancestors: VMMaker.oscog-eem.2437

General robustness, compatibility and cleanups.

Make localNameFor: a self send implemented for compatiblity above FileDirectory and FileSystem.  Analogously so for uiProcess & vmPath[Size] above Pharo & Squeak.

A few fewer isKindOf:s.

Fix some receiuvers in NewObjectMemory (can it be that long since we've simulated a V3 image?? Yes :-))

FIx a C compiler warning in returnAs:ThroughCallback:Context:.

Fix an MNU in printing incomplete TSend nodes that broke the Pharo6 debugger.

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

Item was changed:
  ----- Method: CCodeGenerator>>isCLiteral: (in category 'C code generator') -----
  isCLiteral: anObject
+ anObject isInteger ifTrue: [^true].
+ anObject isString ifTrue: [^true].
+ anObject isFloat ifTrue: [^true].
- (anObject isKindOf: Integer) ifTrue: [^true].
- (anObject isKindOf: String) ifTrue: [^true].
- (anObject isKindOf: Float) ifTrue: [^true].
  anObject == nil ifTrue: [^true].
  anObject == true ifTrue: [^true]. "ikp"
  anObject == false ifTrue: [^true]. "ikp"
+ anObject isCharacter ifTrue:[^true]. "ar"
- (anObject isKindOf: Character) ifTrue:[^true]. "ar"
  ^false!

Item was changed:
  ----- Method: CogMethodSurrogate>>+ (in category 'arithmetic') -----
+ + anInteger
+ "N.B. Mimic C semantics so that aCogMethod + 1 is a pointer to the byte past the CogMethod header."
+ ^address + (anInteger * self class alignedByteSize)!
- + aCogMethodOrAddress
- ^address + aCogMethodOrAddress asInteger!

Item was changed:
  ----- Method: CogVMSimulator>>imageNamePut:Length: (in category 'file primitives') -----
  imageNamePut: p Length: sz
  | newName window |
  newName := ByteString new: sz.
  1 to: sz  do:
  [:i |
  newName
  at: i
  put: (Character value: (objectMemory byteAt: p + i - 1))].
  imageName := newName.
  (displayView notNil
  and: [(window := displayView containingWindow) notNil]) ifTrue:
  [window setLabel: (window label
  copyReplaceFrom: (window label lastIndexOf: Character space) + 1
  to: window label size
+ with: (self localNameFor: imageName))]!
- with: (FileDirectory localNameFor: imageName))]!

Item was changed:
  ----- Method: CogVMSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  "Open a morphic view on this simulation."
  | localImageName borderWidth window |
  localImageName := imageName
+ ifNotNil: [self localNameFor: imageName]
- ifNotNil: [FileDirectory default localNameFor: imageName]
  ifNil: [' synthetic image'].
  window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  window paneColor: self windowColorToUse.
 
  window addMorph: (displayView := SimulatorImageMorph new image: displayForm)
  frame: (0@0 corner: 1@0.8).
  displayView activeHand addEventListener: self.
  eventTransformer := SimulatorEventTransformer new.
 
  transcript := TranscriptStream on: (String new: 10000).
  window addMorph: (PluggableTextMorph
  on: transcript text: nil accept: nil
  readSelection: nil menu: #codePaneMenu:shifted:)
  frame: (0@0.8 corner: 0.7@1).
  window addMorph: (PluggableTextMorph on: self
  text: #byteCountText accept: nil
  readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  frame: (0.7@0.8 corner: 1@1).
 
  borderWidth := [SystemWindow borderWidth] "Squeak 4.1"
  on: MessageNotUnderstood
  do: [:ex| 0]. "3.8"
  borderWidth := borderWidth + window borderWidth.
  window openInWorldExtent: (self desiredDisplayExtent
  + (2 * borderWidth @ borderWidth)
  + (0@window labelHeight)
  * (1@(1/0.8))) rounded.
  ^window!

Item was changed:
  ----- Method: CogVMSimulator>>openAsMorphNoTranscript (in category 'UI') -----
  openAsMorphNoTranscript
  "Open a morphic view on this simulation."
  | localImageName borderWidth window |
  localImageName := imageName
+ ifNotNil: [self localNameFor: imageName]
- ifNotNil: [FileDirectory default localNameFor: imageName]
  ifNil: [' synthetic image'].
  window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  window paneColor: self windowColorToUse.
 
  window addMorph: (displayView := SimulatorImageMorph new image: displayForm)
  frame: (0@0 corner: 1@0.95).
  displayView activeHand addEventListener: self.
  eventTransformer := SimulatorEventTransformer new.
 
  window addMorph: (PluggableTextMorph on: self
  text: #byteCountText accept: nil
  readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  frame: (0@0.95 corner: 1@1).
 
  borderWidth := [SystemWindow borderWidth] "Squeak 4.1"
  on: MessageNotUnderstood
  do: [:ex| 0]. "3.8"
  borderWidth := borderWidth + window borderWidth.
  window openInWorldExtent: (self desiredDisplayExtent
  + (2 * borderWidth@borderWidth)
  + (0@window labelHeight)
  * (1@(1/0.95))) rounded!

Item was changed:
  ----- Method: CogVMSimulator>>vmPathGet:Length: (in category 'file primitives') -----
  vmPathGet: stringBase Length: stringSize
  | pathName stringOop |
+ pathName := self vmPath.
- pathName := Smalltalk vmPath.
  stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
  1 to: stringSize do:
  [:i | objectMemory storeByte: i-1 ofObject: stringOop
  withValue: (pathName at: i) asciiValue].
  !

Item was removed:
- ----- Method: CogVMSimulator>>vmPathSize (in category 'file primitives') -----
- vmPathSize
- ^ Smalltalk vmPath size!

Item was changed:
  ----- Method: InterpreterProxy>>is:KindOf: (in category 'testing') -----
  is: oop KindOf: aString
  "InterpreterProxy new is: 42 KindOf: 'Number'"
- | theClass |
  <var: #aString type:'char *'>
+ (Smalltalk at: aString asSymbol ifAbsent:[nil])
+ ifNil:[false]
+ ifNotNil: [:theClass| oop isKindOf: theClass]!
- theClass := Smalltalk at: aString asSymbol ifAbsent:[nil].
- ^theClass isNil
- ifTrue:[false]
- ifFalse:[^oop isKindOf: theClass]!

Item was changed:
  ----- Method: InterpreterSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  "Open a morphic view on this simulation."
  | window localImageName |
  localImageName := imageName
+ ifNotNil: [self localNameFor: imageName]
- ifNotNil: [FileDirectory default localNameFor: imageName]
  ifNil: [' synthetic image'].
  window := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self.
 
  window addMorph: (displayView := ImageMorph new image: displayForm)
  frame: (0@0 corner: 1@0.8).
 
  transcript := TranscriptStream on: (String new: 10000).
  window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil
  readSelection: nil menu: #codePaneMenu:shifted:)
  frame: (0@0.8 corner: 0.7@1).
 
  window addMorph: (PluggableTextMorph on: self
  text: #byteCountText accept: nil) hideScrollBarsIndefinitely
  frame: (0.7@0.8 corner: 1@1).
 
  window openInWorld.
  ^window!

Item was changed:
  ----- Method: InterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
  vmPathGet: stringBase Length: stringSize
  | pathName stringOop |
+ pathName := self vmPath.
- pathName := Smalltalk vmPath.
  stringOop := stringBase - self baseHeaderSize. "Due to C call in Interp"
  1 to: stringSize do:
  [:i | self storeByte: i-1 ofObject: stringOop
  withValue: (pathName at: i) asciiValue].
  !

Item was removed:
- ----- Method: InterpreterSimulator>>vmPathSize (in category 'file primitives') -----
- vmPathSize
- ^ Smalltalk vmPath size!

Item was added:
+ ----- Method: NewObjectMemory>>finalizeReference: (in category 'finalization') -----
+ finalizeReference: oop
+ "During sweep phase we have encountered a weak reference. Check if its object
+ has gone away (or is about to) and if so, signal a semaphore.  Do *not* inline
+ this in sweepPhase - it is quite an unlikely case to run into a weak reference.
+ Override to ask the coInterpreter to signal finalization."
+ | weakOop oopGone chunk numFields firstField lastField |
+ <inline: false>
+ <var: #oop type: #usqInt>
+ <var: #weakOop type: #usqInt>
+ numFields := self nonWeakFieldsOf: oop. "so nonWeakFieldsOf: may be inlined"
+ firstField := self baseHeaderSize + (numFields << self shiftForWord).
+ lastField := self lastPointerOf: oop.
+ firstField to: lastField by: self wordSize do:
+ [:i|
+ weakOop := self longAt: oop + i.
+ "ar 1/18/2005: Added oop < youngStart test to make sure we're not testing
+ objects in non-GCable region. This could lead to a forward reference in
+ old space with the oop pointed to not being marked and thus treated as free."
+ (weakOop = nilObj or: [(self isIntegerObject: weakOop) or:[weakOop < youngStart]]) ifFalse:
+ ["Check if the object is being collected.
+ If the weak reference points  
+ * backward: check if the weakOops chunk is free
+ * forward: check if the weakOoop has been marked by GC"
+ weakOop < oop
+ ifTrue: [chunk := self chunkFromOop: weakOop.
+ oopGone := ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree]
+ ifFalse: [oopGone := (self isMarked: weakOop) not].
+ oopGone ifTrue: "Store nil in the pointer and signal the  interpreter"
+ [self longAt: oop + i put: nilObj.
+ self
+ cppIf: PharoVM
+ ifTrue: [numFields >= 2 ifTrue: [self weakFinalizerCheck: oop]].
+ coInterpreter signalFinalization: oop]]]!

Item was changed:
  ----- Method: NewObjectMemory>>fullGC (in category 'garbage collection') -----
  fullGC
  "Do a mark/sweep garbage collection of the entire object memory.
  Free inaccessible objects but do not move them."
 
  <inline: false>
  fullGCLock > 0 ifTrue:
  [self warning: 'aborting fullGC because fullGCLock > 0'.
  ^self].
  self runLeakCheckerFor: GCModeFull.
+ coInterpreter preGCAction: GCModeFull.
- self preGCAction: GCModeFull.
  needGCFlag := false.
  gcStartUsecs := self ioUTCMicrosecondsNow.
  statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
  self clearRootsTable.
  self initWeakTableForIncrementalGC: false.
  youngStart := self startOfMemory.  "process all of memory"
  self markPhase: true.
  "Sweep phase returns the number of survivors.
  Use the up-to-date version instead the one from startup."
  totalObjectCount := self sweepPhaseForFullGC.
  self runLeakCheckerFor: GCModeFull.
  self fullCompaction.
  statFullGCs := statFullGCs + 1.
  statGCEndUsecs := self ioUTCMicrosecondsNow.
  statFullGCUsecs := statFullGCUsecs + (statGCEndUsecs - gcStartUsecs).
+ coInterpreter capturePendingFinalizationSignals.
- self capturePendingFinalizationSignals.
 
  youngStart := freeStart.  "reset the young object boundary"
  self attemptToShrink.
+ coInterpreter postGCAction: GCModeFull.
- self postGCAction: GCModeFull.
  self runLeakCheckerFor: GCModeFull!

Item was changed:
  ----- Method: NewObjectMemory>>incrementalGC (in category 'garbage collection') -----
  incrementalGC
  "Do a mark/sweep garbage collection of just the young object
  area of object memory (i.e., objects above youngStart), using
  the root table to identify objects containing pointers to
  young objects from the old object area."
  | survivorCount weDidGrow |
  <inline: false>
 
  rootTableOverflowed ifTrue:
  ["root table overflow; cannot do an incremental GC because some roots are missing.
  (this should be very rare)"
  statRootTableOverflows := statRootTableOverflows + 1.
  ^self fullGC].
  self runLeakCheckerFor: GCModeNewSpace.
  coInterpreter preGCAction: GCModeNewSpace.
  needGCFlag := false.
  gcStartUsecs := self ioUTCMicrosecondsNow.
  statSweepCount := statMarkCount := statMkFwdCount := statCompMoveCount := 0.
  self initWeakTableForIncrementalGC: true.
  "implicitly process memory from youngStart to freeStart"
  self markPhase: false.
  self assert: weakRootCount <= WeakRootTableSize.
  1 to: weakRootCount do:
  [:i| self finalizeReference: (weakRoots at: i)].
  survivorCount := self sweepPhase.
  self runLeakCheckerFor: GCModeNewSpace.
  self incrementalCompaction.
  statIncrGCs := statIncrGCs + 1.
  statGCEndUsecs := self ioUTCMicrosecondsNow.
  statIGCDeltaUsecs := statGCEndUsecs - gcStartUsecs.
  statIncrGCUsecs := statIncrGCUsecs + statIGCDeltaUsecs.
+ coInterpreter capturePendingFinalizationSignals.
- self capturePendingFinalizationSignals.
 
  statRootTableCount  := rootTableCount.
  statSurvivorCount := survivorCount.
  weDidGrow := false.
  (((survivorCount > tenuringThreshold)
  or: [rootTableCount >= RootTableRedZone])
  or: [forceTenureFlag == true]) ifTrue:
  ["move up the young space boundary if
   * there are too many survivors:
  this limits the number of objects that must be
  processed on future incremental GC's
   * we're about to overflow the roots table:
  this limits the number of full GCs that may be caused
  by root table overflows in the near future"
  forceTenureFlag := false.
  statTenures := statTenures + 1.
  self clearRootsTable.
  ((self freeSize < growHeadroom)
  and: [gcBiasToGrow > 0]) ifTrue:
  [self biasToGrow.
  weDidGrow := true].
  youngStart := freeStart].
  self attemptToShrink.
  coInterpreter postGCAction: GCModeNewSpace.
 
  self runLeakCheckerFor: GCModeNewSpace.
  weDidGrow ifTrue:
  [self biasToGrowCheckGCLimit]!

Item was changed:
  ----- Method: NewObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') -----
  initializeMemoryFirstFree: firstFree
  "Initialize endOfMemory to the top of oop storage space, reserving some space
  for forwarding blocks, and set freeStart from which space is allocated."
  "Note: The amount of space reserved for forwarding blocks should be chosen to
   ensure that incremental compactions can usually be done in a single pass.
   However, there should be enough forwarding blocks so a full compaction can be done
   in a reasonable number of passes, say ten. (A full compaction requires N object-moving
   passes, where N = number of non-garbage objects / number of forwarding blocks).
 
  di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be
  used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means
  an absolute worst case of 8 passes to compact memory. In most cases it will be
  adequate to do compaction in a single pass. "
  | fwdBlockBytes totalReserve |
  "reserve space for forwarding blocks and the interpreter.  We can sacrifice
  forwarding block space at the cost of slower compactions but we cannot
  safely sacrifice interpreter allocation headroom."
  fwdBlockBytes := totalObjectCount bitAnd: WordMask - self wordSize + 1.
+ totalReserve := fwdBlockBytes + coInterpreter interpreterAllocationReserveBytes.
- totalReserve := fwdBlockBytes + self interpreterAllocationReserveBytes.
  (self oop: memoryLimit - totalReserve isLessThan: firstFree + self baseHeaderSize) ifTrue:
  ["reserve enough space for a minimal free block of BaseHeaderSize bytes.
   We are apparently in an emergency situation here because we have no space
   for reserve and forwarding blocks.  But a full GC will occur immediately in
   sufficientSpaceAfterGC: which will grow memory and restore the reserve."
  fwdBlockBytes := memoryLimit - (firstFree  + self baseHeaderSize)].
 
  "set endOfMemory reserveStart and freeStart"
  self setEndOfMemory: memoryLimit - fwdBlockBytes.
+ reserveStart := endOfMemory - coInterpreter interpreterAllocationReserveBytes.
- reserveStart := endOfMemory - self interpreterAllocationReserveBytes.
  freeStart := firstFree. "bytes available for oops"
  scavengeThreshold := freeStart + edenBytes min: reserveStart.
  self maybeFillWithAllocationCheckFillerFrom: freeStart to: scavengeThreshold.
 
  self assert: (self oop: freeStart isLessThan: reserveStart).
  "We would like to assert this but can't because in GC situations it may be false.  It is
  established by sufficientSpaceToAllocate: and sufficientSpaceAfterGC:"
  false ifTrue: [self assert: (self oop: reserveStart isLessThan: endOfMemory)].
  self assert: (self oop: endOfMemory isLessThan: memoryLimit)!

Item was changed:
  ----- Method: NewObjectMemory>>markPhase: (in category 'gc -- mark and sweep') -----
  markPhase: fullGCFlag
  "Mark phase of the mark and sweep garbage collector. Set
  the mark bits of all reachable objects. Free chunks are
  untouched by this process."
  "Assume: All non-free objects are initially unmarked. Root
  objects were unmarked when they were made roots.
  (Make sure this stays true!!!!)."
  | oop statMarkCountPriorToStackPageFreeing |
  <inline: false>
  "trace the interpreter's objects, including the active stacks
  and special objects array"
+ coInterpreter markAndTraceInterpreterOops: fullGCFlag.
- self markAndTraceInterpreterOops: fullGCFlag.
  statSpecialMarkCount := statMarkCount.
  "trace the roots"
  1 to: rootTableCount do:
  [:i |
  oop := rootTable at: i.
  self markAndTrace: oop].
  1 to: extraRootCount do:
  [:i|
  oop := (extraRoots at: i) at: 0.
  ((self isIntegerObject: oop) or: [self isFreeObject: oop]) ifFalse:
  [self markAndTrace: oop]].
  statMarkCountPriorToStackPageFreeing := statMarkCount.
  "Only safe to free stack pages after all roots have been traced."
+ coInterpreter markAndTraceAndMaybeFreeStackPages: fullGCFlag.
- self markAndTraceAndMaybeFreeStackPages: fullGCFlag.
  "Only safe to free any machine code methods after all
  stack pages have been traced."
+ coInterpreter markAndTraceOrFreeMachineCode: fullGCFlag.
- self markAndTraceOrFreeMachineCode: fullGCFlag.
  statSpecialMarkCount := statSpecialMarkCount + (statMarkCount - statMarkCountPriorToStackPageFreeing)!

Item was changed:
  ----- Method: NewObjectMemory>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
 
  "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."
 
  "The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers).  If either array is too small, the primitive will fail, but in no other case.
 
  During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values.  To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type).  Tables are kept of both kinds of oops, as well as of the original headers for restoration.
 
  To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray.  Each grows oops from the bottom up, and preserved headers from halfway up.
 
  In case of either success or failure, the headers must be restored.  In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."
 
  | savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop
   doingClass lastPtr extraSize hdrTypeBits hdrBaseIn hdrBaseOut header firstOut versionOffset |
  <inline: false>
  <var: #firstIn type: #usqInt>
  <var: #lastIn type: #usqInt>
  <var: #firstOut type: #usqInt>
  <var: #lastOut type: #usqInt>
  <var: #hdrBaseIn type: #usqInt>
  <var: #hdrBaseOut type: #usqInt>
  <var: #lastSeg type: #usqInt>
  <var: #endSeg type: #usqInt>
  <var: #fieldPtr type: #usqInt>
  <var: #lastPtr type: #usqInt>
  <var: #segOop type: #usqInt>
  <var: #savedYoungStart type: #usqInt>
 
  ((self headerType: outPointerArray) = HeaderTypeSizeAndClass "Must be 3-word header"
  and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass]) "Must be 3-word header"
  ifFalse: [^PrimErrGenericFailure].
 
  DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  "Use the top half of outPointers for saved headers."
  firstOut := outPointerArray + self baseHeaderSize.
  lastOut := firstOut - self wordSize.
  hdrBaseOut := outPointerArray + ((self lastPointerOf: outPointerArray) // (self wordSize*2) * self wordSize). "top half"
 
  lastSeg := segmentWordArray.
  endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self wordSize.
 
  "Write a version number for byte order and version check"
  versionOffset := self wordSize.
  lastSeg := lastSeg + versionOffset.
  lastSeg > endSeg ifTrue: [^PrimErrGenericFailure].
  self longAt: lastSeg put: self imageSegmentVersion.
 
  "Allocate top 1/8 of segment for table of internal oops and saved headers"
  firstIn := endSeg - ((self sizeBitsOf: segmentWordArray) // (self wordSize*8) * self wordSize).  "Take 1/8 of seg"
  lastIn := firstIn - self wordSize.
  hdrBaseIn := firstIn + ((self sizeBitsOf: segmentWordArray) // (self wordSize*16) * self wordSize). "top half of that"
 
  "First mark the rootArray and all root objects."
  self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: MarkBit).
  lastPtr := arrayOfRoots + (self lastPointerOf: arrayOfRoots).
  fieldPtr := arrayOfRoots + self baseHeaderSize.
  [fieldPtr <= lastPtr] whileTrue:
  [fieldOop := self longAt: fieldPtr.
  (self isIntegerObject: fieldOop) ifFalse:
  [self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: MarkBit)].
  fieldPtr := fieldPtr + self wordSize].
 
  "Then do a mark pass over all objects.  This will stop at our marked roots,
  thus leaving our segment unmarked in their shadow."
  savedYoungStart := youngStart.
  youngStart := self startOfMemory.  "process all of memory"
+ coInterpreter markAndTraceInterpreterOops: false. "and special objects array"
- self markAndTraceInterpreterOops: false. "and special objects array"
  youngStart := savedYoungStart.
 
  "Finally unmark the rootArray and all root objects."
  self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: AllButMarkBit).
  fieldPtr := arrayOfRoots + self baseHeaderSize.
  [fieldPtr <= lastPtr] whileTrue:
  [fieldOop := self longAt: fieldPtr.
  (self isIntegerObject: fieldOop) ifFalse:
  [self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: AllButMarkBit)].
  fieldPtr := fieldPtr + self wordSize].
 
  "All external objects, and only they, are now marked.
  Copy the array of roots into the segment, and forward its oop."
  lastIn := lastIn + self wordSize.
  (lastIn >= hdrBaseIn
  or: [0 = (lastSeg := self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn))]) ifTrue:
  [lastIn := lastIn - self wordSize.
  self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
  ^self primitiveFailCodeAfterCleanup: outPointerArray].
 
  "Now run through the segment fixing up all the pointers.
  Note that more objects will be added to the segment as we make our way along."
  segOop := self oopFromChunk: segmentWordArray + versionOffset + self baseHeaderSize.
  [segOop <= lastSeg] whileTrue:
  [(self headerType: segOop) <= 1
  ifTrue: ["This object has a class field (type=0 or 1) -- start with that."
  fieldPtr := segOop - self wordSize.  doingClass := true]
  ifFalse: ["No class field -- start with first data field"
  fieldPtr := segOop + self baseHeaderSize.  doingClass := false].
  lastPtr := segOop + (self lastPointerOf: segOop). "last field"
 
  "Go through all oops, remapping them..."
  [fieldPtr > lastPtr] whileFalse:
  ["Examine each pointer field"
  fieldOop := self longAt: fieldPtr.
  doingClass ifTrue:
  [hdrTypeBits := fieldOop bitAnd: TypeMask.
  fieldOop := fieldOop - hdrTypeBits].
  (self isIntegerObject: fieldOop)
  ifTrue: ["Just an integer -- nothing to do"
  fieldPtr := fieldPtr + self wordSize]
  ifFalse:
  [header := self longAt: fieldOop.
  (header bitAnd: TypeMask) = HeaderTypeFree
  ifTrue: ["Has already been forwarded -- this is the link"
  mapOop := header bitAnd: AllButTypeMask]
  ifFalse:
  [((self longAt: fieldOop) bitAnd: MarkBit) = 0
  ifTrue:
  ["Points to an unmarked obj -- an internal pointer.
  Copy the object into the segment, and forward its oop."
  lastIn := lastIn + self wordSize.
  (lastIn >= hdrBaseIn
  or: [0 = (lastSeg := self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn))]) ifTrue:
  ["Out of space in segment"
  lastIn := lastIn - self wordSize.
  self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
  ^self primitiveFailCodeAfterCleanup: outPointerArray].
  mapOop := (self longAt: fieldOop) bitAnd: AllButTypeMask]
  ifFalse:
  ["Points to a marked obj -- an external pointer.
  Map it as a tagged index in outPointers, and forward its oop."
  lastOut := lastOut + self wordSize.
  lastOut >= hdrBaseOut ifTrue:
  ["Out of space in outPointerArray"
  lastOut := lastOut - self wordSize.
  self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
  ^self primitiveFailCodeAfterCleanup: outPointerArray].
  . mapOop := lastOut - outPointerArray bitOr: 16r80000000.
  self forward: fieldOop to: mapOop
  savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]].
  "Replace the oop by its mapped value"
  doingClass
  ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
  fieldPtr := fieldPtr + (self wordSize*2).
  doingClass := false]
  ifFalse: [self longAt: fieldPtr put: mapOop.
  fieldPtr := fieldPtr + self wordSize]]].
  segOop := self objectAfter: segOop].
 
  self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
 
  "Truncate the outPointerArray..."
  ((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12
  or: [(endSeg - lastSeg) < 12]) ifTrue:
  ["Not enough room to insert simple 3-word headers"
  ^self primitiveFailCodeAfterCleanup: outPointerArray].
  extraSize := self extraHeaderBytes: segmentWordArray.
  hdrTypeBits := self headerType: segmentWordArray.
  "Copy the 3-word wordArray header to establish a free chunk."
  self transfer: 3
  from: segmentWordArray - extraSize
  to: lastOut+self wordSize.
  "Adjust the size of the original as well as the free chunk."
  self longAt: lastOut+self wordSize
  put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits.
  self longAt: outPointerArray-extraSize
  put: lastOut - firstOut + (self wordSize*2) + hdrTypeBits.
  "Note that pointers have been stored into roots table"
  self beRootIfOld: outPointerArray.
 
  "Truncate the image segment..."
  "Copy the 3-word wordArray header to establish a free chunk."
  self transfer: 3
  from: segmentWordArray - extraSize
  to: lastSeg+self wordSize.
  "Adjust the size of the original as well as the free chunk."
  self longAt: segmentWordArray-extraSize
  put: lastSeg - segmentWordArray + self baseHeaderSize + hdrTypeBits.
  self longAt: lastSeg+self wordSize
  put: endSeg - lastSeg - extraSize + hdrTypeBits.
 
  DoAssertionChecks ifTrue: [self verifyCleanHeaders].
  ^PrimNoErr!

Item was changed:
  ----- Method: SpurMemoryManager>>mem:cp:y: (in category 'simulation') -----
  mem: destAddress cp: sourceAddress y: bytes
  "For SpurGenerationScavenger>>copyToFutureSpace:bytes:. N.B. If ranges overlap, must use memmove."
  <doNotGenerate>
+ self deny: ((destAddress <= sourceAddress and: [destAddress asInteger + bytes > sourceAddress])
+ or: [sourceAddress <= destAddress and: [sourceAddress asInteger + bytes > destAddress]]).
- self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress])
- or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]]).
  ^self mem: destAddress mo: sourceAddress ve: bytes!

Item was changed:
  ----- Method: StackInterpreter>>returnAs:ThroughCallback:Context: (in category 'callback support') -----
  returnAs: returnTypeOop ThroughCallback: vmCallbackContext Context: callbackMethodContext
  "callbackMethodContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
  Its sender is the VM's state prior to the callback.  Reestablish that state (via longjmp),
  and mark callbackMethodContext as dead."
  <export: true>
  <var: #vmCallbackContext type: #'VMCallbackContext *'>
  | calloutMethodContext theFP thePage |
  <var: #theFP type: #'char *'>
  <var: #thePage type: #'StackPage *'>
  self assert: primFailCode = 0.
  self assert: (objectMemory isIntegerObject: returnTypeOop).
+ self assert: (objectMemory isImmediate: vmCallbackContext asInteger) not.
- self assert: (objectMemory isImmediate: vmCallbackContext) not.
  self assert: ((objectMemory addressCouldBeObj: callbackMethodContext)
  and: [objectMemory isContext: callbackMethodContext]).
  self assert: (debugCallbackPath := 0) = 0.
  ((objectMemory isIntegerObject: returnTypeOop)
  and: [self isLiveContext: callbackMethodContext]) ifFalse:
  [self assert: (debugCallbackPath := 1) = 1.
  ^false].
  calloutMethodContext := self externalInstVar: SenderIndex ofContext: callbackMethodContext.
  (self isLiveContext: calloutMethodContext) ifFalse:
  [self assert: (debugCallbackPath := 2) = 2.
  ^false].
  self assert: (debugCallbackReturns := debugCallbackReturns + 1) > 0.
  "self assert: debugCallbackReturns < 3802."
  "We're about to leave this stack page; must save the current frame's instructionPointer."
  self push: instructionPointer.
  self externalWriteBackHeadFramePointers.
  "Mark callbackMethodContext as dead; the common case is that it is the current frame.
  We go the extra mile for the debugger."
  (self isSingleContext: callbackMethodContext)
  ifTrue:
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 4) > 0.
  self markContextAsDead: callbackMethodContext]
  ifFalse:
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 8) > 0.
  theFP := self frameOfMarriedContext: callbackMethodContext.
  self assert: (self frameReceiver: theFP) = (objectMemory splObj: ClassAlien).
  framePointer = theFP "common case"
  ifTrue:
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 16) > 0.
  (self isBaseFrame: theFP) ifFalse: "calloutMethodContext is immediately below on the same page.  Make it current."
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 32) > 0.
  instructionPointer := (self frameCallerSavedIP: theFP) asUnsignedInteger.
  stackPointer := theFP + (self frameStackedReceiverOffset: theFP) + objectMemory wordSize.
  framePointer := self frameCallerFP: theFP.
  self setMethod: (self frameMethodObject: framePointer).
  self restoreCStackStateForCallbackContext: vmCallbackContext.
  self assertValidExecutionPointe: instructionPointer r: framePointer s: stackPointer.
  "N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
   This matches the use of _setjmp in ia32abicc.c."
  self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
  ^true].
  stackPages freeStackPage: stackPage]
  ifFalse:
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 64) > 0.
  self externalDivorceFrame: theFP andContext: callbackMethodContext.
  self markContextAsDead: callbackMethodContext]].
  "Make the calloutMethodContext the active frame.  The case where calloutMethodContext
  is immediately below callbackMethodContext on the same page is handled above."
  (self isStillMarriedContext: calloutMethodContext)
  ifTrue:
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 128) > 0.
  theFP := self frameOfMarriedContext: calloutMethodContext.
  thePage := stackPages stackPageFor: theFP.
  "findSPOf:on: points to the word beneath the instructionPointer, but
   there is no instructionPointer on the top frame of the current page."
  self assert: thePage ~= stackPage.
  stackPointer := thePage headFP = theFP
  ifTrue: [thePage headSP]
  ifFalse: [(self findSPOf: theFP on: thePage) - objectMemory wordSize].
  framePointer := theFP.
  self assert: stackPointer < framePointer]
  ifFalse:
  [self assert: (debugCallbackPath := debugCallbackPath bitOr: 256) > 0.
  thePage := self makeBaseFrameFor: calloutMethodContext.
  self setStackPointersFromPage: thePage].
  instructionPointer := self popStack.
  self setMethod: (objectMemory fetchPointer: MethodIndex ofObject: calloutMethodContext).
  self setStackPageAndLimit: thePage.
  self restoreCStackStateForCallbackContext: vmCallbackContext.
  primitiveFunctionPointer := vmCallbackContext savedPrimFunctionPointer.
  "N.B. siglongjmp is defined as _longjmp on non-win32 platforms.
   This matches the use of _setjmp in ia32abicc.c."
  self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
  "NOTREACHED"
  ^true!

Item was changed:
  ----- Method: StackInterpreterSimulator>>imageNamePut:Length: (in category 'file primitives') -----
  imageNamePut: p Length: sz
  | newName window |
  newName := ByteString new: sz.
  1 to: sz  do:
  [:i |
  newName
  at: i
  put: (Character value: (objectMemory byteAt: p + i - 1))].
  imageName := newName.
  (displayView notNil
  and: [(window := displayView containingWindow) notNil]) ifTrue:
  [window setLabel: (window label
  copyReplaceFrom: (window label lastIndexOf: Character space) + 1
  to: window label size
+ with: (self localNameFor: imageName))]!
- with: (FileDirectory localNameFor: imageName))]!

Item was changed:
  ----- Method: StackInterpreterSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  "Open a morphic view on this simulation."
  | localImageName borderWidth window |
  localImageName := imageName
+ ifNotNil: [self localNameFor: imageName]
- ifNotNil: [FileDirectory default localNameFor: imageName]
  ifNil: [' synthetic image'].
  window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  window paneColor: self windowColorToUse.
 
  window addMorph: (displayView := SimulatorImageMorph new image: displayForm)
  frame: (0@0 corner: 1@0.8).
  displayView activeHand addEventListener: self.
  eventTransformer := SimulatorEventTransformer new.
 
  transcript := TranscriptStream on: (String new: 10000).
  window addMorph: (PluggableTextMorph
  on: transcript text: nil accept: nil
  readSelection: nil menu: #codePaneMenu:shifted:)
  frame: (0@0.8 corner: 0.7@1).
  window addMorph: (PluggableTextMorph on: self
  text: #byteCountText accept: nil
  readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  frame: (0.7@0.8 corner: 1@1).
 
  borderWidth := [SystemWindow borderWidth] "Squeak 4.1"
  on: MessageNotUnderstood
  do: [:ex| 0]. "3.8"
  borderWidth := borderWidth + window borderWidth.
  window openInWorldExtent: (self desiredDisplayExtent
  + (2 * borderWidth@borderWidth)
  + (0@window labelHeight)
  * (1@(1/0.8))) rounded.
  ^window!

Item was changed:
  ----- Method: StackInterpreterSimulator>>openAsMorphNoTranscript (in category 'UI') -----
  openAsMorphNoTranscript
  "Open a morphic view on this simulation."
  | localImageName borderWidth window |
  localImageName := imageName
+ ifNotNil: [self localNameFor: imageName]
- ifNotNil: [FileDirectory default localNameFor: imageName]
  ifNil: [' synthetic image'].
  window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  window paneColor: self windowColorToUse.
 
  window addMorph: (displayView := SimulatorImageMorph new image: displayForm)
  frame: (0@0 corner: 1@0.95).
  displayView activeHand addEventListener: self.
  eventTransformer := SimulatorEventTransformer new.
 
  window addMorph: (PluggableTextMorph on: self
  text: #byteCountText accept: nil
  readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  frame: (0@0.95 corner: 1@1).
 
  borderWidth := [SystemWindow borderWidth] "Squeak 4.1"
  on: MessageNotUnderstood
  do: [:ex| 0]. "3.8"
  borderWidth := borderWidth + window borderWidth.
  window openInWorldExtent: (self desiredDisplayExtent
  + (2 * borderWidth@borderWidth)
  + (0@window labelHeight)
  * (1@(1/0.95))) rounded!

Item was changed:
  ----- Method: StackInterpreterSimulator>>openAsSimulatorMorph (in category 'UI') -----
  openAsSimulatorMorph
  "Open a morphic view on this simulation. ala Bert Freudenberg's
  SqueakJS http://lively-web.org/users/bert/squeak.html        "
  | localImageName borderWidth window |
  localImageName := imageName
  ifNil: [' synthetic image']
+ ifNotNil: [self localNameFor: imageName].
- ifNotNil: [FileDirectory default localNameFor: imageName].
 
  transcript := TranscriptStream on: (String new: 10000).
 
  window := SimulatorMorph
  withVMSimulator: self
  title: 'Simulation of ' , localImageName, ' (beta)'
  transcript: transcript.
 
  borderWidth := [SimulatorMorph borderWidth] "Squeak 4.1"
  on: MessageNotUnderstood
  do: [:ex | 0].
  "3.8"
  borderWidth := borderWidth + window borderWidth.
  window openInWorldExtent: (self desiredDisplayExtent + (2 * borderWidth) + (0 @ window labelHeight) * (1 @ (1 / 0.8))) rounded.
  ^window!

Item was changed:
  ----- Method: StackInterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
  vmPathGet: stringBase Length: stringSize
  | pathName stringOop |
+ pathName := self vmPath.
- pathName := Smalltalk vmPath.
  stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
  1 to: stringSize do:
  [:i | objectMemory storeByte: i-1 ofObject: stringOop
  withValue: (pathName at: i) asciiValue].
  !

Item was removed:
- ----- Method: StackInterpreterSimulator>>vmPathSize (in category 'file primitives') -----
- vmPathSize
- ^ Smalltalk vmPath size!

Item was changed:
  ----- Method: TSendNode>>printOn:level: (in category 'printing') -----
  printOn: aStream level: level
  | possiblyParenthesize |
  possiblyParenthesize :=
  [:node :newLevel|
+ node
+ ifNil: [aStream print: node]
+ ifNotNil:
+ [(node isSend
+  and: [node selector precedence >= 3]) ifTrue:
+ [aStream nextPut: $(].
+ node printOn: aStream level: newLevel.
+ (node isSend
+ and: [node selector precedence >= 3]) ifTrue:
+ [aStream nextPut: $)]]].
- (node isSend
- and: [node selector precedence >= 3]) ifTrue:
- [aStream nextPut: $(].
- node printOn: aStream level: newLevel.
- (node isSend
- and: [node selector precedence >= 3]) ifTrue:
- [aStream nextPut: $)]].
 
  possiblyParenthesize value: receiver value: level.
  arguments size = 0 ifTrue:
  [aStream space; nextPutAll: selector.
  ^self].
  selector keywords with: (arguments first: selector numArgs) do:
  [:keyword :arg |
  aStream space; nextPutAll: keyword; space.
  possiblyParenthesize value: arg value: level + 1]!

Item was changed:
  ----- Method: VMClass>>doOrDefer: (in category 'simulation support') -----
  doOrDefer: aBlock
  <doNotGenerate>
  "Either evaluate aBlock immediately if in the uiProcess or defer aBlock as a UI message"
+ Processor activeProcess == self uiProcess
- Processor activeProcess == Project uiProcess
  ifTrue: [aBlock value]
  ifFalse: [WorldState addDeferredUIMessage: aBlock]!

Item was added:
+ ----- Method: VMClass>>localNameFor: (in category 'hack compatibility') -----
+ localNameFor: aString
+ <doNotGenerate>
+ ^(Smalltalk classNamed: #FileSystem)
+ ifNotNil: [:fs| (fs disk pathFromString: aString) basename]
+ ifNil: [FileDirectory default localNameFor: aString]!

Item was added:
+ ----- Method: VMClass>>uiProcess (in category 'hack compatibility') -----
+ uiProcess
+ <doNotGenerate>
+ ^(Smalltalk classNamed: #Project)
+ ifNotNil: [:project| Project uiProcess] "Squeak"
+ ifNil: [UIManager default uiProcess] "Pharo"!

Item was added:
+ ----- Method: VMClass>>vmPath (in category 'hack compatibility') -----
+ vmPath
+ <doNotGenerate>
+ ^(Smalltalk classNamed: #VirtualMachine)
+ ifNotNil: [:project| Smalltalk vm path] "Squeak"
+ ifNil: [Smalltalk vmPath] "Pharo"!

Item was added:
+ ----- Method: VMClass>>vmPathSize (in category 'hack compatibility') -----
+ vmPathSize
+ <doNotGenerate>
+ ^self vmPath size!