Paste: UM32

USING: accessors alien.data alien.endian arrays command-line
formatting io io.encodings.binary io.files kernel
kernel.private math math.bitwise math.functions math.private
namespaces sequences sequences.private specialized-arrays
strings vectors ;

IN: um32

SPECIALIZED-ARRAY: ube32

TUPLE: UM32
  ! Error state, or "" if operating normally.
  { error string }
  ! How many cycles have we executed?
  { clk fixnum }
  ! Register file. Contains 9 registers. r0 through r7 are general purpose; r8 is the instruction pointer.
  { r array }
  ! Memory banks; vector of vectors of machine words. $0 is initialized with the
  ! program. Others must be allocated at runtime with the ALLOC instruction.
  { mem vector }
  ! Freelist. Dequeue of bank IDs that were allocated but have now been freed
  ! and are available for reuse.
  { freelist vector }
  ;

: <UM32> ( program -- um32 )
    [ "" 0 { 0 0 0 0 0 0 0 0 0 } ] dip 1vector V{ } clone UM32 boa ;

! Register and memory access words

: get-reg ( r vm -- i )
    { fixnum UM32 } declare r>> nth-unsafe { fixnum } declare ; inline

: set-reg ( i r vm -- )
    { fixnum UM32 } declare r>> set-nth-unsafe ;

: get-ip ( vm -- ip ) 8 swap get-reg ;

: set-ip ( ip vm -- ) 8 swap set-reg ;

: get-bank ( bank vm -- mem )
    { fixnum UM32 } declare mem>> nth { array } declare ; inline

: set-bank ( mem bank vm -- )
   { fixnum UM32 } declare mem>> set-nth ;

: get-mem ( addr bank vm -- i )
    { fixnum fixnum UM32 } declare get-bank nth { fixnum } declare ; inline

: set-mem ( i addr bank vm -- )
    { fixnum fixnum UM32 } declare get-bank set-nth ;

: halt-vm ( vm reason -- vm ) >>error ;

: check-ip ( vm -- vm )
    8 over get-reg 0 pick get-bank length <
    [ "IP out of bounds" halt-vm ] unless ;

! Instruction decoding

: get-instruction ( addr vm -- instr )
    { fixnum UM32 } declare mem>> 0 swap nth-unsafe { array } declare nth-unsafe ; inline

: fetch ( vm -- vm instr )
    dup get-ip [ over get-instruction ] [ 1 fixnum+fast pick set-ip ] bi ;

: decode-opcode ( instr -- opcode ) { fixnum } declare -28 shift 4 bits ; inline

: decode-a ( instr -- a ) { fixnum } declare -6 shift 3 bits ; inline

: decode-b ( instr -- b ) { fixnum } declare -3 shift 3 bits ; inline

: decode-c ( instr -- c ) { fixnum } declare 3 bits ; inline

: decode-abc ( instr -- a b c )
    [ decode-a ] [ decode-b ] [ decode-c ] tri ; inline

: decode-ai ( instr -- a i )
    { fixnum } declare [ -25 shift 3 bits ] [ 25 bits ] bi ; inline

! Instruction dispatch

! Implements all math of the form: A <- B op C
:: op-math ( vm instr quot -- vm )
    instr decode-abc :> ( a b c )
    b vm get-reg
    c vm get-reg
    quot call
    a vm set-reg
    vm ; inline

:: op-cmov ( vm instr -- vm )  ! A <- B iff C!=0
    instr decode-c vm get-reg zero? [
        instr decode-b vm get-reg
        instr decode-a vm set-reg
    ] unless vm ;

:: op-load ( vm instr -- vm )  ! A <- $B:C
    instr decode-abc :> ( a b c )
    c vm get-reg
    b vm get-reg
    vm get-mem
    a vm set-reg
    vm ;

:: op-store ( vm instr -- vm )  ! $A:B <- C
    instr decode-abc :> ( a b c )
    c vm get-reg
    b vm get-reg
    a vm get-reg
    vm set-mem
    vm ;

: op-add ( vm instr -- vm ) [ fixnum+fast 32 bits ] op-math ;

: op-mul ( vm instr -- vm ) [ fixnum*fast 32 bits ] op-math ;

: op-div ( vm instr -- vm ) [ fixnum/i-fast 32 bits ] op-math ;

: op-nand ( vm instr -- vm ) [ fixnum-bitand fixnum-bitnot 32 bits ] op-math ;

: op-halt ( vm instr -- vm ) drop "halted" halt-vm ;

: free-bank ( vm -- bankid )
    { UM32 } declare
    dup freelist>> [ mem>> length ] [ nip pop ] if-empty ;

:: op-alloc ( vm instr -- vm ) ! B <- calloc(C)
    instr decode-c vm get-reg 0 <array>
    vm free-bank [ vm set-bank ] [ instr decode-b vm set-reg ] bi vm ;

:: op-free ( vm instr -- vm )  ! free(C)
    { } instr decode-c vm get-reg [ vm set-bank ] [ vm freelist>> push ] bi vm ;

: op-out ( vm instr -- vm )  ! putc(C)
    decode-c over get-reg write1 flush ;

: op-in ( vm instr -- vm )  ! C <- getc()
    decode-c read1 swap pick set-reg ;

:: op-exec ( vm instr -- vm )  ! $0 <- $B; IP <- C
    instr decode-b vm get-reg [ vm get-bank clone 0 vm set-bank ] unless-zero
    instr decode-c vm get-reg 8 vm set-reg vm ;

: op-literal ( vm instr -- vm )  ! A <- val
    decode-ai swap pick set-reg ;

: handle ( vm instr -- vm )
    dup decode-opcode {
        [ op-cmov ]
        [ op-load ]
        [ op-store ]
        [ op-add ]
        [ op-mul ]
        [ op-div ]
        [ op-nand ]
        [ op-halt ]
        [ op-alloc ]
        [ op-free ]
        [ op-out ]
        [ op-in ]
        [ op-exec ]
        [ op-literal ]
        [ drop "bad opcode" halt-vm ]
        [ drop "bad opcode" halt-vm ]
    } dispatch ;

! VM entry point

: run-um32 ( program -- vm )
    <UM32> [
        fetch handle check-ip { UM32 } declare
        [ 1 fixnum+fast ] change-clk dup error>> empty?
    ] loop ;

: run-um32-file ( filename -- vm )
    binary file-contents ube32 cast-array { } like run-um32 ;

: um32-main ( -- )
    ! Invoke as: factor um32.factor sandmark.umz
    command-line get first run-um32-file drop ;

MAIN: um32-main