X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fmacros.lisp;h=9d0128c3111b1f706d4dc1f0d7787374f66ba49c;hb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;hp=fcb878f66df8fe15795a5e9a3dfd79dd18debae4;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index fcb878f..9d0128c 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. -;;; +;;;; various useful macros for generating Alpha code -;;; -;;; ********************************************************************** -;;; -;;; This file contains various useful macros for generating Alpha code. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; Alpha conversion by Sean Hallgren. -;;; +;;;; 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. (in-package "SB!VM") - -;;; Handy macro for defining top-level forms that depend on the compile -;;; environment. - +;;; 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 sb!vm:simple-fun-code-offset sb!vm:word-shift) + sb!vm: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,28 +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 widetagsize) &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 - +;;;; error code (defvar *adjustable-vectors* nil) @@ -288,11 +266,11 @@ (deftype load/store-index (scale lowtag min-offset &optional (max-offset min-offset)) `(integer ,(- (truncate (+ (ash 1 16) - (* min-offset word-bytes) + (* min-offset n-word-bytes) (- lowtag)) scale)) ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset word-bytes)) + (* max-offset n-word-bytes)) scale))) (defmacro define-full-reffer (name type offset lowtag scs el-type @@ -310,7 +288,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,12 +298,12 @@ (: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))))))) @@ -346,7 +324,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 +334,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 +368,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 @@ -431,36 +412,36 @@ ,@(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 +470,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 @@ -523,27 +504,27 @@ (:generator 5 ,@(ecase size (:byte - `((inst lda temp (- (* ,offset word-bytes) + `((inst lda temp (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object) - (inst ldq_u temp1 (- (* ,offset word-bytes) + (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) + (inst stq_u temp1 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object))) (:short - `((inst lda temp (- (* ,offset word-bytes) + `((inst lda temp (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object) - (inst ldq_u temp1 (- (* ,offset word-bytes) + (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) + (inst stq_u temp (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object)))) (move value result))))))