structure W32 = Word32
structure A = Array

infix 5 << >> ~>>
structure SC = StringCvt

val zpad = SC.padLeft #"0"
val trace = ref false

val i2s = Int.toString
fun w2s w = "0wx"^zpad 8 (W32.toString w)



datatype operator =
         CMove  of reg * reg * reg
       | ARead  of reg * reg * reg
       | AWrite of reg * reg * reg
       | Add    of reg * reg * reg
       | Mult   of reg * reg * reg
       | Div    of reg * reg * reg
       | NAnd   of reg * reg * reg
       | Halt
       | Alloc  of {size : reg, result : reg}
       | Free   of reg
       | Output of reg
       | Input  of reg
       | Load   of {src : reg, offset : reg}
       | Const  of reg * word
withtype reg = int

fun o2s opr =
    case opr of
        CMove(A,B,C) => "CMOVE A="^i2s A^" B="^i2s B^" C="^i2s C
      | ARead(A,B,C) => "AREAD A="^i2s A^" B="^i2s B^" C="^i2s C
      | AWrite(A,B,C) => "AWrite A="^i2s A^" B="^i2s B^" C="^i2s C
      | Add(A,B,C) => "ADD A="^i2s A^" B="^i2s B^" C="^i2s C
      | Mult(A,B,C) => "MULT A="^i2s A^" B="^i2s B^" C="^i2s C
      | Div(A,B,C) => "DIV A="^i2s A^" B="^i2s B^" C="^i2s C
      | NAnd(A,B,C) => "NAND A="^i2s A^" B="^i2s B^" C="^i2s C
      | Halt => "HALT"
      | Alloc{size, result} => "Alloc size="^i2s size^" res="^i2s result
      | Free A => "FREE A="^i2s A
      | Output C => "OUTPUT C="^i2s C  
      | Input C => "INPUT C="^i2s C  
      | Load{src, offset} => "LOAD src="^i2s src^" off="^i2s offset
      | Const(A,value) => "CONST A="^i2s A^" val="^w2s value

fun standardRegs w =
    let open Word32
        val A = (w << 0w23) >> 0w29
        val B = (w << 0w26) >> 0w29
        val C = andb(w, 0w7)
    in (toInt A, toInt B, toInt C)
    end

fun decode w =
    let open Word32
        val opr = w >> 0w28
    in case opr of
           0w0  => CMove(standardRegs w)
         | 0w1  => ARead(standardRegs w)
         | 0w2  => AWrite(standardRegs w)
         | 0w3  => Add(standardRegs w)
         | 0w4  => Mult(standardRegs w) 
         | 0w5  => Div(standardRegs w)
         | 0w6  => NAnd(standardRegs w)
         | 0w7  => Halt
         | 0w8  => let val (_,B,C) = standardRegs w
                   in  Alloc{size = C, result = B}
                   end
         | 0w9  => let val (_,_,C) = standardRegs w
                   in  Free C
                   end
         | 0w10 => let val (_,_,C) = standardRegs w
                   in  Output C
                   end
         | 0w11 => let val (_,_,C) = standardRegs w
                   in  Input C
                   end
         | 0w12 => let val (_,B,C) = standardRegs w
                   in  Load{src = B, offset = C}
                   end
         | 0w13 => let val A = toInt((w << 0w4) >> 0w29)
                       val value = (w << 0w7) >> 0w7
                   in Const(A, value)
                   end
         | _ => raise Fail ("Decode error operator="^i2s(toInt opr))
    end    

fun decodeTrace (i, w) =
    ( print (o2s (decode w)
             handle Fail msg => "ERROR instr no "^i2s i^" "^msg)
    ; print ( " w = "^w2s w^" ("^zpad 32 (W32.fmt SC.BIN w)^")\n")
    ; decode w 
    )


fun blockToWord block =
    let open Word32
        fun w8ToW32 w = fromInt(Word8.toInt w)
    in  Word8Vector.foldl (fn(w,res) => (res << 0w8) + w8ToW32 w) 0w0 block
    end 

fun readFile filename =
    let val dev = BinIO.openIn filename
        fun loop acc =
            let val block = BinIO.inputN(dev, 4) 
            in  if  Word8Vector.length block <> 4 then
                    Vector.mapi decodeTrace (Vector.fromList(rev acc))
                else loop (blockToWord block :: acc)
            end
    in  loop [] before BinIO.closeIn dev
    end

fun readFilePack filename =
    let val dev = BinIO.openIn filename
        val all = BinIO.inputAll dev before BinIO.closeIn dev
        val words = A.tabulate(Word8Vector.length all div 4, 
                                    fn i => W32.fromLargeWord(PackWord32Big.subVec(all,i)))
    in  words
    end

infix 9 sub 
infix <-
val op sub = A.sub

fun interp prog =
    let val regs = A.array(8, 0w0)
        fun $ reg = regs sub reg
        fun reg <- x = A.update(regs, reg, x)
                    
        val finger = ref 0
        val prog = ref prog
        fun spin () = let val w = !prog sub (!finger)
                      in  finger := !finger + 1
                        ; w
                      end
        fun load arr =
            prog := A.tabulate(A.length arr, fn i => arr sub i)


        val null = A.array(0, 0w0)
        val arrays = ref(A.array(16, null))
        val freelist = ref(List.tabulate(15, fn i => W32.fromInt(i+1)))
        fun $$ reg = if $reg = 0w0 then !prog 
                     else !arrays sub (W32.toInt($reg))
        fun next () =
            case !freelist of
                [] =>
                let val current = A.length(!arrays)
                    val new = A.array(current * 2, null)
                in  freelist := List.tabulate(current - 1,
                                           fn i => W32.fromInt(i+current+1))
                  ; A.copy{src = !arrays, dst = new, di = 0}
                  ; arrays := new
                  ; W32.fromInt current
                end
              | w :: ws => ( freelist := ws
                           ; w
                           ) 
        fun alloc size =
            let val new = A.array(size, 0w0)
                val id  = next()
            in  A.update(!arrays, W32.toInt id, new)
              ; id
            end
        fun free id = ( A.update(!arrays, W32.toInt id, null)
                      ; freelist := id :: !freelist
                      )
                      
        exception STOP

    in  (while true do
             case decode(spin()) of
                 CMove(A,B,C) => if $C = 0w0 then ()
                                 else A <- $B
               | ARead(A,B,C) => A <- $$B sub (W32.toInt($C))
               | AWrite(A,B,C) => A.update($$A, W32.toInt($B), $C)
               | Add(A,B,C) => A <- $B + $C
               | Mult(A,B,C) => A <- $B * $C
               | Div(A,B,C) => A <- $B div $C
               | NAnd(A,B,C) => A <- W32.notb(W32.andb($B, $C))
               | Halt => raise STOP
               | Alloc{size, result} => result <- alloc (W32.toInt($size))
               | Free A => free ($A)
               | Output C => ( TextIO.output1(TextIO.stdOut, 
                                              Char.chr(W32.toInt($C)))
                             ; TextIO.flushOut TextIO.stdOut
                             )
               | Input C => C <- (case TextIO.input1 TextIO.stdIn of
                                      SOME c => W32.fromInt(Char.ord c)
                                    | NONE   => 0wxFFFFFFFF) 
               | Load{src, offset} => ( if $src = 0w0 then ()
                                        else load($$src)
                                      ; finger := W32.toInt($offset)
                                      ) 
               | Const(A,value) => A <- value)
        handle STOP => ()
             | ?? => ( A.appi (fn(i,w) => 
                                  print("reg["^i2s i^"] = "^w2s w^"\n")) 
                                  regs
                     ; raise ??)
    end


val _ = let val args = CommandLine.arguments()
        in  if length args > 1 then trace := true else ();
            interp (readFilePack (hd(args)))
        end