requires: {#CompiledMethod}.
provides: {#Interpreter}.

VM addPrototype: #LexicalContext derivedFrom: {Array derive}.
VM LexicalContext addSlot: #framePointer valued: Nil.

VM addPrototype: #Interpreter derivedFrom: {Cloneable}.
"An in-Slate version of the bytecode VM, an interpreter of the bytecodes and
method structure."
VM Interpreter addSlot: #method valued: Nil.
"The method currently being executed."
VM Interpreter addSlot: #lexicalContext valued: Nil.
"The lexical context of the method."
VM Interpreter addSlot: #codePointer valued: 0.
"The offset of the currently executing bytecode in the method."
VM Interpreter addSlot: #stack valued: Stack newEmpty.

i@(VM Interpreter traits) newEmpty
[| newI |
  newI: i clone.
  newI stack: i stack newEmpty.
  newI
].

i@(VM Interpreter traits) copy
[| newI |
  newI: i clone.
  newI stack: i stack copy.
  newI
].

i@(VM Interpreter traits) decodeShort
[| n val |
  n: i codePointer. 
  i codePointer: n + 2.
  val: (i method code at: n) + ((i method code at: n + 1) bitShift: 8).
  val >= 16r8000
    ifTrue: [-16r8000 + (val bitAnd: 16r7FFF)]
    ifFalse: [val]
].
  
i@(VM Interpreter traits) decodeImmediate
[| n code val |
  n: i codePointer.
  code: (i method code at: n).
  val: (code bitAnd: 16r7F).
  [code >= 16r80]
    whileTrue:
      [n: n + 1.
       code: (i method code at: n).
       val: ((val bitShift: 7) bitOr: (code bitAnd: 16r7F))].
  i codePointer: n.
  val
].
       
i@(VM Interpreter traits) sendMessage: n
[| selector args method lexicalContext |
   args: (i stack pop: n).
   selector: i stack pop.
   method: (selector findOn: args).
   method  
     ifNil: [selector notFoundOn: args].
   (method isSameAs: VM CompiledMethod)
     ifFalse: 
       [^ (i stack push: (method applyTo: args))].

   lexicalContext: (VM LexicalContext newSize: method localVariables).
   n > method inputVariables
     ifTrue:  
       [method restVariable
         ifFalse: [selector notFoundOn: args].
         lexicalContext at: method inputVariables + method optionalKeywords size
           put: (args last: n - method inputVariables)].
   0 below: method inputVariables
     do:
       [| :i | lexicalContext at: i put: (args at: i)].
   
   i stack push: i method.
   i stack push: i lexicalContext.
   i stack push: i codePointer.
   
   lexicalContext framePointer: i stack position.   

   i method: method.
   i lexicalContext: lexicalContext.
   i codePointer: 0
].


i@(VM Interpreter traits) resendMessage
"TODO: Make this pass in optional keywords properly, and possibly rest arguments."
[| framePointer selector args method lexicalContext |
   args: (i lexicalContext copyFrom: 0 to: i method inputVariables - 1).
   selector: i method selector.
   method: (selector findOn: args after: i method).
   method
     ifNil: [selector notFoundOn: args].
   (method isSameAs: VM CompiledMethod)
     ifFalse:
       [^ (i stack push: (method applyTo: args))].

   lexicalContext: (VM LexicalContext newSize: method localVariables).
   0 below: method inputVariables
     do:
       [| :i | lexicalContext at: i put: (args at: i)].

   i stack push: i method.
   i stack push: i lexicalContext.
   i stack push: i codePointer.

   lexicalContext framePointer: i stack position.

   i method: method.
   i lexicalContext: lexicalContext.
   i codePointer: 0
].

i@(VM Interpreter traits) sendMessageWithOptionals: n 
[| selector args opts method lexicalContext |
   opts: i stack pop.
   args: (i stack pop: n).
   selector: i stack pop.
   method: (selector findOn: args).
   method
     ifNil: [selector notFoundOn: args].
   (method isSameAs: VM CompiledMethod)
     ifFalse:
       [^ (i stack push: (method applyTo: args &optionals: opts))].

   lexicalContext: (VM LexicalContext newSize: method localVariables).
   n > method inputVariables
     ifTrue: 
       [method restVariable
         ifFalse: [selector notFoundOn: args].
         lexicalContext at: method inputVariables + method optionalKeywords size
           put: (args last: n - method inputVariables)].
   0 below: method inputVariables
     do:
       [| :i | lexicalContext at: i put: (args at: i)].
   opts
     do:
       [| :key :val |
         (method optionalKeywords indexOf: key)
           ifNotNilDo:
             [| :i | lexicalContext at: method inputVariables + i put: val]]
     inGroupsOf: 2.

   i stack push: i method.
   i stack push: i lexicalContext.
   i stack push: i codePointer.

   lexicalContext framePointer: i stack position.

   i method: method.
   i lexicalContext: lexicalContext.
   i codePointer: 0
].

i@(VM Interpreter traits) loadVariable: n
[
  i stack push: (i lexicalContext at: n)
].

i@(VM Interpreter traits) storeVariable: n
[
  i lexicalContext at: n put: i stack pop
].

i@(VM Interpreter traits) loadFreeVariable: n
[
  i stack push: ((i method lexicalWindow at: n - 1) at: i decodeImmediate)
].

i@(VM Interpreter traits) storeFreeVariable: n
[
  (i method lexicalWindow at: n - 1) at: i decodeImmediate put: i stack pop
].

i@(VM Interpreter traits) loadLiteral: n
[
  i stack push: (i method literals at: n)
].

i@(VM Interpreter traits) loadSelector: n
[
  i stack push: (i method selectors at: n)
].

i@(VM Interpreter traits) popStack: n
[
  i stack position: i stack position - n
].

i@(VM Interpreter traits) newArray: n
[
  i stack push: (i stack pop: n)
].

i@(VM Interpreter traits) newBlock: n
[| block |
  block: (i method literals at: n) clone.
  block lexicalWindow: { i lexicalContext } ; i method lexicalWindow. 
  i stack push: block
].

i@(VM Interpreter traits) pushInteger: n
[
  i stack push: n
].

i@(VM Interpreter traits) jumpTo
[| offset |
  offset: i decodeShort.
  i codePointer: i codePointer + offset
].

i@(VM Interpreter traits) branchIfTrue
[| offset |
  offset: i decodeShort. 
  i stack pop
    ifTrue: [i codePointer: i codePointer + offset]
].

i@(VM Interpreter traits) branchIfFalse
[| offset |
  offset: i decodeShort.
  i stack pop
    ifFalse: [i codePointer: i codePointer + offset]
].

i@(VM Interpreter traits) pushEnvironment
[
  i stack push: i method environment
].

i@(VM Interpreter traits) pushNil
[
  i stack push: Nil
].

i@(VM Interpreter traits) pushTrue
[
  i stack push: True
].

i@(VM Interpreter traits) pushFalse
[
  i stack push: False
].

i@(VM Interpreter traits) isIdenticalTo
[
  i stack push: (i stack pop == i stack pop)
].

i@(VM Interpreter traits) returnFrom: n
[| result lexicalWindow lexicalContext |
  result: i stack pop.

  lexicalWindow: i method lexicalWindow.
  n = 0
    ifTrue:
      [lexicalContext: i lexicalContext]
    ifFalse:
      [lexicalContext: (lexicalWindow at: n - 1).
        lexicalContext framePointer
          ifNil: [error: 'Can\'t return from exited lexical context.']].

  i stack position: lexicalContext framePointer.

  i lexicalContext framePointer: Nil.
  0 below: n
    do:
      [| :i | (lexicalWindow at: i) framePointer: Nil].
  
  i codePointer: i stack pop.
  i lexicalContext: i stack pop.
  i method: i stack pop.

  i stack push: result
].

i@(VM Interpreter traits) branchKeyed: n
[| obj hash table |
  table: (i method literals at: n).
  obj: i stack pop.
  hash: ((val hash * 2) bitAnd: table size - 1).
  table
    do:
      [| :key :offset |
        obj = key
          ifTrue: [^ (i codePointer: i codePointer + offset)]]
    inGroupsOf: 2
    startingAt: hash.
  table
    do:
      [| :key :offset |
        obj = key
          ifTrue: [^ (i codePointer: i codePointer + offset)]]
    inGroupsOf: 2
].

m@(VM CompiledMethod traits) applyTo: args &optionals: opts
[| i lexicalContext |
  i: VM Interpreter newEmpty.

  i stack push: i method.
  i stack push: i lexicalContext.
  i stack push: i codePointer.

  lexicalContext: (VM LexicalContext newSize: m localVariables).
  args size > m inputVariables
    ifTrue:
      [m restVariable
        ifFalse: [selector notFoundOn: args].
        lexicalContext at: m inputVariables + m optionalKeywords size
          put: (args last: args size - m inputVariables)].
  0 below: m inputVariables
    do:
      [| :i | lexicalContext at: i put: (args at: i)].
  opts
    ifNotNil:
      [opts
        do:
          [| :key :val |
            (m optionalKeywords indexOf: key)
              ifNotNilDo:
                [| :i | lexicalContext at: m inputVariables + i put: val]]
        inGroupsOf: 2].
  
  lexicalContext framePointer: i stack position.

  i method: m.
  i lexicalContext: lexicalContext.
  i codePointer: 0.

  [i interpret]
    on: Condition
    do: 
      [| :c | 
        [c signal]
          handlingCases:
            { 
              (VM Interpreter InspectFrame in: i) -> [| :_ |] 
            }
      ]
].

i@(VM Interpreter traits) interpret
[| op val result |
  [
    [i codePointer < i method code size]
      whileTrue:
        [
          op: (i method code at: i codePointer).
          i codePointer: i codePointer + 1.
          val: (op bitShift: -4).
          val = 16rF ifTrue: [val: i decodeImmediate].
          (op bitAnd: 16r0F) caseOf:
            {
              VM ByteCode sendMessage -> [i sendMessage: val].
              VM ByteCode loadVariable -> [i loadVariable: val].
              VM ByteCode storeVariable -> [i storeVariable: val].
              VM ByteCode loadFreeVariable -> [i loadFreeVariable: val].
              VM ByteCode storeFreeVariable -> [i storeFreeVariable: val].
              VM ByteCode loadLiteral -> [i loadLiteral: val].
              VM ByteCode loadSelector -> [i loadSelector: val].
              VM ByteCode popStack -> [i popStack: val].
              VM ByteCode newArray -> [i newArray: val].
              VM ByteCode newBlock -> [i newBlock: val].
              VM ByteCode branchKeyed -> [i branchKeyed: val].
              VM ByteCode sendMessageWithOptionals -> [i sendMessageWithOptionals: val].
              VM ByteCode returnFrom -> [i returnFrom: val].
              VM ByteCode pushInteger -> [i pushInteger: val].
              VM ByteCode extended ->
                [op caseOf:
                  {
                    VM ByteCode jumpTo -> [i jumpTo].
                    VM ByteCode branchIfTrue -> [i branchIfTrue].
                    VM ByteCode branchIfFalse -> [i branchIfFalse].
                    VM ByteCode resendMessage -> [i resendMessage].
                    VM ByteCode pushEnvironment -> [i pushEnvironment].
                    VM ByteCode pushTrue -> [i pushTrue].
                    VM ByteCode pushFalse -> [i pushFalse].
                    VM ByteCode pushNil -> [i pushNil].
                    VM ByteCode isIdenticalTo -> [i isIdenticalTo]
                  }]
            }
        ].
    result: i stack pop.
    
    i lexicalContext framePointer: Nil.
    
    i codePointer: i stack pop.
    i lexicalContext: i stack pop.
    i method: i stack pop.

    i stack push: result.

    i method isNotNil
  ] whileTrue.
  
  i stack pop
].

VM Interpreter addPrototype: #Debug derivedFrom: {Restart}.
VM Interpreter Debug addSlot: #interpreter.

d@(VM Interpreter Debug traits) in: interp
[| newD |
  newD: d clone.
  newD interpreter: interp.
  newD
].
  
VM Interpreter addPrototype: #InspectFrame derivedFrom: {VM Interpreter Debug}.
VM Interpreter InspectFrame addSlot: #stackFrame valued: 0.

r@(VM Interpreter InspectFrame traits) describe
[
   DebugConsole ; 'Inspect a stack frame\n'
].

r@(VM Interpreter InspectFrame traits) query
[| offset |
   [
     DebugConsole ; 'Select a stack frame [0..]: '.
     offset: (DebugConsole reader upTo: $\n).
     (offset size > 0 and: [offset allSatisfy: [| :c | c isDigit]])
       ifTrue: 
         [
           offset: ((offset as: String) as: Integer).
           offset >= 0
             ifTrue:
               [r stackFrame: offset.
                 ^ Nil]
         ]
   ] loop
].

r@(VM Interpreter InspectFrame traits) defaultHandler
[| frame method lexicalContext codePointer |
   method: r interpreter method.
   lexicalContext: r interpreter lexicalContext.
   codePointer: r interpreter codePointer.
   r stackFrame
     timesRepeat:
       [
         frame: lexicalContext framePointer.
         method: (r interpreter stack at: frame - 3).
         method
           ifNil: 
             [DebugConsole ; 'Invalid stack frame.\n'.
               ^ Nil].
         lexicalContext: (r interpreter stack at: frame - 2).
         codePointer: (r interpreter stack at: frame - 1)
       ].
   Syntax SourceWriter clone print: method sourceTree on: DebugConsole writer.
   DebugConsole ; '\n\n'.
   Syntax SourceWriter clone print: (method sourceTreeOf: codePointer - 1) on: DebugConsole writer.
   DebugConsole ; '\n\n'.
   method sourceTree localVariables
     doWithIndex:
       [| :var :index |
         DebugConsole ; (var name as: String) ; ': ' ; (lexicalContext at: index) print ; '\n'
       ].
   DebugConsole ; '\n'.
].