[Vm-dev] VM Maker: VMMaker.oscog-eem.124.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Sep 10 11:33:30 UTC 2011
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.124.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.124
Author: eem
Time: 9 September 2011, 5:34:05.923 pm
UUID: 6dc066ca-29ab-4d2f-b988-60cc2c425779
Ancestors: VMMaker.oscog-eem.123
CoInterpreterMT:
Fix an assert failure/thread state issue with threadSwitchIfNecessary:from:.
Make willingVMThread return highest priority thread wanting ownership.
Interpreters, as part of CogMemoryManager work:
Nuke assertClassOf:is:compactClassIndex: in favour of
is:instanceOf:compactClassIndex: et al. (Next step is to hide compact class
indices in ObjectMemory, by implementing isFloatOop:, isFloatNonInt: etc).
Refactor various float conversion routines to call the core floatValueOf: method.
Eliminate a SLang warning in compactClassAt:.
Elsewhere, as part of buildup to changing semantics of translating symbols:
Fix the one use of #Symbol => C string in initializeExtraClassInstVarIndices where
#Array was expected to translate to "Array".
Convert type sends to pragmas in various pragmas.
CogMemoryManager:
Transcribe David Ungar's generation scavenger into Smalltalk.
=============== Diff against VMMaker.oscog-eem.123 ===============
Item was changed:
----- Method: CoInterpreterMT>>threadSwitchIfNecessary:from: (in category 'process primitive support') -----
threadSwitchIfNecessary: newProc from: sourceCode
"Invoked from transferTo:from: to switch threads if the new process is bound or affined to some other thread."
| newProcThreadId vmThread activeContext tlti vmo |
<var: #vmThread type: #'CogVMThread *'>
self cCode: []
inSmalltalk:
[vmo := cogThreadManager getVMOwner.
tlti := cogThreadManager ioGetThreadLocalThreadIndex.
self assert: vmo = tlti].
deferThreadSwitch ifTrue: [^self].
newProcThreadId := self ownerIndexOfProcess: newProc.
((activeProcessAffined := newProcThreadId ~= 0)
and: [newProcThreadId ~= cogThreadManager getVMOwner]) ifTrue:
[self cCode: ''
inSmalltalk:
[self transcript ensureCr; nextPutAll: #threadSwitchIfNecessary:from:; space; print: newProc;
space; print: vmo; nextPutAll: '->'; print: newProcThreadId; cr; flush].
"If primitiveProcessBindToThreadId has bound a process and indicated a thread
switch is necessary we'll come in here but the activeProcess won't have a
context yet, and it needs one from which the new thread can resume execution."
(objectMemory fetchPointer: SuspendedContextIndex ofObject: newProc) = objectMemory nilObject ifTrue:
[self assert: newProc = self activeProcess.
self push: instructionPointer.
self externalWriteBackHeadFramePointers.
activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: activeContext].
vmThread := cogThreadManager vmThreadAt: newProcThreadId.
vmThread priority: (self quickFetchInteger: PriorityIndex ofObject: newProc).
+ vmThread state = CTMUnavailable ifTrue:
+ [vmThread state: CTMWantingOwnership].
self returnToSchedulingLoopAndReleaseVMOrWakeThread: vmThread source: CSSwitchIfNeccessary].
(self quickFetchInteger: PriorityIndex ofObject: newProc) < maxWaitingPriority ifTrue:
[checkThreadActivation := true.
self forceInterruptCheck]!
Item was added:
+ VMClass subclass: #CogGenerationScavenger
+ instanceVariableNames: 'coInterpreter manager memory futureSpace pastSpace rememberedSet rememberedSetSize'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-MemoryManager'!
Item was added:
+ ----- Method: CogGenerationScavenger>>copyAndForward: (in category 'api') -----
+ copyAndForward: survivor
+ "copyAndForward: survivor copies a survivor object either to
+ futureSurvivorSpace or, if it is to be promoted, to oldSpace.
+ It leaves a forwarding pointer behind."
+ <var: #survivor type: #'object *'>
+ | newLocation |
+ newLocation := (self shouldBeTenured: survivor)
+ ifTrue: [self copyToOldSpace: survivor]
+ ifFalse: [self copyToFutureSpace: survivor].
+ manager forward: survivor to: newLocation
+ !
Item was added:
+ ----- Method: CogGenerationScavenger>>scavenge (in category 'api') -----
+ scavenge
+ "The main routine, scavenge, scavenges young objects reachable from the roots (the stack zone
+ and the rememberedTable). It first scavenges the new objects immediately reachable from the
+ stack zone, then those directly from old ones (all in the remembered table). Then it scavenges
+ those that are transitively reachable. If this results in a promotion, the promotee gets remembered,
+ and it first scavenges objects adjacent to the promotee, then scavenges the ones reachable from
+ the promoted. This loop continues until no more reachable objects are left. At that point,
+ pastSurvivorSpace is exchanged with futureSurvivorSpace.
+
+ Notice that each pointer in a live object is inspected once and only once. The previousRememberedSetSize
+ and previousFutureSurvivorSpaceSize variables ensure that no object is scanned twice, as well as
+ detecting closure. If this were not true, some pointers might get forwarded twice."
+
+ coInterpreter scavengeStacks.
+ self scavengeLoop.
+ self exchange: pastSpace with: futureSpace!
Item was added:
+ ----- Method: CogGenerationScavenger>>scavengeFutureSurvivorSpaceStartingAt: (in category 'api') -----
+ scavengeFutureSurvivorSpaceStartingAt: initialAddress
+ "scavengeFutureSurvivorSpaceStartingAt: does a depth-first traversal of the
+ new objects starting at the one at the nth word of futureSurvivorSpace."
+ | ptr |
+ <var: #ptr type: #'char *'>
+ ptr := initialAddress.
+ [ptr < futureSpace limit] whileTrue:
+ [| obj |
+ obj := manager objectAt: ptr.
+ ptr := ptr + (manager byteLengthOf: obj).
+ self cCoerceSimple: (self scavengeReferentsOf: obj)
+ to: #void]!
Item was added:
+ ----- Method: CogGenerationScavenger>>scavengeLoop (in category 'api') -----
+ scavengeLoop
+ "This is the inner loop of the main routine, scavenge. It first scavenges the new objects immediately
+ reachable from old ones. Then it scavenges those that are transitively reachable. If this results in a
+ promotion, the promotee gets remembered, and it first scavenges objects adjacent to the promotee,
+ then scavenges the ones reachable from the promoted. This loop continues until no more reachable
+ objects are left. At that point, pastSurvivorSpace is exchanged with futureSurvivorSpace.
+
+ Notice that each pointer in a live object is inspected once and only once. The previousRememberedSetSize
+ and previousFutureSurvivorSpaceLimit variables ensure that no object is scanned twice, as well as
+ detecting closure. If this were not true, some pointers might get forwarded twice."
+
+ | previousRememberedSetSize previousFutureSurvivorSpaceLimit |
+ previousRememberedSetSize := 0.
+ previousFutureSurvivorSpaceLimit := futureSpace limit.
+ self assert: futureSpace limit = futureSpace start.
+ [self scavengeRememberedSetStartingAt: previousRememberedSetSize.
+ previousFutureSurvivorSpaceLimit = futureSpace limit ifTrue:
+ [^self].
+
+ previousRememberedSetSize := rememberedSetSize.
+ self scavengeFutureSurvivorSpaceStartingAt: previousFutureSurvivorSpaceLimit.
+ previousFutureSurvivorSpaceLimit = rememberedSetSize ifTrue:
+ [^self].
+
+ previousFutureSurvivorSpaceLimit := futureSpace size] repeat!
Item was added:
+ ----- Method: CogGenerationScavenger>>scavengeReferentsOf: (in category 'api') -----
+ scavengeReferentsOf: referrer
+ "scavengeReferentsOf: referrer inspects all the pointers in referrer.
+ If any are new objects, it has them moved to FutureSurvivorSpace,
+ and returns truth. If there are no new referents, it returns falsity."
+ <var: #referrer type: #'object *'>
+ | foundNewReferent referent |
+ referrer isPointers ifFalse:
+ [^self].
+ foundNewReferent := false.
+ 0 to: (manager lengthOf: referrer) do:
+ [:i|
+ referent := manager fetchPointer: i ofObject: referrer.
+ (manager isYoung: referent) ifTrue:
+ [foundNewReferent := true.
+ referent isForwarded ifFalse:
+ [self copyAndForward: referent].
+ manager
+ storePointerUnchecked: i
+ ofObject: referrer
+ withValue: (manager forwardingPointerOf: referent)]].
+ ^foundNewReferent!
Item was added:
+ ----- Method: CogGenerationScavenger>>scavengeRememberedSetStartingAt: (in category 'api') -----
+ scavengeRememberedSetStartingAt: n
+ "scavengeRememberedSetStartingAt: n traverses objects in the remembered
+ set starting at the nth one. If the object does not refer to any new objects, it
+ is removed from the set. Otherwise, its new referents are scavenged."
+ | destIndex sourceIndex |
+ sourceIndex := destIndex := n.
+ [sourceIndex < rememberedSetSize] whileTrue:
+ [| referree |
+ referree := rememberedSet at: sourceIndex.
+ (self scavengeReferentsOf: referree)
+ ifTrue:
+ [rememberedSet at: destIndex put: referree.
+ destIndex := destIndex + 1]
+ ifFalse:
+ [referree isRemembered: false].
+ sourceIndex := sourceIndex + 1].
+ rememberedSetSize := destIndex!
Item was added:
+ ----- Method: CogObjectHeader>>isForwarded (in category 'accessing') -----
+ isForwarded
+ ^self classIndex = 0!
Item was added:
+ ----- Method: CogObjectHeader>>setIsForwarded (in category 'accessing') -----
+ setIsForwarded
+ self classIndex: 0!
Item was changed:
----- Method: CogThreadManager>>willingVMThread (in category 'thread set') -----
willingVMThread
"Answer a pointer to a live CogVMThread in any of the ``will do VM work''
states (other than the current owner if the VM is owned), or nil if none.
Preferentially answer threads wanting ownership."
<returnTypeC: #'CogVMThread *'>
+ | thread threadWantingVM threadWilling |
- | vmThreadA vmThreadB |
<inline: false>
+ <var: #thread type: #'CogVMThread *'>
+ <var: #threadWantingVM type: #'CogVMThread *'>
+ <var: #threadWilling type: #'CogVMThread *'>
+ threadWantingVM := threadWilling := nil.
- <var: #vmThreadA type: #'CogVMThread *'>
- <var: #vmThreadB type: #'CogVMThread *'>
1 to: numThreads do:
[:i|
+ i ~= vmOwner ifTrue:
+ [thread := threads at: i.
+ thread state = CTMWantingOwnership ifTrue:
+ [(threadWantingVM isNil
+ or: [threadWantingVM priority < thread priority]) ifTrue:
+ [threadWantingVM := thread]].
+ thread state = CTMAssignableOrInVM ifTrue:
+ [(threadWilling isNil
+ or: [threadWilling priority < thread priority]) ifTrue:
+ [threadWilling := thread]]]].
+ threadWantingVM ifNotNil:
+ [^threadWantingVM].
+ threadWilling ifNotNil:
+ [^threadWilling].
- vmThreadA := threads at: i.
- vmThreadA state = CTMWantingOwnership ifTrue:
- [^vmThreadA].
- (i ~= vmOwner
- and: [vmThreadA state = CTMAssignableOrInVM]) ifTrue:
- [i + 1 to: numThreads do:
- [:j|
- vmThreadB := threads at: i.
- vmThreadB state = CTMWantingOwnership ifTrue:
- [^vmThreadB]].
- ^vmThreadA]].
^nil!
Item was changed:
----- Method: GeniePlugin>>cSquaredDistanceFrom:to: (in category 'computation') -----
cSquaredDistanceFrom: aPoint to: bPoint
"arguments are pointer to ints paired as x,y coordinates of points"
| aPointX aPointY bPointX bPointY xDiff yDiff |
+ <var: #aPoint type: #'int *'>
+ <var: #bPoint type: #'int *'>
- self var: #aPoint type: 'int * '.
- self var: #bPoint type: 'int * '.
aPointX := aPoint at: 0.
aPointY := aPoint at: 1.
bPointX := bPoint at: 0.
bPointY := bPoint at: 1.
xDiff := bPointX - aPointX.
yDiff := bPointY - aPointY.
^ xDiff * xDiff + (yDiff * yDiff)!
Item was changed:
----- Method: GeniePlugin>>primSameClassAbsoluteStrokeDistanceMyPoints:otherPoints:myVectors:otherVectors:mySquaredLengths:otherSquaredLengths:myAngles:otherAngles:maxSizeAndReferenceFlag:rowBase:rowInsertRemove:rowInsertRemoveCount: (in category 'computation') -----
primSameClassAbsoluteStrokeDistanceMyPoints: myPointsOop otherPoints: otherPointsOop myVectors: myVectorsOop otherVectors: otherVectorsOop mySquaredLengths: mySquaredLengthsOop otherSquaredLengths: otherSquaredLengthsOop myAngles: myAnglesOop otherAngles: otherAnglesOop maxSizeAndReferenceFlag: maxSizeAndRefFlag rowBase: rowBaseOop rowInsertRemove: rowInsertRemoveOop rowInsertRemoveCount: rowInsertRemoveCountOop
| base insertRemove jLimiT substBase insert remove subst removeBase insertBase insertRemoveCount additionalMultiInsertRemoveCost myPoints otherPoints myVectors otherVectors rowInsertRemoveCount mySquaredLengths otherSquaredLengths myAngles otherAngles rowBase rowInsertRemove otherPointsSize myVectorsSize otherVectorsSize otherSquaredLengthsSize rowBaseSize maxDist maxSize forReference jM1 iM1 iM1T2 jM1T2 |
+ <var: #myPoints type: #'int *'>
+ <var: #otherPoints type: #'int *'>
+ <var: #myVectors type: #'int *'>
+ <var: #otherVectors type: #'int *'>
+ <var: #mySquaredLengths type: #'int *'>
+ <var: #otherSquaredLengths type: #'int *'>
+ <var: #myAngles type: #'int *'>
+ <var: #otherAngles type: #'int *'>
+ <var: #rowBase type: #'int *'>
+ <var: #rowInsertRemove type: #'int *'>
+ <var: #rowInsertRemoveCount type: #'int *'>
- self var: #myPoints type: 'int * '.
- self var: #otherPoints type: 'int * '.
- self var: #myVectors type: 'int * '.
- self var: #otherVectors type: 'int * '.
- self var: #mySquaredLengths type: 'int * '.
- self var: #otherSquaredLengths type: 'int * '.
- self var: #myAngles type: 'int * '.
- self var: #otherAngles type: 'int * '.
- self var: #rowBase type: 'int * '.
- self var: #rowInsertRemove type: 'int * '.
- self var: #rowInsertRemoveCount type: 'int * '.
self
primitive: 'primSameClassAbsoluteStrokeDistanceMyPoints_otherPoints_myVectors_otherVectors_mySquaredLengths_otherSquaredLengths_myAngles_otherAngles_maxSizeAndReferenceFlag_rowBase_rowInsertRemove_rowInsertRemoveCount'
parameters: #(#Oop #Oop #Oop #Oop #Oop #Oop #Oop #Oop #SmallInteger #Oop #Oop #Oop)
receiver: #Oop.
interpreterProxy failed
ifTrue: [self msg: 'failed 1'.
^ nil].
interpreterProxy success: (interpreterProxy isWords: myPointsOop)
& (interpreterProxy isWords: otherPointsOop)
& (interpreterProxy isWords: myVectorsOop)
& (interpreterProxy isWords: otherVectorsOop)
& (interpreterProxy isWords: mySquaredLengthsOop)
& (interpreterProxy isWords: otherSquaredLengthsOop)
& (interpreterProxy isWords: myAnglesOop)
& (interpreterProxy isWords: otherAnglesOop)
& (interpreterProxy isWords: rowBaseOop)
& (interpreterProxy isWords: rowInsertRemoveOop)
& (interpreterProxy isWords: rowInsertRemoveCountOop).
interpreterProxy failed
ifTrue: [self msg: 'failed 2'.
^ nil].
interpreterProxy success: (interpreterProxy is: myPointsOop MemberOf: 'PointArray')
& (interpreterProxy is: otherPointsOop MemberOf: 'PointArray').
interpreterProxy failed
ifTrue: [self msg: 'failed 3'.
^ nil].
myPoints := interpreterProxy firstIndexableField: myPointsOop.
otherPoints := interpreterProxy firstIndexableField: otherPointsOop.
myVectors := interpreterProxy firstIndexableField: myVectorsOop.
otherVectors := interpreterProxy firstIndexableField: otherVectorsOop.
mySquaredLengths := interpreterProxy firstIndexableField: mySquaredLengthsOop.
otherSquaredLengths := interpreterProxy firstIndexableField: otherSquaredLengthsOop.
myAngles := interpreterProxy firstIndexableField: myAnglesOop.
otherAngles := interpreterProxy firstIndexableField: otherAnglesOop.
rowBase := interpreterProxy firstIndexableField: rowBaseOop.
rowInsertRemove := interpreterProxy firstIndexableField: rowInsertRemoveOop.
rowInsertRemoveCount := interpreterProxy firstIndexableField: rowInsertRemoveCountOop.
"Note: myPointsSize and mySquaredLengthsSize variables eliminated to reduce
method temporary variable count for closure-enabled images"
"PointArrays"
"myPointsSize := (interpreterProxy stSizeOf: myPointsOop) bitShift: -1."
otherPointsSize := (interpreterProxy stSizeOf: otherPointsOop) bitShift: -1.
myVectorsSize := (interpreterProxy stSizeOf: myVectorsOop) bitShift: -1.
otherVectorsSize := (interpreterProxy stSizeOf: otherVectorsOop) bitShift: -1.
"IntegerArrays"
"mySquaredLengthsSize := interpreterProxy stSizeOf: mySquaredLengthsOop."
otherSquaredLengthsSize := interpreterProxy stSizeOf: otherSquaredLengthsOop.
rowBaseSize := interpreterProxy stSizeOf: rowBaseOop.
interpreterProxy success: rowBaseSize
= (interpreterProxy stSizeOf: rowInsertRemoveOop) & (rowBaseSize
= (interpreterProxy stSizeOf: rowInsertRemoveCountOop)) & (rowBaseSize > otherVectorsSize).
interpreterProxy failed
ifTrue: [self msg: 'failed 4'.
^ nil].
interpreterProxy success: (interpreterProxy stSizeOf: mySquaredLengthsOop) >= (myVectorsSize - 1)
& (((interpreterProxy stSizeOf: myPointsOop) bitShift: -1) >= myVectorsSize)
& (otherSquaredLengthsSize >= (otherVectorsSize - 1))
& (otherPointsSize >= otherVectorsSize) & ((interpreterProxy stSizeOf: myAnglesOop)
>= (myVectorsSize - 1)) & ((interpreterProxy stSizeOf: otherAnglesOop)
>= (otherVectorsSize - 1)).
interpreterProxy failed
ifTrue: [self msg: 'failed 5'.
^ nil].
"maxSizeAndRefFlag contains the maxium feature size (pixel) and also indicates whether
the reference flag (boolean) is set. Therefore the maximum size is moved to the left
and the reference flag is stored in the LSB.
Note: This is necessary to avoid more than 12 primitive parameters"
forReference := maxSizeAndRefFlag bitAnd: 1.
maxSize := maxSizeAndRefFlag bitShift: -1.
maxDist := 1 bitShift: 29.
forReference
ifTrue: [additionalMultiInsertRemoveCost := 0]
ifFalse: [additionalMultiInsertRemoveCost := maxSize * maxSize bitShift: -10].
"C indices!!!!"
rowBase
at: 0
put: 0.
rowInsertRemove
at: 0
put: 0.
rowInsertRemoveCount
at: 0
put: 2.
insertRemove := 0 - additionalMultiInsertRemoveCost.
jLimiT := otherVectorsSize.
otherPointsSize >= (jLimiT - 1) & (otherSquaredLengthsSize >= (jLimiT - 1))
ifFalse: [^ interpreterProxy primitiveFail].
1
to: jLimiT
do: [:j |
jM1 := j - 1.
insertRemove := insertRemove + ((otherSquaredLengths at: jM1)
+ (self
cSquaredDistanceFrom: (otherPoints + (jM1 bitShift: 1))
to: myPoints) bitShift: -7) + additionalMultiInsertRemoveCost.
rowInsertRemove
at: j
put: insertRemove.
rowBase
at: j
put: insertRemove * j.
rowInsertRemoveCount
at: j
put: j + 1].
insertRemove := (rowInsertRemove at: 0)
- additionalMultiInsertRemoveCost.
1
to: myVectorsSize
do: [:i |
iM1 := i - 1.
iM1T2 := iM1 bitShift: 1.
substBase := rowBase at: 0.
insertRemove := insertRemove + ((mySquaredLengths at: iM1)
+ (self
cSquaredDistanceFrom: (myPoints + iM1T2)
to: otherPoints) bitShift: -7) + additionalMultiInsertRemoveCost.
rowInsertRemove
at: 0
put: insertRemove.
rowBase
at: 0
put: insertRemove * i.
rowInsertRemoveCount
at: 0
put: i + 1.
jLimiT := otherVectorsSize.
1
to: jLimiT
do: [:j |
jM1 := j - 1.
jM1T2 := jM1 bitShift: 1.
removeBase := rowBase at: j.
insertBase := rowBase at: jM1.
remove := (mySquaredLengths at: iM1)
+ (self
cSquaredDistanceFrom: (myPoints + iM1T2)
to: (otherPoints + (j bitShift: 1))) bitShift: -7.
(insertRemove := rowInsertRemove at: j) = 0
ifTrue: [removeBase := removeBase + remove]
ifFalse: [removeBase := removeBase + insertRemove + (remove
* (rowInsertRemoveCount at: j)).
remove := remove + insertRemove].
insert := (otherSquaredLengths at: jM1)
+ (self
cSquaredDistanceFrom: (otherPoints + jM1T2)
to: (myPoints + (i bitShift: 1))) bitShift: -7.
(insertRemove := rowInsertRemove at: jM1) = 0
ifTrue: [insertBase := insertBase + insert]
ifFalse: [insertBase := insertBase + insertRemove + (insert
* (rowInsertRemoveCount at: jM1)).
insert := insert + insertRemove].
forReference
ifTrue: [substBase := maxDist]
ifFalse: [subst := (self
cSquaredDistanceFrom: (otherVectors + jM1T2)
to: (myVectors + iM1T2))
+ (self
cSquaredDistanceFrom: (otherPoints + jM1T2)
to: (myPoints + iM1T2)) * (16
+ (self
cSubstAngleFactorFrom: (otherAngles at: jM1)
to: (myAngles at: iM1))) bitShift: -11.
substBase := substBase + subst].
(substBase <= removeBase
and: [substBase <= insertBase])
ifTrue: [base := substBase.
insertRemove := 0.
insertRemoveCount := 1]
ifFalse: [removeBase <= insertBase
ifTrue: [base := removeBase.
insertRemove := remove + additionalMultiInsertRemoveCost.
insertRemoveCount := (rowInsertRemoveCount at: j)
+ 1]
ifFalse: [base := insertBase.
insertRemove := insert + additionalMultiInsertRemoveCost.
insertRemoveCount := (rowInsertRemoveCount at: jM1)
+ 1]].
substBase := rowBase at: j.
rowBase
at: j
put: (base min: maxDist).
rowInsertRemove
at: j
put: (insertRemove min: maxDist).
rowInsertRemoveCount
at: j
put: insertRemoveCount].
insertRemove := rowInsertRemove at: 0].
^ base asOop: SmallInteger
!
Item was changed:
----- Method: HostWindowPlugin>>primitiveShowHostWindow:bits:width:height:depth:left:right:top:bottom: (in category 'system primitives') -----
primitiveShowHostWindow: windowIndex bits: dispBits width: w height: h depth: d
left: left right: right top: top bottom: bottom
"Host window analogue of DisplayScreen> primShowRectLeft:right:top:bottom:
(Interpreter>primitiveShowDisplayRect) which takes the window index, bitmap
details and the rectangle bounds. Fail if the windowIndex is invalid or the
platform routine returns false to indicate failure"
|ok|
+ <var: #dispBits type: #'unsigned char *'>
- self var: #dispBits type: 'unsigned char * '.
self primitive: 'primitiveShowHostWindowRect'
parameters: #(SmallInteger WordArray SmallInteger SmallInteger SmallInteger
SmallInteger SmallInteger SmallInteger SmallInteger).
"Tell the vm to copy pixel's from dispBits to the screen - this is just
ioShowDisplay with the extra parameter of the windowIndex integer"
ok := self cCode: 'ioShowDisplayOnWindow(dispBits, w, h, d, left, right, top,
bottom, windowIndex)'.
ok ifFalse:[interpreterProxy primitiveFail]!
Item was changed:
----- Method: InternetConfigPlugin>>primitiveGetMacintoshFileTypeAndCreatorFrom: (in category 'system primitives') -----
primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName
| oop ptr keyLength creator |
+ <var: #aFile declareC: 'char aFile[256]'>
+ <var: #creator declareC: 'char creator[8]'>
+ <var: #ptr type: 'char *'>
self primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom'
parameters: #(String).
+
- self var: #aFile declareC: 'char aFile[256]'.
- self var: #creator declareC: 'char creator[8]'.
- self var: #ptr type: 'char *'.
-
keyLength := interpreterProxy byteSizeOf: aFileName cPtrAsOop.
self sqInternetGetMacintoshFileTypeAndCreatorFrom: aFileName keySize: keyLength into: creator.
oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: 8.
ptr := interpreterProxy firstIndexableField: oop.
0 to: 7 do:[:i|
ptr at: i put: (creator at: i)].
^oop.
!
Item was changed:
----- Method: InternetConfigPlugin>>primitiveGetStringKeyedBy: (in category 'system primitives') -----
primitiveGetStringKeyedBy: aKey
| oop ptr size aString keyLength |
+ <var: #aString declareC: 'char aString[1025]'>
+ <var: #ptr type: 'char *'>
self primitive: 'primitiveGetStringKeyedBy'
parameters: #(String).
- self var: #aString declareC: 'char aString[1025]'.
- self var: #ptr type: 'char *'.
keyLength := interpreterProxy byteSizeOf: aKey cPtrAsOop.
size := self sqInternetConfigurationGetStringKeyedBy: aKey keySize: keyLength into: aString.
oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size.
ptr := interpreterProxy firstIndexableField: oop.
0 to: size-1 do:[:i|
ptr at: i put: (aString at: i)].
^oop.
!
Item was changed:
----- Method: Interpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
+ "Fetch the instance variable at the given index of the given object. Answer the C
+ double precision floating point value of that instance variable, or fail if it is not a Float."
- "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
- "Note: May be called by translated primitive code."
+ | isFloat result |
+ <returnTypeC: #double>
+ <var: #result type: #double>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
+ ClassArrayCompactIndex is non-zero."
+ isFloat := self
+ is: oop
+ instanceOf: (self splObj: ClassFloat)
+ compactClassIndex: ClassFloatCompactIndex.
+ isFloat ifTrue:
+ [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + BaseHeaderSize into: result.
+ ^result].
+ self primitiveFail.
+ ^0.0!
- "DO _NOT_ USE THIS IN DEBUG PRINTING!! assertClassOf:is: sets successFlag."
-
- | result |
- self flag: #Dan. "None of the float stuff has been converted for 64 bits"
- self returnTypeC: 'double'.
- self var: #result type: 'double '.
- self assertClassOf: oop is: (self splObj: ClassFloat).
- successFlag
- ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: oop + BaseHeaderSize into: result]
- ifFalse: [result := 0.0].
- ^ result!
Item was changed:
----- Method: Interpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
+ If it is a Float, then load its value and return it.
+ Otherwise fail -- ie return with primErrorCode non-zero."
- If it is a Float, then load its value and return it.
- Otherwise fail -- ie return with successFlag set to false."
- | result |
<inline: true>
<asmLabel: false>
+ <returnTypeC: #double>
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
(self isIntegerObject: floatOrInt) ifTrue:
[^(self integerValueOf: floatOrInt) asFloat].
+ ^self floatValueOf: floatOrInt!
- (self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat) ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: floatOrInt + BaseHeaderSize into: result.
- ^result].
- successFlag := false!
Item was changed:
----- Method: Interpreter>>popFloat (in category 'stack bytecodes') -----
popFloat
+ <returnTypeC: #double>
+ ^self floatValueOf: self popStack!
- "Note: May be called by translated primitive code."
-
- | top result |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- top := self popStack.
- self assertClassOf: top is: (self splObj: ClassFloat).
- successFlag ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: top + BaseHeaderSize into: result].
- ^ result!
Item was changed:
----- Method: Interpreter>>stackFloatValue: (in category 'contexts') -----
stackFloatValue: offset
+ <returnTypeC: #double>
+ ^self floatValueOf: (self longAt: stackPointer - (offset*BytesPerWord))!
- "Note: May be called by translated primitive code."
- | result floatPointer |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- floatPointer := self longAt: stackPointer - (offset*BytesPerWord).
- (self fetchClassOf: floatPointer) = (self splObj: ClassFloat)
- ifFalse:[self primitiveFail. ^0.0].
- self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: floatPointer + BaseHeaderSize into: result.
- ^ result!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetItemCmd:item: (in category 'system primitives') -----
primitiveGetItemCmd: menuHandleOop item: anInteger
| menuHandle aCharacter |
+ <var: 'menuHandle' type: 'MenuHandle'>
+ <var: #aCharacter type: 'CharParameter '>
+ <var: #ptr type: 'char *'>
self primitive: 'primitiveGetItemCmd'
parameters: #(Oop SmallInteger).
- self var: 'menuHandle' type: 'MenuHandle'.
- self var: #aCharacter type: 'CharParameter '.
- self var: #ptr type: 'char *'.
menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
aCharacter := 0.
self cCode: 'GetItemCmd(menuHandle,anInteger,&aCharacter)' inSmalltalk:[menuHandle].
^aCharacter asSmallIntegerObj
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetItemMark:item: (in category 'system primitives') -----
primitiveGetItemMark: menuHandleOop item: anInteger
| menuHandle aCharacter |
+ <var: 'menuHandle' type: 'MenuHandle'>
+ <var: #aCharacter type: 'CharParameter '>
+ <var: #ptr type: 'char *'>
self primitive: 'primitiveGetItemMark'
parameters: #(Oop SmallInteger).
- self var: 'menuHandle' type: 'MenuHandle'.
- self var: #aCharacter type: 'CharParameter '.
- self var: #ptr type: 'char *'.
menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
aCharacter := 0.
self cCode: 'GetItemMark(menuHandle,anInteger,&aCharacter)' inSmalltalk:[menuHandle].
^aCharacter asSmallIntegerObj
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetMenuItemText:item: (in category 'system primitives') -----
primitiveGetMenuItemText: menuHandleOop item: anInteger
| menuHandle size oop ptr aString |
+ <var: 'menuHandle' type: 'MenuHandle'>
+ <var: #aString type: 'Str255 '>
+ <var: #ptr type: 'char *'>
self primitive: 'primitiveGetMenuItemText'
parameters: #(Oop SmallInteger).
- self var: 'menuHandle' type: 'MenuHandle'.
- self var: #aString type: 'Str255 '.
- self var: #ptr type: 'char *'.
menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
aString at: 0 put: 0.
self cCode: 'GetMenuItemText(menuHandle,anInteger,aString)' inSmalltalk:[menuHandle].
size := self cCode: 'aString[0]' inSmalltalk: [0].
oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size.
ptr := interpreterProxy firstIndexableField: oop.
0 to: size-1 do:[:i|
ptr at: i put: (aString at: (i+1))].
^oop
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetMenuTitle: (in category 'system primitives') -----
primitiveGetMenuTitle: menuHandleOop
| menuHandle size oop ptr aString |
+ <var: 'menuHandle' type: 'MenuHandle'>
+ <var: #aString type: 'Str255 '>
+ <var: #ptr type: 'char *'>
self primitive: 'primitiveGetMenuTitle'
parameters: #(Oop).
- self var: 'menuHandle' type: 'MenuHandle'.
- self var: #aString type: 'Str255 '.
- self var: #ptr type: 'char *'.
menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
aString at: 0 put: 0.
self cCode: 'GetMenuTitle(menuHandle,aString)' inSmalltalk:[menuHandle].
size := self cCode: 'aString[0]' inSmalltalk: [0].
oop := interpreterProxy instantiateClass: interpreterProxy classString indexableSize: size.
ptr := interpreterProxy firstIndexableField: oop.
0 to: size-1 do:[:i|
ptr at: i put: (aString at: (i+1))].
^oop
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveSetItemCmd:item:cmdChar: (in category 'system primitives') -----
primitiveSetItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar
| menuHandle aCharacter |
+ <var: 'menuHandle' type: 'MenuHandle'>
+ <var: #aCharacter type: 'CharParameter '>
self primitive: 'primitiveSetItemCmd'
parameters: #(Oop SmallInteger SmallInteger).
- self var: 'menuHandle' type: 'MenuHandle'.
- self var: #aCharacter type: 'CharParameter '.
menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
aCharacter := anIntegerCmdChar.
self cCode: 'SetItemCmd(menuHandle,anInteger,aCharacter)' inSmalltalk:[menuHandle].
^nil
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveSetItemMark:item:markChar: (in category 'system primitives') -----
primitiveSetItemMark: menuHandleOop item: anInteger markChar: aMarkChar
| menuHandle aCharacter |
+ <var: 'menuHandle' type: 'MenuHandle'>
+ <var: #aCharacter type: 'CharParameter '>
self primitive: 'primitiveSetItemMark'
parameters: #(Oop SmallInteger SmallInteger).
- self var: 'menuHandle' type: 'MenuHandle'.
- self var: #aCharacter type: 'CharParameter '.
menuHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: 'MenuHandle'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
aCharacter := aMarkChar.
self cCode: 'SetItemMark(menuHandle,anInteger,aCharacter)' inSmalltalk:[menuHandle].
^nil
!
Item was changed:
----- Method: Mpeg3Plugin>>primitiveMPEG3ReadFrame:buffer:bufferOffset:x:y:w:h:ow:oh:colorModel:stream:bytesPerRow: (in category 'primitives') -----
primitiveMPEG3ReadFrame: fileHandle buffer: aBuffer bufferOffset: aBufferOffset x: xNumber y: yNumber w: width h: height ow: outWidth oh: outHeight colorModel: model stream: aNumber bytesPerRow: aByteNumber
| file result outputRowsPtr bufferBaseAddr |
"int mpeg3_read_frame(mpeg3_t *file,
unsigned char **output_rows,
int in_x,
int in_y,
int in_w,
int in_h,
int out_w,
int out_h,
int color_model,
int stream)"
+ <var: #file declareC: 'mpeg3_t * file'>
+ <var: #bufferBaseAddr declareC: 'unsigned char *bufferBaseAddr'>
+ <var: #outputRowsPtr declareC: 'unsigned char ** outputRowsPtr'>
self primitive: 'primitiveMPEG3ReadFrameBufferOffset'
parameters: #(Oop WordArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger).
- self var: #file declareC: 'mpeg3_t * file'.
- self var: #bufferBaseAddr declareC: 'unsigned char *bufferBaseAddr'.
- self var: #outputRowsPtr declareC: 'unsigned char ** outputRowsPtr'.
file := self mpeg3tValueOf: fileHandle.
file = nil ifTrue: [^0].
aNumber < 0 ifTrue: [ interpreterProxy success: false. ^nil ].
aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
interpreterProxy success: false. ^0 ].
bufferBaseAddr := self cCoerce: aBuffer to: 'unsigned char *'.
self cCode: 'outputRowsPtr = (unsigned char **) memoryAllocate(1,sizeof(unsigned char*) * outHeight)'.
0 to: outHeight-1 do: [:i | outputRowsPtr at: i put: (bufferBaseAddr + aBufferOffset + (aByteNumber*i))].
self cCode: 'result = mpeg3_read_frame(file,outputRowsPtr,xNumber,yNumber,width,height,outWidth,outHeight,model,aNumber)'.
self cCode: 'memoryFree(outputRowsPtr)'.
^result asSmallIntegerObj
!
Item was changed:
----- Method: Mpeg3Plugin>>primitiveMPEG3ReadFrame:buffer:x:y:w:h:ow:oh:colorModel:stream:bytesPerRow: (in category 'primitives') -----
primitiveMPEG3ReadFrame: fileHandle buffer: aBuffer x: xNumber y: yNumber w: width h: height ow: outWidth oh: outHeight colorModel: model stream: aNumber bytesPerRow: aByteNumber
| file result outputRowsPtr bufferBaseAddr |
"int mpeg3_read_frame(mpeg3_t *file,
unsigned char **output_rows,
int in_x,
int in_y,
int in_w,
int in_h,
int out_w,
int out_h,
int color_model,
int stream)"
+ <var: #file type: 'mpeg3_t * '>
+ <var: #bufferBaseAddr type: 'unsigned char *'>
+ <var: #outputRowsPtr type: 'unsigned char ** '>
self primitive: 'primitiveMPEG3ReadFrame'
parameters: #(Oop WordArray SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger).
- self var: #file type: 'mpeg3_t * '.
- self var: #bufferBaseAddr type: 'unsigned char *'.
- self var: #outputRowsPtr type: 'unsigned char ** '.
file := self mpeg3tValueOf: fileHandle.
file = nil ifTrue: [^0].
aNumber < 0 ifTrue: [ interpreterProxy success: false. ^nil ].
aNumber >= (self cCode: 'result = mpeg3_total_vstreams(file)') ifTrue: [
interpreterProxy success: false. ^0 ].
bufferBaseAddr := self cCoerce: aBuffer to: 'unsigned char *'.
self cCode: 'outputRowsPtr = (unsigned char **) memoryAllocate(1,sizeof(unsigned char*) * outHeight)'.
0 to: outHeight-1 do: [:i | outputRowsPtr at: i put: (bufferBaseAddr + (aByteNumber*i))].
self cCode: 'result = mpeg3_read_frame(file,outputRowsPtr,xNumber,yNumber,width,height,outWidth,outHeight,model,aNumber)'.
self cCode: 'memoryFree(outputRowsPtr)'.
^result asSmallIntegerObj
!
Item was changed:
----- Method: NewspeakInterpreter>>allocateMemory:minimum:imageFile:headerSize: (in category 'as yet unclassified') -----
allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize
"Translate to C function call with (case sensitive) camelCase. The purpose of this
method is to document the translation.
The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may
be redefined to make use of the image file and header size parameters for efficient
implementation with mmap().
See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
+ <inline: true>
+ <returnTypeC: #'char *'>
+ <var: #fileStream type: #sqImageFile>
- self inline: true.
- self returnTypeC: 'char *'.
- self var: #fileStream type: 'sqImageFile'.
^ self
allocateMemory: heapSize
Minimum: minimumMemory
ImageFile: fileStream
+ HeaderSize: headerSize!
- HeaderSize: headerSize
- !
Item was removed:
- ----- Method: NewspeakInterpreter>>assertClassOf:is:compactClassIndex: (in category 'utilities') -----
- assertClassOf: oop is: classOop compactClassIndex: compactClassIndex
- "Succeed if the oop is an instance of the given class. Fail if the object is an integer.
- If the class has a (non-zero) compactClassIndex use that to speed up the check.
- N.B. Inlining should result in classOop not being accessed if compactClassIndex
- is non-zero."
-
- <inline: true>
- self success: (self is: oop instanceOf: classOop compactClassIndex: compactClassIndex)!
Item was changed:
----- Method: NewspeakInterpreter>>floatArg: (in category 'plugin primitive support') -----
floatArg: index
"Like #stackFloatValue: but access method arguments left-to-right"
+ | oop |
- | result oop |
<returnTypeC: #double>
- <var: #result type: #double>
oop := self methodArg: index.
oop = 0 ifTrue:[^0.0]. "methodArg: failed"
+ ^self floatValueOf: oop!
- "N.B. Because Slang always inlines isClassOfNonImm:equalTo:compactClassIndex:
- (because isClassOfNonImm:equalTo:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
- ClassArrayCompactIndex is non-zero."
- (self isClassOfNonImm: oop equalTo: (self splObj: ClassFloat) compactClassIndex: ClassFloatCompactIndex) ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: oop + BaseHeaderSize into: result.
- ^result].
- self primitiveFail.
- ^0.0!
Item was changed:
----- Method: NewspeakInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
+ "Fetch the instance variable at the given index of the given object. Answer the C
+ double precision floating point value of that instance variable, or fail if it is not a Float."
- "Fetch the instance variable at the given index of the given object. Return the
- C double precision floating point value of that object, or fail if it is not a Float."
+ | isFloat result |
- | result |
<returnTypeC: #double>
<var: #result type: #double>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
+ ClassArrayCompactIndex is non-zero."
+ isFloat := self
+ is: oop
+ instanceOf: (self splObj: ClassFloat)
+ compactClassIndex: ClassFloatCompactIndex.
+ isFloat ifTrue:
+ [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + BaseHeaderSize into: result.
+ ^result].
+ self primitiveFail.
+ ^0.0!
- self flag: #Dan. "None of the float stuff has been converted for 64 bits"
- "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
- (because assertClassOf:is:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_
- evaluated if ClassArrayCompactIndex is non-zero."
- (self is: oop
- instanceOf: (self splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex)
- ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: oop + BaseHeaderSize into: result.
- ^result]
- ifFalse:
- [self primitiveFail.
- ^0.0]!
Item was changed:
----- Method: NewspeakInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') -----
initializeExtraClassInstVarIndices
"Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and
classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf:
via classNameOf:is: (evil but a reality we have to accept)."
| classArrayObj classArrayClass |
classNameIndex := 6. "default"
thisClassIndex := 5. "default"
classArrayObj := self splObj: ClassArray.
classArrayClass := self fetchClassOfNonInt: classArrayObj.
metaclassSizeBytes := self sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)"
InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayClass) do:
[:i|
(self fetchPointer: i ofObject: classArrayClass) = classArrayObj ifTrue:
[thisClassIndex := i]].
InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayObj) do:
[:i| | oop |
oop := self fetchPointer: i ofObject: classArrayObj.
((self isBytes: oop)
and: [(self lengthOf: oop) = 5
+ and: [(self str: 'Array' n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
- and: [(self str: #Array n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
[classNameIndex := i]]!
Item was changed:
----- Method: NewspeakInterpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
+ If it is a Float, then load its value and return it.
+ Otherwise fail -- ie return with primErrorCode non-zero."
- If it is a Float, then load its value and return it.
- Otherwise fail -- ie return with primErrorCode non-zero."
- | result |
<inline: true>
<asmLabel: false>
<returnTypeC: #double>
- <var: #result type: #double>
(self isIntegerObject: floatOrInt) ifTrue:
[^(self integerValueOf: floatOrInt) asFloat].
+ ^self floatValueOf: floatOrInt!
- self assertClassOf: floatOrInt
- is: (self splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
- self cCode: '' inSmalltalk: [result := Float new: 2].
- self successful ifTrue:
- [self fetchFloatAt: floatOrInt + BaseHeaderSize into: result].
- ^result!
Item was changed:
----- Method: NewspeakInterpreter>>popFloat (in category 'stack bytecodes') -----
popFloat
+ <returnTypeC: #double>
+ ^self floatValueOf: self popStack!
- "Note: May be called by translated primitive code."
-
- | top result |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- top := self popStack.
- self assertClassOf: top is: (self splObj: ClassFloat).
- self successful ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: top + BaseHeaderSize into: result].
- ^ result!
Item was changed:
----- Method: NewspeakInterpreter>>stackFloatValue: (in category 'internal interpreter access') -----
stackFloatValue: offset
+ <returnTypeC: #double>
+ ^self floatValueOf: (self longAt: stackPointer - (offset*BytesPerWord))!
- "Note: May be called by translated primitive code."
- | result floatPointer |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- floatPointer := self longAt: stackPointer - (offset*BytesPerWord).
- (self fetchClassOf: floatPointer) = (self splObj: ClassFloat)
- ifFalse:[self primitiveFail. ^0.0].
- self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: floatPointer + BaseHeaderSize into: result.
- ^ result!
Item was changed:
----- Method: ObjectMemory>>compactClassAt: (in category 'interpreter access') -----
compactClassAt: ccIndex
+ "Index must be between 1 and compactClassArray size. A zero compact class
+ index in the base header indicate that the class is in the class header word."
- "Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)"
<api>
+ | classesArray |
+ classesArray := self fetchPointer: CompactClasses ofObject: self specialObjectsOop.
+ ^self fetchPointer: ccIndex - 1 ofObject: classesArray!
- | classArray |
- classArray := self fetchPointer: CompactClasses ofObject: self specialObjectsOop.
- ^self fetchPointer: (ccIndex - 1) ofObject: classArray!
Item was changed:
----- Method: SoundPlugin>>primitiveSoundGetVolume (in category 'primitives') -----
primitiveSoundGetVolume
"Set the sound input recording level."
+ | left right results |
+ <var: #left type: #double>
+ <var: #right type: #double>
- | left right results |
self primitive: 'primitiveSoundGetVolume'
parameters: #( ).
- self var: #left type: 'double '.
- self var: #right type: 'double '.
left := 0.
right := 0.
self cCode: 'snd_Volume((double *) &left,(double *) &right)'.
interpreterProxy pushRemappableOop: (right asOop: Float).
interpreterProxy pushRemappableOop: (left asOop: Float).
interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
results := interpreterProxy popRemappableOop.
interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
^ results!
Item was changed:
----- Method: SoundPlugin>>primitiveSoundRecordSamplesInto:startingAt: (in category 'primitives') -----
primitiveSoundRecordSamplesInto: buf startingAt: startWordIndex
"Record a buffer's worth of 16-bit sound samples."
| bufSizeInBytes samplesRecorded bufPtr byteOffset bufLen |
+ <var: #bufPtr type: #'char*'>
- self var: #bufPtr type: 'char*'.
self primitive: 'primitiveSoundRecordSamples'
parameters: #(WordArray SmallInteger ).
interpreterProxy failed ifFalse:
[bufSizeInBytes := (interpreterProxy slotSizeOf: buf cPtrAsOop) * 4.
interpreterProxy success: (startWordIndex >= 1 and: [startWordIndex - 1 * 2 < bufSizeInBytes])].
interpreterProxy failed ifFalse:[
byteOffset := (startWordIndex - 1) * 2.
bufPtr := (self cCoerce: buf to: 'char*') + byteOffset.
bufLen := bufSizeInBytes - byteOffset.
samplesRecorded := self cCode: 'snd_RecordSamplesIntoAtLength(bufPtr, 0, bufLen)' inSmalltalk:[bufPtr. bufLen. 0].
].
^ samplesRecorded asPositiveIntegerObj!
Item was changed:
----- Method: StackInterpreter>>allocateMemory:minimum:imageFile:headerSize: (in category 'image save/restore') -----
allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize
"Translate to C function call with (case sensitive) camelCase. The purpose of this
method is to document the translation.
The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may
be redefined to make use of the image file and header size parameters for efficient
implementation with mmap().
See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
+ <inline: true>
+ <returnTypeC: #'char *'>
+ <var: #fileStream type: #sqImageFile>
- self inline: true.
- self returnTypeC: 'char *'.
- self var: #fileStream type: 'sqImageFile'.
^ self
allocateMemory: heapSize
Minimum: minimumMemory
ImageFile: fileStream
HeaderSize: headerSize
!
Item was removed:
- ----- Method: StackInterpreter>>assertClassOf:is:compactClassIndex: (in category 'utilities') -----
- assertClassOf: oop is: classOop compactClassIndex: compactClassIndex
- "Succeed if the oop is an instance of the given class. Fail if the object is an integer.
- If the class has a (non-zero) compactClassIndex use that to speed up the check.
- N.B. Inlining should result in classOop not being accessed if compactClassIndex
- is non-zero."
-
- <inline: true>
- self success: (objectMemory is: oop instanceOf: classOop compactClassIndex: compactClassIndex)!
Item was changed:
----- Method: StackInterpreter>>floatArg: (in category 'plugin primitive support') -----
floatArg: index
"Like #stackFloatValue: but access method arguments left-to-right"
+ | oop |
- | result oop |
<returnTypeC: #double>
- <var: #result type: #double>
oop := self methodArg: index.
oop = 0 ifTrue:[^0.0]. "methodArg: failed"
+ ^self floatValueOf: oop!
- "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
- (because assertClassOf:is:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_
- evaluated if ClassArrayCompactIndex is non-zero."
- self assertClassOf: oop is: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
- self successful ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- objectMemory fetchFloatAt: oop + BaseHeaderSize into: result.
- ^result].
- ^0.0!
Item was changed:
----- Method: StackInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
"Note: May be called by translated primitive code."
+ | isFloat result |
- | result |
<returnTypeC: #double>
<var: #result type: #double>
+ "N.B. Because Slang always inlines is:instanceOf:compactClassIndex:
+ (because is:instanceOf:compactClassIndex: has an inline: pragma) the
+ phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if
+ ClassArrayCompactIndex is non-zero."
+ isFloat := objectMemory
+ is: oop
+ instanceOf: (objectMemory splObj: ClassFloat)
+ compactClassIndex: ClassFloatCompactIndex.
+ isFloat ifTrue:
- self flag: #Dan. "None of the float stuff has been converted for 64 bits"
- "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
- (because assertClassOf:is:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_
- evaluated if ClassArrayCompactIndex is non-zero."
- self assertClassOf: oop
- is: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
- self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: oop + BaseHeaderSize into: result.
+ ^result].
+ self primitiveFail.
- objectMemory fetchFloatAt: oop + BaseHeaderSize into: result.
- ^result].
^0.0!
Item was changed:
----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') -----
initializeExtraClassInstVarIndices
"Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and
classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf:
via classNameOf:is: (evil but a reality we have to accept)."
| classArrayObj classArrayClass |
classArrayObj := objectMemory splObj: ClassArray.
classArrayClass := objectMemory fetchClassOfNonInt: classArrayObj.
metaclassSizeBytes := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)"
thisClassIndex := 5. "default"
InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do:
[:i|
(objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue:
[thisClassIndex := i - 1]].
classNameIndex := 6. "default"
InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do:
[:i| | oop |
oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj.
((objectMemory isBytes: oop)
and: [(objectMemory lengthOf: oop) = 5
+ and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
- and: [(self str: #Array n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
[classNameIndex := i - 1]]!
Item was removed:
- ----- Method: StackInterpreter>>isFloatObjectNonInt:floatClass: (in category 'internal interpreter access') -----
- isFloatObjectNonInt: oop floatClass: floatClass
- ^ClassFloatCompactIndex ~= 0
- ifTrue: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex]
- ifFalse: [(objectMemory fetchClassOfNonInt: oop) = floatClass]!
Item was changed:
----- Method: StackInterpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
+ If it is a Float, then load its value and return it.
+ Otherwise fail -- ie return with primErrorCode non-zero."
- If it is a Float, then load its value and return it.
- Otherwise fail -- ie return with primErrorCode non-zero."
- | result |
<inline: true>
<asmLabel: false>
<returnTypeC: #double>
- <var: #result type: #double>
(objectMemory isIntegerObject: floatOrInt) ifTrue:
[^(objectMemory integerValueOf: floatOrInt) asFloat].
+ ^self floatValueOf: floatOrInt!
- self assertClassOf: floatOrInt
- is: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
- self cCode: '' inSmalltalk: [result := Float new: 2].
- self successful ifTrue:
- [objectMemory fetchFloatAt: floatOrInt + BaseHeaderSize into: result].
- ^result!
Item was changed:
----- Method: StackInterpreter>>popFloat (in category 'stack bytecodes') -----
popFloat
- "Note: May be called by translated primitive code."
-
- | top result |
<returnTypeC: #double>
+ ^self floatValueOf: self popStack!
- <var: #result type: #double>
- top := self popStack.
- "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
- (because assertClassOf:is:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_
- evaluated if ClassArrayCompactIndex is non-zero."
- self assertClassOf: top
- is: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
- self successful ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- objectMemory fetchFloatAt: top + BaseHeaderSize into: result].
- ^ result!
Item was changed:
----- Method: StackInterpreter>>stackFloatValue: (in category 'internal interpreter access') -----
stackFloatValue: offset
"In the StackInterpreter stacks grow down."
- | result floatPointer |
<returnTypeC: #double>
+ ^self floatValueOf: (stackPages longAt: stackPointer + (offset*BytesPerWord))!
- <var: #result type: #double>
- floatPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
-
- "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex:
- (because assertClassOf:is:compactClassIndex: has an inline: pragma) the
- phrase (self splObj: ClassArray) is expanded in-place and is _not_
- evaluated if ClassArrayCompactIndex is non-zero."
- self assertClassOf: floatPointer
- is: (objectMemory splObj: ClassFloat)
- compactClassIndex: ClassFloatCompactIndex.
- self successful ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- objectMemory fetchFloatAt: floatPointer + BaseHeaderSize into: result.
- ^result].
- ^0.0!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') -----
primitiveDoNamedPrimitiveWithArgs
"Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything.
e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments"
| argumentArray arraySize methodArg methodHeader
moduleName functionName moduleLength functionLength
+ spec addr primRcvr ctxtRcvr isArray |
- spec addr primRcvr ctxtRcvr |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
arraySize := objectMemory fetchWordLengthOf: argumentArray.
self success: (self roomToPushNArgs: arraySize).
methodArg := self stackObjectValue: 2.
self successful ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
(objectMemory isOopCompiledMethod: methodArg) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
methodHeader := self headerOf: methodArg.
(self literalCountOfHeader: methodHeader) > 2 ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
+ isArray := objectMemory
+ is: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg)
+ instanceOf: (objectMemory splObj: ClassArray)
+ compactClassIndex: ClassArrayCompactIndex.
+ (isArray
- (self assertClassOf: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg)
- is: (objectMemory splObj: ClassArray)
- compactClassIndex: ClassArrayCompactIndex).
- (self successful
and: [(objectMemory lengthOf: spec) = 4
and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
[^self primitiveFailFor: -2]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: spec.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [self success: (objectMemory isBytes: moduleName).
moduleLength := objectMemory lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := objectMemory fetchPointer: 1 ofObject: spec.
self success: (objectMemory isBytes: functionName).
functionLength := objectMemory lengthOf: functionName.
self successful ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state"
addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength.
addr = 0 ifTrue:
[^self primitiveFailFor: -1]. "could not find function; answer generic failure (see below)"
"Cannot fail this primitive from now on. Can only fail the external primitive."
objectMemory pushRemappableOop: (argumentArray := self popStack).
objectMemory pushRemappableOop: (primRcvr := self popStack).
objectMemory pushRemappableOop: self popStack. "the method"
objectMemory pushRemappableOop: self popStack. "the context receiver"
self push: primRcvr. "replace context receiver with actual receiver"
argumentCount := arraySize.
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
"Run the primitive (sets primFailCode)"
lkupClass := objectMemory nilObject.
self callExternalPrimitive: addr.
ctxtRcvr := objectMemory popRemappableOop.
methodArg := objectMemory popRemappableOop.
primRcvr := objectMemory popRemappableOop.
argumentArray := objectMemory popRemappableOop.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize + 1.
self push: ctxtRcvr.
self push: methodArg.
self push: primRcvr.
self push: argumentArray.
argumentCount := 3.
"Hack. A nil prim error code (primErrorCode = 1) is interpreted by the image
as meaning this primitive is not implemented. So to pass back nil as an error
code we use -1 to indicate generic failure."
primFailCode = 1 ifTrue:
[primFailCode := -1]]!
Item was added:
+ ----- Method: VMClass>>mem:cp:y: (in category 'C library simulation') -----
+ mem: aString cp: bString y: n
+ <doNotGenerate>
+ "implementation of memcpy(3)"
+ ^self st: aString rn: bString cpy: n!
More information about the Vm-dev
mailing list