The Trunk: Compiler-nice.432.mcz

Nicolas Cellier uploaded a new version of Compiler to project The Trunk:
http://source.squeak.org/trunk/Compiler-nice.432.mcz

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

Name: Compiler-nice.432
Author: nice
Time: 10 May 2020, 12:50:37.677856 pm
UUID: f6faf998-9905-4fbd-9bc4-66a2e9f8bc93
Ancestors: Compiler-nice.431

Fix Decompiler after correction byteCodes generated by inlined #caseOf: and recompile all senders of caseOf: in postscript.

Note: I have changed the logic a little bit:
- the ancient CaseFlag is replaced by OtherwiseFlag (that's the purpose, we are trying to detect last case before otherwise:).
- CascadeFlag is replaced by CaseFlag as soon as we have detected a potential caseOf:.

I never put so many Halt in code before having it right. Good luck to the next one wanting to change the Decompiler...

=============== Diff against Compiler-nice.431 ===============

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'
+ classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag IfNilFlag OtherwiseFlag'
- 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 changed:
  ----- Method: Decompiler class>>initialize (in category 'class initialization') -----
  initialize
 
  CascadeFlag := 'cascade'.  "A unique object"
  CaseFlag := 'case'. "Ditto"
+ OtherwiseFlag := 'otherwise'. "Ditto"
  ArgumentFlag := 'argument'.  "Ditto"
  IfNilFlag := 'ifNil'.  "Ditto"
 
  "Decompiler initialize"!

Item was changed:
  ----- Method: Decompiler>>case: (in category 'instruction decoding') -----
  case: dist
  "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"
 
  | nextCase thenJump stmtStream elements b node cases otherBlock myExits |
  nextCase := pc + dist.
 
+ "Now add CaseFlag & keyValueBlock to statements"
- "Now add CascadeFlag & keyValueBlock to statements"
  statements addLast: stack removeLast.
+ "Trick: put a flag on the stack.
+ If it is the last case before otherwise: block, then
+ - there won't be a dup of caseOf: receiver before sending =
+ - there won't be a pop in the case handling block"
+ stack addLast: OtherwiseFlag. "set for next pop"
- stack addLast: CaseFlag. "set for next pop"
  statements addLast: (self blockForCaseTo: nextCase).
+
+ stack last == OtherwiseFlag
-
- stack last == CaseFlag
  ifTrue: "Last case"
  ["ensure jump is within block (in case thenExpr returns wierdly I guess)"
  stack removeLast. "get rid of CaseFlag"
  stmtStream := ReadStream on: (self popTo: stack removeLast).
 
  elements := OrderedCollection new.
  b := OrderedCollection new.
  [stmtStream atEnd] whileFalse:
+ [(node := stmtStream next) == CaseFlag
- [(node := stmtStream next) == CascadeFlag
  ifTrue:
  [elements addLast: (constructor
  codeMessage: (constructor codeBlock: b returns: false)
  selector: (constructor codeSelector: #-> code: #macro)
  arguments: (Array with: stmtStream next)).
  b := OrderedCollection new]
  ifFalse: [b addLast: node]].
  b size > 0 ifTrue: [self error: 'Bad cases'].
  cases := constructor codeBrace: elements.
 
  "try find the end of the case"
  myExits := caseExits removeLast: elements size.
  myExits := myExits reject: [ :e | e isNil or: [ e < 0 or: [ e > method endPC ] ] ].
  thenJump := myExits isEmpty
  ifTrue: [ nextCase ]
  ifFalse: [ myExits max ].
 
  otherBlock := self blockTo: thenJump.
  stack addLast:
  (constructor
  codeMessage: stack removeLast
  selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
  arguments: (Array with: cases with: otherBlock))].!

Item was changed:
  ----- Method: Decompiler>>doDup (in category 'instruction decoding') -----
  doDup
+ stack last == CaseFlag
+ ifTrue:
+ ["We are in the process of decompiling a caseOf:"
+ stack addLast: CaseFlag.
+ ^self].
-
  stack last == CascadeFlag
  ifFalse:
  ["Save position and mark cascade"
  stack addLast: statements size.
  stack addLast: CascadeFlag].
  stack addLast: CascadeFlag!

Item was changed:
  ----- Method: Decompiler>>doPop (in category 'instruction decoding') -----
  doPop
 
  stack isEmpty ifTrue:
  ["Ignore pop in first leg of ifNil for value"
  ^ self].
+ stack last == OtherwiseFlag
- stack last == CaseFlag
  ifTrue: [stack removeLast]
  ifFalse: [statements addLast: stack removeLast].!

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 |
  lastJumpIfPcStack addLast: lastPc.
+ stack last == CaseFlag ifTrue: [^ [self case: dist] ensure: [lastJumpIfPcStack removeLast]].
- 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...
   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."
  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)
  arguments: blockArgs).
  pc := elseStart.
  selector == #whileTrue: ifTrue:
  [self convertToDoLoop: blockBodyReadCounts]]
  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:
  [(sign
  ifTrue: [{elseBlock. thenBlock}]
  ifFalse: [{thenBlock. elseBlock}]) in:
  [:args |
  (constructor
  decodeIfNilWithReceiver: ifExpr
  selector: #ifTrue:ifFalse:
  arguments: args
  tempReadCounts: tempReadCounts) ifNil:
  [constructor
  codeMessage: ifExpr
  selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
  arguments: args]]].
  stack := saveStack.
  condHasValue
  ifTrue: [stack addLast: cond]
  ifFalse: [statements addLast: cond]].
  lastJumpIfPcStack removeLast.!

Item was changed:
  ----- Method: Decompiler>>send:super:numArgs: (in category 'instruction decoding') -----
  send: selector super: superFlag numArgs: numArgs
 
  | args rcvr selNode msgNode messages |
  args := Array new: numArgs.
  (numArgs to: 1 by: -1) do:
  [:i | args at: i put: stack removeLast].
  rcvr := stack removeLast.
  superFlag ifTrue: [rcvr := constructor codeSuper].
  selNode := constructor codeAnySelector: selector.
+ rcvr == CaseFlag
+ ifTrue:
+ [| cases stmtStream elements node b |
+ selector == #= ifTrue:
+ [" = signals a case statement..."
+ statements addLast: args first.
+ stack addLast: rcvr. "restore CaseFlag"
+ ^ self].
+ selector = #caseError ifFalse: [self error: 'unexpected message send while decompiling a caseOf:'].
+ stmtStream := ReadStream on: (self popTo: stack removeLast).
+
+ elements := OrderedCollection new.
+ b := OrderedCollection new.
+ [stmtStream atEnd] whileFalse:
+ [(node := stmtStream next) == CaseFlag
+ ifTrue:
+ [elements addLast: (constructor
+ codeMessage: (constructor codeBlock: b returns: false)
+ selector: (constructor codeSelector: #-> code: #macro)
+ arguments: (Array with: stmtStream next)).
+ b := OrderedCollection new]
+ ifFalse: [b addLast: node]].
+ b size > 0 ifTrue: [self error: 'Bad cases'].
+ cases := constructor codeBrace: elements.
+
+ stack addLast:
+ (constructor
+ codeMessage: stack removeLast
+ selector: (constructor codeSelector: #caseOf: code: #macro)
+ arguments: (Array with: cases)).
+ ^self].
  rcvr == CascadeFlag
  ifTrue:
  ["May actually be a cascade or an ifNil: for value."
  self willJumpIfFalse
  ifTrue: "= generated by a case macro"
  [selector == #= ifTrue:
  [" = signals a case statement..."
  statements addLast: args first.
+ stack removeLast; addLast: CaseFlag; addLast: CaseFlag. "Properly mark the case statement"
- stack addLast: rcvr. "restore CascadeFlag"
  ^ self].
  selector == #== ifTrue:
  [" == signals an ifNil: for value..."
  stack removeLast; removeLast.
  rcvr := stack removeLast.
  stack addLast: IfNilFlag;
  addLast: (constructor
  codeMessage: rcvr
  selector: selNode
  arguments: args).
  ^ self]]
  ifFalse:
  [(self willJumpIfTrue and: [selector == #==]) ifTrue:
  [" == signals an ifNotNil: for value..."
  stack removeLast; removeLast.
  rcvr := stack removeLast.
  stack addLast: IfNilFlag;
  addLast: (constructor
  codeMessage: rcvr
  selector: selNode
  arguments: args).
  ^ self]].
  msgNode := constructor
  codeCascadedMessage: selNode
  arguments: args.
  stack last == CascadeFlag ifFalse:
  ["Last message of a cascade"
  statements addLast: msgNode.
  messages := self popTo: stack removeLast.  "Depth saved by first dup"
  msgNode := constructor
  codeCascade: stack removeLast
  messages: messages]]
  ifFalse:
  [msgNode := constructor
  codeMessage: rcvr
  selector: selNode
  arguments: args].
  stack addLast: msgNode!

Item was changed:
  ----- Method: Decompiler>>statementsForCaseTo: (in category 'control') -----
  statementsForCaseTo: 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.
+ Note that stack initially contains a OtherwiseFlag which will be removed by
- Note that stack initially contains a CaseFlag which will be removed by
  a subsequent Pop instruction, so adjust the StackPos accordingly."
 
  | blockPos stackPos |
  blockPos := statements size.
+ stackPos := stack size - 1. "Adjust for OtherwiseFlag"
- stackPos := stack size - 1. "Adjust for CaseFlag"
  [pc < end]
  whileTrue:
  [lastPc := pc.  limit := end.  "for performs"
  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:
+ [stack last == OtherwiseFlag
- [stack last == CaseFlag
  ifFalse: [ statements addLast: stack removeLast] ].
  lastJumpPc = lastPc ifFalse: [exit := pc].
  caseExits add: exit.
  ^self popTo: blockPos!

Item was changed:
  (PackageInfo named: 'Compiler') postscript: '"below, add code to be run after the loading of this package"
 
+ "Recompile senders of caseOf:"
+ self systemNavigation allSelectorsAndMethodsDo: [ :behavior :selector :method |
+ (method hasLiteral: #caseOf:)
+ ifTrue: [behavior recompile: selector]]'!
- "Make all relevant literals read-only, avoiding the recompile step, so as to avoid unbound methods"
- self systemNavigation allSelect:
- [:m| | b |
- b := #notNil.
- b := [:lit| lit isCollection ifTrue: [lit beReadOnlyObject. lit isArray ifTrue: [lit do: b "do: b do:"]]].
- m allLiteralsDo:
- [:l|
- (l isLiteral
- and: [(l isCollection or: [l isNumber and: [l isReadOnlyObject not]])
- and: [(l isArray and: [m primitive == 117 and: [l == (m literalAt: 1)]]) not]]) ifTrue:
- [b value: l]].
- false]'!