X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fmips%2Fmacros.lisp;h=da719e276b7a11b34d42c93c2a7474b315bf5ec0;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=ca9f3594fc87023ed8a89e39c0f827d2da827187;hpb=d294785c8e313384513208c1d93a44c3f22a0464;p=sbcl.git diff --git a/src/compiler/mips/macros.lisp b/src/compiler/mips/macros.lisp index ca9f359..da719e2 100644 --- a/src/compiler/mips/macros.lisp +++ b/src/compiler/mips/macros.lisp @@ -24,8 +24,9 @@ ;;; Instruction-like macros. (defmacro move (dst src &optional (always-emit-code-p nil)) + #!+sb-doc "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P - is nil)." +is nil)." (once-only ((n-dst dst) (n-src src)) `(if (location= ,n-dst ,n-src) @@ -61,8 +62,9 @@ (- other-pointer-lowtag)))) (defmacro load-type (target source &optional (offset 0)) + #!+sb-doc "Loads the type bits of a pointer into target independent of - byte-ordering issues." +byte-ordering issues." (once-only ((n-target target) (n-source source) (n-offset offset)) @@ -77,6 +79,7 @@ ;;; return instructions. (defmacro lisp-jump (function lip) + #!+sb-doc "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift) @@ -85,6 +88,7 @@ (move code-tn ,function t))) (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) + #!+sb-doc "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn (inst addu ,lip ,return-pc @@ -96,9 +100,10 @@ (defmacro emit-return-pc (label) + #!+sb-doc "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn - (align n-lowtag-bits) + (emit-alignment n-lowtag-bits) (emit-label ,label) (inst lra-header-word))) @@ -124,6 +129,7 @@ (storew reg cfp-tn offset)))))) (defmacro maybe-load-stack-tn (reg reg-or-stack) + #!+sb-doc "Move the TN Reg-Or-Stack into Reg if it isn't already there." (once-only ((n-reg reg) (n-stack reg-or-stack)) @@ -137,21 +143,39 @@ ;;;; Storage allocation: -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) +(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code + size dynamic-extent-p + &key (lowtag other-pointer-lowtag)) &body body) + #!+sb-doc "Do stuff to allocate an other-pointer object of fixed Size with a single - word header having the specified Type-Code. The result is placed in - Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non- - descriptor temp (which may be randomly used by the body.) The body is - placed inside the PSEUDO-ATOMIC, and presumably initializes the object." +word header having the specified Type-Code. The result is placed in +Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non- +descriptor temp (which may be randomly used by the body.) The body is +placed inside the PSEUDO-ATOMIC, and presumably initializes the object." (unless body (bug "empty &body in WITH-FIXED-ALLOCATION")) - (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size)) - `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) - (inst or ,result-tn alloc-tn other-pointer-lowtag) - (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) - ,@body))) + (once-only ((result-tn result-tn) (flag-tn flag-tn) (temp-tn temp-tn) + (type-code type-code) (size size) + (dynamic-extent-p dynamic-extent-p) + (lowtag lowtag)) + `(if ,dynamic-extent-p + (pseudo-atomic (,flag-tn) + (align-csp ,temp-tn) + (inst or ,result-tn csp-tn ,lowtag) + (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (inst addu csp-tn (pad-data-block ,size)) + (storew ,temp-tn ,result-tn 0 ,lowtag) + ,@body) + (pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) + ;; The pseudo-atomic bit in alloc-tn is set. If the lowtag also + ;; has a 1 bit in the same position, we're all set. Otherwise, + ;; we need to subtract the pseudo-atomic bit. + (inst or ,result-tn alloc-tn ,lowtag) + (unless (logbitp 0 ,lowtag) (inst sub ,result-tn 1)) + (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 ,lowtag) + ,@body)))) (defun align-csp (temp) ;; is used for stack allocation of dynamic-extent objects @@ -178,8 +202,8 @@ (:signed (inst slt temp x y))) (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target))) + (inst beq temp target) + (inst bne temp target))) (:gt (ecase flavor (:unsigned @@ -187,14 +211,14 @@ (:signed (inst slt temp y x))) (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)))) + (inst beq temp target) + (inst bne temp target)))) (inst nop)) ;;;; Error Code -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) `((let ((vop ,vop)) @@ -213,15 +237,17 @@ (inst byte (length ,vector)) (dotimes (i (length ,vector)) (inst byte (aref ,vector i)))) - (align word-shift))))) + (emit-alignment word-shift))))) (defmacro error-call (vop error-code &rest values) + #!+sb-doc "Cause an error. ERROR-CODE is the error to cause." (cons 'progn (emit-error-break vop error-trap error-code values))) (defmacro cerror-call (vop label error-code &rest values) + #!+sb-doc "Cause a continuable error. If the error is continued, execution resumes at LABEL." `(progn @@ -230,6 +256,7 @@ ,@(emit-error-break vop cerror-trap error-code values)))) (defmacro generate-error-code (vop error-code &rest values) + #!+sb-doc "Generate-Error-Code Error-code Value* Emit code for an error with the specified Error-Code and context Values." `(assemble (*elsewhere*) @@ -239,6 +266,7 @@ start-lab))) (defmacro generate-cerror-code (vop error-code &rest values) + #!+sb-doc "Generate-CError-Code Error-code Value* Emit code for a continuable error with the specified Error-Code and context Values. If the error is continued, execution resumes after