X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Falpha%2Fmacros.lisp;h=a2515016fdba481deca0479c5fe4dff546ec4576;hb=a4c3562138e342465826de31fb8c324ae8a4b594;hp=fcb878f66df8fe15795a5e9a3dfd79dd18debae4;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index fcb878f..a251501 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -1,34 +1,26 @@ -;;; -*- Package: ALPHA; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; - -;;; -;;; ********************************************************************** -;;; -;;; This file contains various useful macros for generating Alpha code. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; Alpha conversion by Sean Hallgren. -;;; - -(in-package "SB!VM") +;;;; various useful macros for generating Alpha code +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. -;;; Handy macro for defining top-level forms that depend on the compile -;;; environment. +(in-package "SB!VM") +;;; a handy macro for defining top level forms that depend on the +;;; compile environment (defmacro expand (expr) (let ((gensym (gensym))) `(macrolet ((,gensym () ,expr)) (,gensym)))) - -;;; Instruction-like macros. +;;; instruction-like macros ;;; c.f. x86 backend: ;;(defmacro move (dst src) @@ -39,7 +31,6 @@ ;; `(unless (location= ,n-dst ,n-src) ;; (inst mov ,n-dst ,n-src)))) - (defmacro move (src dst) "Move SRC into DST unless they are location=." (once-only ((n-src src) (n-dst dst)) @@ -70,14 +61,14 @@ `(inst ldl ,reg (+ (static-symbol-offset ',symbol) (ash symbol-value-slot word-shift) - (- other-pointer-type)) + (- other-pointer-lowtag)) null-tn)) (defmacro store-symbol-value (reg symbol) `(inst stl ,reg (+ (static-symbol-offset ',symbol) (ash symbol-value-slot word-shift) - (- other-pointer-type)) + (- other-pointer-lowtag)) null-tn)) (defmacro load-type (target source &optional (offset 0)) @@ -90,14 +81,14 @@ (inst ldl ,n-target ,n-offset ,n-source) (inst and ,n-target #xff ,n-target)))) -;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions. +;;; macros to handle the fact that we cannot use the machine native +;;; call and return instructions (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn - (inst lda ,lip (- (ash sb!vm:function-code-offset sb!vm:word-shift) - sb!vm:function-pointer-type) + (inst lda ,lip (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag) ,function) (move ,function code-tn) (inst jsr zero-tn ,lip 1))) @@ -106,7 +97,7 @@ "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn (inst lda ,lip - (- (* (1+ ,offset) word-bytes) other-pointer-type) + (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) ,return-pc) ,@(when frob-code `((move ,return-pc code-tn))) @@ -117,18 +108,15 @@ "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn - (align lowtag-bits) + (align n-lowtag-bits) (emit-label ,label) (inst lra-header-word))) -;;;; Stack TN's +;;;; stack TN's -;;; Load-Stack-TN, Store-Stack-TN -- Interface -;;; ;;; Move a stack TN to a register and vice-versa. -;;; (defmacro load-stack-tn (reg stack) `(let ((reg ,reg) (stack ,stack)) @@ -136,7 +124,6 @@ (sc-case stack ((control-stack) (loadw reg cfp-tn offset)))))) - (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) (reg ,reg)) @@ -145,11 +132,8 @@ ((control-stack) (storew reg cfp-tn offset)))))) - -;;; MAYBE-LOAD-STACK-TN -- Interface -;;; +;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (defmacro maybe-load-stack-tn (reg reg-or-stack) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." (once-only ((n-reg reg) (n-stack reg-or-stack)) `(sc-case ,n-reg @@ -160,10 +144,8 @@ ((control-stack) (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) -;;; MAYBE-LOAD-STACK-NFP-TN -- Interface -;;; +;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp) - "Move the TN Reg-Or-Stack into Reg if it isn't already there." (once-only ((n-reg reg) (n-stack reg-or-stack)) `(when ,reg @@ -176,43 +158,24 @@ (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) (inst mskll nsp-tn 0 ,temp) (inst bis ,temp ,n-reg ,n-reg)))))))) - - -;;;; Storage allocation: - -(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) +;;;; storage allocation + +;;; Do stuff to allocate an other-pointer object of fixed SIZE with a +;;; single word header having the specified WIDETAG value. The result is +;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-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. +(defmacro with-fixed-allocation ((result-tn temp-tn widetag size) &body body) - "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 NL3-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." `(pseudo-atomic (:extra (pad-data-block ,size)) - (inst bis alloc-tn other-pointer-type ,result-tn) - (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn) - (storew ,temp-tn ,result-tn 0 other-pointer-type) + (inst bis alloc-tn other-pointer-lowtag ,result-tn) + (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn) + (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) ,@body)) - - -;;;; Error Code - - -(defvar *adjustable-vectors* nil) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - +;;;; error code (eval-when (:compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) @@ -222,12 +185,12 @@ (inst gentrap ,kind) (with-adjustable-vector (,vector) (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) + ,@(mapcar (lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) values) (inst byte (length ,vector)) (dotimes (i (length ,vector)) @@ -261,8 +224,7 @@ Emit code for a continuable error with the specified Error-Code and context Values. If the error is continued, execution resumes after the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) @@ -272,28 +234,15 @@ ,error))))) -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. -;;; +;;; a handy macro for making sequences look atomic (defmacro pseudo-atomic ((&key (extra 0)) &rest forms) `(progn (inst addq alloc-tn 1 alloc-tn) ,@forms (inst lda alloc-tn (1- ,extra) alloc-tn) (inst stl zero-tn 0 alloc-tn))) - - -;;;; Memory accessor vop generators - -(deftype load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) - `(integer ,(- (truncate (+ (ash 1 16) - (* min-offset word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset word-bytes)) - scale))) +;;;; memory accessor vop generators (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) @@ -310,7 +259,7 @@ (:result-types ,el-type) (:generator 5 (inst addq object index lip) - (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip) + (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip) ,@(when (equal scs '(unsigned-reg)) '((inst mskll value 4 value))))) (define-vop (,(symbolicate name "-C")) @@ -320,18 +269,18 @@ (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) ,(eval offset)))) (:results (value :scs ,scs)) (:result-types ,el-type) (:generator 4 - (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag) + (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object) ,@(when (equal scs '(unsigned-reg)) '((inst mskll value 4 value))))))) (defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate #+gengc (remember t)) + &optional translate #!+gengc (remember t)) `(progn (define-vop (,name) ,@(when translate @@ -346,7 +295,7 @@ (:result-types ,el-type) (:generator 2 (inst addq index object lip) - (inst stl value (- (* ,offset word-bytes) ,lowtag) lip) + (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) (move value result))) (define-vop (,(symbolicate name "-C")) ,@(when translate @@ -356,13 +305,13 @@ (value :scs ,scs)) (:info index) (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) ,(eval offset))) ,el-type) (:results (result :scs ,scs)) (:result-types ,el-type) (:generator 1 - (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag) + (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object) (move value result))))) @@ -390,28 +339,31 @@ ,@(ecase size (:byte (if signed - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag)) + (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag)) lip) (inst extqh temp temp1 temp) (inst sra temp 56 value)) - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u + temp + (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst extbl temp temp1 value)))) (:short (if signed - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst extwl temp temp1 temp) (inst sll temp 48 temp) (inst sra temp 48 value)) - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst extwl temp temp1 value))))))) (define-vop (,(symbolicate name "-C")) ,@(when translate @@ -427,40 +379,40 @@ (:result-types ,el-type) (:temporary (:sc non-descriptor-reg) temp) (:temporary (:sc non-descriptor-reg) temp1) - (:generator 5 + (:generator 4 ,@(ecase size (:byte (if signed - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (1+ (- (+ (* ,offset word-bytes) + (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)) object) (inst extqh temp temp1 temp) (inst sra temp 56 value)) - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (- (+ (* ,offset word-bytes) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) (inst extbl temp temp1 value)))) (:short (if signed - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (- (+ (* ,offset word-bytes) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) (inst extwl temp temp1 temp) (inst sll temp 48 temp) (inst sra temp 48 value)) - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (- (+ (* ,offset word-bytes) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) (inst extwl temp temp1 value)))))))))) @@ -489,19 +441,19 @@ '((inst addq lip index lip))) ,@(ecase size (:byte - `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip) + `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst insbl value temp temp2) (inst mskbl temp1 temp temp1) (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip))) + (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip))) (:short - `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip) + `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst mskwl temp1 temp temp1) (inst inswl value temp temp2) (inst bis temp1 temp2 temp) - (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip)))) + (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip)))) (move value result))) (define-vop (,(symbolicate name "-C")) ,@(when translate @@ -520,30 +472,45 @@ (:temporary (:sc non-descriptor-reg) temp2) (:results (result :scs ,scs)) (:result-types ,el-type) - (:generator 5 + (:generator 4 ,@(ecase size (:byte - `((inst lda temp (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) + `((inst lda temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object) - (inst ldq_u temp1 (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) + (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object) (inst insbl value temp temp2) (inst mskbl temp1 temp temp1) (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) object))) + (inst stq_u temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object))) (:short - `((inst lda temp (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) + `((inst lda temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object) - (inst ldq_u temp1 (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) + (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object) (inst mskwl temp1 temp temp1) (inst inswl value temp temp2) (inst bis temp1 temp2 temp) - (inst stq_u temp (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) object)))) + (inst stq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object)))) (move value result)))))) + +(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body) + "Arrange with the garbage collector that the pages occupied by +OBJECTS will not be moved in memory for the duration of BODY. +Useful for e.g. foreign calls where another thread may trigger +garbage collection. This is currently implemented by disabling GC" + (declare (ignore objects)) ;should we eval these for side-effect? + `(without-gcing + ,@body))