[Vm-dev] VM Maker: VMMaker.oscog-nice.1988.mcz
commits at source.squeak.org
commits at source.squeak.org
Sun Nov 13 09:27:59 UTC 2016
Nicolas Cellier uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-nice.1988.mcz
==================== Summary ====================
Name: VMMaker.oscog-nice.1988
Author: nice
Time: 13 November 2016, 10:26:14.021969 am
UUID: 01ed55f2-205d-441f-b4f6-4a8607b3327d
Ancestors: VMMaker.oscog-nice.1987
Fix inlining problem of shortPrintContext: - a side effect was eliminated on stack flavour.
Fix prototype of unlockSurfaceFn after recent platforms source file revision.
Also, the surfceID returned by primitiveCreateManualSurface is an int, so fits in signed32BitIntegerFor:.
Avoid passing a sqInt to Serial and Midi external functions when they expect a pointer.
Explicit a few conversions 64->32 bits to avoid compiler warnings in LargeIntegers.
=============== Diff against VMMaker.oscog-nice.1987 ===============
Item was changed:
----- Method: BitBltSimulation>>unlockSurfaces (in category 'surface support') -----
unlockSurfaces
"Unlock the bits of any OS surfaces."
"See the comment in lockSurfaces. Similar rules apply. That is, the area provided in ioUnlockSurface can be used to determine the dirty region after drawing. If a source is unlocked, then the area will be (0,0,0,0) to indicate that no portion is dirty."
| sourceHandle destHandle destLocked fn |
+ <var: #fn declareC:'int (*fn)(int, int, int, int, int)'>
- <var: #fn declareC:'sqInt (*fn)(sqInt, sqInt, sqInt, sqInt, sqInt)'>
hasSurfaceLock ifTrue:[
unlockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
+ fn := self cCoerce: unlockSurfaceFn to: 'int (*)(int, int, int, int, int)'.
- fn := self cCoerce: unlockSurfaceFn to: 'sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt)'.
destLocked := false.
destHandle := interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
(interpreterProxy isIntegerObject: destHandle) ifTrue:[
destHandle := interpreterProxy integerValueOf: destHandle.
"The destBits are always assumed to be dirty"
self cCode:'fn(destHandle, affectedL, affectedT, affectedR-affectedL, affectedB-affectedT)'.
destBits := destPitch := 0.
destLocked := true.
].
noSource ifFalse:[
sourceHandle := interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
(interpreterProxy isIntegerObject: sourceHandle) ifTrue:[
sourceHandle := interpreterProxy integerValueOf: sourceHandle.
"Only unlock sourceHandle if different from destHandle"
(destLocked and:[sourceHandle = destHandle])
ifFalse:[self cCode: 'fn(sourceHandle, 0, 0, 0, 0)'].
sourceBits := sourcePitch := 0.
].
].
hasSurfaceLock := false.
self cCode: [] inSmalltalk:
[self touch: fn.
interpreterProxy displayObject = destForm ifTrue:
[interpreterProxy getDeferDisplayUpdates "for some reason this is true..."
ifTrue:
[interpreterProxy fullDisplayUpdate]
ifFalse:
[interpreterProxy fullDisplayUpdate]]].
].!
Item was changed:
----- Method: LargeIntegersPlugin>>cDigitDiv:len:rem:len:quo:len: (in category 'C core') -----
cDigitDiv: pDiv len: divLen rem: pRem len: remLen quo: pQuo len: quoLen
| dl ql dh dnh j t hi lo r3 l a b cond q r1r2 mul |
<var: #pDiv type: #'unsigned int *'>
<var: #pRem type: #'unsigned int *'>
<var: #pQuo type: #'unsigned int *'>
<var: #dh type: #'unsigned int'>
<var: #dnh type: #'unsigned int'>
<var: #r3 type: #'unsigned int'>
<var: #q type: #'unsigned long long'>
<var: #a type: #'unsigned long long'>
<var: #b type: #'unsigned long long'>
<var: #t type: #'unsigned long long'>
<var: #mul type: #'unsigned long long'>
<var: #hi type: #'unsigned long long'>
<var: #lo type: #'unsigned long long'>
<var: #r1r2 type: #'unsigned long long'>
dl := divLen - 1.
"Last actual byte of data (ST ix)"
ql := quoLen.
dh := self cDigitOf: pDiv at: dl - 1.
dl = 1
ifTrue: [dnh := 0]
ifFalse: [dnh := self cDigitOf: pDiv at: dl - 2].
1 to: ql do:
[:k |
"maintain quo*arg+rem=self"
"Estimate rem/div by dividing the leading two unint32 of rem by dh."
"The estimate is q = qhi*16r100000000+qlo, where qhi and qlo are uint32."
j := remLen + 1 - k.
"r1 := rem digitAt: j."
(self cDigitOf: pRem at: j - 1)
= dh
ifTrue: [q := 16rFFFFFFFF]
ifFalse:
["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.
Note that r1,r2 are uint64, not uint32."
"r2 := (rem digitAt: j - 2)."
r1r2 := self cDigitOf: pRem at: j - 1.
r1r2 := (r1r2 << 32) + (self cDigitOf: pRem at: j - 2).
t := r1r2 \\ dh.
q := r1r2 // dh.
"Next compute (hi,lo) := q*dnh"
mul := q * dnh.
hi := mul >> 32.
lo := mul bitAnd: 16rFFFFFFFF.
"Correct overestimate of q.
Max of 2 iterations through loop -- see Knuth vol. 2"
j < 3
ifTrue: [r3 := 0]
ifFalse: [r3 := self cDigitOf: pRem at: j - 3].
[(t < hi
or: [t = hi and: [r3 < lo]])
ifTrue:
["i.e. (t,r3) < (hi,lo)"
q := q - 1.
hi = 0 "since hi is unsigned we must have this guard"
ifTrue: [cond := false]
ifFalse:
[lo < dnh
ifTrue:
[hi := hi - 1.
lo := lo + 16r100000000 - dnh]
ifFalse:
[lo := lo - dnh].
cond := hi >= dh]]
ifFalse: [cond := false].
cond]
whileTrue: [hi := hi - dh]].
"Subtract q*div from rem"
l := j - dl.
a := 0.
1 to: divLen do:
[:i |
hi := (self cDigitOf: pDiv at: i - 1) * (q >> 32).
lo := (self cDigitOf: pDiv at: i - 1) * (q bitAnd: 16rFFFFFFFF).
b := (self cDigitOf: pRem at: l - 1) - a - (lo bitAnd: 16rFFFFFFFF).
self cDigitOf: pRem at: l - 1 put: (b bitAnd: 16rFFFFFFFF).
"simulate arithmetic shift (preserving sign of b)"
b := b >> 32 bitOr: (0 - (b >> 63) bitAnd: 16rFFFFFFFF00000000).
a := hi + (lo >> 32) - b.
l := l + 1].
a > 0
ifTrue:
["Add div back into rem, decrease q by 1"
q := q - 1.
l := j - dl.
a := 0.
1 to: divLen do:
[:i |
a := (a >> 32)
+ (self cDigitOf: pRem at: l - 1) + (self cDigitOf: pDiv at: i - 1).
self cDigitOf: pRem at: l - 1 put: (a bitAnd: 16rFFFFFFFF).
l := l + 1]].
+ self cDigitOf: pQuo at: quoLen - k put: (self cCoerceSimple: q to: #'unsigned int')].
- self cDigitOf: pQuo at: quoLen - k put: q].
^0!
Item was changed:
----- Method: LargeIntegersPlugin>>normalizePositive: (in category 'oop functions') -----
normalizePositive: aLargePositiveInteger
"Check for leading zeroes and return shortened copy if so."
"First establish len = significant length."
| val val2 sLen digitLen byteLen oldByteLen maxVal |
<var: #val type: #usqInt>
<var: #val2 type: #usqInt>
<var: #maxVal type: #usqInt>
digitLen := self digitSizeOfLargeInt: aLargePositiveInteger.
[digitLen ~= 0 and: [(self unsafeDigitOfLargeInt: aLargePositiveInteger at: digitLen) = 0]]
whileTrue: [digitLen := digitLen - 1].
digitLen = 0 ifTrue: [^ 0 asOop: SmallInteger].
"Now check if in SmallInteger range"
val := self unsafeDigitOfLargeInt: aLargePositiveInteger at: digitLen.
sLen := interpreterProxy maxSmallInteger > 16r3FFFFFFF
ifTrue: [2]
ifFalse: [1]. "SmallInteger maxVal digitLength"
digitLen <= sLen
ifTrue:
[maxVal := interpreterProxy maxSmallInteger.
val2 := val.
+ digitLen > 1 ifTrue:
+ ["Note: asUnsignedLongLong is not necessary because this branch is for 64 bits only.
+ but we want to avoid a C Compiler warning on 32 bits"
+ val2 := val2 asUnsignedLongLong << 32 + (self unsafeDigitOfLargeInt: aLargePositiveInteger at: 1)].
- digitLen > 1 ifTrue: [val2 := val2 << 32 + (self unsafeDigitOfLargeInt: aLargePositiveInteger at: 1)].
val2 <= maxVal
ifTrue: [^val2 asOop: SmallInteger]].
"Return self, or a shortened copy"
byteLen := digitLen * 4.
val <= 16rFFFF
ifTrue: [byteLen := byteLen - 2]
ifFalse: [val := val >> 16].
val <= 16rFF
ifTrue: [byteLen := byteLen - 1].
oldByteLen := self byteSizeOfLargeInt: aLargePositiveInteger.
byteLen < oldByteLen
ifTrue: [^ self largeInt: aLargePositiveInteger growTo: byteLen]
ifFalse: [^ aLargePositiveInteger]!
Item was changed:
----- Method: MIDIPlugin>>primitiveMIDIRead:into: (in category 'primitives') -----
primitiveMIDIRead: portNum into: array
| arrayLength bytesRead |
self primitive: 'primitiveMIDIRead'
parameters: #(SmallInteger ByteArray).
arrayLength := interpreterProxy byteSizeOf: array cPtrAsOop.
bytesRead := self sqMIDIPort: portNum
Read: arrayLength
+ Into: array.
- Into: array asInteger.
^bytesRead asSmallIntegerObj!
Item was changed:
----- Method: MIDIPlugin>>primitiveMIDIWrite:from:at: (in category 'primitives') -----
primitiveMIDIWrite: portNum from: array at: time
| arrayLength bytesWritten |
self primitive: 'primitiveMIDIWrite'
parameters: #(SmallInteger ByteArray SmallInteger).
arrayLength := interpreterProxy byteSizeOf: array cPtrAsOop.
bytesWritten := self sqMIDIPort: portNum
Write: arrayLength
+ From: array
- From: array asInteger
At: time.
^bytesWritten asSmallIntegerObj!
Item was changed:
----- Method: SerialPlugin>>primitiveSerialPortReadByName:into:startingAt:count: (in category 'primitives') -----
primitiveSerialPortReadByName: portName into: array startingAt: startIndex count: count
<option: #PharoVM>
<var: #port type: 'char *'>
| port portNameSize bytesRead arrayPtr |
self primitive: 'primitiveSerialPortReadByName'
parameters: #(String ByteArray SmallInteger SmallInteger ).
interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
"adjust for zero-origin indexing"
portNameSize := interpreterProxy slotSizeOf: (portName asOop: String).
port := self cCode: 'calloc(portNameSize+1, sizeof(char))'.
self cCode: 'memcpy(port, portName, portNameSize)'.
+ arrayPtr := array + startIndex - 1.
- arrayPtr := array asInteger + startIndex - 1.
bytesRead := self cCode: 'serialPortReadIntoByName( port, count, arrayPtr)'.
self free: port.
^ bytesRead asSmallIntegerObj!
Item was changed:
----- Method: SerialPlugin>>primitiveSerialPortWrite:from:startingAt:count: (in category 'primitives') -----
primitiveSerialPortWrite: portNum from: array startingAt: startIndex count: count
| bytesWritten arrayPtr |
self primitive: 'primitiveSerialPortWrite'
parameters: #(SmallInteger ByteArray SmallInteger SmallInteger ).
interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
interpreterProxy failed
+ ifFalse: [arrayPtr := array + startIndex - 1.
- ifFalse: [arrayPtr := array asInteger + startIndex - 1.
bytesWritten := self
serialPort: portNum
Write: count
From: arrayPtr].
^ bytesWritten asSmallIntegerObj!
Item was changed:
----- Method: SerialPlugin>>primitiveSerialPortWriteByName:from:startingAt:count: (in category 'primitives') -----
primitiveSerialPortWriteByName: portName from: array startingAt: startIndex count: count
<option: #PharoVM>
<var: #port type: 'char *'>
| bytesWritten arrayPtr portNameSize port |
self primitive: 'primitiveSerialPortWriteByName'
parameters: #(String ByteArray SmallInteger SmallInteger ).
portNameSize := interpreterProxy slotSizeOf: (portName asOop: String).
port := self cCode: 'calloc(portNameSize+1, sizeof(char))'.
self cCode: 'memcpy(port, portName, portNameSize)'.
interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
interpreterProxy failed
+ ifFalse: [arrayPtr := array + startIndex - 1.
- ifFalse: [arrayPtr := array asInteger + startIndex - 1.
bytesWritten := self cCode: 'serialPortWriteFromByName(port, count, arrayPtr)' ].
self free: port.
^ bytesWritten asSmallIntegerObj!
Item was changed:
----- Method: Spur32BitMemoryManager>>integerValueOf: (in category 'immediates') -----
integerValueOf: oop
"Translator produces 'oop >> 1'"
+ ^(oop >> 31) = 1 "tests top bit"
- ^(oop bitShift: -31) = 1 "tests top bit"
ifTrue: "negative"
+ [((oop >> 1) bitAnd: 16r3FFFFFFF) - 16r3FFFFFFF - 1 "Faster than -16r40000000 (a LgInt)"]
- [((oop bitShift: -1) bitAnd: 16r3FFFFFFF) - 16r3FFFFFFF - 1 "Faster than -16r40000000 (a LgInt)"]
ifFalse: "positive"
+ [oop >> 1]!
- [oop bitShift: -1]!
Item was changed:
----- Method: Spur64BitMemoryManager>>integerValueOf: (in category 'immediates') -----
integerValueOf: oop
"Translator produces 'oop >> 3'"
+ ^(oop >> 63) = 1 "tests top bit"
- ^(oop bitShift: -63) = 1 "tests top bit"
ifTrue: "negative"
+ [((oop >> self numTagBits) bitAnd: 16r1FFFFFFFFFFFFFFF) - 16r1FFFFFFFFFFFFFFF - 1 "Faster than -16r4000000000000000 (a LgInt)"]
- [((oop bitShift: self numTagBits negated) bitAnd: 16r1FFFFFFFFFFFFFFF) - 16r1FFFFFFFFFFFFFFF - 1 "Faster than -16r4000000000000000 (a LgInt)"]
ifFalse: "positive"
+ [oop >> self numTagBits]!
- [oop bitShift: self numTagBits negated]!
Item was changed:
----- Method: StackInterpreter>>shortPrintContext: (in category 'debug printing') -----
shortPrintContext: aContext
| theFP |
<inline: false>
<var: #theFP type: #'char *'>
(objectMemory isContext: aContext) ifFalse:
[self printHex: aContext; print: ' is not a context'; cr.
^nil].
self printHex: aContext.
(self isMarriedOrWidowedContext: aContext)
ifTrue: [(self checkIsStillMarriedContext: aContext currentFP: framePointer)
ifTrue:
+ [theFP := self frameOfMarriedContext: aContext.
+ (self isMachineCodeFrame: theFP)
- [(self isMachineCodeFrame: (theFP := self frameOfMarriedContext: aContext))
ifTrue: [self print: ' M (']
ifFalse: [self print: ' I ('].
+ self printHex: theFP asUnsignedIntegerPtr; print: ') ']
- self printHex: theFP asUnsignedInteger; print: ') ']
ifFalse:
[self print: ' w ']]
ifFalse: [self print: ' s '].
(self findHomeForContext: aContext)
ifNil: [self print: ' BOGUS CONTEXT (can''t determine home)']
ifNotNil:
[:home|
self printActivationNameFor: (objectMemory
fetchPointer: MethodIndex
ofObject: (home ifNil: [aContext]))
receiver: (home
ifNil: [objectMemory nilObject]
ifNotNil: [objectMemory fetchPointer: ReceiverIndex ofObject: home])
isBlock: home ~= aContext
firstTemporary: (objectMemory fetchPointer: 0 + CtxtTempFrameStart ofObject: home)].
self cr!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveCreateManualSurface (in category 'primitives - surfaces') -----
primitiveCreateManualSurface
"arguments: name(type, stack offset)
width(Integer, 4)
height(Integer, 3)
rowPitch(Integer, 2)
depth(Integer, 1)
isMSB(Boolean, 0)"
| width height rowPitch depth isMSB result |
<export: true>
interpreterProxy methodArgumentCount = 5 ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadNumArgs].
width := interpreterProxy stackIntegerValue: 4.
height := interpreterProxy stackIntegerValue: 3.
rowPitch := interpreterProxy stackIntegerValue: 2.
depth := interpreterProxy stackIntegerValue: 1.
isMSB := interpreterProxy stackObjectValue: 0.
isMSB := interpreterProxy booleanValueOf: isMSB.
interpreterProxy failed ifTrue: [^nil].
result := self cCode: 'createManualSurface(width, height, rowPitch, depth, isMSB)'
inSmalltalk: [self create: width Man: height ual: rowPitch Surf: depth ace: isMSB].
result < 0 ifTrue:
[^interpreterProxy primitiveFail].
+ result := interpreterProxy signed32BitIntegerFor: result.
- result := interpreterProxy signedMachineIntegerFor: result.
^interpreterProxy pop: 6 thenPush: result
!
More information about the Vm-dev
mailing list