The Trunk: Compiler-eem.353.mcz

Eliot Miranda uploaded a new version of Compiler to project The Trunk:
http://source.squeak.org/trunk/Compiler-eem.353.mcz

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

Name: Compiler-eem.353
Author: eem
Time: 25 April 2017, 6:43:55.473745 pm
UUID: 76c9fea6-d855-42cd-aeb5-9cb0753f6f9d
Ancestors: Compiler-ul.352

Fix the order-of-evaluation bug with inlined to:[by:]do: loops.

Fix the decompiler to correctly decompile the new ordering.
Use isFoo methods instead of isMemberOf: in the new decompiler code.
Nuke some obsolete decompilation methods.

Make the postscript re3compile all senders of to:do: or to:by:do:.

=============== Diff against Compiler-ul.352 ===============

Item was changed:
  ----- Method: AssignmentNode>>toDoIncrement: (in category 'initialize-release') -----
  toDoIncrement: var
+ ^(var = variable
+   and: [value isMessageNode]) ifTrue:
+ [value toDoIncrement: var]!
- var = variable ifFalse: [^ nil].
- (value isMemberOf: MessageNode)
- ifTrue: [^ value toDoIncrement: var]
- ifFalse: [^ nil]!

Item was changed:
  InstructionStream subclass: #Decompiler
+ instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit caseExits lastJumpPc lastReturnPc limit hasValue blockStackBase numLocalTemps blockStartsToTempVars tempVarCount lastJumpIfPcStack tempReadCounts'
- instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit caseExits lastJumpPc lastReturnPc limit hasValue blockStackBase numLocalTemps blockStartsToTempVars tempVarCount lastJumpIfPcStack'
  classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag IfNilFlag'
  poolDictionaries: ''
  category: 'Compiler-Kernel'!
 
  !Decompiler commentStamp: 'nice 2/3/2011 22:54' prior: 0!
  I decompile a method in three phases:
  Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms)
  Parser: prefix symbolic codes -> node tree (same as the compiler)
  Printer: node tree -> text (done by the nodes)
 
 
  instance vars:
 
  constructor <DecompilerConstructor> an auxiliary knowing how to generate Abstract Syntax Tree (node tree)
  method <CompiledMethod> the method being decompiled
  instVars <Array of: String> the instance variables of the class implementing method
  tempVars <String | (OrderedCollection of: String)> hold the names of temporary variables (if known)
  NOTE: POLYMORPHISM WILL BE RESOLVED IN #initSymbols:
  constTable <Collection of: ParseNode> parse node associated with byte encoded constants (nil true false 0 1 -1 etc...)
  stack <OrderedCollection of: (ParseNode | String | Integer) > multipurpose...
  statements <OrderedCollection of: ParseNode> the statements of the method being decompiled
  lastPc <Integer>
  exit <Integer>
  caseExits <OrderedCollection of: Integer> - stack of exit addresses that have been seen in the branches of caseOf:'s
  lastJumpPc <Integer>
  lastReturnPc <Integer>
  limit <Integer>
  hasValue <Boolean>
  blockStackBase <Integer>
  numLocaltemps <Integer | Symbol> - number of temps local to a block; also a flag indicating decompiling a block
  blockStartsToTempVars <Dictionary key: Integer value: (OrderedCollection of: String)>
  tempVarCount <Integer> number of temp vars used by the method
  lastJumpIfPcStack <OrderedCollection of: Integer> the value of program counter just before the last encountered conditional jumps!

Item was removed:
- ----- Method: Decompiler>>blockScopeRefersOnlyOnceToTemp: (in category 'private') -----
- blockScopeRefersOnlyOnceToTemp: offset
- | nRefs byteCode extension scanner scan |
- scanner := InstructionStream on: method.
- nRefs := 0.
- scan := offset <= 15
- ifTrue:
- [byteCode := 16 + offset.
- [:instr |
-  instr = byteCode ifTrue:
- [nRefs := nRefs + 1].
-  nRefs > 1]]
- ifFalse:
- [extension := 64 + offset.
- [:instr |
-  (instr = 128 and: [scanner followingByte = extension]) ifTrue:
- [nRefs := nRefs + 1].
-   nRefs > 1]].
- self scanBlockScopeFor: pc from: method initialPC to: method endPC with: scan scanner: scanner.
- ^nRefs = 1!

Item was removed:
- ----- Method: Decompiler>>convertToDoLoop (in category 'private') -----
- convertToDoLoop
- "If statements contains the pattern
- var := startExpr.
- [var <= limit] whileTrue: [...statements... var := var + incConst]
- then replace this by
- startExpr to: limit by: incConst do: [:var | ...statements...]"
- | leaveOnStack initStmt toDoStmt limitStmt |
- leaveOnStack := false.
- (stack notEmpty
- and: [stack last isAssignmentNode])
- ifTrue:
- [initStmt := stack last.
- (toDoStmt := statements last toDoFromWhileWithInit: initStmt) ifNil:
- [^self].
- stack removeLast.
- statements removeLast; addLast: toDoStmt.
- leaveOnStack := true]
- ifFalse:
- [statements size < 2 ifTrue:
- [^self].
- initStmt := statements at: statements size-1.
- (toDoStmt := statements last toDoFromWhileWithInit: initStmt) ifNil:
- [^self].
- statements removeLast; removeLast; addLast: toDoStmt].
- initStmt variable scope: -1.  "Flag arg as block temp"
-
- "Attempt further conversion of the pattern
- limitVar := limitExpr.
- startExpr to: limitVar by: incConst do: [:var | ...statements...]
- to
- startExpr to: limitExpr by: incConst do: [:var | ...statements...].
- The complication here is that limitVar := limitExpr's value may be used, in which case it'll
- be statements last, or may not be used, in which case it'll be statements nextToLast."
- statements size < 2 ifTrue:
- [leaveOnStack ifTrue:
- [stack addLast: statements removeLast].
- ^self].
- limitStmt := statements last.
- ((limitStmt isMemberOf: AssignmentNode)
- and: [limitStmt variable isTemp
- and: [limitStmt variable == toDoStmt arguments first]]) ifFalse:
- [limitStmt := statements at: statements size-1.
- ((limitStmt isMemberOf: AssignmentNode)
- and: [limitStmt variable isTemp
- and: [limitStmt variable == toDoStmt arguments first]]) ifFalse:
- [leaveOnStack ifTrue:
- [stack addLast: statements removeLast].
- ^self]].
-
- (self blockScopeRefersOnlyOnceToTemp: limitStmt variable fieldOffset) ifFalse:
- [^self].
- toDoStmt arguments at: 1 put: limitStmt value.
- limitStmt variable scope: -2.  "Flag limit var so it won't print"
- statements last == limitStmt
- ifTrue: [statements removeLast]
- ifFalse: [statements removeLast; removeLast; addLast: toDoStmt]!

Item was added:
+ ----- Method: Decompiler>>convertToDoLoop: (in category 'private') -----
+ convertToDoLoop: blockBodyTempCounts
+ "If statements contains the pattern
+ var := startExpr.
+ [var <= limit] whileTrue: [...statements... var := var + incConst]
+ or
+ var := startExpr.
+ limit := limitExpr.
+ [var <= limit] whileTrue: [...statements... var := var + incConst]
+ then replace this by
+ startExpr to: limit by: incConst do: [:var | ...statements...]
+ and answer true."
+ | whileStmt incrStmt initStmt limitStmt toDoStmt |
+ whileStmt := statements last.
+ incrStmt := whileStmt arguments first statements last.
+ incrStmt isAssignmentNode ifFalse:
+ [^false].
+ (self startAndLimitFor: incrStmt variable from: stack into:
+ [:startExpr :limitExpr| initStmt := startExpr. limitStmt := limitExpr])
+ ifTrue:
+ [| limitInStatements |
+ limitInStatements := limitStmt isNil
+    and: [statements size > 1
+    and: [self startAndLimitFor: incrStmt variable from: { stack last. (statements last: 2) first } into:
+ [:startExpr :limitExpr| limitStmt := limitExpr]]].
+ (toDoStmt := statements last toDoFromWhileWithCounts: blockBodyTempCounts init: initStmt limit: limitStmt) ifNil:
+ [^false].
+ limitInStatements
+ ifTrue:
+ [stack
+ removeLast;
+ addLast: toDoStmt.
+ statements removeLast: 2]
+ ifFalse:
+ [stack
+ removeLast: (limitStmt ifNil: [1] ifNotNil: [2]);
+ addLast: toDoStmt.
+ statements removeLast]]
+ ifFalse:
+ [(self startAndLimitFor: incrStmt variable from: statements allButLast into:
+ [:startExpr :limitExpr| initStmt := startExpr. limitStmt := limitExpr]) ifFalse:
+ [^false].
+ (toDoStmt := statements last toDoFromWhileWithCounts: blockBodyTempCounts init: initStmt limit: limitStmt) ifNil:
+ [^false].
+ statements
+ removeLast: (limitStmt ifNil: [2] ifNotNil: [3]);
+ addLast: toDoStmt].
+ self markTemp: initStmt variable asOutOfScope: -1. "Flag arg as out of scope"
+ initStmt variable beBlockArg.
+ limitStmt ifNotNil:
+ [self markTemp: limitStmt variable asOutOfScope: -2.
+ toDoStmt arguments at: 1 put: limitStmt value]. "Flag limit as hidden"
+ ^true!

Item was changed:
  ----- Method: Decompiler>>initSymbols: (in category 'initialize-release') -----
  initSymbols: aClass
  constructor method: method class: aClass literals: method literals.
  constTable := constructor codeConstants.
  instVars := Array new: aClass instSize.
  tempVarCount := method numTemps.
  "(tempVars isNil
  and: [method holdsTempNames]) ifTrue:
  [tempVars := method tempNamesString]."
  tempVars isString
  ifTrue:
  [blockStartsToTempVars := self mapFromBlockStartsIn: method
  toTempVarsFrom: tempVars
  constructor: constructor.
  tempVars := blockStartsToTempVars at: method initialPC]
  ifFalse:
  [| namedTemps |
  namedTemps := tempVars ifNil: [(1 to: tempVarCount) collect: [:i| 't', i printString]].
  tempVars := (1 to: tempVarCount) collect:
  [:i | i <= namedTemps size
  ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)]
  ifFalse: [constructor codeTemp: i - 1]]].
  1 to: method numArgs do:
  [:i|
+ (tempVars at: i) beMethodArg].
+ tempReadCounts := Dictionary new!
- (tempVars at: i) beMethodArg]!

Item was changed:
  ----- Method: Decompiler>>jump:if: (in category 'instruction decoding') -----
  jump: dist if: condition
 
  | savePc sign elsePc elseStart end cond ifExpr thenBlock elseBlock
+  thenJump elseJump condHasValue isIfNil saveStack |
-  thenJump elseJump condHasValue isIfNil saveStack blockBody blockArgs |
  lastJumpIfPcStack addLast: lastPc.
  stack last == CascadeFlag ifTrue: [^ [self case: dist] ensure: [lastJumpIfPcStack removeLast]].
  elsePc := lastPc.
  elseStart := pc + dist.
  end := limit.
  "Check for bfp-jmp to invert condition.
  Don't be fooled by a loop with a null body."
  sign := condition.
  savePc := pc.
  self interpretJump ifNotNil:
  [:elseDist|
  (elseDist >= 0 and: [elseStart = pc]) ifTrue:
  [sign := sign not.  elseStart := pc + elseDist]].
  pc := savePc.
  ifExpr := stack removeLast.
  (isIfNil := stack size > 0 and: [stack last == IfNilFlag]) ifTrue:
  [stack removeLast].
  saveStack := stack.
  stack := OrderedCollection new.
  thenBlock := self blockTo: elseStart.
  condHasValue := hasValue or: [isIfNil].
  "ensure jump is within block (in case thenExpr returns)"
  thenJump := exit <= end ifTrue: [exit] ifFalse: [elseStart].
  "if jump goes back, then it's a loop"
  thenJump < elseStart
  ifTrue:
+ [| blockBody blockArgs savedReadCounts blockBodyReadCounts selector |
+ "Must be a while loop...
- ["Must be a while loop...
   thenJump will jump to the beginning of the while expr.  In the case of while's
   with a block in the condition, the while expr should include more than just
+  the last expression: find all the statements needed by searching for the node
+  with the relevant pc."
-  the last expression: find all the statements needed by re-decompiling."
  stack := saveStack.
+ savedReadCounts := tempReadCounts copy.
  pc := thenJump.
  blockBody := self statementsTo: elsePc.
+ blockBodyReadCounts := tempReadCounts.
+ savedReadCounts keysAndValuesDo:
+ [:temp :count|
+ blockBodyReadCounts at: temp put: (blockBodyReadCounts at: temp) - count].
+ tempReadCounts := savedReadCounts.
  "discard unwanted statements from block"
  blockBody size - 1 timesRepeat: [statements removeLast].
  blockArgs := thenBlock statements = constructor codeEmptyBlock statements
  ifTrue: [#()]
  ifFalse: [{ thenBlock }].
+ selector := blockArgs isEmpty
+ ifTrue: [sign ifTrue: [#whileFalse] ifFalse: [#whileTrue]]
+ ifFalse: [sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]].
  statements addLast:
  (constructor
  codeMessage: (constructor codeBlock: blockBody returns: false)
+ selector: (constructor codeSelector: selector code: #macro)
- selector: (constructor
- codeSelector: (blockArgs isEmpty
- ifTrue:
- [sign
- ifTrue: [#whileFalse]
- ifFalse: [#whileTrue]]
- ifFalse:
- [sign
- ifTrue: [#whileFalse:]
- ifFalse: [#whileTrue:]])
- code: #macro)
  arguments: blockArgs).
  pc := elseStart.
+ selector == #whileTrue: ifTrue:
+ [self convertToDoLoop: blockBodyReadCounts]]
- self convertToDoLoop]
  ifFalse:
  ["Must be a conditional..."
  elseBlock := self blockTo: thenJump.
  elseJump := exit.
  "if elseJump is backwards, it is not part of the elseExpr"
  elseJump < elsePc ifTrue:
  [pc := lastPc].
  cond := isIfNil
  ifTrue:
  [constructor
  codeMessage: ifExpr ifNilReceiver
  selector: (constructor
  codeSelector: (sign ifTrue: [#ifNotNil:] ifFalse: [#ifNil:])
  code: #macro)
  arguments: (Array with: thenBlock)]
  ifFalse:
  [constructor
  codeMessage: ifExpr
  selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
  arguments: (sign
  ifTrue: [{elseBlock. thenBlock}]
  ifFalse: [{thenBlock. elseBlock}])].
  stack := saveStack.
  condHasValue
  ifTrue: [stack addLast: cond]
  ifFalse: [statements addLast: cond]].
  lastJumpIfPcStack removeLast.!

Item was added:
+ ----- Method: Decompiler>>markTemp:asOutOfScope: (in category 'private') -----
+ markTemp: tempVarNode asOutOfScope: scopeFlag
+ tempVarNode scope: scopeFlag.
+ tempReadCounts removeKey: tempVarNode ifAbsent: []!

Item was changed:
  ----- Method: Decompiler>>popIntoTemporaryVariable: (in category 'instruction decoding') -----
  popIntoTemporaryVariable: offset
  | maybeTVTag tempVector start |
  maybeTVTag := stack last.
  ((maybeTVTag isMemberOf: Association)
  and: [maybeTVTag key == #pushNewArray]) ifTrue:
  [blockStartsToTempVars notNil "implies we were intialized with temp names."
  ifTrue: "Use the provided temps"
  [self assert: ((tempVector := tempVars at: offset + 1 ifAbsent: [ParseNode basicNew]) isTemp
  and: [tempVector isIndirectTempVector
  and: [tempVector remoteTemps size = maybeTVTag value size]])]
  ifFalse: "Synthesize some remote temps"
  [tempVector := maybeTVTag value.
  offset + 1 <= tempVars size
  ifTrue:
  [start := 2.
  tempVector at: 1 put: (tempVars at: offset + 1)]
  ifFalse:
  [tempVars := (Array new: offset + 1)
  replaceFrom: 1
  to: tempVars size
  with: tempVars.
  start := 1].
  start to: tempVector size do:
  [:i|
  tempVector
  at: i
  put: (constructor
  codeTemp: numLocalTemps + offset + i - 1
  named: 't', (tempVarCount + i) printString)].
  tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector)].
  tempVarCount := tempVarCount + maybeTVTag value size.
  stack removeLast.
  ^self].
+ stack addLast: (offset >= tempVars size
+ ifTrue: "Handle the case of chained LiteralVariableBinding assigments"
+ [stack at: (offset + 1 - tempVars size)]
+ ifFalse: "A regular argument or temporary"
+ [tempVars at: offset + 1]).
+ self doStore: statements!
- self pushTemporaryVariable: offset; doStore: statements!

Item was changed:
  ----- Method: Decompiler>>pushTemporaryVariable: (in category 'instruction decoding') -----
  pushTemporaryVariable: offset
+ | node |
+ offset >= tempVars size
+ ifTrue: "Handle the case of chained LiteralVariableBinding assigments"
+ [self halt.
+ node := stack at: offset + 1 - tempVars size]
+ ifFalse: "A regular argument or temporary"
+ [node := tempVars at: offset + 1.
+ node isArg ifFalse: "count temp reads for the whileTrue: => to:do: transformation."
+ [tempReadCounts at: node put: (tempReadCounts at: node ifAbsent: [0]) + 1]].
+ stack addLast: node!
-
- stack addLast: (offset >= tempVars size
- ifTrue:
- ["Handle the case of chained LiteralVariableBinding assigments"
- stack at: (offset + 1 - tempVars size)]
- ifFalse:
- ["A regular argument or temporary"
- tempVars at: offset + 1])!

Item was removed:
- ----- Method: Decompiler>>scanBlockScopeFor:from:to:with:scanner: (in category 'private') -----
- scanBlockScopeFor: refpc from: startpc to: endpc with: scan scanner: scanner
- | bsl maybeBlockSize |
- bsl := BlockStartLocator new.
- scanner pc: startpc.
- [scanner pc <= endpc] whileTrue:
- [refpc = scanner pc ifTrue:
- [scanner pc: startpc.
- [scanner pc <= endpc] whileTrue:
- [(scan value: scanner firstByte) ifTrue:
- [^endpc].
- (maybeBlockSize := scanner interpretNextInstructionFor: bsl) isInteger ifTrue:
- [scanner pc: scanner pc + maybeBlockSize]].
-   ^self].
- (maybeBlockSize := scanner interpretNextInstructionFor: bsl) isInteger ifTrue:
- [refpc <= (scanner pc + maybeBlockSize)
- ifTrue: [^self scanBlockScopeFor: refpc from: scanner pc to: scanner pc + maybeBlockSize with: scan scanner: scanner]
- ifFalse: [scanner pc: scanner pc + maybeBlockSize]]]!

Item was added:
+ ----- Method: Decompiler>>startAndLimitFor:from:into: (in category 'private') -----
+ startAndLimitFor: incrVar from: aStack into: binaryBlock
+ "If incrVar matches the increment of a whileLoop at the end of statements
+ evaluate binaryBlock with the init statement for incrVar and the init statement
+ for the block's limit, if any, and answer true.  Otherwise answer false.  Used to
+ help convert whileTrue: loops into to:[by:]do: loops."
+ | guard initExpr limitInit size |
+ ((size := aStack size) >= 1
+ and: [(initExpr := aStack at: size) isAssignmentNode]) ifFalse:
+ [^false].
+ initExpr variable == incrVar ifTrue:
+ [binaryBlock value: initExpr value: nil.
+ ^true].
+ limitInit := initExpr.
+ (size >= 2
+ and: [(initExpr := aStack at: size - 1) isAssignmentNode
+ and: [initExpr variable == incrVar
+ and: [(guard := statements last receiver) isBlockNode
+ and: [guard statements size = 1
+ and: [(guard := guard statements first) isMessageNode
+ and: [guard receiver == incrVar
+ and: [guard arguments first == limitInit variable]]]]]]]) ifTrue:
+ [binaryBlock value: initExpr value: limitInit.
+ ^true].
+ ^false!

Item was changed:
  ----- Method: Decompiler>>statementsTo: (in category 'control') -----
  statementsTo: end
  "Decompile the method from pc up to end and return an array of
  expressions. If at run time this block will leave a value on the stack,
  set hasValue to true. If the block ends with a jump or return, set exit
  to the destination of the jump, or the end of the method; otherwise, set
  exit = end. Leave pc = end."
 
+ | encoderClass blockPos stackPos |
+ encoderClass := method encoderClass.
- | blockPos stackPos t |
  blockPos := statements size.
  stackPos := stack size.
  [pc < end]
  whileTrue:
  [lastPc := pc.  limit := end.  "for performs"
+ "If you want instrumentation replace the following statement with this one,
+  and edit the implementation:
+ self interpretNextInstructionFor: self"
+ encoderClass interpretNextInstructionFor: self in: self].
- self interpretNextInstructionFor: self].
  "If there is an additional item on the stack, it will be the value
  of this block."
  (hasValue := stack size > stackPos)
  ifTrue:
  [statements addLast: stack removeLast].
  lastJumpPc = lastPc ifFalse: [exit := pc].
  ^self popTo: blockPos!

Item was changed:
  ----- Method: Decompiler>>storeIntoTemporaryVariable: (in category 'instruction decoding') -----
  storeIntoTemporaryVariable: offset
+ stack addLast: (offset >= tempVars size
+ ifTrue: "Handle the case of chained LiteralVariableBinding assigments"
+ [stack at: (offset + 1 - tempVars size)]
+ ifFalse: "A regular argument or temporary"
+ [tempVars at: offset + 1]).
+ self doStore: stack!
-
- self pushTemporaryVariable: offset; doStore: stack!

Item was removed:
- ----- Method: DecompilerConstructor>>codeArguments:block: (in category 'constructor') -----
- codeArguments: args block: block
-
- ^block arguments: args!

Item was changed:
  ----- Method: MessageNode>>emitCodeForToDo:encoder:value: (in category 'code generation') -----
  emitCodeForToDo: stack encoder: encoder value: forValue
  " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: "
  | loopSize initStmt limitInit test block incStmt blockSize |
  initStmt := arguments at: 4.
  limitInit := arguments at: 7.
  test := arguments at: 5.
  block := arguments at: 3.
  incStmt := arguments at: 6.
  blockSize := sizes at: 1.
  loopSize := sizes at: 2.
- limitInit == nil
- ifFalse: [limitInit emitCodeForEffect: stack encoder: encoder].
 
  "This will return the receiver of to:do: which is the initial value of the loop"
  forValue
+ ifTrue: [initStmt emitCodeForValue: stack encoder: encoder]
- ifTrue: [initStmt emitCodeForValue: stack encoder: encoder.]
  ifFalse: [initStmt emitCodeForEffect: stack encoder: encoder].
+ limitInit ifNotNil:
+ [limitInit emitCodeForEffect: stack encoder: encoder].
  test emitCodeForValue: stack encoder: encoder.
  self emitCodeForBranchOn: false dist: blockSize pop: stack encoder: encoder.
  pc := encoder methodStreamPosition.
  block emitCodeForEvaluatedEffect: stack encoder: encoder.
  incStmt emitCodeForEffect: stack encoder: encoder.
+ self emitCodeForJump: 0 - loopSize encoder: encoder!
- self emitCodeForJump: 0 - loopSize encoder: encoder.!

Item was added:
+ ----- Method: MessageNode>>toDoFromWhileWithCounts:init:limit: (in category 'decompiling') -----
+ toDoFromWhileWithCounts: blockBodyTempCounts init: incrInit limit: limitInitOrNil
+ "If the receiver, a whileTrue: loop, represents a to:[by:]do: loop
+ then answer the replacement to:[by:]do:, otherwise answer nil."
+ | variable increment limit toDoBlock body test |
+ self assert: (selector key == #whileTrue:
+ and: [incrInit isAssignmentNode]).
+ (limitInitOrNil notNil "limit should not be referenced within the loop"
+  and: [(blockBodyTempCounts at: limitInitOrNil variable ifAbsent: [0]) ~= 1]) ifTrue:
+ [^nil].
+ body := arguments last statements.
+ (variable := incrInit variable) isTemp ifFalse:
+ [^nil].
+ (increment := body last toDoIncrement: variable) ifNil:
+ [^nil].
+ receiver statements size ~= 1 ifTrue:
+ [^nil].
+ test := receiver statements first.
+ "Note: test should really be checked that <= or >= comparison
+ jibes with the sign of the (constant) increment"
+ (test isMessageNode
+ and: [(limit := test toDoLimit: variable) notNil]) ifFalse:
+ [^nil].
+ "The block must not overwrite the limit"
+ (limit isVariableNode and: [body anySatisfy: [:e | e isAssignmentNode and: [e variable = limit]]]) ifTrue:
+ [^nil].
+ toDoBlock := BlockNode statements: body allButLast returns: false.
+ toDoBlock arguments: {variable}.
+ ^MessageNode new
+ receiver: incrInit value
+ selector: (SelectorNode new key: #to:by:do: code: #macro)
+ arguments: (Array with: limit with: increment with: toDoBlock)
+ precedence: precedence!

Item was removed:
- ----- Method: MessageNode>>toDoFromWhileWithInit: (in category 'macro transformations') -----
- toDoFromWhileWithInit: initStmt
- "Return nil, or a to:do: expression equivalent to this whileTrue:"
- | variable increment limit toDoBlock body test |
- (selector key == #whileTrue:
- and: [initStmt isAssignmentNode
- and: [initStmt variable isTemp]]) ifFalse:
- [^nil].
- body := arguments last statements.
- variable := initStmt variable.
- increment := body last toDoIncrement: variable.
- (increment == nil
- or: [receiver statements size ~= 1]) ifTrue:
- [^nil].
- test := receiver statements first.
- "Note: test chould really be checked that <= or >= comparison
- jibes with the sign of the (constant) increment"
- (test isMessageNode
- and: [(limit := test toDoLimit: variable) notNil]) ifFalse:
- [^nil].
- "The block must not overwrite the limit"
- (limit isVariableNode and: [body anySatisfy: [:e | e isAssignmentNode and: [e variable = limit]]])
- ifTrue: [^nil].
- toDoBlock := BlockNode statements: body allButLast returns: false.
- toDoBlock arguments: (Array with: variable).
- variable scope: -1.
- variable beBlockArg.
- ^MessageNode new
- receiver: initStmt value
- selector: (SelectorNode new key: #to:by:do: code: #macro)
- arguments: (Array with: limit with: increment with: toDoBlock)
- precedence: precedence!

Item was added:
+ ----- Method: MessageNode>>toDoFromWhileWithInit:withLimit: (in category 'decompiling') -----
+ toDoFromWhileWithInit: incrInit withLimit: limitInitOrNil
+ "If the receiver, a whileTrue: loop, represents a to:[by:]do: loop
+ then answer the replacement to:[by:]do:, otherwise answer nil."
+ | variable increment limit toDoBlock body test |
+ self assert: (selector key == #whileTrue:
+ and: [incrInit isAssignmentNode]).
+ body := arguments last statements.
+ (variable := incrInit variable) isTemp ifFalse:
+ [^nil].
+ (increment := body last toDoIncrement: variable) ifNil:
+ [^nil].
+ receiver statements size ~= 1 ifTrue:
+ [^nil].
+ test := receiver statements first.
+ "Note: test should really be checked that <= or >= comparison
+ jibes with the sign of the (constant) increment"
+ (test isMessageNode
+ and: [(limit := test toDoLimit: variable) notNil]) ifFalse:
+ [^nil].
+ "The block must not overwrite the limit"
+ (limit isVariableNode and: [body anySatisfy: [:e | e isAssignmentNode and: [e variable = limit]]]) ifTrue:
+ [^nil].
+ toDoBlock := BlockNode statements: body allButLast returns: false.
+ toDoBlock arguments: {variable}.
+ ^MessageNode new
+ receiver: incrInit value
+ selector: (SelectorNode new key: #to:by:do: code: #macro)
+ arguments: (Array with: limit with: increment with: toDoBlock)
+ precedence: precedence!

Item was changed:
  ----- Method: MessageNode>>toDoIncrement: (in category 'testing') -----
  toDoIncrement: variable
+ ^(receiver = variable
+   and: [selector key = #+
+   and: [arguments first isConstantNumber]]) ifTrue:
+ [arguments first]!
- (receiver = variable and: [selector key = #+])
- ifFalse: [^ nil].
- arguments first isConstantNumber
- ifTrue: [^ arguments first]
- ifFalse: [^ nil]!

Item was changed:
  ----- Method: MessageNode>>toDoLimit: (in category 'testing') -----
  toDoLimit: variable
+ ^(receiver = variable
+   and: [selector key = #<= or: [selector key = #>=]]) ifTrue:
+ [arguments first]!
- (receiver = variable and: [selector key = #<= or: [selector key = #>=]])
- ifTrue: [^ arguments first]
- ifFalse: [^ nil]!

Item was changed:
+ (PackageInfo named: 'Compiler') postscript: '"below, add code to be run after the loading of this package"
+ "Make sure all methods using to:do: and to:by:do: are recompiled"
- (PackageInfo named: 'Compiler') postscript: '"Make sure all affected methods are recompiled"
  UIManager default
+ informUser: ''Recompiling methods sending to:do: and to:by:do:''
- informUser: ''Recompiling affected methods''
  during:
  [(self systemNavigation allMethodsSelect:
+ [:m|
+ #(to:do: to:by:do:) anySatisfy: [:l| m refersToLiteral: l]]) do:
+ [:mr| mr actualClass recompile: mr selector]]'!
- [:m| | ebc | "All affected methods send one of these optimized selectors..."
- (#(to:do: to:by:do: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) anySatisfy: [:l| m refersToLiteral: l])
- "but the textDomain properties confuse method comparison below..."
- and: [(m propertyValueAt: #textDomain ifAbsent: nil) isNil
- and: [m numTemps > m numArgs "and have non-argument temporaries in them..."
-  or: [(ebc := m embeddedBlockClosures) notEmpty
- and: [ebc anySatisfy: [:bc| bc numTemps > bc numArgs]]]]]]) do:
- [:mr| | old new |
- old := mr compiledMethod.
- "do a test recompile of the method..."
- new := (mr actualClass compile: old getSource asString notifying: nil trailer: old trailer ifFail: nil) method.
- "and if it changed, report it to the transcript and really recompile it..."
- old ~= new ifTrue:
- [Transcript cr. old printReferenceOn: Transcript. Transcript flush.
- mr actualClass recompile: old selector]]]'!