Revert "Use of ::= in the Compiler, eliminating almost all mutable state from its...

[cslatevm.git] / src / mobius / compiler.slate

m@(CompiledMethod traits) new
"Answer a new CompiledMethod with a fresh compilation state."
[
  m clone `>>
    [| :newM |
      method := newM.
      literals := m literals new.
      selectors := m selectors new.
      optionalKeywords := m optionalKeywords new.
      code := m code new.
      debugMap := m debugMap new. ]
].

m@(CompiledMethod traits) sourceTreeOf: index
"Find the source tree corresponding to a bytecode's index."
[
  m debugMap
    do: [| :start :end :sourceTree |
         (index between: start and: end)
           ifTrue: [^ sourceTree]]
    inGroupsOf: 3.
  Nil
].

m@(CompiledMethod traits) definitionLocation
[
  m sourceTree isNotNil /\ [m sourceTree hasSlotNamed: #source]
    ifTrue: [m sourceTree definitionLocation]
    ifFalse: ['Nil']
].

m@(CompiledMethod traits) recompile
"If the method has a sourceTree, replace the method with a re-compiled version
of it."
[
  m sourceTree
    ifNil: [warn: 'The method has no source code to recompile.'. m]
    ifNotNilDo: [| :src | m forwardTo: src compile]
].

lobby ensureNamespace: #VM.
VM ensureNamespace: #SSACode.

VM SSACode define: #Instruction &parents: {Cloneable} &slots: {
  #code.
  #selector.
  #name.
  #argNames -> {}.
  #offsettingArgIndices -> {}.
}.

VM SSACode Instruction traits define: #ByCode -> Dictionary new.

i@(VM SSACode Instruction traits) instancesSetting: slotNames to: values
[
  resend `>> [do: [| :each |
    each argNames do:
      [| :argName | (#{'arity'. 'size'} includes: argName) ifTrue:
        [""]].
    VM SSACode addImmutableSlot: each selector valued: each code.
    i ByCode at: each code put: each].
  ]
].

VM SSACode Instruction instancesSetting: #{#code. #selector. #name. #argNames. #offsettingArgIndices} to: #{
  {0. #directSendMessage. 'Direct Send'. {'register of result'. 'selector'. 'arity' ". args..."}. {2}}.
  "{1. #indirectSendMessage. 'Indirect Send'. {'register of result'. 'selector'. 'arity'. args...}. {2}}."
  "{2. #allocateRegisters. 'Allocate Registers'. 3. {}}."
  {3. #loadLiteral. 'Load Literal'. {'register of result'. 'index of literal'}}.
  "{4. #storeLiteral. 'Store Literal'. {'index of literal'. 'register of source'}}."
  {5. #sendMessageWithOptionals. 'Send with Optionals'. {'register of result'. 'selector'. 'arity'. 'register of optionals array' ". args..."}. {2}}.
  {7. #newClosure. 'New Closure'. {'register of result'. 'block'}}.
  {8. #newArrayWith. 'New Array With'. {'register of result'. 'size' ". args..."}. {1}}.
  {9. #resendMessage. 'Resend'. {'register of result'. 'lexical offset'}}.
  {10. #returnFrom. 'Return From'. {'register of result'. 'lexical offset'}}.
  {11. #loadEnvironment. 'Load Environment'. {'register of result'}}.
  {12. #loadVariable. 'Load Variable'. {'register of result'}}.
  {13. #storeVariable. 'Store Variable'. {'register of result'}}.
  {14. #loadFreeVariable. 'Load Free Variable'. {'register of result'. 'lexical offset'. 'index of variable'}}.
  {15. #storeFreeVariable. 'Store Free Variable'. {'lexical offset'. 'index of variable'. 'register of source'}}.
  {16. #isIdenticalTo. 'Is Identical To'. {'register of result'. 'register of x'. 'register of y'}}.
  {17. #branchKeyed. 'Branch Keyed'. {'register of key'. 'table'}}.
  {18. #jumpTo. 'Jump To'. {'offset'}}.
  "Used like SSA phi / branch merges:"
  {19. #moveRegister. 'Move Register'. {'register of source'. 'register of result'}}.
  {20. #branchIfTrue. 'Branch If True'. {'register of condition'. 'branch offset'}}.
  {21. #branchIfFalse. 'Branch If False'. {'register of condition'. 'branch offset'}}.
  "Marks the end of a block:"
  {22. #returnRegister. 'Return Register'. {'register of value'}}.
  "Marks the end of a block:"
  {23. #returnValue. 'Return Value'. {'value to return'}}.
  "I'm not sure what this does yet..used in bootstrap:"
  {24. #resume. 'Resume'. {}}.
  {25. #primitiveDo. 'Primitive Do'. {'number of primitive'. 'arity'. 'register of result' ". args..."}. {1}}.
  {26. #directApplyTo. 'Direct Apply To'. {'method'. 'arity'. 'register of result' ". args..."}. {1}}.
  {27. #isNilOp. 'Is Nil'. {'register of result'. 'register of x'}}.
  "these check the arguments to see if their maps match the ones in the map array"
  "if they match, we fall through to the next instruction which is the primitive (no code) or inlined function"
  "it also needs to set up the input varibles"
  {28. #inlinePrimitiveCheckJump. 'Inline Primitive Check Jump'. {'register of result'. 'map array'. 'prim number(in-opcode not a register)'. 'arity'. 'jump offset' ". args..."}. {3}}.
  {29. #inlineMethodCheckJump. 'Inline Method Check Jump'. {'map array'. 'arity'. 'jump offset' ". args..."}. {1}}.
  {30. #sendMessageWithOptionalsInline. 'Send with Optionals Inline'. {'register of result'. 'selector'. 'arity'. 'optional count'. ". args...optionals..."}. {2. 3}}.

}.

VM define: #SSACompiler &parents: {Cloneable}
  &slots: {#contexts -> Stack new}.

VM SSACompiler traitsWindow addDelegate: VM SSACode.

g@(VM SSACompiler traits) new
[g clone `>> [contexts := g contexts new. ]].

VM SSACompiler traits define: #Context &parents: {Cloneable} &slots:
  {#isClosure -> False "Whether the method being compiled is a closure.".
   #method -> CompiledMethod new "The method the context targets.".
   #codeWriter "The stream for writing bytecodes to the method.".
   #debugMap -> ExtensibleArray new
   "Gathers the method's debug map; must be indexable at all times.".
   #registerValues -> ExtensibleArray new
   "The current register values.".
   #labels -> ExtensibleArray new
   "label serials -> code index.".
   #relocations -> Dictionary new
   "code index -> label serials".
   #currentRegister -> 0
   "The last assigned register value.. or the count?"
   }.

c@(VM SSACompiler Context traits) newOn: method
"FIXME change method code to array instead of bytearray."
[
  method code := Array new.
  c clone `setting: #{#method. #codeWriter. #debugMap. #registerValues. #relocations. #labels. #currentRegister}
   to: {method.
        method code writer.
        method debugMap as: c debugMap.
        c registerValues new.
        c relocations new.
        c labels new.
        method inputVariables + method localVariables}
].

c@(VM SSACompiler Context traits) copy
[
  resend `setting: (registerValues relocations labels currentRegister)
         to: {c registerValues copy.
              c relocations copy.
              c labels copy.
              c currentRegister}
].

c@(VM SSACompiler Context traits) resolveLabel: label at: index
[
  (c labels at: label) - index
].

c@(VM SSACompiler Context traits) resolveLabels
"This takes the labels Dictionary and uses it to replace the temporary ID's
placed in the jump fields with actual offsets."
[| code |
  code := c method code.
  c relocations keysAndValuesDo:
    [| :index :label offset |
     offset := c resolveLabel: label at: index.
     code at: index put: offset]
].

c@(VM SSACompiler Context traits) flush
[
  c method code := c codeWriter contents.
  c method debugMap := c debugMap as: Array.
  c resolveLabels.
  c
].

c@(VM SSACompiler Context traits) beClosure [c isClosure := True].

gen@(VM SSACompiler traits) currentContext
[gen contexts top].

gen@(VM SSACompiler traits) newRegister
[
  gen contexts top currentRegister += 1
].

gen@(VM SSACompiler traits) registerFor: obj from: def result: result
[| saveRegister |
   "the whole problem with this function is that we could cache a literal that
 is only loaded in a loop which may not always be executed. remove this code
until we have it figured out."
"  gen contexts top registerValues do:
    [| :val | val value = obj
                 ifTrue:
                   [val key = result \/ [result isNil]
                        ifTrue: [^ val key]
                        ifFalse: [result `defaultsTo: gen newRegister.
                                   gen emitInstruction: gen moveRegister withParameters: {result. val key} from: def.
                                  ^ result]]].
 "
  "we don't want result to be a local variable and have it overwritten later"
  "saveRegister := result isNil."
  saveRegister := False.
  result `defaultsTo: gen newRegister.
  gen emitInstruction: gen loadLiteral withParameters: {result. obj} from: def.
  saveRegister ifTrue: [gen setRegister: result to: obj].
  result
].

gen@(VM SSACompiler traits) setRegister: x to: y
[
  gen contexts top registerValues add: x -> y ifPresent:
    [error: 'Compiler error: Register already set.'].
].

gen@(VM SSACompiler traits) currentMethod
[gen currentContext method].

gen@(VM SSACompiler traits) codeWriter
[gen currentContext codeWriter].

gen@(VM SSACompiler traits) newLabelIndex
[
  gen currentContext labels `>> [addLast: Nil. indexLast]
].

gen@(VM SSACompiler traits) emitLabel &labelIndex: labelIndex
[
  labelIndex `defaultsTo: gen newLabelIndex.
  gen currentContext labels at: labelIndex put: gen codeWriter position.
  labelIndex
].

gen@(VM SSACompiler traits) emitRelocationAgainst: label
[
  gen currentContext relocations at: gen codeWriter position put: label
].

gen@(VM SSACompiler traits) emitObject: value from: node
[
  "0 below: bytesPerWord do: [| :byte | gen emitByte: (value byteShift: 0 - byte) intoByte from: node]."
  gen mapTo: node.
  gen codeWriter nextPut: value
].

gen@(VM SSACompiler traits) emitBranchTo: label from: msg
[
  gen emitRelocationAgainst: label.
  gen emitObject: 0 from: msg "replaced later when flushed"
].

gen@(VM SSACompiler traits) mapTo: sourceTree
[| index |
  index := gen codeWriter position.
  gen currentContext debugMap `cacheAs: #debugMap.
  debugMap isEmpty not /\ [debugMap last == sourceTree]
    ifTrue: [debugMap at: debugMap indexLast - 1 infect: [| :value | index max: value].
             debugMap at: debugMap indexLast - 2 infect: [| :value | index min: value]]
    ifFalse: [debugMap addAllLast: {index. index. sourceTree}]
].

gen@(VM SSACompiler traits) emitInstruction: code@(Integer traits) withParameters: values from: node
"this gets called before the real function"
[
  "values do: [| :value | (value is: nodes Node) ifTrue: [error: 'bad code']]." "commented out because we could actually load node literals in compiler code"
  resend
].

gen@(VM SSACompiler traits) emitInstruction: code withParameters: values from: node
[
  "add the selector to the list so we know what this function calls... so it can be unoptimized if needed"
  code = gen directSendMessage
    \/ [code = gen sendMessageWithOptionals]
    \/ [code = gen sendMessageWithOptionalsInline]
    ifTrue: [gen currentContext method selectors := gen currentContext method selectors ; {values second}].
  gen emitObject: code from: node.
  values do: [| :value | gen emitObject: value from: node]
].

gen@(VM SSACompiler traits) emitInstruction: code from: node
"Emitting an instruction without an immediate value required just puts the
byte onto the end."
[
  gen emitInstruction: code withParameters: #{} from: node
].

"
=======================================================================
Generate methods. They all must return the register(s) with the results
=======================================================================
"

_@(VM SSACompiler traits) generate: _@(nodes Node traits)
"Do nothing in the default case, for comments and annotations and such."
[error: 'do not call generate without a result'].

_@(VM SSACompiler traits) generate: _@(nodes Node traits) result: result
"Do nothing in the default case, for comments and annotations and such."
[].

gen@(VM SSACompiler traits) generate: ann@(nodes Annotation traits) result: result
"Generate the annotation's value."
[
  gen generate: ann value
].

gen@(VM SSACompiler traits) generate: block@(nodes Block traits) result: result &topLevel: topLevel
"Encountering a new block, build a new CompiledMethod object and push it and
a new bytecode array writer onto the generator, then go through the underlying
code and generate that. When done, pop both, set up the block as a literal
and push it onto the stack."
[| newBlock isClosure statements |
  topLevel `defaultsTo: False.
  newBlock := CompiledMethod new `>>
    [environment := gen contexts isEmpty
       ifTrue: [block parentScope topLevel namespace]
       ifFalse: [gen currentMethod environment].
     sourceTree := block. ].
  gen contexts push: (gen Context newOn: newBlock).
  "we macroexpand everything before we set the current register because macroexpansion can add localvariables etc"
  statements := block statements collect:
    [| :statement | statement macroExpand &environment: gen currentMethod sourceTree].
  gen currentContext currentRegister := block localVariables size. "input variables might not be needed"
  statements allButLastDo: [| :node | gen generate: node result: Nil].
  statements isEmpty
    ifTrue: [gen emitInstruction: gen returnValue withParameters: {Nil} from: block]
    ifFalse: [gen emitInstruction: gen returnRegister withParameters: {gen generate: statements last result: Nil} from: block].

  "Set the variable information after generation, just in case it was modified."
  newBlock `>>
   [inputVariables := block inputVariables size.
    localVariables := block localVariables size.
    restVariable := block restVariable isNotNil.
    registerCount := gen currentContext currentRegister + 1.
    "reserved1 := gen currentContext currentRegister + 1."
    optionalKeywords := block optionalKeywords. ].
  isClosure := gen currentContext isClosure.

  gen contexts pop flush.
  "Forces the newBlock to record all the remaining stream input correctly."

  gen contexts isEmpty \/ [topLevel]
    ifFalse:
      [result `defaultsTo: gen newRegister. "asking for a register requires a context"
       gen emitInstruction: (isClosure ifTrue: [gen newClosure] ifFalse: [gen loadLiteral])
           withParameters: {result. newBlock} from: block].

  gen contexts isEmpty \/ [topLevel] ifTrue: [newBlock] ifFalse: [result]
].

gen@(VM SSACompiler traits) generate: sig@(nodes Signature traits) result: resultRegister
[
  shouldNotImplement
].

gen@(VM SSACompiler traits) generate: def@(nodes MethodDefinition traits) result: resultRegister
"Translate method definitions to equivalent asMethod:on: invocations."
[| blockRegister roleRegisters arrayRegister resultRegister selectorRegister |
  gen contexts isEmpty
    ifTrue: [^ resend].
  blockRegister := #generate:result: sendTo: {gen. def. Nil} through: {gen. nodes Block. Nil}.
  arrayRegister := gen newRegister.
  selectorRegister := gen registerFor: def selector from: def result: Nil.
  roleRegisters := def roles collect: #(gen generate: _ result: Nil) `er.
  resultRegister `defaultsTo: gen newRegister.
  gen emitInstruction: gen newArrayWith withParameters: {arrayRegister. roleRegisters size} ; roleRegisters from: def.
  gen emitInstruction: gen directSendMessage withParameters: {resultRegister. #asMethod:on:. 3. blockRegister. selectorRegister. arrayRegister} from: def.
  resultRegister
].

gen@(VM SSACompiler traits) generate: r@(nodes Resend traits) result: resultRegister
[| lexOffset scope |
  scope := gen currentMethod sourceTree.
  lexOffset := gen contexts indexLast -
    ((gen contexts indexOfLastSatisfying: [| :context | context method sourceTree isSameAs: nodes MethodDefinition])
      ifNil:
        [error: 'resend must be used within a method definition.']).
  lexOffset isPositive
    ifTrue:
      [(gen contexts fromTop: lexOffset) method heapAllocate := True.
       (gen contexts top: lexOffset) do: #beClosure `er].
  resultRegister `defaultsTo: gen newRegister.
  gen emitInstruction: gen resendMessage withParameters: {resultRegister. lexOffset} from: r.
  resultRegister
].

gen@(VM SSACompiler traits) generate: r@(nodes Return traits) result: blah
[overrideThis].

gen@(VM SSACompiler traits) generate: r@(nodes Return traits) by: lexOffset result: resultRegister
[
  resultRegister `defaultsTo: gen newRegister.
  lexOffset isPositive
    ifTrue:
      [(gen contexts fromTop: lexOffset) method heapAllocate := True.
       (gen contexts top: lexOffset) do: #beClosure `er].
  gen generate: r value result: resultRegister.
  gen emitInstruction: gen returnFrom withParameters: {resultRegister. lexOffset} from: r.
  resultRegister.
].

gen@(VM SSACompiler traits) generate: r@(nodes ReturnClose traits) result: resultRegister
"Exits the first enclosing named method in the lexical scope."
[| lexOffset |
  lexOffset := gen contexts indexLast -
    ((gen contexts indexOfLastSatisfying: [| :context | context method sourceTree isSameAs: nodes MethodDefinition])
      ifNil:
        [error: '^ must be used within a method definition.']).
  gen generate: r by: lexOffset result: resultRegister
].

gen@(VM SSACompiler traits) generate: r@(nodes ReturnFar traits) result: result
"Exits the last enclosing named method in the lexical scope."
[| lexOffset |
  lexOffset := gen contexts indexLast -
    ((gen contexts indexOfFirstSatisfying: [| :context | context method sourceTree isSameAs: nodes MethodDefinition])
      ifNil:
        [error: '^^ must be used within a method definition.']).
  gen generate: r by: lexOffset result: result
].

gen@(VM SSACompiler traits) generate: r@(nodes ReturnLevel traits) result: result
"Exits the Nth enclosing lexical scope."
[gen generate: r by: r level result: result].

gen@(VM SSACompiler traits) generate: literal@(nodes Literal traits) result: result
[
  gen registerFor: literal value from: literal result: result
].

gen@(VM SSACompiler traits) generate: n@(nodes CompoundStatement traits) result: result
"return the registers that the values were saved into"
[
  n statements isEmpty
    ifTrue: [#{}]
    ifFalse: [(n statements allButLast collect: [| :node | gen generate: node result: Nil])
                ; {(gen generate: n statements last result: result)}]
].

gen@(VM SSACompiler traits) generate: n@(nodes Parenthesis traits) result: result
"return the registers that the values were saved into"
[
  n statements isEmpty
   ifTrue: [#{}]
   ifFalse: [n statements allButLastDo: [| :node | gen generate: node result: Nil].
             gen generate: n statements last result: result]
].

gen@(VM SSACompiler traits) generate: i@(nodes ImplicitArgument traits) result: result
[
  result `defaultsTo: gen newRegister.
  gen emitInstruction: gen loadEnvironment withParameters: {result} from: i.
  result
].

gen@(VM SSACompiler traits) generate: _@(nodes Namespace traits) result: result
[shouldNotImplement].

gen@(VM SSACompiler traits) generate: load@(nodes LoadVariable traits) result: result
[| lexOffset varIndex |
  load variable scope `cacheAs: #scope.
  varIndex := scope localVariables indexOf: load variable.
  lexOffset := gen contexts indexLast -
    ((gen contexts indexOfLastSatisfying: [| :context | context method sourceTree == scope])
      ifNil:
        [error: 'Could not determine variable scope.']).
  lexOffset isZero
    ifTrue:
      [result `defaultsTo: varIndex.
       gen emitInstruction: gen loadVariable withParameters: {varIndex} from: load.
       result = varIndex
              ifFalse: [gen emitInstruction: gen moveRegister withParameters: {result. varIndex} from: load]]
    ifFalse:
      [result `defaultsTo: gen newRegister.
       (gen contexts fromTop: lexOffset) method heapAllocate := True.
       (gen contexts top: lexOffset) do: #beClosure `er.
       gen emitInstruction: gen loadFreeVariable withParameters: {result. lexOffset. varIndex} from: load].
  result
].

gen@(VM SSACompiler traits) generate: store@(nodes StoreVariable traits) result: result
[| lexOffset varIndex |
  store variable scope `cacheAs: #scope.
  varIndex := scope localVariables indexOf: store variable.
  lexOffset := gen contexts indexLast -
    ((gen contexts indexOfLastSatisfying: [| :context | context method sourceTree == scope])
      ifNil:
        [error: 'Could not determine variable scope.']).
  lexOffset isZero
    ifTrue:
      [result `defaultsTo: varIndex.
       gen generate: store value result: varIndex.
       gen emitInstruction: gen storeVariable withParameters: {varIndex} from: store.
       result = varIndex
              ifFalse: [gen emitInstruction: gen moveRegister withParameters: {result. varIndex} from: store]]
    ifFalse:
      [result `defaultsTo: gen newRegister.
       gen generate: store value result: result.
       (gen contexts fromTop: lexOffset) method heapAllocate := True.
       (gen contexts top: lexOffset) do: #beClosure `er.
       gen emitInstruction: gen storeFreeVariable withParameters: {lexOffset. varIndex. result} from: store].
  result
].

gen@(VM SSACompiler traits) generate: array@(nodes Array traits) result: result
"Generate the code to push the element expression results on the stack,
then the appropriate literal-array constructor bytecode."
[| registers |
  registers := resend.
  result `defaultsTo: gen newRegister.
  gen emitInstruction: gen newArrayWith withParameters: {result. array size} ; registers from: array.
  result
].

gen@(VM SSACompiler traits) generate: selector@(Symbol traits) on: args from: msg@(nodes Message traits) result: result
"Generate the code to push the argument expression results on the stack, then
the push for the selector, and then the appropriate message send bytecode."
[| argRegisters |
  result `defaultsTo: gen newRegister.
  argRegisters := args collect: #(gen generate: _ result: Nil) `er.
  gen emitInstruction: gen directSendMessage withParameters: {result. selector. args size} ; argRegisters from: msg.
  result
].

gen@(VM SSACompiler traits) generate: msg@(nodes Message traits) result: result &optionals: opts
[
  gen generate: msg selector on: msg arguments from: (opts ifNil: [msg]) result: result
].

gen@(VM SSACompiler traits) generate: macro@(nodes Macro traits) result: result &optionals: opts
[
  "gen generate: (macro macroExpand &optionals: opts &environment: gen currentMethod sourceTree) result: result"
  error: 'SSA Compiler cannot support macroexpansion at code generation time because of localVariable side-effects'.
].

gen@(VM SSACompiler traits) generate: def@(nodes Deferred traits) result: result &optionals: opts
[| block message |
  block := nodes Block new `>> [parentScope := gen currentMethod sourceTree. ].
  def arguments size timesRepeat: [block addInputVariable].
  message := nodes Message sending: def selector to:
    (block inputVariables collect: #(nodes LoadVariable from: _) `er).
  opts
    ifNotNil:
      [message :=
        ((nodes OptionalArguments for: message)
          `>> [arguments := opts arguments deepCopy: block. ])].
  block statements := {message}.
  gen generate:
    (nodes KeywordMessage
      sending: #whenFulfilled:
      to: {def arguments as: nodes Array. block})
    result: result
].

gen@(VM SSACompiler traits) generate: selector@(Symbol traits) on: args from: opts@(nodes OptionalKeywords traits) result: result
"Generate the code to push the argument expression results on the stack, then
the push for the selector, and then the appropriate message send bytecode."
[| argRegisters optsArray optsWriter |
  result `defaultsTo: gen newRegister.
  argRegisters := args collect: #(gen generate: _ result: Nil) `er.
  optsArray := ExtensibleArray new.
  optsWriter := optsArray writer.
  opts keywords with: opts arguments do:
    [| :key :arg |
     optsWriter nextPut: (gen registerFor: key from: opts result: Nil).
     optsWriter nextPut: (gen generate: arg result: Nil)].
  gen emitInstruction: gen sendMessageWithOptionalsInline withParameters:
    {result. selector. args size. optsArray size} ; argRegisters ; optsArray from: opts.
  result
].

gen@(VM SSACompiler traits) generate: opts@(nodes OptionalKeywords traits) result: result
[
  gen generate: opts message result: result &optionals: opts
].

gen@(VM SSACompiler traits) generate: rest@(nodes RestArguments traits) result: result
[
  gen generate: rest message selector on: rest message arguments ; rest arguments from: rest message result: result
].

gen@(VM SSACompiler traits) generate: _@#apply* on: args from: msg result: result
[| methodReg argRegs |
  result `defaultsTo: gen newRegister.
  methodReg := gen generate: args first result: Nil.
  argRegs := args allButFirst collect: [| :item | gen generate: item result: Nil].
  gen emitInstruction: gen directApplyTo withParameters: {methodReg. argRegs size. result} ; argRegs from: msg.
  result
].

gen@(VM SSACompiler traits) generate: _@#applyTo: on: args from: msg result: result
[| methodReg argRegs |
  (args second isSameAs: nodes Array)
    ifTrue:
      [result `defaultsTo: gen newRegister.
       methodReg := gen generate: args first result: Nil.
       argRegs := args second statements collect:
         [| :item | gen generate: item result: Nil].
       gen emitInstruction: gen directApplyTo
         withParameters: {methodReg. argRegs size. result} ; argRegs
         from: msg.
       result]
    ifFalse: [resend]
].

gen@(VM SSACompiler traits) generate: _@#primitiveApply* on: args from: msg result: result
[| indexReg argRegs |
  result `defaultsTo: gen newRegister.
  indexReg := gen generate: args first result: Nil.
  argRegs := args second statements collect: [| :item | gen generate: item result: Nil].
  gen emitInstruction: gen primitiveDo withParameters: {indexReg. argRegs size. result} ; argRegs from: msg.
  result
].

gen@(VM SSACompiler traits) generate: _@#True on: args from: msg result: result
[
  (args first isSameAs: nodes ImplicitArgument)
    ifTrue: [gen registerFor: True from: msg result: result]
    ifFalse: [resend]
].

gen@(VM SSACompiler traits) generate: _@#False on: args from: msg result: result
[
  (args first isSameAs: nodes ImplicitArgument)
    ifTrue: [gen registerFor: False from: msg result: result]
    ifFalse: [resend]
].

gen@(VM SSACompiler traits) generate: _@#Nil on: args from: msg result: result
[
  (args first isSameAs: nodes ImplicitArgument)
    ifTrue: [gen registerFor: Nil from: msg result: result]
    ifFalse: [resend]
].

gen@(VM SSACompiler traits) generate: _@#== on: args from: msg result: result
[| argRegs |
  result `defaultsTo: gen newRegister.
  argRegs := args collect: [| :arg | gen generate: arg result: Nil].
  gen emitInstruction: gen isIdenticalTo withParameters: {result. argRegs first. argRegs second} from: msg.
  result
].

gen@(VM SSACompiler traits) generate: _@#do on: args from: msg result: result
"If the block is a literal with no variables, then inline it.
Otherwise, fall back to evaluating it via 'do'."
[
  args first `cacheAs: #block.
  (block isSameAs: nodes Block)
    /\ [block localVariables isEmpty]
    ifTrue:
      [result `defaultsTo: gen newRegister.
       block statements isEmpty
         ifTrue: [gen emitInstruction: gen loadLiteral withParameters: {result. Nil} from: msg.
                  result]
         ifFalse: [block statements allButLastDo: [| :node | gen generate: node result: Nil].
                   gen generate: block statements last result: result]]
    ifFalse: [resend]
].

gen@(VM SSACompiler traits) generateExecutionOf: args from: msg result: result
[gen generate: #do on: args from: msg result: result].

gen@(VM SSACompiler traits) generate: _@#loop on: args from: msg result: result
"Repeatedly evaluates a block via 'do'."
[| label |
  label := gen emitLabel.
  gen generateExecutionOf: args from: msg result: Nil.
  gen emitInstruction: gen jumpTo withParameters: #{}"see below" from: msg.
  gen emitBranchTo: label from: msg.
  gen registerFor: Nil from: msg result: result "return nil"
].

gen@(VM SSACompiler traits) generate: _@#isNil on: args from: msg result: result
[ | objReg |
  result `defaultsTo: gen newRegister.
  objReg := gen generate: args first result: Nil.
  gen emitInstruction: gen isNilOp withParameters: {result. objReg} from: msg.
  result
].

gen@(VM SSACompiler traits) branchTableHash: key
[
  key identityHash
].

gen@(VM SSACompiler traits) buildBranchTableMapping: keys
[| table tableSize |
  tableSize := 1.
  [tableSize < keys size]
    whileTrue:
      [tableSize *= 2].
  table := Array newSize: tableSize * 2.
  keys do:
    [| :key hash |
      hash := (gen branchTableHash: key) bitAnd: (tableSize - 1) * 2.
      [(table at: hash) isNil]
        whileFalse:
          [key = (table at: hash)
            ifTrue:
              [error: 'Duplicate key ' ; key printString ; ' in caseOf:.'].
            (hash += 2) >= (tableSize * 2) ifTrue:
              [hash := 0]].
      table at: hash put: key].
  table
].

gen@(VM SSACompiler traits) mayInlineCaseOf: msg
"Answer whether a safe inlining is possible for a caseOf: expression without
further analysis; currently this is the case where the second argument is a
literal array, and the appropriate Associations and their elements are laid
out with literal keys."
[
  (msg arguments second isSameAs: nodes Array) /\
   [msg arguments second statements allSatisfy:
     [| :assoc |
      (assoc is: nodes Message)
        /\ [assoc selector = #->]
        /\ [assoc arguments first is: nodes Literal]
        /\ [{Symbol. ASCIIString Character. SmallInteger} anySatisfy:
          [| :proto | assoc arguments first value is: proto]]]]
].

gen@(VM SSACompiler traits) generate: _@#caseOf:otherwise: on: args from: msg result: finalResult
[| labels table indices branchOffset otherwiseLabel endLabel switchKeyRegister |
  (gen mayInlineCaseOf: msg)
    ifFalse: [^ resend].
  args second statements `cacheAs: #assocs.
  labels := assocs collect: [| :_ | gen newLabelIndex].
  finalResult `defaultsTo: gen newRegister.
  table :=
    (gen
      buildBranchTableMapping:
        (assocs collect: [| :assoc | assoc arguments first value])).
  indices := IdentityDictionary new.
  0 below: table size by: 2 do: [| :index |
    (table at: index) ifNotNilDo: [| :val | indices at: val put: index]].

  switchKeyRegister := gen generate: args first result: Nil.
  gen emitInstruction: gen branchKeyed
      withParameters: {switchKeyRegister. (gen registerFor: table from: msg result: Nil)}
      from: msg.
  branchOffset := gen codeWriter position.
  gen emitInstruction: gen jumpTo from: msg.
  endLabel := gen newLabelIndex.
  otherwiseLabel := gen newLabelIndex.
  gen emitBranchTo: otherwiseLabel from: msg.

  assocs with: labels do:
    [| :assoc :label |
      gen emitLabel &labelIndex: label.
      table
        at: (indices at: assoc arguments first value) + 1
        put: (gen currentContext resolveLabel: label at: branchOffset).
      gen generateExecutionOf: {assoc arguments second} from: msg result: finalResult.
      gen emitInstruction: gen jumpTo from: msg.
      gen emitBranchTo: endLabel from: msg].

  "Handle the otherwise clause. If we didn't get a literal block for it, just
  encode a Nil-push."
  gen emitLabel &labelIndex: otherwiseLabel.
  args size >= 3
    ifTrue: [gen generateExecutionOf: {args third} from: msg result: finalResult]
    ifFalse: [gen registerFor: Nil from: msg result: finalResult].
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#caseOf: on: args from: msg result: result
"Generates a caseOf:otherwise: with a default otherwise clause."
[
  (gen mayInlineCaseOf: msg)
    ifTrue: [gen generate: #caseOf:otherwise: on: args from: msg result: result]
    ifFalse: [resend]
].

gen@(VM SSACompiler traits) generate: _@#ifTrue:ifFalse: on: args from: msg result: finalResult
"Branches to one of two blocks and evaluates it."
[| falseLabel endLabel condReg |
  falseLabel := gen newLabelIndex.
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  (condReg := gen generate: args first result: Nil)
    ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfFalse withParameters: {condReg} from: msg.
  gen emitBranchTo: falseLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen emitLabel &labelIndex: falseLabel.
  gen generateExecutionOf: {args third} from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#ifTrue: on: args from: msg result: finalResult
"Optionally evaluates a block."
[| falseLabel endLabel condReg |
  falseLabel := gen newLabelIndex.
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  (condReg := gen generate: args first result: Nil)
    ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfFalse withParameters: {condReg} from: msg.
  gen emitBranchTo: falseLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen emitLabel &labelIndex: falseLabel.
  gen registerFor: Nil from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#ifFalse: on: args from: msg result: finalResult
[| falseLabel endLabel condResult |
  falseLabel := gen newLabelIndex.
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  (condResult := gen generate: args first result: Nil)
    ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfTrue withParameters: {condResult} from: msg.
  gen emitBranchTo: falseLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen emitLabel &labelIndex: falseLabel.
  gen registerFor: Nil from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#ifNil: on: args from: msg result: finalResult
[ | endLabel condReg lhsValueReg |
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  lhsValueReg := gen generate: args first result: finalResult. "do not evaluate twice"
  condReg := gen newRegister.
  gen emitInstruction: gen isNilOp withParameters: {condReg. lhsValueReg} from: msg.
  gen emitInstruction: gen branchIfFalse withParameters: {condReg} from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#ifNotNil: on: args from: msg result: finalResult
[ | endLabel condReg lhsValueReg |
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  lhsValueReg := gen generate: args first result: finalResult. "do not evaluate twice"
  condReg := gen newRegister.
  gen emitInstruction: gen isNilOp withParameters: {condReg. lhsValueReg} from: msg.
  gen emitInstruction: gen branchIfTrue withParameters: {condReg} from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#/\ on: args from: msg result: finalResult
"Optionally evaluates a block."
[| falseLabel endLabel condResult |
  (args second isSameAs: nodes Block)
    ifFalse: [^ resend].
  falseLabel := gen newLabelIndex.
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  (condResult := gen generate: args first result: Nil)
    ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfFalse withParameters: {condResult} from: msg.
  gen emitBranchTo: falseLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen emitLabel &labelIndex: falseLabel.
  gen registerFor: False from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#\/ on: args from: msg result: finalResult
"Optionally evaluates a block."
[| block falseLabel endLabel condResult |
  (args second isSameAs: nodes Block)
    ifFalse: [^ resend].
  falseLabel := gen newLabelIndex.
  endLabel := gen newLabelIndex.
  finalResult `defaultsTo: gen newRegister.
  (condResult := gen generate: args first result: Nil)
    ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfTrue withParameters: {condResult} from: msg.
  gen emitBranchTo: falseLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: finalResult.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen emitLabel &labelIndex: falseLabel.
  gen registerFor: True from: msg result: finalResult.
  gen emitLabel &labelIndex: endLabel.
  finalResult
].

gen@(VM SSACompiler traits) generate: _@#whileTrue: on: args from: msg result: finalResult
"Repeatedly evaluates a block while it returns True."
[| label endLabel condResult |
  endLabel := gen newLabelIndex.
  label := gen emitLabel.
  (condResult := gen generateExecutionOf: {args first} from: msg result: Nil)
    ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfFalse withParameters: {condResult} from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: Nil.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: label from: msg.
  gen emitLabel &labelIndex: endLabel.
  gen registerFor: Nil from: msg result: finalResult
].

gen@(VM SSACompiler traits) generate: _@#whileFalse: on: args from: msg result: finalResult
"Repeatedly evaluates a block while it returns False."
[| label endLabel condResult |
  endLabel := gen newLabelIndex.
  label := gen emitLabel.
  condResult := gen generateExecutionOf: {args first} from: msg result: Nil.
  condResult ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfTrue withParameters: {condResult} from: msg.
  gen emitBranchTo: endLabel from: msg.
  gen generateExecutionOf: {args second} from: msg result: Nil.
  gen emitInstruction: gen jumpTo from: msg.
  gen emitBranchTo: label from: msg.
  gen emitLabel &labelIndex: endLabel.
  gen registerFor: Nil from: msg result: finalResult
].

gen@(VM SSACompiler traits) generate: _@#whileTrue on: args from: msg result: result
"Repeatedly evaluates a block while it returns True."
[| label condResult |
  label := gen emitLabel.
  condResult := gen generateExecutionOf: args from: msg result: Nil.
  condResult ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfTrue withParameters: {condResult} from: msg.
  gen emitBranchTo: label from: msg.
  gen registerFor: Nil from: msg result: result
].

gen@(VM SSACompiler traits) generate: _@#whileFalse on: args from: msg result: result
"Repeatedly evaluates a block while it returns False."
[| label condResult |
  label := gen emitLabel.
  condResult := gen generateExecutionOf: args from: msg result: Nil.
  condResult ifNil: [error: 'conditional is nil: ' ; args first printString].
  gen emitInstruction: gen branchIfFalse withParameters: {condResult} from: msg.
  gen emitBranchTo: label from: msg.
  gen registerFor: Nil from: msg result: result
].

gen@(VM SSACompiler traits) generate: _@#primitiveDo: on: args from: msg result: result
[| indexReg argRegs |
  result `defaultsTo: gen newRegister.
  indexReg := gen generate: args first result: Nil.
  argRegs := args second statements collect: [| :item | gen generate: item result: Nil].
  gen emitInstruction: gen primitiveDo withParameters: {indexReg. argRegs size. result} ; argRegs from: msg.
  result
].

gen@(VM SSACompiler traits) generate: _@#fill:with: on: args from: msg result: result
[| block index var value |
  block := args first.
  index := args second.
  value := args third.
  (block isSameAs: nodes Block)
    /\ [index isSameAs: nodes Literal]
    /\ [block inputVariables acceptsKey: index value]
    ifFalse: [^ resend].
  (value isSameAs: nodes Literal)
    ifFalse:
      [| tmp |
        tmp := gen currentMethod sourceTree addVariable.
        gen generate: (nodes StoreVariable of: value into: tmp) result: Nil. "fixme"
        value := nodes LoadVariable from: tmp].
  index := index value.
  var := block inputVariables at: index.
  block inputVariables := block inputVariables copyWithoutAt: index.
  block localVariables
    replaceFrom: index
    below: block localVariables indexLast
    with: block localVariables
    startingAt: index + 1.
  block localVariables at: block localVariables indexLast put: var.
  block statements:
    {(nodes StoreVariable of: value into: var)} ; block statements.
  gen generate: block result: result
].

gen@(VM SSACompiler traits) generate: _@#<-* on: args from: msg result: result
"Optimizes currying calls on literal blocks using #fill:with:."
[
  (args first isSameAs: nodes Block)
    ifTrue:
      [gen
         generate: #fill:with:
         on: (args copyWith:
                (nodes Literal for: args first inputVariables indexLast) at: 1)
         from: msg
         result: result]
    ifFalse: [resend]
].