"ilo.st, for gnu smalltalk - (c) charles childers"

Object subclass: #IloVM
    instanceVariableNames: 'memory dataStack addrStack ip sp rp blocks rom'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'IloVM'
!

!IloVM class methodsFor: 'helpers'!
wrap32: value
    "Clamp to signed 32-bit range using two's complement rules."
    | v |
    v := value bitAnd: 16rFFFFFFFF.
    ^v >= 16r80000000
        ifTrue: [v - 16r100000000]
        ifFalse: [v]
!

decodeSigned32From: bytes
    | val |
    bytes size < 4 ifTrue: [^0].
    val := (bytes at: 1)
        + ((bytes at: 2) bitShift: 8)
        + ((bytes at: 3) bitShift: 16)
        + ((bytes at: 4) bitShift: 24).
    ^self wrap32: val
!

encodeSigned32: value
    | v arr |
    v := value.
    v < 0 ifTrue: [v := 16r100000000 + v].
    arr := ByteArray new: 4.
    arr at: 1 put: (v bitAnd: 16rFF).
    arr at: 2 put: ((v bitShift: -8) bitAnd: 16rFF).
    arr at: 3 put: ((v bitShift: -16) bitAnd: 16rFF).
    arr at: 4 put: ((v bitShift: -24) bitAnd: 16rFF).
    ^arr
!

main
    | args blockFile romFile vm |
    args := Smalltalk arguments.
    blockFile := args size >= 1 ifTrue: [args at: 1] ifFalse: ['ilo.blocks'].
    romFile := args size >= 2 ifTrue: [args at: 2] ifFalse: ['ilo.rom'].
    vm := self new blocks: blockFile rom: romFile.
    vm loadImage.
    vm execute.
    vm dumpStack
!

new
    ^super new initialize
!
! !

!IloVM methodsFor: 'init'!
initialize
    memory := Array new: 65536 withAll: 0.
    dataStack := Array new: 33 withAll: 0.
    addrStack := Array new: 257 withAll: 0.
    ip := 0.
    sp := 0.
    rp := 0.
    blocks := 'ilo.blocks'.
    rom := 'ilo.rom'
!

blocks: blockPath rom: romPath
    blocks := blockPath.
    rom := romPath.
    ^self
!

wrap32: value
    ^self class wrap32: value
!

resetRegisters
    ip := 0.
    sp := 0.
    rp := 0
!
! !

!IloVM methodsFor: 'memory'!
memoryAt: index
    ^memory at: index + 1
!

memoryAt: index put: value
    memory at: index + 1 put: (self wrap32: value)
!
! !

!IloVM methodsFor: 'stack'!
push: value
    sp := sp + 1.
    dataStack at: sp put: (self wrap32: value)
!

pop
    | v |
    v := dataStack at: sp.
    sp := sp - 1.
    ^v
!

top
    ^dataStack at: sp
!

second
    ^dataStack at: sp - 1
!

setTop: value
    dataStack at: sp put: (self wrap32: value)
!

saveReturn
    rp := rp + 1.
    addrStack at: rp put: ip
!

popReturn
    | v |
    v := addrStack at: rp.
    rp := rp - 1.
    ^v
!
! !

!IloVM methodsFor: 'image & blocks'!
loadImage
    | stream idx |
    (File exists: rom) ifFalse: [^self resetRegisters].
    memory := Array new: 65536 withAll: 0.
    stream := FileStream open: rom mode: FileStream read.
    [ idx := 0.
      [idx < 65536 and: [stream atEnd not]] whileTrue: [
          self memoryAt: idx put: (self class decodeSigned32From: ((stream next: 4) asByteArray)).
          idx := idx + 1
      ].
    ] ensure: [stream close].
    self resetRegisters
!

saveImage
    | stream |
    stream := FileStream open: rom mode: FileStream write.
    [ 0 to: 65535 do: [:idx |
          stream nextPutAll: (self class encodeSigned32: (self memoryAt: idx))
      ].
    ] ensure: [stream close]
!

readBlock
    | buffer block stream |
    buffer := self pop.
    block := self pop.
    (File exists: blocks) ifFalse: [^self].
    stream := FileStream open: blocks mode: FileStream read.
    [ stream position: block * 4096.
      0 to: 1023 do: [:offset |
          self memoryAt: buffer + offset put:
              (self class decodeSigned32From: ((stream next: 4) asByteArray))
      ].
    ] ensure: [stream close]
!

writeBlock
    | buffer block stream |
    buffer := self pop.
    block := self pop.
    stream := FileStream open: blocks mode: FileStream readWrite.
    [ stream position: block * 4096.
      0 to: 1023 do: [:offset |
          stream nextPutAll: (self class encodeSigned32: (self memoryAt: buffer + offset))
      ].
    ] ensure: [stream close]
!
! !

!IloVM methodsFor: 'instructions'!
symmetricRem: rem dividend: dividend
    (dividend >= 0 and: [rem < 0]) ifTrue: [^Array with: (rem - dividend) with: 1].
    ^Array with: rem with: 0
!

instLit
    ip := ip + 1.
    self push: (self memoryAt: ip)
!

instDup
    self push: self top
!

instDrop
    sp > 0 ifTrue: [self pop]
!

instSwap
    | a b |
    a := self pop.
    b := self pop.
    self push: a.
    self push: b
!

instPushReturn
    rp := rp + 1.
    addrStack at: rp put: self pop
!

instPopReturn
    self push: (addrStack at: rp).
    rp := rp - 1
!

instJump
    ip := (self pop) - 1
!

instCall
    self saveReturn.
    ip := (self pop) - 1
!

instCondCall
    | target flag |
    target := self pop.
    flag := self pop.
    flag ~= 0 ifTrue: [
        self saveReturn.
        ip := target - 1
    ]
!

instCondJump
    | target flag |
    target := self pop.
    flag := self pop.
    flag ~= 0 ifTrue: [ip := target - 1]
!

instReturn
    ip := self popReturn
!

instEq
    | a b |
    a := self pop.
    b := self pop.
    self push: (b = a ifTrue: [-1] ifFalse: [0])
!

instNe
    | a b |
    a := self pop.
    b := self pop.
    self push: (b ~= a ifTrue: [-1] ifFalse: [0])
!

instLt
    | a b |
    a := self pop.
    b := self pop.
    self push: (b < a ifTrue: [-1] ifFalse: [0])
!

instGt
    | a b |
    a := self pop.
    b := self pop.
    self push: (b > a ifTrue: [-1] ifFalse: [0])
!

instFetch
    self setTop: (self memoryAt: self top)
!

instStore
    | address value |
    address := self pop.
    value := self pop.
    self memoryAt: address put: value
!

instAdd
    | a b |
    a := self pop.
    b := self pop.
    self push: (b + a)
!

instSub
    | a b |
    a := self pop.
    b := self pop.
    self push: (b - a)
!

instMul
    | a b |
    a := self pop.
    b := self pop.
    self push: (b * a)
!

instDivMod
    | divisor dividend rem quo adjust |
    divisor := self pop.
    dividend := self pop.
    rem := dividend rem: divisor.
    quo := dividend quo: divisor.
    adjust := self symmetricRem: rem dividend: dividend.
    rem := self wrap32: (adjust at: 1).
    quo := self wrap32: (quo + (adjust at: 2)).
    self push: rem.
    self push: quo
!

instAnd
    | a b |
    a := self pop.
    b := self pop.
    self push: (b bitAnd: a)
!

instOr
    | a b |
    a := self pop.
    b := self pop.
    self push: (b bitOr: a)
!

instXor
    | a b |
    a := self pop.
    b := self pop.
    self push: (b bitXor: a)
!

instShl
    | a b |
    a := self pop.
    b := self pop.
    self push: (b bitShift: a)
!

instShr
    | a b |
    a := self pop.
    b := self pop.
    self push: (b bitShift: a negated)
!

instCmp
    | len dest src |
    len := self pop.
    dest := self pop.
    src := self top.
    self setTop: -1.
    [len > 0] whileTrue: [
        (self memoryAt: dest) = (self memoryAt: src) ifFalse: [self setTop: 0].
        len := len - 1.
        dest := dest + 1.
        src := src + 1
    ]
!

instCopy
    | len dest src |
    len := self pop.
    dest := self pop.
    src := self pop.
    [len > 0] whileTrue: [
        self memoryAt: dest put: (self memoryAt: src).
        len := len - 1.
        dest := dest + 1.
        src := src + 1
    ]
!

instIoCharOut
    | c |
    c := self pop.
    FileStream stdout nextPut: (Character value: (c bitAnd: 16rFF)).
    FileStream stdout flush
!

instIoCharIn
    | c |
    c := FileStream stdin next.
    c isNil
        ifTrue: [self push: 0]
        ifFalse: [self push: c asInteger]
!

instIo
    | device |
    device := self pop.
    device = 0 ifTrue: [^self instIoCharOut].
    device = 1 ifTrue: [^self instIoCharIn].
    device = 2 ifTrue: [^self readBlock].
    device = 3 ifTrue: [^self writeBlock].
    device = 4 ifTrue: [^self saveImage].
    device = 5 ifTrue: [self loadImage. ip := -1. ^self].
    device = 6 ifTrue: [ip := 65536. ^self].
    device = 7 ifTrue: [self push: sp. self push: rp. ^self].
    ^self
!
! !

!IloVM methodsFor: 'execution'!
process: opcode
    opcode = 0 ifTrue: [^self].
    opcode = 1 ifTrue: [^self instLit].
    opcode = 2 ifTrue: [^self instDup].
    opcode = 3 ifTrue: [^self instDrop].
    opcode = 4 ifTrue: [^self instSwap].
    opcode = 5 ifTrue: [^self instPushReturn].
    opcode = 6 ifTrue: [^self instPopReturn].
    opcode = 7 ifTrue: [^self instJump].
    opcode = 8 ifTrue: [^self instCall].
    opcode = 9 ifTrue: [^self instCondCall].
    opcode = 10 ifTrue: [^self instCondJump].
    opcode = 11 ifTrue: [^self instReturn].
    opcode = 12 ifTrue: [^self instEq].
    opcode = 13 ifTrue: [^self instNe].
    opcode = 14 ifTrue: [^self instLt].
    opcode = 15 ifTrue: [^self instGt].
    opcode = 16 ifTrue: [^self instFetch].
    opcode = 17 ifTrue: [^self instStore].
    opcode = 18 ifTrue: [^self instAdd].
    opcode = 19 ifTrue: [^self instSub].
    opcode = 20 ifTrue: [^self instMul].
    opcode = 21 ifTrue: [^self instDivMod].
    opcode = 22 ifTrue: [^self instAnd].
    opcode = 23 ifTrue: [^self instOr].
    opcode = 24 ifTrue: [^self instXor].
    opcode = 25 ifTrue: [^self instShl].
    opcode = 26 ifTrue: [^self instShr].
    opcode = 27 ifTrue: [^self instCmp].
    opcode = 28 ifTrue: [^self instCopy].
    opcode = 29 ifTrue: [^self instIo].
    ^self
!

processBundle: opcode
    self process: (opcode bitAnd: 16rFF).
    self process: ((opcode bitShift: -8) bitAnd: 16rFF).
    self process: ((opcode bitShift: -16) bitAnd: 16rFF).
    self process: ((opcode bitShift: -24) bitAnd: 16rFF)
!

execute
    [ip < 65536] whileTrue: [
        self processBundle: (self memoryAt: ip).
        ip := ip + 1
    ]
!

dumpStack
    | out |
    out := FileStream stdout.
    sp to: 1 by: -1 do: [:idx |
        out nextPutAll: ' ' , ((dataStack at: idx) printString)
    ].
    out cr.
    out flush
!
! !

IloVM main!