diff --git a/wip-duuqnd/user-side-compiler/backend/code-generator.lisp b/wip-duuqnd/user-side-compiler/backend/code-generator.lisp index a3ba1a5..7d71241 100644 --- a/wip-duuqnd/user-side-compiler/backend/code-generator.lisp +++ b/wip-duuqnd/user-side-compiler/backend/code-generator.lisp @@ -68,6 +68,8 @@ (cons :address (+ (varvec-index (allocation-details data)) +varvec-offset+))) (:direct-to-argvec + (unless (= (count data (inputs (first (users data)))) 1) + (error "Tried to manually dereference reused function argument ~A." data)) (cons :address (+ (position data (inputs (first (users data)))) +argvec-offset+))) (:constant @@ -109,12 +111,19 @@ is the responsibility of the pre-assembly compilation step." (define-normal-emitter emit-cmp #xc9 #xc5 #xcd) (defun emit-store-data (data) - (if (or (eql (strategy (allocation-details data)) :not-saved) - (eql (strategy (allocation-details data)) :constant)) + (if (member (strategy (allocation-details data)) + '(:not-saved :constant :branch)) (setf *last-instruction* :useless) (progn (unless (eql (strategy (allocation-details data)) :accumulator) - (emit-sta (data-reference data))) + (if (and (eql (strategy (allocation-details data)) :direct-to-argvec) + (> (count data (inputs (first (users data)))) 1)) + (loop :with args := (inputs (first (users data))) + :for index := (position data args) + :then (position data args :start (1+ index)) + :until (null index) + :do (emit-sta (cons :address (+ index +argvec-offset+)))) + (emit-sta (data-reference data)))) (setf *last-instruction* (list :store data))))) (defun emit-store-bool (data) @@ -138,6 +147,8 @@ is the responsibility of the pre-assembly compilation step." ((eql (strategy (allocation-details data)) :accumulator) (assert (eql (next (definition data)) (last-use data))) (setf *last-instruction* :useless)) + ((eql (strategy (allocation-details data)) :branch) + (assert (typep (next (definition data)) 'ir-if))) ((eql (strategy (allocation-details data)) :direct-to-argvec) ;; TODO: Assert that it actually has been stored (setf *last-instruction* :useless)) @@ -205,9 +216,11 @@ is the responsibility of the pre-assembly compilation step." (defmethod compile-ir ((inst ir-call)) (loop :for arg :in (inputs inst) :for arg-index :from 0 - :do (emit-load-data arg) + :do (setf *last-instruction* :useless) :unless (eql (strategy (allocation-details arg)) :direct-to-argvec) - :do (emit-sta (cons :address (+ arg-index +argvec-offset+)))) + :do (emit-lda (data-reference arg)) + (emit-sta (cons :address (+ arg-index +argvec-offset+))) + (format t "~D. ~A~%" arg-index arg)) (emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 3) (emit-store-data (output inst))) @@ -216,8 +229,8 @@ is the responsibility of the pre-assembly compilation step." (first (destinations inst))) (emit-asm-instruction :opcode #x4C :operand (first (destinations inst)) - :byte-length 3)) - (setf *last-instruction* (list :jump (first (destinations inst))))) + :byte-length 3) + (setf *last-instruction* (list :jump (first (destinations inst)))))) (defmethod compile-ir ((inst ir-if)) (let ((next-iblock (next (iblock inst))) @@ -228,19 +241,50 @@ is the responsibility of the pre-assembly compilation step." ;; ensures that this assumption become false without us noticing. ;; We implicitly fall through to THEN-BLOCK in the event of no branch. (assert (eql next-iblock then-iblock)) - (emit-load-bool (input inst)) - (emit-asm-instruction :opcode #xD0 - :operand else-iblock - :byte-length 2) + (emit-load-data (input inst)) + (let ((prev-is-test-p (eql (strategy (allocation-details (input inst))) + :branch))) + (if prev-is-test-p + ;; If previous was a test, this instruction will be skipped if the + ;; test succeeds and we fall through to the THEN case. If it fails, + ;; this instruction executes, which jumps to the ELSE case. + (emit-asm-instruction :opcode #x4C + :operand else-iblock + :byte-length 3) + ;; If the input is a bool value, we have to actually do some work. + (progn + ;; BNE +3, if it's Not Equal (zero), then it's true, so we skip... + (emit-asm-instruction :opcode #xD0 :operand 3 :byte-length 2) + ;; ...the jump to the ELSE case. + (emit-asm-instruction :opcode #x4C + :operand else-iblock + :byte-length 3)))) (setf *last-instruction* :branch))) +(defun emit-branch-test-code (inputs output branch-opcode) + (let ((branchp (eql (strategy (allocation-details output)) :branch))) + (emit-load-data (first inputs)) + (unless branchp ; If we're *NOT* branching, we're storing a test result. + ;; LDX #1. This value will go into A if the test succeeds. + (emit-asm-instruction :opcode #xA2 :operand 1 :byte-length 2)) + (emit-cmp (data-reference (second inputs))) + ;; The actual branch instruction for our test. + (emit-asm-instruction :opcode branch-opcode :operand 3 :byte-length 2) + (unless branchp + ;; In the event of no branch -- we're storing the result -- we skip over + ;; an LDX #0 instruction if it succeeded, run if if the test failed. + (emit-asm-instruction :opcode #xA2 :operand 0 :byte-length 2) + ;; And a NOP since the skip is three bytes, since in the even of a branch + ;; it will be skipping over a whole JMP. + (emit-asm-instruction :opcode #xEA :byte-length 1) + ;; Then, regardless if we skipped or not, we put the result we have in X, + ;; either 0 or 1, into A by emitting a TXA. + (emit-asm-instruction :opcode #x8A :byte-length 1)) + ;; And regardless, we store the result, if applicable. + (emit-store-data output))) + (defmethod compile-ir ((inst ir-test-equal)) - (emit-load-data (first (inputs inst))) - (if (eql (strategy (allocation-details (second (inputs inst)))) - :constant) - (emit-cmp :immediate (ir-constant-value (second (inputs inst)))) - (emit-cmp :address (data-reference (second (inputs inst))))) - (emit-store-bool (output inst))) + (emit-branch-test-code (inputs inst) (output inst) #xF0)) (defmacro do-asm-objects ((asm-obj start-asm-obj) &body body) `(loop :for ,asm-obj := ,start-asm-obj :then (next ,asm-obj) @@ -277,8 +321,9 @@ is the responsibility of the pre-assembly compilation step." (when (typep (operand asm-obj) 'iblock) (resolve-iblock asm-obj)) ;; - 2 is to offset for the branch instruction's length - (let* ((offset (- (address (operand asm-obj)) (address asm-obj) 2))) - (setf (operand asm-obj) (ldb (byte 8 0) (the (signed-byte 8) offset))))) + (unless (typep (operand asm-obj) '(unsigned-byte 8)) + (let* ((offset (- (address (operand asm-obj)) (address asm-obj) 2))) + (setf (operand asm-obj) (ldb (byte 8 0) (the (signed-byte 8) offset)))))) (t (when (typep (operand asm-obj) 'iblock) (resolve-iblock asm-obj))