aoc2017-day5-asm.lisp

;;;; +----------------------------------------------------------------+
;;;; | Advent of Code 2017                                            |
;;;; +----------------------------------------------------------------+

;; Inspired by
;;
;; https://www.reddit.com/r/adventofcode/comments/7hngbn/2017_day_5_solutions/dqthchz/
;; https://www.pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/
;;
;; When developing this code I found a bug in SBCL's assembler, which
;; was apparently known to nyef in 2006, and has been there since at
;; the first SBCL commit (in 2000).  I came up with a fix for it
;; that's hopefully correct:
;;
;; https://gist.github.com/death/1a8c18943f4c6ff7b503899913ee5454

(defpackage #:snippets/aoc2017/day5-asm
  (:documentation "Day 5 on the breadboard.")
  (:use #:cl)
  (:import-from #:sb-assem
                #:inst
                #:make-segment
                #:assemble
                #:finalize-segment
                #:segment-contents-as-vector
                #:emit-byte)
  (:import-from #:sb-vm
                #:make-ea)
  (:import-from #:sb-ext
                #:defglobal)
  (:import-from #:sb-c
                #:move
                #:defknown
                #:any
                #:make-fixup)
  (:import-from #:sb-sys
                #:system-area-pointer
                #:vector-sap
                #:with-pinned-objects)
  (:import-from #:sb-disassem
                #:*disassem-location-column-width*
                #:disassemble-memory))

(in-package #:snippets/aoc2017/day5-asm)

(defglobal eax sb-vm::eax-tn)
(defglobal ebx sb-vm::ebx-tn)

(defglobal rax sb-vm::rax-tn)
(defglobal rbx sb-vm::rbx-tn)
(defglobal rcx sb-vm::rcx-tn)
(defglobal rdx sb-vm::rdx-tn)
(defglobal rsi sb-vm::rsi-tn)
(defglobal rdi sb-vm::rdi-tn)
(defglobal rbp sb-vm::rbp-tn)
(defglobal rsp sb-vm::rsp-tn)

(defglobal r8 sb-vm::r8-tn)
(defglobal r9 sb-vm::r9-tn)
(defglobal r10 sb-vm::r10-tn)
(defglobal r11 sb-vm::r11-tn)
(defglobal r12 sb-vm::r12-tn)
(defglobal r13 sb-vm::r13-tn)
(defglobal r14 sb-vm::r14-tn)
(defglobal r15 sb-vm::r15-tn)

(defmacro asm (&body forms)
  `(let ((seg (make-segment))
         (sb-c::*fixup-notes* nil))
     (assemble (seg)
       ,@forms)
     (finalize-segment seg)
     (segment-contents-as-vector seg)))

(defun coerce-to-octets (sequence)
  (make-array (length sequence)
              :element-type '(unsigned-byte 8)
              :initial-contents sequence))

(defun disasm (vector)
  (setf vector (coerce-to-octets vector))
  (with-pinned-objects (vector)
    (let ((*disassem-location-column-width* 0))
      (disassemble-memory (vector-sap vector) (length vector)))))

(defun gen (offsets)
  (asm
    (begin)
    (middle offsets)
    (end)))

(defun begin ()
  (assemble ()
    (inst push rbp)
    (inst mov rbp rsp)
    (inst push rbx)
    (inst push r12)
    (inst sub rsp #x10)
    (inst mov ebx 0)
    (inst push rbp)
    (inst jmp there)
    (end)
    there))

(defun end ()
  (inst pop r12)
  (inst mov eax ebx)
  (inst add rsp #x10)
  (inst pop r12)
  (inst pop rbx)
  (inst pop rbp)
  (inst ret)
  (loop repeat #x12 do (emit-byte sb-assem::**current-segment** #x00)))

(defun middle (offsets)
  (dolist (offset offsets)
    (assemble ()
      (inst add ebx 1)
      (inst pop r12)
      (inst mov eax (make-ea :dword :base r12 :disp -4))
      (inst add eax #x1F)
      (inst cmp eax #x5D)
      (inst jmp :l L0)
      (inst sub eax #x3E)
      L0
      (inst mov (make-ea :dword :base r12 :disp -4) eax)
      (inst call (make-fixup nil :code-object (* (- offset 1) 31))))))

(defknown %run (system-area-pointer) (unsigned-byte 64) (any)
  :overwrite-fndb-silently t)

(in-package #:sb-vm)

(define-vop (snippets/aoc2017/day5-asm::%run)
  (:translate snippets/aoc2017/day5-asm::%run)
  (:policy :fast-safe)
  (:args (code :scs (sap-reg) :target rdi))
  (:arg-types system-area-pointer)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-byte-64)
  (:temporary (:sc sap-reg :offset rax-offset :from :eval) rax)
  (:temporary (:sc sap-reg :offset rbx-offset :from :eval) rbx)
  (:temporary (:sc sap-reg :offset rcx-offset :from :eval) rcx)
  (:temporary (:sc sap-reg :offset rdx-offset :from :eval) rdx)
  (:temporary (:sc sap-reg :offset rdi-offset :from (:argument 0)) rdi)
  (:temporary (:sc sap-reg :offset rsi-offset :from :eval) rsi)
  (:ignore rax rbx rcx rdx rsi)
  (:generator 0
              (move rdi code)
              (inst call rdi)
              (move res rax-tn)))

(in-package #:snippets/aoc2017/day5-asm)

(defun run (code)
  (with-pinned-objects (code)
    (%run (vector-sap code))))

;; (run (gen '(0 3 0 1 -3))) => 10