(define-library (csc encoding)
  (export encode)
  (import (scheme base)
          (only (csc loop)
            loop
            return)
          (only (csc match) match))
  (begin
    ; I'm only going to say this once, so pay attention.
    ; The format of unboxed constants is described in bytecocde/src/data.rs.
    ; Boxed values are represented by a pointer to an array on the heap. The
    ; first position in the array is an integer code indicating what type the
    ; object is. Vectors have code 0, codes for other types are not stable.
    ; Vectors are represented as an array, the first element of which is the
    ; integer 0 (the type code), the second element is the vector length, and
    ; the remaining slots hold the array values.


    (define (low-byte w n)
      (write-u8 (remainder n #x100) w))


    (define (64->le-bytes w n)
      (low-byte w n)
      (low-byte w (quotient n #x100))
      (low-byte w (quotient n #x10000))
      (low-byte w (quotient n #x1000000))
      (low-byte w (quotient n #x100000000))
      (low-byte w (quotient n #x10000000000))
      (low-byte w (quotient n #x1000000000000))
      (low-byte w (quotient n #x100000000000000)))


    ; Bitwise-negates a 63-bit unsigned integer.
    (define (bitwise-not n)
      (loop with n* = 0
            for i from 1 to 63
            for n = n then (quotient n 2)
            for digit = 1 then (* 2 digit)
            if (even? n)
              do (set! n* (+ n* digit))
            finally (return n*)))


    (define (int->le-bytes w n)
      (when (or (>= n #x4000000000000000)
                (< n #x-4000000000000000))
        (error "int constant too large" n))
      (when (negative? n)
        (set! n (remainder
                  (+ 1 (bitwise-not (- n)))
                  #x8000000000000000)))
      (64->le-bytes w (+ 1 (* 2 n))))


    (define (bool->le-bytes w b)
      (if b
        (64->le-bytes w #xa)
        (64->le-bytes w #x2)))


    (define (const->le-bytes w x)
      (cond
        ((integer? x)
          (int->le-bytes w x))
        ((boolean? x)
          (bool->le-bytes w x))
        ((null? x)
          (64->le-bytes w #x12))
        (else (error "unexpected type in const->le-bytes" x))))


    (define (make-opcode w code arg1-const arg2-const)
      (when (>= code #x40)
        (error "code is more than 6 bits" code))
      (define arg1-bit (if arg1-const
                         2
                         0))
      (define arg2-bit (if arg2-const
                         1
                         0))
      (write-u8 (+ (* 4 code) arg1-bit arg2-bit) w))


    (define (arg->le-bytes w atom)
      (match atom 
        (('const val) (const->le-bytes w val))
        (('local i)
          (when (>= i #x100)
            (error "local index is out of range" i))
          (write-u8 i w))
        (_ (error "unexpected form in arg->le-bytes" atom))))


    (define (is-const? atom)
      (match atom
        (('const _) #t)
        (_ #f)))


    (define (opcode-switch w opcode)
      (match opcode
        (('mov dest src)
          (make-opcode w 0 (is-const? src) #f)
          (arg->le-bytes w dest)
          (arg->le-bytes w src))
        (('jmpif test dest)
          (make-opcode w 1 (is-const? test) (is-const? dest))
          (arg->le-bytes w test)
          (arg->le-bytes w dest))
        (('jmp dest)
          (make-opcode w 2 (is-const? dest) #f)
          (arg->le-bytes w dest))
        (('alloc dest size)
          (make-opcode w 3 (is-const? size) #f)
          (arg->le-bytes w dest)
          (arg->le-bytes w size))
        (('peek dest ptr offset)
          (make-opcode w 4 (is-const? ptr) (is-const? offset))  ; ptr will likely never be constant.
          (arg->le-bytes w dest)
          (arg->le-bytes w ptr)
          (arg->le-bytes w offset))
        (('poke word ('local ptr) offset)
          ; We only have 2 bits to store whether the arguments are const, but
          ; it's actually true that a pointer can never be a constant. So we
          ; only track whether the word and offset arguments are constant, and
          ; assume ptr will always be a one-byte register name.
          (make-opcode w 5 (is-const? word) (is-const? offset))
          (arg->le-bytes w word)
          (arg->le-bytes w (list 'local ptr))
          (arg->le-bytes w offset))
        (('add dest x y)
          (make-opcode w 6 (is-const? x) (is-const? y))
          (arg->le-bytes w dest)
          (arg->le-bytes w x)
          (arg->le-bytes w y))
        (('sub dest x y)
          (make-opcode w 7 (is-const? x) (is-const? y))
          (arg->le-bytes w dest)
          (arg->le-bytes w x)
          (arg->le-bytes w y))
        (('mul dest x y)
          (make-opcode w 8 (is-const? x) (is-const? y))
          (arg->le-bytes w dest)
          (arg->le-bytes w x)
          (arg->le-bytes w y))
        (('div dest x y)
          (make-opcode w 9 (is-const? x) (is-const? y))
          (arg->le-bytes w dest)
          (arg->le-bytes w x)
          (arg->le-bytes w y))
        (('mod dest x y)
          (make-opcode w 10 (is-const? x) (is-const? y))
          (arg->le-bytes w dest)
          (arg->le-bytes w x)
          (arg->le-bytes w y))
        (('peekbyte dest ptr offset)
          (make-opcode w 11 (is-const? ptr) (is-const? offset))
          (arg->le-bytes w dest)
          (arg->le-bytes w ptr)
          (arg->le-bytes w offset))
        (('pokebyte word ('local ptr) offset)
          (make-opcode w 12 (is-const? word) (is-const? offset))
          (arg->le-bytes w word)
          (arg->le-bytes w (list 'local ptr))
          (arg->le-bytes w offset))
        (('exit)
          (make-opcode w 13 #f #f))
        (_ (error "invalid opcode" opcode))))


    (define (encode program)
      (define out (open-output-bytevector))
      (map (lambda (op) (opcode-switch out op)) program)
      (get-output-bytevector out))))