[Vm-dev] VM Maker: VMMaker.oscog-eem.794.mcz
commits at source.squeak.org
commits at source.squeak.org
Wed Jul 2 22:43:26 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.794.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.794
Author: eem
Time: 2 July 2014, 3:40:54.432 pm
UUID: 7fd23b24-d4aa-4291-996a-760b99e0d7e2
Ancestors: VMMaker.oscog-eem.793
Fix the shift for divide issues in the LargeIntegersPlugin.
Add code to generateDivide:on:indent: to spit out checking
asserts if required.
Change the SmartSyntaxPluginCodeGenerator to generate
code that ifdefs out the remapOop:in: rigmarole on Spur.
=============== Diff against VMMaker.oscog-eem.793 ===============
Item was changed:
----- Method: CCodeGenerator>>generateDivide:on:indent: (in category 'C translation') -----
generateDivide: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."
+ | rcvr arg divisor check |
+ rcvr := msgNode receiver.
+ arg := msgNode args first.
+ check := false "If you need to check the validity of divides that had been implemented by signed shifts, change this to true..."
+ and: [arg isConstant
+ and: [(divisor := arg value) isInteger
+ and: [divisor isPowerOfTwo
+ and: [divisor > 0
+ and: [divisor <= (1 bitShift: 31)]]]]].
+ check ifTrue:
+ [aStream nextPut: $(; nextPutAll: 'assert(((sqInt) '.
+ self emitCExpression: rcvr on: aStream.
+ aStream nextPutAll: ' >> ', (divisor log: 2) asInteger printString.
+ aStream nextPutAll: ') == ('.
+ self emitCExpression: rcvr on: aStream.
+ aStream nextPutAll: ' / '.
+ self emitCExpression: msgNode args first on: aStream.
+ aStream nextPutAll: ')),'].
self emitCExpression: msgNode receiver on: aStream.
aStream nextPutAll: ' / '.
+ self emitCExpression: msgNode args first on: aStream.
+ check ifTrue:
+ [aStream nextPut: $)]!
- self emitCExpression: msgNode args first on: aStream!
Item was changed:
----- Method: CogObjectRepresentation>>maybeCompileRetry:onPrimitiveFail: (in category 'primitive generators') -----
maybeCompileRetry: retryInst onPrimitiveFail: primIndex
+ <var: #retryInst type: #'AbstractInstruction *'>
- <var: #retry type: #'AbstractInstruction *'>
"Object representations with lazy forwarding will want to check for
forwarding pointers on primitive failure and retry the primitive if found.
By default do nothing."!
Item was changed:
----- Method: CogObjectRepresentationForSpur>>maybeCompileRetry:onPrimitiveFail: (in category 'primitive generators') -----
maybeCompileRetry: retryInst onPrimitiveFail: primIndex
+ <var: #retryInst type: #'AbstractInstruction *'>
- <var: #retry type: #'AbstractInstruction *'>
"If primIndex has an accessorDepth, check for primitive failure and call
ceCheckForAndFollowForwardedPrimitiveStateFor:. If ceCheck.... answers
true, retry the primitive."
| accessorDepth jmp |
<var: #jmp type: #'AbstractInstruction *'>
accessorDepth := coInterpreter accessorDepthForPrimitiveIndex: primIndex.
accessorDepth < 0 ifTrue:
[^0].
cogit MoveAw: coInterpreter primFailCodeAddress R: TempReg.
cogit CmpCq: 0 R: TempReg.
jmp := cogit JumpZero: 0.
cogit
compileCallFor: #ceCheckForAndFollowForwardedPrimitiveStateFor:
numArgs: 1
arg: primIndex
arg: nil
arg: nil
arg: nil
resultReg: TempReg
saveRegs: false.
cogit CmpCq: 0 R: TempReg.
cogit JumpNonZero: retryInst.
jmp jmpTarget: cogit Label.
^0!
Item was changed:
----- Method: LargeIntegersPlugin>>cCoreDigitDivDiv:len:rem:len:quo:len: (in category 'C core') -----
cCoreDigitDivDiv: pDiv len: divLen rem: pRem len: remLen quo: pQuo len: quoLen
| dl ql dh dnh j t hi lo r3 l a cond q r1r2 mul |
+ <var: #pDiv type: #'unsigned char *'>
+ <var: #pRem type: #'unsigned char *'>
+ <var: #pQuo type: #'unsigned char *'>
- <var: #pDiv type: 'unsigned char * '>
- <var: #pRem type: 'unsigned char * '>
- <var: #pQuo type: 'unsigned char * '>
dl := divLen - 1.
"Last actual byte of data (ST ix)"
ql := quoLen.
dh := pDiv at: dl - 1.
+ dnh := dl = 1
+ ifTrue: [0]
+ ifFalse: [pDiv at: dl - 2].
- dl = 1
- ifTrue: [dnh := 0]
- ifFalse: [dnh := pDiv at: dl - 2].
1 to: ql do:
[:k |
"maintain quo*arg+rem=self"
"Estimate rem/div by dividing the leading two bytes of rem by dh."
"The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."
"Nibbles are kicked off!! We use full 16 bits now, because we are in
the year 2000 ;-) [sr]"
j := remLen + 1 - k.
"r1 := rem digitAt: j."
+ (pRem at: j - 1) = dh
- (pRem at: j - 1)
- = dh
ifTrue: [q := 255]
ifFalse:
["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.
Note that r1,r2 are bytes, not nibbles.
Be careful not to generate intermediate results exceeding 13
bits."
"r2 := (rem digitAt: j - 2)."
+ r1r2 := ((pRem at: j - 1) bitShift: 8) + (pRem at: j - 2).
- r1r2 := ((pRem at: j - 1)
- bitShift: 8)
- + (pRem at: j - 2).
t := r1r2 \\ dh.
q := r1r2 // dh.
"Next compute (hi,lo) := q*dnh"
mul := q * dnh.
hi := mul bitShift: -8.
lo := mul bitAnd: 255.
"Correct overestimate of q.
Max of 2 iterations through loop -- see Knuth vol. 2"
j < 3
ifTrue: [r3 := 0]
ifFalse: [r3 := pRem at: j - 3].
[(t < hi
or: [t = hi and: [r3 < lo]])
ifTrue:
["i.e. (t,r3) < (hi,lo)"
q := q - 1.
lo := lo - dnh.
lo < 0
ifTrue:
[hi := hi - 1.
lo := lo + 256].
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 := (pDiv at: i - 1) * (q bitShift: -8).
+ lo := a + (pRem at: l - 1) - ((pDiv at: i - 1) * (q bitAnd: 255)).
+ pRem at: l - 1 put: (self cCode: [lo] inSmalltalk: [lo bitAnd: 255]).
+ a := (lo signedBitShift: -8) - hi.
- hi := (pDiv at: i - 1)
- * (q bitShift: -8).
- lo := a + (pRem at: l - 1) - ((pDiv at: i - 1)
- * (q bitAnd: 255)).
- "pRem at: l - 1 put: lo - (lo // 256 * 256)."
- "sign-tolerant form of (lo bitAnd: 255) -> obsolete..."
- pRem at: l - 1 put: (lo bitAnd: 255).
- "... is sign-tolerant!! [sr]"
- a := lo // 256 - hi.
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 bitShift: -8) + (pRem at: l - 1) + (pDiv at: i - 1).
+ pRem at: l - 1 put: (self cCode: [a] inSmalltalk: [a bitAnd: 255]).
+ 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 bitShift: -8)
- + (pRem at: l - 1) + (pDiv at: i - 1).
- pRem at: l - 1 put: (a bitAnd: 255).
- l := l + 1]].
pQuo at: quoLen - k put: q]!
Item was changed:
----- Method: LargeIntegersPlugin>>cDigitSub:len:with:len:into: (in category 'C core') -----
cDigitSub: pByteSmall len: smallLen with: pByteLarge len: largeLen into: pByteRes
| z |
+ <var: #pByteSmall type: #'unsigned char *'>
+ <var: #pByteLarge type: #'unsigned char *'>
+ <var: #pByteRes type: #'unsigned char *'>
- <var: #pByteSmall type: 'unsigned char * '>
- <var: #pByteLarge type: 'unsigned char * '>
- <var: #pByteRes type: 'unsigned char * '>
z := 0. "Loop invariant is -1<=z<=1"
0 to: smallLen - 1 do:
[:i |
z := z + (pByteLarge at: i) - (pByteSmall at: i).
+ pByteRes at: i put: (self cCode: [z] inSmalltalk: [z bitAnd: 255]).
- pByteRes at: i put: z - (z // 256 * 256). "sign-tolerant form of (z bitAnd: 255)"
z := z signedBitShift: -8].
smallLen to: largeLen - 1 do:
[:i |
z := z + (pByteLarge at: i) .
+ pByteRes at: i put: (self cCode: [z] inSmalltalk: [z bitAnd: 255]).
- pByteRes at: i put: z - (z // 256 * 256). "sign-tolerant form of (z bitAnd: 255)"
z := z signedBitShift: -8].
!
Item was changed:
----- Method: LargeIntegersPlugin>>cdigitMontgomery:len:times:len:modulo:len:mInvModB:into: (in category 'C core') -----
cdigitMontgomery: pBytesFirst
len: firstLen
times: pBytesSecond
len: secondLen
modulo: pBytesThird
len: thirdLen
mInvModB: mInv
into: pBytesRes
| u limit1 limit2 limit3 accum lastByte |
+ <var: #pBytesFirst type: #'unsigned char *'>
+ <var: #pBytesSecond type: #'unsigned char *'>
+ <var: #pBytesThird type: #'unsigned char *'>
+ <var: #pBytesRes type: #'unsigned char *'>
+ <var: #accum type: #usqInt>
+ <var: #u type: #'unsigned char'>
+ <var: #lastByte type: #'unsigned char'>
- <var: #pBytesFirst type: 'unsigned char * '>
- <var: #pBytesSecond type: 'unsigned char * '>
- <var: #pBytesThird type: 'unsigned char * '>
- <var: #pBytesRes type: 'unsigned char * '>
- <var: #accum type: 'usqInt '>
- <var: #u type: 'unsigned char '>
- <var: #lastByte type: 'unsigned char '>
limit1 := firstLen - 1.
limit2 := secondLen - 1.
limit3 := thirdLen - 1.
lastByte := 0.
0 to: limit1 do:
[:i |
accum := (pBytesRes at: 0) + ((pBytesFirst at: i)*(pBytesSecond at: 0)).
u := accum * mInv bitAnd: 255.
accum := accum + (u * (pBytesThird at: 0)).
1 to: limit2 do: [:k |
accum := (accum >> 8) + (pBytesRes at: k) + ((pBytesFirst at: i)*(pBytesSecond at: k)) + (u * (pBytesThird at: k)).
pBytesRes at: k-1 put: (accum bitAnd: 255)].
secondLen to: limit3 do: [:k |
accum := (accum >> 8) + (pBytesRes at: k) + (u * (pBytesThird at: k)).
pBytesRes at: k-1 put: (accum bitAnd: 255)].
accum := (accum >> 8) + lastByte.
pBytesRes at: limit3 put: (accum bitAnd: 255).
lastByte := accum >> 8].
firstLen to: limit3 do:
[:i |
accum := (pBytesRes at: 0).
u := accum * mInv bitAnd: 255.
accum := accum + (u * (pBytesThird at: 0)).
1 to: limit3 do: [:k |
accum := (accum >> 8) + (pBytesRes at: k) + (u * (pBytesThird at: k)).
pBytesRes at: k-1 put: (accum bitAnd: 255)].
accum := (accum >> 8) + lastByte.
pBytesRes at: limit3 put: (accum bitAnd: 255).
lastByte := accum >> 8].
(lastByte = 0 and: [(self cDigitCompare: pBytesThird with: pBytesRes len: thirdLen) = 1]) ifFalse: [
"self cDigitSub: pBytesThird len: thirdLen with: pBytesRes len: thirdLen into: pBytesRes"
accum := 0.
0 to: limit3 do:
[:i |
accum := accum + (pBytesRes at: i) - (pBytesThird at: i).
+ pBytesRes at: i put: (self cCode: [accum] inSmalltalk: [accum bitAnd: 255]).
+ accum := accum signedBitShift: -8]].!
- pBytesRes at: i put: accum - (accum // 256 * 256).
- "sign-tolerant form of (z bitAnd: 255)"
- accum := accum // 256]].!
Item was changed:
----- Method: SmartSyntaxInterpreterPlugin>>remapOop:in: (in category 'simulation') -----
remapOop: oopOrList in: aBlock
+ "Call remapOop: for the variable oopOrList (or all of the variables in oopOrList) before evaluating
+ aBlock, and restore them after. If this is Spur, do nothing, since Spur does not GC on allocation
+ and the SmartSyntaxPluginCodeGenerator generates null code for this op in Spur."
<doNotGenerate>
| ctxt tempNames tempIndices |
+ interpreterProxy hasSpurMemoryManagerAPI ifTrue:
+ [^aBlock value].
ctxt := thisContext sender.
tempNames := ctxt tempNames.
oopOrList isArray
ifTrue:
[tempIndices := oopOrList collect: [:tempName| tempNames indexOf: tempName].
tempIndices do:
[:index| interpreterProxy pushRemappableOop: (ctxt namedTempAt: index)]]
ifFalse: [interpreterProxy pushRemappableOop: oopOrList].
^aBlock ensure:
[oopOrList isArray
ifTrue:
[tempIndices reverseDo:
[:index| ctxt namedTempAt: index put: interpreterProxy popRemappableOop]]
ifFalse:
[1 to: ctxt numTemps do:
[:index|
(ctxt tempAt: index) = oopOrList ifTrue:
[ctxt tempAt: index put: interpreterProxy topRemappableOop]].
interpreterProxy popRemappableOop]]!
Item was changed:
----- Method: SmartSyntaxPluginCodeGenerator>>generateRemapOopIn:on:indent: (in category 'translating builtins') -----
generateRemapOopIn: aNode on: aStream indent: level
"Generate the C code for this message onto the given stream."
+ aStream cr; nextPutAll: '#if SPURVM'; cr.
+ self generateSpurRemapOopIn: aNode on: aStream indent: level.
+ aStream cr; nextPutAll: '#else /* SPURVM */'; cr.
+ self generateV3RemapOopIn: aNode on: aStream indent: level.
+ aStream cr; nextPutAll: '#endif /* SPURVM */'; cr!
- | idList |
- pluginFunctionsUsed add: #pushRemappableOop:; add: #popRemappableOop.
- idList := aNode args first nameOrValue.
- idList class == Array ifFalse: [idList := Array with: idList].
- idList do:
- [:each |
- aStream
- nextPutAll: 'pushRemappableOop(';
- nextPutAll: each asString;
- nextPutAll: ');']
- separatedBy: [aStream crtab: level].
- aStream cr.
- aNode args second emitCCodeOn: aStream level: level generator: self.
- level timesRepeat: [aStream tab].
- idList reversed do:
- [:each |
- aStream
- nextPutAll: each asString;
- nextPutAll: ' = popRemappableOop()']
- separatedBy: [aStream nextPut: $;; crtab: level].!
Item was added:
+ ----- Method: SmartSyntaxPluginCodeGenerator>>generateSpurRemapOopIn:on:indent: (in category 'translating builtins') -----
+ generateSpurRemapOopIn: aNode on: aStream indent: level
+ "Generate just the block argument for this message as Spur does not GC on allocation."
+
+ aNode args second emitCCodeOn: aStream level: level generator: self!
Item was added:
+ ----- Method: SmartSyntaxPluginCodeGenerator>>generateV3RemapOopIn:on:indent: (in category 'translating builtins') -----
+ generateV3RemapOopIn: aNode on: aStream indent: level
+ "Generate call on remapOop: for the variable oopOrList (or all of the
+ variables in oopOrList) before evaluating aBlock, and restore them after.
+ This keeps the oops valid if, as V3 will, there is a GC on allocation."
+
+ | idList |
+ pluginFunctionsUsed add: #pushRemappableOop:; add: #popRemappableOop.
+ idList := aNode args first nameOrValue.
+ idList class == Array ifFalse: [idList := Array with: idList].
+ idList do:
+ [:each |
+ aStream
+ nextPutAll: 'pushRemappableOop(';
+ nextPutAll: each asString;
+ nextPutAll: ');']
+ separatedBy: [aStream crtab: level].
+ aStream cr.
+ aNode args second emitCCodeOn: aStream level: level generator: self.
+ level timesRepeat: [aStream tab].
+ idList reversed do:
+ [:each |
+ aStream
+ nextPutAll: each asString;
+ nextPutAll: ' = popRemappableOop()']
+ separatedBy: [aStream nextPut: $;; crtab: level]!
More information about the Vm-dev
mailing list