(ql:quickload '(:concrete-syntax-tree :trucler-native
		:cleavir2-cst-to-ast :sicl-ast-to-hir
		:sicl-hir-to-mir :sicl-mir-to-lir))

(defun expression-to-lir (expression)
  (let* ((environment (sb-kernel:make-null-lexenv))
	 (client (make-instance 'trucler-native:client))
	 (cst (concrete-syntax-tree:cst-from-expression expression))
	 (ast (cleavir-cst-to-ast:cst-to-ast client cst environment))
	 (hir (sicl-ast-to-hir:ast-to-hir client ast))
	 (mir (sicl-hir-to-mir:hir-to-mir client hir)))
    (sicl-mir-to-lir:mir-to-lir client mir)
    mir))

(defvar *used-labels*)
(defvar *label-count*)

(defun new-label (object)
  (let* ((label-number (incf *label-count*))
	 (label-text (format nil "L~d" label-number)))
    (setf (gethash object *used-labels*) label-text)))

(defun print-lir (lir)
  (let ((*used-labels* (make-hash-table :test 'eq))
	(*label-count* 0)
	(*gensym-counter* 0))
    (write-instruction-chain lir)
    lir))

(defgeneric location-name (location)
  (:method ((location cleavir-ir:register-location))
    (cleavir-ir:name location))
  (:method ((immediate cleavir-ir:immediate-input))
    (prin1-to-string (cleavir-ir:value immediate)))
  (:method ((lexical cleavir-ir:lexical-location))
    (cleavir-ir:name lexical)))

(defun write-instruction-chain (instruction)
  (cond
    ((gethash instruction *used-labels*)
     (format t "~&goto ~a"
	     (gethash instruction *used-labels*)))
    (t
     (when (> (length (cleavir-ir:successors instruction)) 1)
       (format t "~&~a:" (new-label instruction)))
     ;; write-lir-instruction might write out the successors itself, and it
     ;; will return T if it has.
     (unless (write-lir-instruction instruction)
       (mapc #'write-instruction-chain (cleavir-ir:successors instruction))))))

(defgeneric write-lir-instruction (instruction)
  (:method ((instruction cleavir-ir:instruction))
    #-swank (print instruction)
    #+swank (swank::present-repl-results (list instruction))
    nil)
  (:method ((assignment cleavir-ir:assignment-instruction))
    (format t "~&mov ~a, ~a"
	    (location-name (first (cleavir-ir:inputs assignment)))
	    (location-name (first (cleavir-ir:outputs assignment)))))
  (:method ((memset cleavir-ir:memset1-instruction))
    (format t "~&mov [~a], ~a"
	    (location-name (first  (cleavir-ir:inputs memset)))
	    (location-name (second (cleavir-ir:inputs memset)))))
  (:method ((memref cleavir-ir:memref1-instruction))
    (format t "~&mov ~a, [~a]"
	    (location-name (first (cleavir-ir:outputs memref)))
	    (location-name (first (cleavir-ir:inputs memref)))))
  (:method ((sub cleavir-ir:unsigned-sub-instruction))
    (assert (eq (first (cleavir-ir:inputs sub))
		(first (cleavir-ir:outputs sub))))
    (format t "~&sub ~a, ~a"
	    (location-name (first  (cleavir-ir:inputs sub)))
	    (location-name (second (cleavir-ir:inputs sub)))))
  (:method ((add cleavir-ir:unsigned-add-instruction))
    (assert (eq (first (cleavir-ir:inputs add))
		(first (cleavir-ir:outputs add))))
    (format t "~&add ~a, ~a"
	    (location-name (first  (cleavir-ir:inputs add)))
	    (location-name (second (cleavir-ir:inputs add)))))
  (:method ((funcall cleavir-ir:funcall-instruction))
    (format t "~&FUNCALL ~a"
	    (location-name (first (cleavir-ir:inputs funcall)))))
  (:method ((nop cleavir-ir:nop-instruction))
    (format t "~&nop"))
  (:method ((less cleavir-ir:unsigned-less-instruction))
    (format t "~&cmp ~a, ~a"
	    (location-name (first (cleavir-ir:inputs less)))
	    (location-name (second (cleavir-ir:inputs less))))
    (let ((then (gensym "THEN"))
	  (else (gensym "ELSE")))
      (format t "~&jb ~a~&jmp ~a" then else)
      (format t "~&~a:" then)
      (write-instruction-chain (first (cleavir-ir:successors less)))
      (format t "~&~a:" else)
      (write-instruction-chain (second (cleavir-ir:successors less))))
    t))

#|
CL-USER> (print-lir (expression-to-lir '(+ 32 10)))
#<SICL-HIR-TRANSFORMATIONS:TOP-LEVEL-ENTER-INSTRUCTION {1003379FB3}>
mov RBP, R11
sub R11, 9
mov [R11], R12
mov RBP, R11
sub R11, 8
mov [R11], R11
mov R11, [RSP]
add RSP, 8
mov RBP, R12
sub R12, 8
mov [R12], R11
mov [R11], RDI
add R11, 8
mov [R11], RSI
add R11, 8
mov [R11], RDX
add R11, 8
mov [R11], RCX
add R11, 8
mov [R11], R8
add R11, 8
mov RBP, R13
sub R13, 8
L1:
cmp R12, R13
jb THEN0
jmp ELSE1
THEN0:
mov R14, [R12]
mov [R11], R14
add R11, 8
add R12, 8
goto L1 ; #<CLEAVIR-IR:UNSIGNED-LESS-INSTRUCTION {1003395FE3}>
ELSE1:
mov RBP, R11
sub R11, 8
mov R11, [R11]
add R11, 3
mov RBP, R11
sub R11, 10
mov [R11], R11
mov RBP, R11
sub R11, 10
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 11
mov [R11], R11
mov RBP, R11
sub R11, 11
mov R11, [R11]
add R11, 9
mov RBP, R11
sub R11, 12
mov [R11], R11
#<CLEAVIR-IR:SHIFT-LEFT-INSTRUCTION {1003392323}>
mov RBP, R11
sub R11, 13
mov [R11], R11
mov RBP, R11
sub R11, 12
mov R11, [R11]
mov RBP, R11
sub R11, 13
mov R12, [R11]
add R11, R12
mov RBP, R11
sub R11, 14
mov [R11], R11
mov RBP, R11
sub R11, 14
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 15
mov [R11], R11
mov 0, RAX
#<CLEAVIR-IR:SHIFT-LEFT-INSTRUCTION {10033A9653}>
mov RSP, R11
add R11, RAX
mov find-function-cell-function652, [R11]
mov RBP, R11
sub R11, 16
mov R11, [R11]
add R11, 3
mov RBP, R11
sub R11, 17
mov [R11], R11
mov RBP, R11
sub R11, 17
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 18
mov [R11], R11
#<CLEAVIR-IR:SHIFT-LEFT-INSTRUCTION {100338FB03}>
mov RBP, R11
sub R11, 19
mov [R11], R11
mov RBP, R11
sub R11, 18
mov R11, [R11]
mov RBP, R11
sub R11, 19
mov R12, [R11]
add R11, R12
mov RBP, R11
sub R11, 20
mov [R11], R11
mov RBP, R11
sub R11, 20
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 21
mov [R11], R11
mov RBP, R11
sub R11, 16
mov R11, [R11]
add R11, 3
mov RBP, R11
sub R11, 22
mov [R11], R11
mov RBP, R11
sub R11, 22
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 23
mov [R11], R11
#<CLEAVIR-IR:SHIFT-LEFT-INSTRUCTION {100338DC13}>
mov RBP, R11
sub R11, 24
mov [R11], R11
mov RBP, R11
sub R11, 23
mov R11, [R11]
mov RBP, R11
sub R11, 24
mov R12, [R11]
add R11, R12
mov RBP, R11
sub R11, 25
mov [R11], R11
mov RBP, R11
sub R11, 25
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 26
mov [R11], R11
mov G653, RDI
mov ENV, R10
mov topnh646, RBX
FUNCALL ENTRY
mov RAX, G651
nop
mov RBP, R11
sub R11, 27
mov R11, [R11]
sub R11, 1
mov RBP, R11
sub R11, 28
mov [R11], R11
mov RBP, R11
sub R11, 28
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 29
mov [R11], R11
mov 64, R11
mov RBP, R11
sub R11, 30
mov [R11], R11
mov 20, R11
mov RBP, R11
sub R11, 31
mov [R11], R11
mov RBP, R11
sub R11, 29
mov R11, [R11]
add R11, 3
mov RBP, R11
sub R11, 32
mov [R11], R11
mov RBP, R11
sub R11, 32
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 33
mov [R11], R11
#<CLEAVIR-IR:SHIFT-LEFT-INSTRUCTION {100338A6D3}>
mov RBP, R11
sub R11, 34
mov [R11], R11
mov RBP, R11
sub R11, 33
mov R11, [R11]
mov RBP, R11
sub R11, 34
mov R12, [R11]
add R11, R12
mov RBP, R11
sub R11, 35
mov [R11], R11
mov RBP, R11
sub R11, 35
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 36
mov [R11], R11
mov RBP, R11
sub R11, 29
mov R11, [R11]
add R11, 3
mov RBP, R11
sub R11, 37
mov [R11], R11
mov RBP, R11
sub R11, 37
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 38
mov [R11], R11
#<CLEAVIR-IR:SHIFT-LEFT-INSTRUCTION {10033887E3}>
mov RBP, R11
sub R11, 39
mov [R11], R11
mov RBP, R11
sub R11, 38
mov R11, [R11]
mov RBP, R11
sub R11, 39
mov R12, [R11]
add R11, R12
mov RBP, R11
sub R11, 40
mov [R11], R11
mov RBP, R11
sub R11, 40
mov R11, [R11]
mov R11, [R11]
mov RBP, R11
sub R11, 41
mov [R11], R11
mov G649, RDI
mov G650, RSI
mov ENV, R10
mov topnh646, RBX
FUNCALL ENTRY
mov RSP, R11
mov RBP, R8
sub R8, 8
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
sub R11, 8
sub R8, 8
mov RBX, [R11]
mov [R8], RBX
mov RBP, RSP
#<CLEAVIR-IR:RETURN-INSTRUCTION {100337A1C3}>
|#