[Vm-dev] VM Maker: VMMaker.oscog-eem.2460.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Oct 16 23:43:22 UTC 2018
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2460.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.2460
Author: eem
Time: 16 October 2018, 4:42:48.711187 pm
UUID: 01e81ff6-bb89-4309-8654-4a2daea86fa9
Ancestors: VMMaker.oscog-AlistairGrant.2459
Plugins:
Use more Beck formatting (I find it very hard to read anything else; sorry).
BitBltSimulation/BitBltPlugin:
Fix assertion fails regression for source access in primitiveDisplayString (primitiveDisplayString was not modified to set endOfSource & endOfDestination).
Fix accessing off the end of the source bitmap in pickSourcePixels:flags:srcMask:destMask:srcShiftInc:dstShiftInc: (used by copyLoopPixMap) by separating the sourceWord fetch from the sourceIndex increment.
In all cases avoid loading halftoneWord with AllOnes in the inner loop when there is no halftone and only load halftoneWord in the inner loop when there is a halftone (hence make the inner loop slightly smaller for better icache performance).
N.B. The access off the end of the bitmap in copyBitsLockedAndClipped still remains, but we're getting there.
ThreadedFFIPlugin:
Simulate destroyManualSurface: (for Pharo images)
Fix an == 1 to an = 1 and eliminate a bogus comment in primitiveDestroyManualSurface.
Simulator
Eliminate deprecation warnings from use of byteAt: in the VMClass C library simulations.
Fix carriage return printing for printSends.
Have openOn:extraMemory: accept image file names without the .image extension.
=============== Diff against VMMaker.oscog-AlistairGrant.2459 ===============
Item was changed:
----- Method: BitBltSimulation>>copyBitsLockedAndClipped (in category 'setup') -----
copyBitsLockedAndClipped
"Perform the actual copyBits operation.
Assume: Surfaces have been locked and clipping was performed."
- | done |
<inline: false>
self copyBitsRule41Test.
+ interpreterProxy failed ifTrue:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy failed not)
- ifFalse: [^ interpreterProxy primitiveFail].
"Try a shortcut for stuff that should be run as quickly as possible"
+ self tryCopyingBitsQuickly ifTrue:
+ [^nil].
- done := self tryCopyingBitsQuickly.
- done ifTrue:[^nil].
+ (combinationRule between: 30 and: 31) ifTrue:
- (combinationRule = 30) | (combinationRule = 31) ifTrue:
["Check and fetch source alpha parameter for alpha blend"
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
+ sourceAlpha := interpreterProxy stackIntegerValue: 0.
+ (interpreterProxy failed
+ or: [sourceAlpha < 0
+ or: [sourceAlpha > 255]]) ifTrue:
+ [^interpreterProxy primitiveFail]].
- interpreterProxy methodArgumentCount = 1
- ifTrue: [sourceAlpha := interpreterProxy stackIntegerValue: 0.
- (interpreterProxy failed not and: [(sourceAlpha >= 0) & (sourceAlpha <= 255)])
- ifFalse: [^ interpreterProxy primitiveFail]]
- ifFalse: [^ interpreterProxy primitiveFail]].
bitCount := 0.
"Choose and perform the actual copy loop."
self performCopyLoop.
+ (combinationRule between: 30 and: 31)
+ ifTrue:"zero width and height; just return the count"
+ [affectedL := affectedR := affectedT := affectedB := 0]
+ ifFalse:
+ [hDir > 0
+ ifTrue: [affectedL := dx.
+ affectedR := dx + bbW]
+ ifFalse: [affectedL := dx - bbW + 1.
+ affectedR := dx + 1].
+ vDir > 0
+ ifTrue: [affectedT := dy.
+ affectedB := dy + bbH]
+ ifFalse: [affectedT := dy - bbH + 1.
+ affectedB := dy + 1]]!
- (combinationRule = 22) | (combinationRule = 32) ifTrue:
- ["zero width and height; return the count"
- affectedL := affectedR := affectedT := affectedB := 0].
- hDir > 0
- ifTrue: [affectedL := dx.
- affectedR := dx + bbW]
- ifFalse: [affectedL := dx - bbW + 1.
- affectedR := dx + 1].
- vDir > 0
- ifTrue: [affectedT := dy.
- affectedB := dy + bbH]
- ifFalse: [affectedT := dy - bbH + 1.
- affectedB := dy + 1]!
Item was changed:
----- Method: BitBltSimulation>>copyLoopNoSource (in category 'inner loop') -----
copyLoopNoSource
"Faster copyLoop when source not used. hDir and vDir are both
positive, and perload and skew are unused"
| halftoneWord mergeWord mergeFnwith destWord |
<inline: false>
<var: #mergeFnwith declareC: 'unsigned int (*mergeFnwith)(unsigned int, unsigned int)'>
<var: #halftoneWord type: #'unsigned int'>
<var: #mergeWord type: #'unsigned int'>
<var: #destWord type: #'unsigned int'>
mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'unsigned int (*)(unsigned int, unsigned int)'.
mergeFnwith. "null ref for compiler"
+ noHalftone ifTrue:
+ [halftoneWord := AllOnes].
1 to: bbH do: "here is the vertical loop"
[ :i |
+ noHalftone ifFalse:
+ [halftoneWord := self halftoneAt: dy+i-1].
- noHalftone
- ifTrue: [halftoneWord := AllOnes]
- ifFalse: [halftoneWord := self halftoneAt: dy+i-1].
"Note: the horizontal loop has been expanded into three parts for speed:"
+ "This first section requires masking of the destination store..."
+ destMask := mask1.
+ destWord := self dstLongAt: destIndex.
+ mergeWord := self mergeFn: halftoneWord
+ with: destWord.
+ destWord := (destMask bitAnd: mergeWord) bitOr:
+ (destWord bitAnd: destMask bitInvert32).
+ self dstLongAt: destIndex put: destWord.
+ self incDestIndex: 4.
- "This first section requires masking of the destination store..."
- destMask := mask1.
- destWord := self dstLongAt: destIndex.
- mergeWord := self mergeFn: halftoneWord
- with: destWord.
- destWord := (destMask bitAnd: mergeWord) bitOr:
- (destWord bitAnd: destMask bitInvert32).
- self dstLongAt: destIndex put: destWord.
- self incDestIndex: 4.
+ "This central horizontal loop requires no store masking"
+ destMask := AllOnes.
+ combinationRule = 3
+ ifTrue: "Special inner loop for STORE"
+ [destWord := halftoneWord.
- "This central horizontal loop requires no store masking"
- destMask := AllOnes.
- combinationRule = 3 ifTrue: ["Special inner loop for STORE"
- destWord := halftoneWord.
2 to: nWords-1 do:[ :word |
self dstLongAt: destIndex put: destWord.
+ self incDestIndex: 4]]
+ ifFalse: "Normal inner loop does merge"
+ [2 to: nWords-1 do:[ :word | "Normal inner loop does merge"
- self incDestIndex: 4].
- ] ifFalse:[ "Normal inner loop does merge"
- 2 to: nWords-1 do:[ :word | "Normal inner loop does merge"
destWord := self dstLongAt: destIndex.
mergeWord := self mergeFn: halftoneWord with: destWord.
self dstLongAt: destIndex put: mergeWord.
+ self incDestIndex: 4]].
- self incDestIndex: 4].
- ].
"This last section, if used, requires masking of the destination store..."
nWords > 1 ifTrue:
[destMask := mask2.
destWord := self dstLongAt: destIndex.
mergeWord := self mergeFn: halftoneWord with: destWord.
destWord := (destMask bitAnd: mergeWord) bitOr:
(destWord bitAnd: destMask bitInvert32).
self dstLongAt: destIndex put: destWord.
self incDestIndex: 4].
+ self incDestIndex: destDelta]!
- self incDestIndex: destDelta]!
Item was changed:
----- Method: BitBltSimulation>>copyLoopPixMap (in category 'inner loop') -----
copyLoopPixMap
"This version of the inner loop maps source pixels
to a destination form with different depth. Because it is already
unweildy, the loop is not unrolled as in the other versions.
Preload, skew and skewMask are all overlooked, since pickSourcePixels
delivers its destination word already properly aligned.
Note that pickSourcePixels could be copied in-line at the top of
the horizontal loop, and some of its inits moved out of the loop."
"ar 12/7/1999:
The loop has been rewritten to use only one pickSourcePixels call.
The idea is that the call itself could be inlined. If we decide not
to inline pickSourcePixels we could optimize the loop instead."
| skewWord halftoneWord mergeWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask mergeFnwith nPix srcShift dstShift destWord words srcShiftInc dstShiftInc dstShiftLeft mapperFlags |
<inline: false>
<var: #mergeFnwith declareC: 'unsigned int (*mergeFnwith)(unsigned int, unsigned int)'>
<var: #skewWord type: #'unsigned int'>
<var: #halftoneWord type: #'unsigned int'>
<var: #mergeWord type: #'unsigned int'>
<var: #destWord type: #'unsigned int'>
<var: #sourcePixMask type: #'unsigned int'>
<var: #destPixMask type: #'unsigned int'>
mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'unsigned int (*)(unsigned int, unsigned int)'.
mergeFnwith. "null ref for compiler"
"Additional inits peculiar to unequal source and dest pix size..."
sourcePPW := 32//sourceDepth.
sourcePixMask := maskTable at: sourceDepth.
destPixMask := maskTable at: destDepth.
mapperFlags := cmFlags bitAnd: ColorMapNewStyle bitInvert32.
sourceIndex := sourceBits +
(sy * sourcePitch) + ((sx // sourcePPW) *4).
scrStartBits := sourcePPW - (sx bitAnd: sourcePPW-1).
bbW < scrStartBits
ifTrue: [nSourceIncs := 0]
ifFalse: [nSourceIncs := (bbW - scrStartBits)//sourcePPW + 1].
sourceDelta := sourcePitch - (nSourceIncs * 4).
"Note following two items were already calculated in destmask setup!!"
startBits := destPPW - (dx bitAnd: destPPW-1).
endBits := ((dx + bbW - 1) bitAnd: destPPW-1) + 1.
bbW < startBits ifTrue:[startBits := bbW].
"Precomputed shifts for pickSourcePixels"
srcShift := ((sx bitAnd: sourcePPW - 1) * sourceDepth).
dstShift := ((dx bitAnd: destPPW - 1) * destDepth).
srcShiftInc := sourceDepth.
dstShiftInc := destDepth.
dstShiftLeft := 0.
sourceMSB ifTrue:[
srcShift := 32 - sourceDepth - srcShift.
srcShiftInc := 0 - srcShiftInc].
destMSB ifTrue:[
dstShift := 32 - destDepth - dstShift.
dstShiftInc := 0 - dstShiftInc.
dstShiftLeft := 32 - destDepth].
+ noHalftone ifTrue:
+ [halftoneWord := AllOnes].
-
1 to: bbH do: "here is the vertical loop"
[ :i |
+ noHalftone ifFalse:
+ [halftoneWord := self halftoneAt: dy+i-1].
- "*** is it possible at all that noHalftone == false? ***"
- noHalftone
- ifTrue:[halftoneWord := AllOnes]
- ifFalse: [halftoneWord := self halftoneAt: dy+i-1].
"setup first load"
srcBitShift := srcShift.
dstBitShift := dstShift.
destMask := mask1.
nPix := startBits.
"Here is the horizontal loop..."
words := nWords.
["pick up the word"
skewWord := self pickSourcePixels: nPix flags: mapperFlags
srcMask: sourcePixMask destMask: destPixMask
srcShiftInc: srcShiftInc dstShiftInc: dstShiftInc.
"align next word to leftmost pixel"
dstBitShift := dstShiftLeft.
destMask = AllOnes ifTrue:["avoid read-modify-write"
mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
with: (self dstLongAt: destIndex).
self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
] ifFalse:[ "General version using dest masking"
destWord := self dstLongAt: destIndex.
mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
with: (destWord bitAnd: destMask).
destWord := (destMask bitAnd: mergeWord) bitOr:
(destWord bitAnd: destMask bitInvert32).
self dstLongAt: destIndex put: destWord.
].
self incDestIndex: 4.
words = 2 "e.g., is the next word the last word?"
ifTrue:["set mask for last word in this row"
destMask := mask2.
nPix := endBits]
ifFalse:["use fullword mask for inner loop"
destMask := AllOnes.
nPix := destPPW].
(words := words - 1) = 0] whileFalse.
"--- end of inner loop ---"
self incSrcIndex: sourceDelta.
self incDestIndex: destDelta]
!
Item was changed:
----- Method: BitBltSimulation>>lockSurfaces (in category 'surface support') -----
lockSurfaces
"Get a pointer to the bits of any OS surfaces."
"Notes:
* For equal source/dest handles only one locking operation is performed.
This is to prevent locking of overlapping areas which does not work with
certain APIs (as an example, DirectDraw prevents locking of overlapping areas).
A special case for non-overlapping but equal source/dest handle would
be possible but we would have to transfer this information over to
unlockSurfaces somehow (currently, only one unlock operation is
performed for equal source and dest handles). Also, this would require
a change in the notion of ioLockSurface() which is right now interpreted
as a hint and not as a requirement to lock only the specific portion of
the surface.
* The arguments in ioLockSurface() provide the implementation with
an explicit hint what area is affected. It can be very useful to
know the max. affected area beforehand if getting the bits requires expensive
copy operations (e.g., like a roundtrip to the X server or a glReadPixel op).
However, the returned pointer *MUST* point to the virtual origin of the surface
and not to the beginning of the rectangle. The promise made by BitBlt
is to never access data outside the given rectangle (aligned to 4byte boundaries!!)
so it is okay to return a pointer to the virtual origin that is actually outside
the valid memory area.
* The area provided in ioLockSurface() is already clipped (e.g., it will always
be inside the source and dest boundingBox) but it is not aligned to word boundaries
yet. It is up to the support code to compute accurate alignment if necessary.
* Warping always requires the entire source surface to be locked because
there is no beforehand knowledge about what area will actually be traversed.
* Fail if a GC has occurred since the primitive started (presumably in the lockSurface
function), because one or more of the primitives' parameters may have been moved.
"
| sourceHandle destHandle l r t b |
<inline: true>
self assert: numGCsOnInvocation = interpreterProxy statNumGCs.
hasSurfaceLock := false.
destBits = 0 ifTrue: "Blitting *to* OS surface"
[lockSurfaceFn = 0 ifTrue: [self loadSurfacePlugin ifFalse: [^false]].
destHandle := interpreterProxy fetchInteger: FormBitsIndex ofObject: destForm.
(sourceBits ~= 0 or: [noSource]) ifFalse:
[sourceHandle := interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
"Handle the special case of equal source and dest handles"
sourceHandle = destHandle ifTrue:
"If we have overlapping source/dest we lock the entire area
so that there is only one area transmitted"
[isWarping
ifFalse: "When warping we always need the entire surface for the source"
[sourceBits := self lockSurfaceFn: sourceHandle
+ _: (self addressOf: sourcePitch put: [:v| sourcePitch := v])
- _: (self addressOf: sourcePitch)
_: 0
_: 0
_: sourceWidth
_: sourceHeight]
ifTrue: "Otherwise use overlapping area"
[l := sx min: dx. r := (sx max: dx) + bbW.
t := sy min: dy. b := (sy max: dy) + bbH.
sourceBits := self lockSurfaceFn: sourceHandle
+ _: (self addressOf: sourcePitch put: [:v| sourcePitch := v])
- _: (self addressOf: sourcePitch)
_: l
_: t
_: r - l
_: b - t].
destBits := sourceBits.
destPitch := sourcePitch.
hasSurfaceLock := true.
numGCsOnInvocation ~= interpreterProxy statNumGCs ifTrue:
[self unlockSurfaces.
interpreterProxy primitiveFailFor: PrimErrObjectMoved.
^false].
destBits = 0 ifTrue:
[self unlockSurfaces.
interpreterProxy primitiveFailFor: PrimErrCallbackError.
^false].
endOfDestination := endOfSource := sourceBits + (sourcePitch * sourceHeight).
^true]].
"Fall through - if not equal it'll be handled below"
destBits := self lockSurfaceFn: destHandle
+ _: (self addressOf: destPitch put: [:v| destPitch := v])
- _: (self addressOf: destPitch)
_: dx
_: dy
_: bbW
_: bbH.
hasSurfaceLock := true.
numGCsOnInvocation ~= interpreterProxy statNumGCs ifTrue:
[self unlockSurfaces.
interpreterProxy primitiveFailFor: PrimErrObjectMoved.
^false].
destBits = 0 ifTrue:
[interpreterProxy primitiveFailFor: PrimErrCallbackError]].
(sourceBits ~= 0 or: [noSource]) ifFalse: "Blitting *from* OS surface"
[sourceHandle := interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
interpreterProxy failed ifTrue: [^false]. "fetch sourceHandle could fail"
lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
"Warping requiring the entire surface"
isWarping
ifTrue:
[sourceBits := self lockSurfaceFn: sourceHandle
+ _: (self addressOf: sourcePitch put: [:v| sourcePitch := v])
- _: (self addressOf: sourcePitch)
_: 0
_: 0
_: sourceWidth
_: sourceHeight]
ifFalse:
[sourceBits := self lockSurfaceFn: sourceHandle
+ _: (self addressOf: sourcePitch put: [:v| sourcePitch := v])
- _: (self addressOf: sourcePitch)
_: sx
_: sy
_: bbW
_: bbH].
hasSurfaceLock := true.
numGCsOnInvocation ~= interpreterProxy statNumGCs ifTrue:
[self unlockSurfaces.
interpreterProxy primitiveFailFor: PrimErrObjectMoved.
^false].
sourceBits = 0 ifTrue:
[interpreterProxy primitiveFailFor: PrimErrCallbackError]].
+ endOfSource := (noSource or: [sourceBits = 0]) ifTrue: [0] ifFalse: [sourceBits + (sourcePitch * sourceHeight)].
- endOfSource := sourceBits + (sourcePitch * sourceHeight).
endOfDestination := destBits + (destPitch * destHeight).
^destBits ~= 0 and: [sourceBits ~= 0 or: [noSource]]!
Item was changed:
----- Method: BitBltSimulation>>performCopyLoop (in category 'setup') -----
performCopyLoop
"Based on the values provided during setup choose and
perform the appropriate inner loop function."
<inline: true> "Should be inlined into caller for speed"
self destMaskAndPointerInit.
+ noSource
+ ifTrue: "Simple fill loop"
+ [self copyLoopNoSource]
+ ifFalse: "Loop using source and dest"
+ [self checkSourceOverlap.
+ (sourceDepth ~= destDepth or: [cmFlags ~= 0 or: [sourceMSB ~= destMSB]])
+ ifTrue: "If we must convert between pixel depths or use
+ color lookups or swap pixels use the general version"
+ [self copyLoopPixMap]
+ ifFalse: "Otherwise we simply copy pixels and can use a faster version"
+ [self sourceSkewAndPointerInit.
+ self copyLoop]]!
- noSource ifTrue: ["Simple fill loop"
- self copyLoopNoSource.
- ] ifFalse: ["Loop using source and dest"
- self checkSourceOverlap.
- (sourceDepth ~= destDepth or: [(cmFlags ~= 0) or:[sourceMSB ~= destMSB]]) ifTrue: [
- "If we must convert between pixel depths or use
- color lookups or swap pixels use the general version"
- self copyLoopPixMap.
- ] ifFalse: [
- "Otherwise we simple copy pixels and can use a faster version"
- self sourceSkewAndPointerInit.
- self copyLoop.
- ]
- ].!
Item was changed:
----- Method: BitBltSimulation>>pickSourcePixels:flags:srcMask:destMask:srcShiftInc:dstShiftInc: (in category 'combination rules') -----
pickSourcePixels: nPixels flags: mapperFlags srcMask: srcMask destMask: dstMask srcShiftInc: srcShiftInc dstShiftInc: dstShiftInc
"Pick nPix pixels starting at srcBitIndex from the source, map by the
color map, and justify them according to dstBitIndex in the resulting destWord."
| sourceWord destWord sourcePix destPix srcShift dstShift nPix |
<inline: true> "oh please"
<returnTypeC: 'unsigned int'>
<var: #sourceWord type: #'unsigned int'>
<var: #destWord type: #'unsigned int'>
- sourceWord := self srcLongAt: sourceIndex.
destWord := 0.
srcShift := srcBitShift. "Hint: Keep in register"
dstShift := dstBitShift. "Hint: Keep in register"
nPix := nPixels. "always > 0 so we can use do { } while(--nPix);"
(mapperFlags = (ColorMapPresent bitOr: ColorMapIndexedPart)) ifTrue:[
"a little optimization for (pretty crucial) blits using indexed lookups only"
[ "grab, colormap and mix in pixel"
+ sourceWord := self srcLongAt: sourceIndex.
sourcePix := sourceWord >> srcShift bitAnd: srcMask.
destPix := cmLookupTable at: (sourcePix bitAnd: cmMask).
destWord := destWord bitOr: (destPix bitAnd: dstMask) << dstShift.
"adjust dest pix index"
dstShift := dstShift + dstShiftInc.
"adjust source pix index"
+ ((srcShift := srcShift + srcShiftInc) bitAnd: 16rFFFFFFE0) = 0 ifFalse:
+ [srcShift := sourceMSB ifTrue: [srcShift + 32] ifFalse: [srcShift - 32].
+ self incSrcIndex: 4].
- ((srcShift := srcShift + srcShiftInc) bitAnd: 16rFFFFFFE0) = 0 ifFalse:[
- sourceMSB ifTrue:[srcShift := srcShift + 32] ifFalse:[srcShift := srcShift - 32].
- sourceWord := self srcLongAt: (self incSrcIndex: 4)].
(nPix := nPix - 1) = 0] whileFalse.
] ifFalse:[
[ "grab, colormap and mix in pixel"
+ sourceWord := self srcLongAt: sourceIndex.
sourcePix := sourceWord >> srcShift bitAnd: srcMask.
destPix := self mapPixel: sourcePix flags: mapperFlags.
destWord := destWord bitOr: (destPix bitAnd: dstMask) << dstShift.
"adjust dest pix index"
dstShift := dstShift + dstShiftInc.
"adjust source pix index"
+ ((srcShift := srcShift + srcShiftInc) bitAnd: 16rFFFFFFE0) = 0 ifFalse:
+ [srcShift := sourceMSB ifTrue: [srcShift + 32] ifFalse: [srcShift - 32].
+ self incSrcIndex: 4].
- ((srcShift := srcShift + srcShiftInc) bitAnd: 16rFFFFFFE0) = 0 ifFalse:[
- sourceMSB ifTrue:[srcShift := srcShift + 32] ifFalse:[srcShift := srcShift - 32].
- sourceWord := self srcLongAt: (self incSrcIndex: 4)].
(nPix := nPix - 1) = 0] whileFalse.
].
srcBitShift := srcShift. "Store back"
^destWord
!
Item was changed:
----- Method: BitBltSimulation>>primitiveCopyBits (in category 'primitives') -----
primitiveCopyBits
"Invoke the copyBits primitive. If the destination is the display, then copy it to the screen."
| rcvr |
<export: true>
rcvr := interpreterProxy stackValue: interpreterProxy methodArgumentCount.
+ (self loadBitBltFrom: rcvr) ifFalse:
+ [^interpreterProxy primitiveFail].
- (self loadBitBltFrom: rcvr) ifFalse:[^interpreterProxy primitiveFail].
self copyBits.
+ interpreterProxy failed ifTrue: [^nil].
- interpreterProxy failed ifTrue:[^nil].
self showDisplayBits.
+ interpreterProxy failed ifTrue: [^nil].
+ (combinationRule = 22 or: [combinationRule = 32])
+ ifTrue: [interpreterProxy methodReturnInteger: bitCount]
+ ifFalse: [interpreterProxy methodReturnReceiver]!
- interpreterProxy failed ifTrue:[^nil].
- interpreterProxy pop: interpreterProxy methodArgumentCount.
- (combinationRule = 22) | (combinationRule = 32) ifTrue:[
- interpreterProxy pop: 1.
- ^ interpreterProxy pushInteger: bitCount].!
Item was changed:
----- Method: BitBltSimulation>>primitiveDisplayString (in category 'primitives') -----
primitiveDisplayString
| kernDelta xTable glyphMap stopIndex startIndex sourceString bbObj maxGlyph ascii glyphIndex sourcePtr left quickBlt |
<export: true>
<var: #sourcePtr type: 'char *'>
interpreterProxy methodArgumentCount = 6 ifFalse:
[^interpreterProxy primitiveFail].
kernDelta := interpreterProxy stackIntegerValue: 0.
xTable := interpreterProxy stackValue: 1.
glyphMap := interpreterProxy stackValue: 2.
stopIndex := interpreterProxy stackIntegerValue: 3.
startIndex := interpreterProxy stackIntegerValue: 4.
sourceString := interpreterProxy stackValue: 5.
bbObj := interpreterProxy stackObjectValue: 6.
interpreterProxy failed ifTrue:
[^nil].
((interpreterProxy isArray: xTable)
and: [(interpreterProxy isArray: glyphMap)
and: [(interpreterProxy slotSizeOf: glyphMap) = 256
and: [(interpreterProxy isBytes: sourceString)
and: [startIndex > 0
and: [stopIndex >= 0 "to avoid failing for empty strings..."
and: [stopIndex <= (interpreterProxy byteSizeOf: sourceString)
and: [(self loadBitBltFrom: bbObj)
and: [combinationRule ~= 30 "these two need extra source alpha"
and: [combinationRule ~= 31]]]]]]]]]) ifFalse:
[^interpreterProxy primitiveFail].
stopIndex = 0 ifTrue:
[^interpreterProxy pop: 6 "the string is empty; pop args, return rcvr"].
maxGlyph := (interpreterProxy slotSizeOf: xTable) - 2.
"See if we can go directly into copyLoopPixMap (usually we can)"
quickBlt := destBits ~= 0 "no OS surfaces please"
and:[sourceBits ~= 0 "and again"
and:[noSource = false "needs a source"
and:[sourceForm ~= destForm "no blits onto self"
and:[cmFlags ~= 0
or:[sourceMSB ~= destMSB
or:[sourceDepth ~= destDepth]]]]]]. "no point using slower version"
+ quickBlt ifTrue:
+ [endOfSource := sourceBits + (sourcePitch * sourceHeight).
+ endOfDestination := destBits + (destPitch * destHeight)].
left := destX.
sourcePtr := interpreterProxy firstIndexableField: sourceString.
+ startIndex to: stopIndex do:
+ [:charIndex|
- startIndex to: stopIndex do:[:charIndex|
ascii := interpreterProxy byteAtPointer: sourcePtr + charIndex - 1.
glyphIndex := interpreterProxy fetchInteger: ascii ofObject: glyphMap.
+ (glyphIndex < 0 or:[glyphIndex > maxGlyph]) ifTrue:
+ [^interpreterProxy primitiveFail].
- (glyphIndex < 0 or:[glyphIndex > maxGlyph])
- ifTrue:[^interpreterProxy primitiveFail].
sourceX := interpreterProxy fetchInteger: glyphIndex ofObject: xTable.
width := (interpreterProxy fetchInteger: glyphIndex+1 ofObject: xTable) - sourceX.
interpreterProxy failed ifTrue:[^nil].
self clipRange. "Must clip here"
+ (bbW > 0 and: [bbH > 0]) ifTrue:
+ [quickBlt
+ ifTrue:
+ [self destMaskAndPointerInit.
+ self copyLoopPixMap.
+ "both, hDir and vDir are known to be > 0"
+ affectedL := dx.
+ affectedR := dx + bbW.
+ affectedT := dy.
+ affectedB := dy + bbH]
+ ifFalse:
+ [self copyBits]]. "but this means we're doing lockSurfaces/unlockSurfaces *for each character* :-( eem 10/16/2018 15:42"
- (bbW > 0 and:[bbH > 0]) ifTrue: [
- quickBlt ifTrue:[
- self destMaskAndPointerInit.
- self copyLoopPixMap.
- "both, hDir and vDir are known to be > 0"
- affectedL := dx.
- affectedR := dx + bbW.
- affectedT := dy.
- affectedB := dy + bbH.
- ] ifFalse:[self copyBits]].
interpreterProxy failed ifTrue:[^nil].
destX := destX + width + kernDelta.
].
affectedL := left.
self showDisplayBits.
"store destX back"
interpreterProxy storeInteger: BBDestXIndex ofObject: bbObj withValue: destX.
interpreterProxy pop: 6 "pop args, return rcvr"!
Item was changed:
----- Method: BitBltSimulation>>primitiveWarpBits (in category 'primitives') -----
primitiveWarpBits
"Invoke the warpBits primitive. If the destination is the display, then copy it to the screen."
| rcvr |
<export: true>
rcvr := interpreterProxy stackValue: interpreterProxy methodArgumentCount.
(self loadWarpBltFrom: rcvr)
ifFalse:[^interpreterProxy primitiveFail].
self warpBits.
interpreterProxy failed ifTrue:[^nil].
self showDisplayBits.
interpreterProxy failed ifTrue:[^nil].
+ interpreterProxy methodReturnReceiver!
- interpreterProxy pop: interpreterProxy methodArgumentCount.!
Item was changed:
----- Method: BitBltSimulation>>sourceSkewAndPointerInit (in category 'setup') -----
sourceSkewAndPointerInit
"This is only used when source and dest are same depth,
ie, when the barrel-shift copy loop is used."
| dWid sxLowBits dxLowBits pixPerM1 |
<inline: true>
pixPerM1 := destPPW - 1. "A mask, assuming power of two"
sxLowBits := sx bitAnd: pixPerM1.
dxLowBits := dx bitAnd: pixPerM1.
"check if need to preload buffer
(i.e., two words of source needed for first word of destination)"
hDir > 0 ifTrue:
["n Bits stored in 1st word of dest"
dWid := bbW min: destPPW - dxLowBits.
preload := (sxLowBits + dWid) > pixPerM1]
ifFalse:
[dWid := bbW min: dxLowBits + 1.
preload := (sxLowBits - dWid + 1) < 0].
"calculate right-shift skew from source to dest"
+ skew := destDepth * (sourceMSB ifTrue: [sxLowBits - dxLowBits] ifFalse: [dxLowBits - sxLowBits]). " -32..32 "
- sourceMSB
- ifTrue:[skew := (sxLowBits - dxLowBits) * destDepth]
- ifFalse:[skew := (dxLowBits - sxLowBits) * destDepth]. " -32..32 "
preload ifTrue:
+ [skew := skew < 0 ifTrue: [skew + 32] ifFalse: [skew - 32]].
- [skew < 0
- ifTrue: [skew := skew+32]
- ifFalse: [skew := skew-32]].
"Calc byte addr and delta from longWord info"
+ sourceIndex := sourceBits + (sy * sourcePitch) + ((sx // (32 // sourceDepth)) * 4).
- sourceIndex := sourceBits + (sy * sourcePitch) + ((sx // (32//sourceDepth)) *4).
"calculate increments from end of 1 line to start of next"
sourceDelta := (sourcePitch * vDir) - (4 * (nWords * hDir)).
+ preload ifTrue: "Compensate for extra source word fetched"
+ [sourceDelta := sourceDelta - (4 * hDir)]!
- preload ifTrue:
- ["Compensate for extra source word fetched"
- sourceDelta := sourceDelta - (4*hDir)].!
Item was changed:
----- Method: BitBltSimulation>>warpLoop (in category 'inner loop') -----
warpLoop
"This version of the inner loop traverses an arbirary quadrilateral
source, thus producing a general affine transformation."
| skewWord halftoneWord mergeWord startBits
deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy pBx pBy
xDelta yDelta smoothingCount sourceMapOop
nSteps nPix words destWord endBits mergeFnwith dstShiftInc dstShiftLeft mapperFlags |
<inline: false>
<var: #mergeFnwith declareC: 'unsigned int (*mergeFnwith)(unsigned int, unsigned int)'>
<var: #skewWord type: #'unsigned int'>
<var: #halftoneWord type: #'unsigned int'>
<var: #mergeWord type: #'unsigned int'>
<var: #destWord type: #'unsigned int'>
mergeFnwith := self cCoerce: (opTable at: combinationRule+1) to: 'unsigned int (*)(unsigned int, unsigned int)'.
mergeFnwith. "null ref for compiler"
(interpreterProxy slotSizeOf: bitBltOop) >= (BBWarpBase+12)
ifFalse: [^ interpreterProxy primitiveFail].
nSteps := height-1. nSteps <= 0 ifTrue: [nSteps := 1].
pAx := self fetchIntOrFloat: BBWarpBase ofObject: bitBltOop.
words := self fetchIntOrFloat: BBWarpBase+3 ofObject: bitBltOop.
deltaP12x := self deltaFrom: pAx to: words nSteps: nSteps.
deltaP12x < 0 ifTrue: [pAx := words - (nSteps*deltaP12x)].
pAy := self fetchIntOrFloat: BBWarpBase+1 ofObject: bitBltOop.
words := self fetchIntOrFloat: BBWarpBase+4 ofObject: bitBltOop.
deltaP12y := self deltaFrom: pAy to: words nSteps: nSteps.
deltaP12y < 0 ifTrue: [pAy := words - (nSteps*deltaP12y)].
pBx := self fetchIntOrFloat: BBWarpBase+9 ofObject: bitBltOop.
words := self fetchIntOrFloat: BBWarpBase+6 ofObject: bitBltOop.
deltaP43x := self deltaFrom: pBx to: words nSteps: nSteps.
deltaP43x < 0 ifTrue: [pBx := words - (nSteps*deltaP43x)].
pBy := self fetchIntOrFloat: BBWarpBase+10 ofObject: bitBltOop.
words := self fetchIntOrFloat: BBWarpBase+7 ofObject: bitBltOop.
deltaP43y := self deltaFrom: pBy to: words nSteps: nSteps.
deltaP43y < 0 ifTrue: [pBy := words - (nSteps*deltaP43y)].
interpreterProxy failed ifTrue: [^ false]. "ie if non-integers above"
interpreterProxy methodArgumentCount = 2
+ ifTrue:
+ [smoothingCount := interpreterProxy stackIntegerValue: 1.
+ sourceMapOop := interpreterProxy stackValue: 0.
+ sourceMapOop = interpreterProxy nilObject
+ ifTrue:
+ [sourceDepth < 16 ifTrue: "color map is required to smooth non-RGB dest"
+ [^interpreterProxy primitiveFail]]
+ ifFalse:
+ [(interpreterProxy slotSizeOf: sourceMapOop) < (1 << sourceDepth) ifTrue: "sourceMap must be long enough for sourceDepth"
+ [^interpreterProxy primitiveFail].
- ifTrue: [smoothingCount := interpreterProxy stackIntegerValue: 1.
- sourceMapOop := interpreterProxy stackValue: 0.
- sourceMapOop = interpreterProxy nilObject
- ifTrue: [sourceDepth < 16 ifTrue:
- ["color map is required to smooth non-RGB dest"
- ^ interpreterProxy primitiveFail]]
- ifFalse: [(interpreterProxy slotSizeOf: sourceMapOop)
- < (1 << sourceDepth) ifTrue:
- ["sourceMap must be long enough for sourceDepth"
- ^ interpreterProxy primitiveFail].
sourceMapOop := self oopForPointer: (interpreterProxy firstIndexableField: sourceMapOop)]]
+ ifFalse:
+ [smoothingCount := 1.
+ sourceMapOop := interpreterProxy nilObject].
- ifFalse: [smoothingCount := 1.
- sourceMapOop := interpreterProxy nilObject].
nSteps := width-1. nSteps <= 0 ifTrue: [nSteps := 1].
startBits := destPPW - (dx bitAnd: destPPW-1).
endBits := ((dx + bbW - 1) bitAnd: destPPW-1) + 1.
bbW < startBits ifTrue:[startBits := bbW].
destY < clipY ifTrue:[
"Advance increments if there was clipping in y"
pAx := pAx + (clipY - destY * deltaP12x).
pAy := pAy + (clipY - destY * deltaP12y).
pBx := pBx + (clipY - destY * deltaP43x).
pBy := pBy + (clipY - destY * deltaP43y)].
"Setup values for faster pixel fetching."
self warpLoopSetup.
"Setup color mapping if not provided"
+ (smoothingCount > 1 and:[(cmFlags bitAnd: ColorMapNewStyle) = 0]) ifTrue:
+ [cmLookupTable
+ ifNil: [destDepth = 16 ifTrue: [self setupColorMasksFrom: 8 to: 5]]
+ ifNotNil: [self setupColorMasksFrom: 8 to: cmBitsPerColor]].
- (smoothingCount > 1 and:[(cmFlags bitAnd: ColorMapNewStyle) = 0]) ifTrue:[
- cmLookupTable == nil ifTrue:[
- destDepth = 16 ifTrue:[self setupColorMasksFrom: 8 to: 5].
- ] ifFalse:[
- self setupColorMasksFrom: 8 to: cmBitsPerColor.
- ].
- ].
mapperFlags := cmFlags bitAnd: ColorMapNewStyle bitInvert32.
destMSB
ifTrue:[ dstShiftInc := 0 - destDepth.
dstShiftLeft := 32 - destDepth]
ifFalse:[ dstShiftInc := destDepth.
dstShiftLeft := 0].
+ noHalftone ifTrue:
+ [halftoneWord := AllOnes].
1 to: bbH do:
[ :i | "here is the vertical loop..."
xDelta := self deltaFrom: pAx to: pBx nSteps: nSteps.
xDelta >= 0 ifTrue: [sx := pAx] ifFalse: [sx := pBx - (nSteps*xDelta)].
yDelta := self deltaFrom: pAy to: pBy nSteps: nSteps.
yDelta >= 0 ifTrue: [sy := pAy] ifFalse: [sy := pBy - (nSteps*yDelta)].
destMSB
ifTrue:[dstBitShift := 32 - ((dx bitAnd: destPPW - 1) + 1 * destDepth)]
ifFalse:[dstBitShift := (dx bitAnd: destPPW - 1) * destDepth].
(destX < clipX) ifTrue:[
"Advance increments if there was clipping in x"
sx := sx + (clipX - destX * xDelta).
sy := sy + (clipX - destX * yDelta).
].
+ noHalftone ifFalse:
+ [halftoneWord := self halftoneAt: dy + i - 1].
- noHalftone
- ifTrue: [halftoneWord := AllOnes]
- ifFalse: [halftoneWord := self halftoneAt: dy+i-1].
destMask := mask1.
nPix := startBits.
"Here is the inner loop..."
words := nWords.
["pick up word"
smoothingCount = 1 ifTrue:["Faster if not smoothing"
skewWord := self warpPickSourcePixels: nPix
xDeltah: xDelta yDeltah: yDelta
xDeltav: deltaP12x yDeltav: deltaP12y
dstShiftInc: dstShiftInc flags: mapperFlags.
] ifFalse:["more difficult with smoothing"
skewWord := self warpPickSmoothPixels: nPix
xDeltah: xDelta yDeltah: yDelta
xDeltav: deltaP12x yDeltav: deltaP12y
sourceMap: sourceMapOop
smoothing: smoothingCount
dstShiftInc: dstShiftInc.
].
"align next word access to left most pixel"
dstBitShift := dstShiftLeft.
destMask = AllOnes ifTrue:["avoid read-modify-write"
mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
with: (self dstLongAt: destIndex).
self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
] ifFalse:[ "General version using dest masking"
destWord := self dstLongAt: destIndex.
mergeWord := self mergeFn: (skewWord bitAnd: halftoneWord)
with: (destWord bitAnd: destMask).
destWord := (destMask bitAnd: mergeWord) bitOr:
(destWord bitAnd: destMask bitInvert32).
self dstLongAt: destIndex put: destWord.
].
self incDestIndex: 4.
words = 2 "e.g., is the next word the last word?"
ifTrue:["set mask for last word in this row"
destMask := mask2.
nPix := endBits]
ifFalse:["use fullword mask for inner loop"
destMask := AllOnes.
nPix := destPPW].
(words := words - 1) = 0] whileFalse.
"--- end of inner loop ---"
pAx := pAx + deltaP12x.
pAy := pAy + deltaP12y.
pBx := pBx + deltaP43x.
pBy := pBy + deltaP43y.
self incDestIndex: destDelta]!
Item was changed:
----- Method: CogVMSimulator>>byteAt: (in category 'memory access') -----
byteAt: byteAddress
+ "This is really only for the C library simulations memcpy:_:_: et al in VMClass.
+ Use objectMemory byteAt: directly where possible."
^objectMemory byteAt: byteAddress!
Item was changed:
----- Method: CogVMSimulator>>openOn:extraMemory: (in category 'initialization') -----
openOn: fileName extraMemory: extraBytes
"CogVMSimulator new openOn: 'clone.im' extraMemory: 100000"
| f version headerSize dataSize count oldBaseAddr bytesToShift swapBytes
headerFlags firstSegSize heapSize
hdrNumStackPages hdrEdenBytes hdrMaxExtSemTabSize
hdrCogCodeSize stackZoneSize methodCacheSize primTraceLogSize allocationReserve |
"open image file and read the header"
+ (f := self openImageFileNamed: fileName) ifNil: [^self].
- f := FileStream readOnlyFileNamed: fileName.
- f ifNil: [^self error: 'no image found'].
"Set the image name and the first argument; there are
no arguments during simulation unless set explicitly."
systemAttributes at: 1 put: fileName; at: 2 put: nil.
["begin ensure block..."
imageName := f fullName.
f binary.
version := self getWord32FromFile: f swap: false. "current version: 16r1968 (=6504) vive la revolucion!!"
(self readableFormat: version)
ifTrue: [swapBytes := false]
ifFalse: [(version := version byteSwap32) = self imageFormatVersion
ifTrue: [swapBytes := true]
ifFalse: [self error: 'incomaptible image format']].
headerSize := self getWord32FromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes. "length of heap in file"
oldBaseAddr := self getLongFromFile: f swap: swapBytes. "object memory base address of image"
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "Should be loaded from, and saved to the image header"
savedWindowSize := self getLongFromFile: f swap: swapBytes.
headerFlags := self getLongFromFile: f swap: swapBytes.
self setImageHeaderFlagsFrom: headerFlags.
extraVMMemory := self getWord32FromFile: 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"
numStackPages := desiredNumStackPages ~= 0
ifTrue: [desiredNumStackPages]
ifFalse: [hdrNumStackPages = 0
ifTrue: [self defaultNumStackPages]
ifFalse: [hdrNumStackPages]].
desiredNumStackPages := hdrNumStackPages.
stackZoneSize := self computeStackZoneSize.
"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: [cogit defaultCogCodeSize]
ifFalse: [hdrCogCodeSize]].
desiredCogCodeSize := hdrCogCodeSize.
self assert: f position = (objectMemory wordSize = 4 ifTrue: [40] ifFalse: [64]).
hdrEdenBytes := self getWord32FromFile: 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].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
self assert: f position = (objectMemory wordSize = 4 ifTrue: [48] ifFalse: [72]).
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"For Open PICs to be able to probe the method cache during
simulation the methodCache must be relocated to memory."
methodCacheSize := methodCache size * objectMemory wordSize.
primTraceLogSize := primTraceLog size * objectMemory wordSize.
"allocate interpreter memory. This list is in address order, low to high.
In the actual VM the stack zone exists on the C stack."
heapBase := (Cogit guardPageSize
+ cogCodeSize
+ stackZoneSize
+ methodCacheSize
+ primTraceLogSize
+ self rumpCStackSize) roundUpTo: objectMemory allocationUnit.
"compare memory requirements with availability"
allocationReserve := self interpreterAllocationReserveBytes.
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[| freeOldSpaceInImage headroom |
freeOldSpaceInImage := self getLongFromFile: f swap: swapBytes.
headroom := objectMemory
initialHeadroom: extraVMMemory
givenFreeOldSpaceInImage: freeOldSpaceInImage.
heapSize := objectMemory roundUpHeapSize:
dataSize
+ headroom
+ objectMemory newSpaceBytes
+ (headroom > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve])]
ifFalse:
[heapSize := dataSize
+ extraBytes
+ objectMemory newSpaceBytes
+ (extraBytes > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve])].
heapBase := objectMemory
setHeapBase: heapBase
memoryLimit: heapBase + heapSize
endOfMemory: heapBase + dataSize.
self assert: cogCodeSize \\ 4 = 0.
self assert: objectMemory memoryLimit \\ 4 = 0.
self assert: self rumpCStackSize \\ 4 = 0.
objectMemory allocateMemoryOfSize: objectMemory memoryLimit.
"read in the image in bulk, then swap the bytes if necessary"
f position: headerSize.
count := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
count ~= dataSize ifTrue: [self halt]]
ensure: [f close].
self moveMethodCacheToMemoryAt: objectMemory cogCodeBase + cogCodeSize + stackZoneSize.
self movePrimTraceLogToMemoryAt: objectMemory cogCodeBase + cogCodeSize + stackZoneSize + methodCacheSize.
self ensureImageFormatIsUpToDate: swapBytes.
bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. "adjust pointers for zero base address"
UIManager default
informUser: 'Relocating object pointers...'
during: [self initializeInterpreter: bytesToShift].
self initializeCodeGenerator!
Item was added:
+ ----- Method: StackInterpreter>>openImageFileNamed: (in category 'simulation support') -----
+ openImageFileNamed: fileName
+ "Attempt to open fileName or fileName, '.image'"
+ <doNotGenerate>
+ | f |
+ f := [FileStream readOnlyFileNamed: fileName]
+ on: FileDoesNotExistException
+ do: [:ex|
+ ((fileName endsWith: '.image') not
+ and: [FileDirectory default fileExists: fileName, '.image']) ifFalse:
+ [ex pass].
+ FileStream readOnlyFileNamed: fileName, '.image'].
+ ^f ifNil: [self error: 'no image found'. nil].!
Item was changed:
----- Method: StackInterpreterSimulator>>byteAt: (in category 'memory access') -----
byteAt: byteAddress
+ "This is really only for the C library simulations memcpy:_:_: et al in VMClass.
+ Use objectMemory byteAt: directly where possible."
- self deprecated.
^objectMemory byteAt: byteAddress!
Item was changed:
----- Method: StackInterpreterSimulator>>internalFindNewMethodOrdinary (in category 'testing') -----
internalFindNewMethodOrdinary
"
| cName |
traceOn ifTrue:
[cName := (self sizeBitsOf: class) = 16r20
ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))]
ifFalse: [(self nameOfClass: class)].
self cr; print: cName , '>>' , (self stringOf: messageSelector)].
"
messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [self halt].
sendCount := sendCount + 1.
+ " printSends ifTrue:
+ [self print: byteCount; space; printStringOf: messageSelector; cr]."
- printSends ifTrue:
- [self cr; print: byteCount; space; printStringOf: messageSelector].
"
(sendCount > 1000 and: [sendCount\\10 = 0]) ifTrue:
[Transcript print: sendCount; space.
self validate].
"
"
(sendCount > 100150) ifTrue:
[self qvalidate.
messageQueue == nil ifTrue: [messageQueue := OrderedCollection new].
messageQueue addLast: (self stringOf: messageSelector)].
"
super internalFindNewMethodOrdinary!
Item was changed:
----- Method: StackInterpreterSimulator>>openOn:extraMemory: (in category 'initialization') -----
openOn: fileName extraMemory: extraBytes
"StackInterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"
| f version headerSize dataSize count oldBaseAddr bytesToShift swapBytes
headerFlags heapBase firstSegSize heapSize
hdrNumStackPages hdrEdenBytes hdrMaxExtSemTabSize allocationReserve |
"open image file and read the header"
+ (f := self openImageFileNamed: fileName) ifNil: [^self].
- f := FileStream readOnlyFileNamed: fileName.
- f ifNil: [^self error: 'no image found'].
"Set the image name and the first argument; there are
no arguments during simulation unless set explicitly."
systemAttributes at: 1 put: fileName; at: 2 put: nil.
["begin ensure block..."
imageName := f fullName.
f binary.
version := self getWord32FromFile: f swap: false. "current version: 16r1968 (=6504) vive la revolucion!!"
(self readableFormat: version)
ifTrue: [swapBytes := false]
ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion
ifTrue: [swapBytes := true]
ifFalse: [self error: 'incomaptible image format']].
headerSize := self getWord32FromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes. "length of heap in file"
oldBaseAddr := self getLongFromFile: f swap: swapBytes. "object memory base address of image"
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "Should be loaded from, and saved to the image header"
savedWindowSize := self getLongFromFile: f swap: swapBytes.
headerFlags := self getLongFromFile: f swap: swapBytes.
self setImageHeaderFlagsFrom: headerFlags.
extraVMMemory := self getWord32FromFile: 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"
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.
It is used for the cog code size in Cog. Preserve it to be polite to other VMs."
theUnknownShort := self getShortFromFile: f swap: swapBytes.
self assert: f position = (objectMemory wordSize = 4 ifTrue: [40] ifFalse: [64]).
hdrEdenBytes := self getWord32FromFile: f swap: swapBytes.
objectMemory edenBytes: (hdrEdenBytes = 0
ifTrue: [objectMemory defaultEdenBytes]
ifFalse: [hdrEdenBytes]).
desiredEdenBytes := hdrEdenBytes.
hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes.
hdrMaxExtSemTabSize ~= 0 ifTrue:
[self setMaxExtSemSizeTo: hdrMaxExtSemTabSize].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
self assert: f position = (objectMemory wordSize = 4 ifTrue: [48] ifFalse: [72]).
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"compare memory requirements with availability"
allocationReserve := self interpreterAllocationReserveBytes.
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[| freeOldSpaceInImage headroom |
freeOldSpaceInImage := self getLongFromFile: f swap: swapBytes.
headroom := objectMemory
initialHeadroom: extraVMMemory
givenFreeOldSpaceInImage: freeOldSpaceInImage.
heapSize := objectMemory roundUpHeapSize:
dataSize
+ headroom
+ objectMemory newSpaceBytes
+ (headroom > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve])]
ifFalse:
[heapSize := dataSize
+ extraBytes
+ objectMemory newSpaceBytes
+ (extraBytes > allocationReserve
ifTrue: [0]
ifFalse: [allocationReserve])].
"allocate interpreter memory"
heapBase := objectMemory startOfMemory.
objectMemory
setHeapBase: heapBase
memoryLimit: heapBase + heapSize
endOfMemory: heapBase + dataSize. "bogus for Spur"
objectMemory allocateMemoryOfSize: objectMemory memoryLimit.
"read in the image in bulk, then swap the bytes if necessary"
f position: headerSize.
count := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
count ~= dataSize ifTrue: [self halt]]
ensure: [f close].
self ensureImageFormatIsUpToDate: swapBytes.
bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. "adjust pointers for zero base address"
UIManager default
informUser: 'Relocating object pointers...'
during: [self initializeInterpreter: bytesToShift]!
Item was added:
+ ----- Method: ThreadedFFIPlugin>>destroyManualSurface: (in category 'simulation') -----
+ destroyManualSurface: surfaceID
+ <doNotGenerate>
+ "Temporarily hack the simulation. Soon enough we could defer top the actual SurfacePlugin to simulate surfaces properly."
+ ^1!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveDestroyManualSurface (in category 'primitives - surfaces') -----
primitiveDestroyManualSurface
+ | surfaceID |
- "arguments: name(type, stack offset)
- surfaceID(Integer, 0)"
- | surfaceID result |
<export: true>
+ interpreterProxy methodArgumentCount = 1 ifFalse:
+ [^interpreterProxy primitiveFail].
-
- interpreterProxy methodArgumentCount == 1 ifFalse: [^interpreterProxy primitiveFail].
surfaceID := interpreterProxy stackIntegerValue: 0.
+ interpreterProxy failed ifFalse:
+ [(self destroyManualSurface: surfaceID) = 0
+ ifTrue: [interpreterProxy primitiveFail]
+ ifFalse: [interpreterProxy pop: 1]]!
- interpreterProxy failed ifTrue: [^nil].
- result := self destroyManualSurface: surfaceID.
- result = 0 ifTrue: [^interpreterProxy primitiveFail].
- ^interpreterProxy pop: 1
- !
More information about the Vm-dev
mailing list