;;; -*- Mode:Lisp; Package:(NC LISP); Readtable:CL; Base:10 -*- ;;;; Hardware Primops ;;; See the file PRIMITIVES (define-primop hw:nop () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:NOP) ''NIL)) (define-primop hw:memory-wait () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:MEMORY-WAIT) ''NIL)) ;;; compiler internal ;;; (hw: ...) expands into this (define-primop read-functional-source (fsource) (:generate (node) (leaf-value (call-arg-n 2 node)))) ;;; Magic functional source (define-primop hw:read-md () (:side-effects? t) (:generate (node) (let ((dest (get-destination (call-arg-n 1 node)))) (if (eql dest IGNORED) (progn (emit 'K:MOVE dest 'K:MD) dest) 'K:MD)))) (define-primop hw:trap-off () (:side-effects? t) (:generate (node) (let ((dest (get-destination (call-arg-n 1 node)))) (if (eql dest IGNORED) (progn (emit 'K:MOVE dest 'K:TRAP-OFF) dest) 'K:TRAP-OFF)))) ;;; compiler internal ;;; (hw: ...) expands into this (define-primop write-functional-dest (fdest value) (:side-effects? t) (:generate (node) (let ((fdest (leaf-value (call-arg-n 2 node))) (value (call-arg-n 3 node))) (generate-move value fdest) (if (register-p fdest) fdest ''NIL)))) ;;; This does not use write-functional-dest because ;;; it has to be done twice and a temp holding the value ;;; could get allocated to MEMORY-MAP then the second ;;; move would not get generated. (define-primop hw:write-map (value) (:side-effects? t) (:generate (node) (let ((ref (get-right-operand (call-arg-n 2 node)))) (emit 'K:MOVE 'K:MEMORY-MAP ref 'K:UNBOXED) (emit 'K:MOVE 'K:MEMORY-MAP ref 'K:UNBOXED) ref))) ;;; This does not use write-functional-dest because ;;; it has to be done twice and a temp holding the value ;;; could get allocated to GC-RAM then the second ;;; move would not get generated. (define-primop hw:write-gc-ram (value) (:side-effects? t) (:generate (node) (let ((ref (get-right-operand (call-arg-n 2 node)))) (emit 'K:MOVE 'K:GC-RAM ref 'K:UNBOXED) (emit 'K:MOVE 'K:GC-RAM ref 'K:UNBOXED) ref))) ;;; This does not use write-functional-dest because ;;; it has to be done twice and a temp holding the value ;;; could get allocated to TRANSPORTER-RAM then the second ;;; mofe would not get generated. (define-primop hw:write-transporter-ram (value) (:side-effects? t) (:generate (node) (let ((ref (get-right-operand (call-arg-n 2 node)))) (emit 'K:MOVE 'K:TRANSPORTER-RAM ref 'K:UNBOXED) (emit 'K:MOVE 'K:TRANSPORTER-RAM ref 'K:UNBOXED) ref))) (define-primop hw:dpb (value byte-spec word) (:simplify (node) (simplify-if-constant-expression node 'nlisp::dpb)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word)))) (define-primop hw:dpb-xor (value byte-spec word) ;; This is broken. ; (:simplify (node) ; (simplify-if-constant-expression node 'nlisp::dpb)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word 'K:DT-NONE 'K:BOXED-RIGHT 'K:FIELD-XOR)))) (define-primop hw:dpb-ior (value byte-spec word) ;; This is broken. ; (:simplify (node) ; (simplify-if-constant-expression node 'nlisp::dpb)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word 'K:DT-NONE 'K:BOXED-RIGHT 'K:FIELD-OR)))) (define-primop hw:dpb-aligned (value byte-spec word) ;; This is broken. ; (:simplify (node) ; (simplify-if-constant-expression node 'nlisp::dpb)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word 'K:DT-NONE 'K:BOXED-RIGHT 'K:ALIGNED-FIELD-PASS-LEFT)))) (define-primop hw:dpb-and-unboxed (value byte-spec word) ;; This is broken. ; (:simplify (node) ; (simplify-if-constant-expression node 'nlisp::dpb)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word 'K:DT-NONE 'K:UNBOXED 'K:FIELD-AND)))) ;;; This is some stuff to do compile time arithmetic ;;; on unboxed constants (defun get-integer (n) (cond ((integerp n) n) ((and (consp n) (eq (car n) 'hw:unboxed-constant)) (cadr n)) (t (error "Some primitive was given a non integer: ~s" n)))) (defmacro unboxed-fcn (fcn &rest args) ``(hw:unboxed-constant ,(,fcn . ,(mapcar #'(lambda (arg) `(GET-INTEGER ,arg)) args)))) (defun hw-dpb-unboxed (value byte-spec word) `(hw:unboxed-constant ,(nlisp:dpb (get-integer value) byte-spec (get-integer word)))) (define-primop hw:dpb-unboxed (value byte-spec word) (:simplify (node) (simplify-if-constant-expression node 'hw-dpb-unboxed)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word 'K:DT-NONE 'K:UNBOXED)))) (defun hw-dpb-boxed (from byte-spec into) `(hw:boxed-constant ,(nlisp::dpb from byte-spec into))) (define-primop hw::dpb-boxed (value byte-spec word) (:simplify (node) (simplify-if-constant-expression node 'hw-dpb-boxed)) (:generate (node) (destructure (((cont value byte-spec word) (call-args node))) (generate-dpb cont value byte-spec word 'K:DT-NONE 'K:BOXED)))) (defun hw-ldb (from byte-spec into) (nlisp::dpb (nlisp::ldb byte-spec from) (prims::byte (prims::byte-size byte-spec) 0) into)) (define-primop hw:ldb (from byte-spec into) (:simplify (node) (simplify-if-constant-expression node 'hw-ldb)) (:generate (node) (destructure (((cont from byte-spec into) (call-args node))) (generate-ldb cont from byte-spec into)))) (defun hw-ldb-boxed (from byte-spec into) `(hw:boxed-constant ,(hw-ldb from byte-spec into))) (define-primop hw:ldb-boxed (from byte-spec into) (:simplify (node) (simplify-if-constant-expression node 'hw-ldb-boxed)) (:generate (node) (destructure (((cont from byte-spec into) (call-args node))) (generate-ldb cont from byte-spec into 'K:DT-NONE 'K:BOXED)))) (defun hw-ldb-not (from byte-spec into) (nlisp::dpb (lognot (nlisp::ldb byte-spec from)) (prims::byte (prims::byte-size byte-spec) 0) into)) (define-primop hw::ldb-not (from byte-spec into) (:simplify (node) (simplify-if-constant-expression node 'hw-ldb-not)) (:generate (node) (destructure (((cont from byte-spec into) (call-args node))) (generate-ldb cont from byte-spec into 'K:DT-NONE 'K:BOXED-RIGHT 'K:FIELD-NOT)))) (define-primop hw::field-extract-64 (from-hi from-lo byte-spec) (:generate (node) (destructure (((cont from-hi from-lo byte-spec) (call-args node))) (generate-ldb cont from-hi byte-spec from-lo 'K:DT-NONE 'K:UNBOXED 'K:FIELD-EXTRACT-LR)))) (define-primop hw::merge-24 (left-high-byte right-low-24) ;;||| Written by 10/13/88 --wkf ;;Useful for making fixnums from unboxed 24 data; Sets Zero and Negative bits of alu-status accordingly. (:generate (node) (generate-binop node 'K:MERGE-R 'K:MERGE-R 'K:BW-24 'K:BOXED))) (define-primop hw:32logbitp (index n) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (let ((index (call-arg-n 4 node)) (n (call-arg-n 5 node))) (if (literal-node? index) (emit-alu-field 'K:EXTRACT-BIT-RIGHT 'K:NOP IGNORED (get-right-operand n) `(PRIMS::BYTE 0 ,(leaf-value index)) 'K:PW-II) (progn (generate-load-sr-position index) (emit-alu-field 'K:EXTRACT-BIT-RIGHT 'K:NOP IGNORED (get-right-operand n) ''0 'K:PW-RR))) (generate-conditional node 'K:BR-ZERO)))) (define-primop hw::alu-status-logbitp (index) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (let ((index (call-arg-n 4 node))) (if (literal-node? index) (emit-alu-field 'K:EXTRACT-BIT-STATUS 'K:NOP IGNORED 'GR::*ZERO* `(PRIMS::BYTE 0 ,(leaf-value index)) 'K:PW-II) (progn (error "Argh, logbitp non constant from status. Fix me."))) ; (emit-alu 'K:LOAD-STATUS-R 'K:NOP ; IGNORED (get-right-operand index) '(K:BW-8)) ; (emit-alu-field 'K:EXTRACT-BIT-RIGHT 'K:NOP ; IGNORED (get-right-operand n) ; ''0 ; 'K:PW-RR))) (generate-conditional node 'K:BR-ZERO)))) (define-primop hw::32set-bit (index word) (:generate (node) (destructure (((cont index word) (call-args node))) ;; not good enough (let ((dest (get-destination cont))) (if (literal-node? index) (emit-alu-field 'K:SET-BIT-RIGHT dest IGNORED (get-right-operand word) `(PRIMS::BYTE 0 ,(leaf-value index)) 'K:PW-II) (progn (generate-load-sr-position index) (emit-alu-field 'K:SET-BIT-RIGHT dest IGNORED (get-right-operand word) ''0 'K:PW-RR))) dest)))) (define-primop hw::32clear-bit (index word) (:generate (node) (destructure (((cont index word) (call-args node))) ;; not good enough (let ((dest (get-destination cont))) (if (literal-node? index) (emit-alu-field 'K:RESET-BIT-RIGHT dest IGNORED (get-right-operand word) `(PRIMS::BYTE 0 ,(leaf-value index)) 'K:PW-II) (progn (generate-load-sr-position index) (emit-alu-field 'K:RESET-BIT-RIGHT dest IGNORED (get-right-operand word) ''0 'K:PW-RR))) dest)))) (define-primop hw:field-extract (from byte-spec) (:generate (node) (destructure (((cont from byte-spec) (call-args node))) (multiple-value-bind (dest right) (get-dest-and-right-operand cont from) (if (literal-node? byte-spec) (emit-alu-field 'K:FIELD-extract-r dest IGNORED right (let ((byte-spec (leaf-value byte-spec))) `(PRIMS:BYTE ,(prims:byte-size byte-spec) ,(- (prims:byte-position byte-spec)))) 'K:PW-II) (error "non constant field-extract not yet implemented")) dest)))) ;;; Do a tail open (define-primop hw:ch-topen () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:TAIL-OPEN) ''NIL)) ;;; Have the call hardware do a tail call operation ;;; without really calling (define-primop hw:ch-tcall () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:TAIL-CALL '(0 0) 'K:NEXT-PC-PC+1) ''NIL)) (define-primop hw::ch-return () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:NOP 'K:CH-RETURN) ''NIL)) (define-primop hw::ch-return-one-value () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:MOVE 'K::RETURN 'K:R0 'K:CH-RETURN) ''NIL)) (define-primop hw::ch-return-multiple-values () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:MOVE 'K:RETURN-MV 'K:R0 'K:CH-RETURN) ''NIL)) (define-primop hw::ch-topen-call () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:TAIL-OPEN-CALL '(0 0) nil 'K:NEXT-PC-PC+1) ''NIL)) ;;; Have the call hardware do an open-call operation ;;; without transferring control. (define-primop hw::ch-open-call (&optional dest) (:side-effects? t) (:generate (node) (let ((call-dest (call-arg-n 2 node))) (emit 'K:OPEN-CALL '(0 0) (if call-dest (get-left-operand call-dest) IGNORED) NIL 'K:NEXT-PC-PC+1) ''NIL))) (define-primop hw::open-frame () (:side-effects? t) (:generate (node) (declare (ignore node)) (emit 'K:OPEN) ''NIL)) (define-primop hw::call (fcn nargs) (:side-effects? t) (:generate (node) (destructure (((cont fcn nargs) (call-args node))) (let ((dest (get-destination cont))) (emit 'K:CALL (list (literal-value fcn) (literal-value nargs)) dest) dest)))) ;;; dispatch to a computed value (define-primop hw:dispatch (pc) (:side-effects? t) (:generate (node) (generate-move (call-arg-n 2 node) 'K:NOP) (emit 'K:NOP) (emit 'K:NOP 'K:NEXT-PC-DISPATCH) ''NIL)) (define-primop hw:tail-call-dispatch (pc) (:side-effects? t) (:generate (node) (generate-move (call-arg-n 2 node) 'K:NOP) (emit 'K:NOP) (emit 'K:NOP 'K:NEXT-PC-DISPATCH 'K:CH-TAIL-CALL) ''NIL)) (define-primop hw:jump (fcn) (:side-effects? t) (:special? t) ;no continuation (:generate (node) (emit 'K:JUMP (leaf-value (call-arg-n 2 node))))) ;;; This is used to implement a simple subroutine call mechanism ;;; without changing the call hardware. ;;; BUG: The compiler doesn't seem to realize that the code at the target PC ;;; can modify the environment and then return here. It will optimize code ;;; after the HW:JUMP-SAVING-PC as if this had no side effects. (define-primop hw:jump-saving-pc (target &optional (pc-place gr:*return-pc-1*)) (:side-effects? t) (:generate (node) (let ((pc-place (call-arg-n 3 node))) (unless pc-place (setq pc-place 'gr:*return-pc-1*)) (generate-move 'K:TRAP-PC+ pc-place) (emit 'K:JUMP (leaf-value (call-arg-n 2 node)))))) ;;; I can't imagine what you might use this for. (define-primop hw:return (value) (:side-effects? t) (:special? t) (:generate (node) (emit 'K:RETURN (get-right-operand (call-arg-n 2 node))))) ;;; Use this if you are setting up the return registers yourself ;;; Don't forget to set *number-of-return-values* (define-primop hw:return-mv (value) (:side-effects? t) (:special? t) (:generate (node) (emit 'K:RETURN-MV (get-right-operand (call-arg-n 2 node))))) (define-primop hw:return-tail (value) (:side-effects? t) (:special? t) (:generate (node) (emit 'K:RETURN-TAIL (get-right-operand (call-arg-n 2 node))))) ;(define-primop hw:unboxed-constant (number) ; (:generate (node) ; (let ((n (call-arg-n 2 node))) ; (if (and (literal-node? n) ; (integerp (leaf-value n))) ; (emit 'K:MOVEI (get-destination (call-arg-n 1 node)) (cons '/# (leaf-value n)) 'K:UNBOXED) ; (error "Argument to HW:UNBOXED-CONSTANT: ~s should be an integer." (leaf-value n)))))) (define-primop hw:32zerop (number) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (generate-arith-predicate node 'K:BR-NOT-ZERO))) ;;; Actually this is the same as eq? (define-primop hw:32= (n1 n2) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (comparator node 'K:BR-NOT-EQUAL 'K:BW-32))) (define-primop hw::32> (n1 n2) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (comparator node 'k:BR-NOT-GREATER-THAN 'K:BW-32))) (define-primop hw::32< (n1 n2) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (comparator node 'k:BR-NOT-LESS-THAN 'K:BW-32))) (define-primop hw:32>= (n1 n2) (:generate (node) (comparator node 'K:BR-NOT-GREATER-OR-EQUAL 'K:BW-32)) (:presimplify (node) (presimplify-to-conditional node)) (:conditional? t)) (define-primop hw:32<= (n1 n2) (:generate (node) (comparator node 'K:BR-NOT-LESS-OR-EQUAL 'K:BW-32)) (:presimplify (node) (presimplify-to-conditional node)) (:conditional? t)) (defun hw-32logand (n1 n2) (unboxed-fcn logand n1 n2)) (define-primop hw:32logand (n1 n2) (:simplify (node) (simplify-if-constant-expression node 'hw-32logand)) (:generate (node) (generate-binop node 'K:AND 'K:AND 'K:BW-32))) (defun hw-32logxor (n1 n2) (unboxed-fcn logxor n1 n2)) (define-primop hw:32logxor (n1 n2) (:simplify (node) (simplify-if-constant-expression node 'logxor)) (:generate (node) (generate-binop node 'K:XOR 'K:XOR 'K:BW-32))) (defun hw-32logior (n1 n2) (unboxed-fcn logior n1 n2)) (define-primop hw:32logior (n1 n2) (:simplify (node) (simplify-if-constant-expression node 'hw-32logior)) (:generate (node) (generate-binop node 'K:OR 'K:OR 'K:BW-32))) (define-primop hw:32-1+ (n) ; (:simplify (node) ; (simplify-if-constant-expression node '1+)) (:generate (node) (generate-unop node 'K:R+1 'K:BW-32))) (define-primop hw:32-2+ (n) ; (:simplify (node) ; (simplify-if-constant-expression node '1+)) (:generate (node) (generate-unop node 'K:R+2 'K:BW-32))) (define-primop hw:32-4+ (n) ; (:simplify (node) ; (simplify-if-constant-expression node '1+)) (:generate (node) (generate-unop node 'K:R+4 'K:BW-32))) (define-primop hw:32-1- (n) ; (:simplify (node) ; (simplify-if-constant-expression node '1-)) (:generate (node) (generate-unop node 'K:R-1 'K:BW-32))) (define-primop hw:32-2- (n) ; (:simplify (node) ; (simplify-if-constant-expression node '1+)) (:generate (node) (generate-unop node 'K:R-2 'K:BW-32))) (define-primop hw:32-4- (n) ; (:simplify (node) ; (simplify-if-constant-expression node '1+)) (:generate (node) (generate-unop node 'K:R-4 'K:BW-32))) (define-primop hw:accumulate-box-bits (n1 n2) (:generate (node) (let ((dest (get-destination (cont node)))) ;; the destination of this instruction can't be the MD ;; (or VMA which we aren't doing) ;; because BOXED-RIGHT needs to be set (if (MD-p dest) (multiple-value-bind (l r) (get-operands (call-arg-n 2 node) (call-arg-n 3 node)) (emit-alu 'K:SHIFT-UP-LF-L R0 l r '(K:BW-24 K:CARRY-1 K:BOXED-RIGHT)) (generate-move R0 dest) dest) (generate-binop node 'K:SHIFT-UP-LF-L 'K:SHIFT-UP-LF-L 'K:BW-24 'K:CARRY-1 'K:BOXED-RIGHT))))) (define-primop hw:32+ (n1 n2) (:generate (node) (generate-binop node 'K:L+R 'K:L+R))) (define-primop hw:32- (n1 n2) (:generate (node) (generate-binop node 'K:L-R 'K:R-L))) (define-primop hw:8+ (n1 n2) (:generate (node) (generate-binop node 'K:L+R 'K:L+R 'K:BW-8 'K:BOXED-RIGHT))) (define-primop hw:8-1+ (n) (:generate (node) (generate-unop node 'K:R+1 'K:BW-8 'K:BOXED-RIGHT))) (define-primop hw:8-1- (n) (:generate (node) (generate-unop node 'K:R-1 'K:BW-8 'K:BOXED-RIGHT))) (define-primop hw:24-1+ (n) (:generate (node) (generate-unop node 'K:R+1 'K:BW-24 'K:BOXED-RIGHT))) (define-primop hw:24-1- (n) (:generate (node) (generate-unop node 'K:R-1 'K:BW-24 'K:BOXED-RIGHT))) (define-primop hw:8- (n1 n2) (:generate (node) (generate-binop node 'K:L-R 'K:R-L 'K:BW-8 'K:BOXED-RIGHT))) (define-primop hw:left+right+1-bw24 (n1 n2) (:generate (node) (generate-binop node 'K:L+R+C 'K:L+R+C 'K:BW-24 'k:CARRY-1 'K:BOXED-RIGHT))) (define-primop hw:left+right+1-bw32 (n1 n2) (:generate (node) (generate-binop node 'K:L+R+C 'K:L+R+C 'K:BW-32 'K:CARRY-1 'K:UNBOXED))) (define-primop hw:32logical-shift-up (n nbits) (:generate (node) (destructure (((cont n nbits) (call-args node))) (let ((dest (get-destination cont))) (if (literal-node? nbits) (let ((amount (leaf-value nbits))) (emit-alu-field 'K:NB-SHIFT-0F-R dest IGNORED (get-right-operand n) `(PRIMS::BYTE 0 ,amount) 'K:PW-II)) (progn (generate-load-sr-position nbits) (emit-alu-field 'K:NB-SHIFT-0F-R dest IGNORED (get-right-operand n) ''0 'K:PW-RR))) dest)))) (define-primop hw:32logical-shift-down (n nbits) (:generate (node) (destructure (((cont n nbits) (call-args node))) (let ((dest (get-destination cont))) (if (literal-node? nbits) (let ((amount (leaf-value nbits))) (emit-alu-field 'K:NB-SHIFT-0F-R dest IGNORED (get-right-operand n) `(PRIMS::BYTE 0 ,(- amount)) 'K:PW-II)) (progn (generate-load-sr-minus-position nbits) (emit-alu-field 'K:NB-SHIFT-0F-R dest IGNORED (get-right-operand n) ''0 'K:PW-RR))) dest)))) (define-primop hw:32arithmetic-shift-down (n nbits) (:generate (node) (destructure (((cont n nbits) (call-args node))) (let ((dest (get-destination cont))) (if (literal-node? nbits) (let ((amount (leaf-value nbits))) (emit-alu-field 'K:NB-SHIFT-AR-R dest IGNORED (get-right-operand n) `(PRIMS::BYTE 0 ,(- amount)) 'K:PW-II)) (progn (generate-load-sr-minus-position nbits) (emit-alu-field 'K:NB-SHIFT-AR-R dest IGNORED (get-right-operand n) ''0 'K:PW-RR))) dest)))) (define-primop hw:32arithmetic-shift-up (n nbits) (:generate (node) (destructure (((cont n nbits) (call-args node))) (let ((dest (get-destination cont))) (if (literal-node? nbits) (let ((amount (leaf-value nbits))) (emit-alu-field 'K:NB-SHIFT-AR-R dest IGNORED (get-right-operand n) `(PRIMS::BYTE 0 ,amount) 'K:PW-II)) (progn (generate-load-sr-position nbits) (emit-alu-field 'K:NB-SHIFT-AR-R dest IGNORED (get-right-operand n) ''0 'K:PW-RR))) dest)))) (define-primop hw:32-rotate-up (n nbits) (:generate (node) (destructure (((cont n nbits) (call-args node))) (let ((dest (get-destination cont))) (if (literal-node? nbits) (let ((amount (leaf-value nbits))) (emit-alu-field 'K:ROTATE-R dest IGNORED (get-right-operand n) `(PRIMS::BYTE 0 ,amount) 'K:PW-II 'K:UNBOXED)) (progn (generate-load-sr-position nbits) (emit-alu-field 'K:ROTATE-R dest IGNORED (get-right-operand n) ''0 'K:PW-RR 'K:UNBOXED))) dest)))) ;;; This is just like equal but doesn't TRAP-UNLES-BOTH-FIX (define-primop hw:24= (n1 n2) (:generate (node) (comparator node 'K:BR-NOT-EQUAL 'K:BW-24)) (:presimplify (node) (presimplify-to-conditional node)) (:conditional? t)) (define-primop hw:24> (n1 n2) (:generate (node) (comparator node 'K:BR-NOT-GREATER-THAN 'K:BW-24)) (:presimplify (node) (presimplify-to-conditional node)) (:conditional? t)) ;;; like + but no dtp trap (define-primop hw:24+ (left right) (:generate (node) (generate-binop node 'K:L+R 'K:L+R 'K:BW-24 'K:BOXED-RIGHT))) (define-primop hw:24- (left right) (:generate (node) (generate-binop node 'K:L-R 'K:L-R 'K:BW-24 'K:BOXED-RIGHT))) ;;; (ALU-FIELD ALIGNED-FIELD-XOR NOP l r dtp) (define-primop hw::field= (x y byte-spec) (:conditional? t) (:presimplify (node) (presimplify-to-conditional node)) (:generate (node) (let ((byte-spec (call-arg-n 6 node))) (multiple-value-bind (l r) (get-operands (call-arg-n 4 node) (call-arg-n 5 node)) (if (literal-node? byte-spec) (emit-alu-field 'K:ALIGNED-FIELD-XOR 'K:NOP l r `',(leaf-value byte-spec) 'K:PW-II) (error "not yet implemented")) (generate-conditional node 'K:BR-NOT-EQUAL))))) (define-primop hw::load-q-register (value) (:side-effects? t) (:generate (node) (destructure (((cont value) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:LOAD-Q-R dest (get-left-operand value) (get-right-operand value) '(k:BW-32 K:BOXED-RIGHT)) dest)))) ;;This is not currently used 9/22/88 but might be used for optimization where you want the status registers ;; filled with the status of the low 24bits (requires that the high 8 bits are in a known state) --wkf #+Not-currently-used (define-primop hw::24-load-q-register (value) (:side-effects? t) (:generate (node) (destructure (((cont value) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:LOAD-Q-R dest (get-left-operand value) (get-right-operand value) '(K:BW-24 K:BOXED-RIGHT)) dest)))) (define-primop hw::read-q-register () (:generate (node) (destructure (((cont) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:PASS-Q dest 'K:IGNORE 'K:IGNORE '(K:BW-32 K:UNBOXED)) dest)))) (define-primop hw::read-q-register-boxed () (:generate (node) (destructure (((cont) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:PASS-Q dest 'K:IGNORE 'K:IGNORE '(K:BW-32 K:BOXED)) dest)))) (define-primop hw::read-alu-status () (:side-effects? t) (:generate (node) (destructure (((cont) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:PASS-STATUS dest 'GR::*ZERO* 'GR::*ZERO* '(K:BW-24 K:BOXED)) dest)))) (define-primop hw::signed-multiply-first-step (a b) (:side-effects? t) (:generate (node) (destructure (((cont a b) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:SMUL-FIRST dest (get-left-operand a) (get-right-operand b) '(K:BW-24 K:BOXED-RIGHT)) dest)))) (define-primop hw::signed-multiply-step (a b) (:side-effects? t) (:generate (node) (destructure (((cont a b) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:SMUL-STEP dest (get-left-operand a) (get-right-operand b) '(K:BW-24 K:BOXED-RIGHT)) dest)))) (define-primop hw::32-sign-fill (a) (:generate (node) (destructure (((cont a) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:SIGN dest (get-left-operand a) (get-right-operand a) '(K:BW-32 K:UNBOXED)) dest)))) (define-primop hw::24-sign-fill (a) (:generate (node) (destructure (((cont a) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:SIGN dest (get-left-operand a) (get-right-operand a) '(K:BW-24 K:BOXED-RIGHT)) dest)))) (define-primop hw::32-sign-extend-byte (a) (:generate (node) (destructure (((cont a) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:SEX-R dest (get-left-operand a) (get-right-operand a) '(K:BW-8 K:UNBOXED)) ;;8 Width before extending dest)))) (define-primop hw::32-sign-extend (a) (:generate (node) (destructure (((cont a) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:SEX-R dest (get-left-operand a) (get-right-operand a) '(K:BW-24 K:UNBOXED)) ;;24 Width before extending dest)))) (define-primop hw::32-prioritize (a) (:generate (node) (destructure (((cont a) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:PRIORITIZE-R dest (get-left-operand a) (get-right-operand a) '(K:BW-32 K:UNBOXED)) dest)))) (define-primop hw::24-prioritize (a) (:generate (node) (destructure (((cont a) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'K:PRIORITIZE-R dest (get-right-operand a) (get-right-operand a) '(K:BW-24 K:UNBOXED)) dest)))) (define-primop hw::signed-divide-first-step (x y) (:side-effects? t) (:generate (node) (destructure (((cont x y) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'k:sdiv-first dest (get-left-operand x) (get-right-operand y) '(K:bw-24 K:BOXED)) dest)))) (define-primop hw::signed-divide-step (x y) (:side-effects? t) (:generate (node) (destructure (((cont x y) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'k:sdiv-step dest (get-left-operand x) (get-right-operand y) '(K:bw-24 K:BOXED)) dest)))) (define-primop hw::signed-divide-last1 (x y) (:side-effects? t) (:generate (node) (destructure (((cont x y) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'k:sdiv-last1 dest (get-left-operand x) (get-right-operand y) '(K:bw-24 k:boxed)) dest)))) (define-primop hw::signed-divide-last2 (x y) (:side-effects? t) (:generate (node) (destructure (((cont x y) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'k:sdiv-last2 dest (get-left-operand x) (get-right-operand y) '(K:bw-24 k:boxed)) dest)))) (define-primop hw::quotient-correct (x) (:side-effects? t) (:generate (node) (destructure (((cont x) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'k:quo-corr dest (get-left-operand x) (get-right-operand x) '(K:bw-24 k:boxed)) dest)))) (define-primop hw::remainder-correct (x y) (:side-effects? t) (:generate (node) (destructure (((cont x y) (call-args node))) (let ((dest (get-destination cont))) (emit-alu 'k:rem-corr dest (get-left-operand x) (get-right-operand y) '(K:bw-24 k:boxed)) dest)))) ;;; Floating point chip primitives (define-primop hw:float-add-single (x y) (:generate (node) (generate-float-single-op 'K:FALU 'K:SINGLE-ADD node))) (define-primop hw:float-subtract-single (x y) (:generate (node) (generate-float-single-op 'K:FALU 'K:SINGLE-SUBTRACT node))) (define-primop hw:float-multiply-single (x y) (:generate (node) (generate-float-single-op 'K:FMUL 'K:SINGLE-MULTIPLY node))) (define-primop hw:float-divide-single (divisor dividend) ;;||| Args are backwards for some reason 9/29/88 --wkf (:generate (node) (generate-float-single-op 'K:FMUL 'K:SINGLE-DIVIDE node 9))) (define-primop hw:float-compare-single (x y) (:side-effects? t) (:generate (node) (generate-float-single-op 'K:FALU 'K:SINGLE-COMPARE node))) (defun generate-float-single-op (wtl op node &optional delay) (destructure (((cont x y) (call-args node))) (multiple-value-bind (dest left right) (get-dest-and-operands cont x y) (emit wtl op 'K:NOP left right 'K:FPU-LOAD-XY 'K:FPU-UNLOAD-HIGH 'K:UNBOXED) (emit wtl op 'K:NOP left right 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-HIGH 'K:UNBOXED) (when delay (generate-delay delay)) (emit wtl op 'K:NOP left right 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-HIGH 'K:UNBOXED) (emit wtl op 'K:NOP left right 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-HIGH 'K:UNBOXED) (emit wtl op dest left right 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-HIGH 'K:UNBOXED) dest))) (defun generate-delay (ticks &optional (reg R0)) ;; ||| Changed to include looping delay when possible, fixed bug with loop time. 10/12/88 --wkf (multiple-value-bind (quotient remainder) (floor (1- ticks) 3) (let ((tag (gen-tag 'loop))) (dotimes (i remainder) (emit 'K:NOP)) (if (zerop quotient) (emit 'K:NOP) (emit-code `((K:MOVEI ,reg ',quotient) ,tag (K:ALU K:R-1 ,reg K:IGNORE ,reg K:BW-24) (K:TEST K:BR-NOT-ZERO) (K:BRANCH ,tag))))))) (define-primop hw:float-add-double (xhi xlo yhi ylo) (:special? t) (:generate (node) (generate-float-double-op 'K:FALU 'K:DOUBLE-ADD node))) (define-primop hw:float-subtract-double (xhi xlo yhi ylo) (:special? t) (:generate (node) (generate-float-double-op 'K:FALU 'K:DOUBLE-SUBTRACT node))) (define-primop hw:float-multiply-double (xhi xlo yhi ylo) (:special? t) (:generate (node) (generate-float-double-op 'K:FMUL 'K:DOUBLE-MULTIPLY node))) (define-primop hw:float-divide-double (xhi xlo yhi ylo) (:special? t) (:generate (node) (generate-float-double-op 'K:FMUL 'K:DOUBLE-DIVIDE node 21))) (define-primop hw:float-compare-double (xhi xlo yhi ylo) (:special? t) (:side-effects? t) (:generate (node) (generate-float-double-op 'K:FALU 'K:DOUBLE-COMPARE node))) (defun generate-float-double-op (wtl op node &optional (delay 3)) ;;Changed to take wtl of either 'K:FMUL or 'K:FALU 9/30/88 --wkf ||| (destructure (((cont xhi xlo yhi ylo) (call-args node))) (multiple-value-bind (y-left y-right) (get-operands yhi ylo) ;; Load Y (emit wtl op 'K:NOP y-left y-right 'K:FPU-LOAD-Y 'K:FPU-UNLOAD-HIGH 'K:UNBOXED)) (multiple-value-bind (x-left x-right) (get-operands xhi xlo) ;; Load X and start alu (emit wtl op 'K:NOP x-left x-right 'K:FPU-LOAD-X 'K:FPU-UNLOAD-HIGH 'K:UNBOXED)) (generate-delay delay) (if (not (lambda-node? cont)) (progn (error "You should use MULTIPLE-VALUE-BIND with double-float operations") (generate-continuation ''NIL cont 1)) (destructure (((hi lo) (lambda-variables cont))) (let ((hi-acc (acc hi)) (lo-acc (if lo (acc lo) IGNORED))) (emit wtl op 'K:NOP IGNORED IGNORED 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-HIGH 'K:UNBOXED) (emit wtl op 'K:NOP IGNORED IGNORED 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-LOW 'K:UNBOXED) (emit wtl op (if (or (register-p hi-acc) (global-p hi-acc)) hi-acc R0) IGNORED IGNORED 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-LOW 'K:UNBOXED) (emit wtl op (if (or (register-p lo-acc) (global-p lo-acc)) lo-acc R1) IGNORED IGNORED 'K:FPU-LOAD-NOP 'K:FPU-UNLOAD-LOW 'K:UNBOXED) (unless (or (register-p hi-acc) (global-p hi-acc)) (generate-move R0 hi-acc)) (unless (or (register-p lo-acc) (global-p lo-acc)) (generate-move R1 lo-acc)) (generate-continuation hi-acc cont 2))))))