Skip to content
Snippets Groups Projects
Commit e687116c authored by cwang's avatar cwang
Browse files

amd64 files

parent 85b80477
No related branches found
No related tags found
No related merge requests found
Showing
with 16450 additions and 0 deletions
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/alloc.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; Allocation VOPs for the amd64 port.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1996.
;;;
(in-package :amd64)
;;;; Dynamic-Extent
;;;
;;; Take an arg where to move the stack pointer instead of returning
;;; it via :results, because the former generates a single move.
;;;
(define-vop (%dynamic-extent-start)
(:args (saved-stack-pointer :scs (any-reg control-stack)))
(:results)
(:policy :safe)
(:generator 0 (inst mov saved-stack-pointer rsp-tn)))
(define-vop (%dynamic-extent-end)
(:args (saved-stack-pointer :scs (any-reg control-stack)))
(:results)
(:policy :safe)
(:generator 0 (inst mov rsp-tn saved-stack-pointer)))
;;;; LIST and LIST*
(define-vop (list-or-list*)
(:args (things :more t))
(:temporary (:sc unsigned-reg) ptr temp)
(:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
(:info num dynamic-extent)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:node-var node)
(:generator 0
(cond ((zerop num)
;; (move result nil-value)
(inst mov result nil-value))
((and star (= num 1))
(move result (tn-ref-tn things)))
(t
(macrolet
((store-car (tn list &optional (slot vm:cons-car-slot))
`(let ((reg
(sc-case ,tn
((any-reg descriptor-reg) ,tn)
((control-stack)
(move temp ,tn)
temp))))
(storew reg ,list ,slot vm:list-pointer-type))))
(let ((cons-cells (if star (1- num) num))
(*enable-pseudo-atomic* (unless dynamic-extent
*enable-pseudo-atomic*)))
(pseudo-atomic
(allocation res (* (pad-data-block cons-size) cons-cells) temp node
dynamic-extent)
(inst lea res
(make-ea :byte :base res :disp list-pointer-type))
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(setf things (tn-ref-across things))
(inst add ptr (pad-data-block cons-size))
(storew ptr ptr (- cons-cdr-slot cons-size)
list-pointer-type))
(store-car (tn-ref-tn things) ptr)
(cond (star
(setf things (tn-ref-across things))
(store-car (tn-ref-tn things) ptr cons-cdr-slot))
(t
(storew nil-value ptr cons-cdr-slot
list-pointer-type)))
(assert (null (tn-ref-across things)))))
(move result res))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (list* list-or-list*)
(:variant t))
;;;; Special purpose inline allocators.
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
(unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :from :eval) temp)
(:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
(:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
(:generator 100
(move boxed boxed-arg)
(inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
(inst and boxed (lognot lowtag-mask))
(move unboxed unboxed-arg)
(inst shr unboxed word-shift)
(inst add unboxed lowtag-mask)
(inst and unboxed (lognot lowtag-mask))
(pseudo-atomic
;; now loading code into static space cause it can't move
(load-symbol-value temp lisp::*static-space-free-pointer*)
(inst lea result (make-ea :byte :base temp :disp other-pointer-type))
(inst add temp boxed)
(inst add temp unboxed)
(store-symbol-value temp lisp::*static-space-free-pointer*)
(inst shl boxed (- type-bits word-shift))
(inst or boxed code-header-type)
(storew boxed result 0 other-pointer-type)
(storew unboxed result code-code-size-slot other-pointer-type)
(inst mov temp nil-value)
(storew temp result code-entry-points-slot other-pointer-type))
(storew temp result code-debug-info-slot other-pointer-type)))
(define-vop (allocate-dynamic-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed) ; fixnum, number of words
(unboxed-arg :scs (any-reg) :target unboxed)) ; fixnum, number of bytes
(:results (result :scs (descriptor-reg) :from :eval))
(:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
(:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
(:temporary (:sc any-reg) temp)
(:node-var node)
(:generator 100
(move boxed boxed-arg)
;; the compiled code assumes it's dual word aligned
(inst lea boxed (make-ea :byte :base boxed :index boxed
:disp (* 8 (1+ code-trace-table-offset-slot))))
(inst and boxed (lognot 15))
(move unboxed unboxed-arg)
(inst shr unboxed 2)
(inst add unboxed 15)
(inst and unboxed (lognot 15)) ; alignment
(inst mov result boxed)
(inst add result unboxed) ; total number of bytes
(pseudo-atomic
(allocation result result temp node)
(inst lea result (make-ea :byte :base result :disp other-pointer-type))
(inst shl boxed (- type-bits word-shift))
(inst or boxed code-header-type)
(storew boxed result 0 other-pointer-type)
(inst shr unboxed 1) ; number of code words (fixnum tag)
(storew unboxed result code-code-size-slot other-pointer-type)
(storew nil-value result code-entry-points-slot other-pointer-type))
(storew nil-value result code-debug-info-slot other-pointer-type)))
(define-vop (make-fdefn)
(:policy :fast-safe)
(:translate make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:results (result :scs (descriptor-reg) :from :argument))
(:temporary (:sc any-reg) temp)
(:node-var node)
(:generator 37
(with-fixed-allocation (result fdefn-type fdefn-size temp node)
(storew name result fdefn-name-slot other-pointer-type)
(storew nil-value result fdefn-function-slot other-pointer-type)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
result fdefn-raw-addr-slot other-pointer-type))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:info length dynamic-extent)
(:temporary (:sc any-reg) temp)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 10
(let ((*enable-pseudo-atomic* (unless dynamic-extent
*enable-pseudo-atomic*)))
(pseudo-atomic
(let ((size (+ length closure-info-offset)))
(allocation result (pad-data-block size) temp node dynamic-extent)
(inst lea result
(make-ea :byte :base result :disp function-pointer-type))
(storew (logior (ash (1- size) type-bits) closure-header-type)
result 0 function-pointer-type))
(loadw temp function closure-function-slot function-pointer-type)
(storew temp result closure-function-slot function-pointer-type)))))
;;; The compiler likes to be able to directly make value cells.
;;;
(define-vop (make-value-cell)
(:args (value :scs (descriptor-reg any-reg) :to :result))
(:results (result :scs (descriptor-reg) :from :eval))
(:temporary (:sc any-reg) temp)
(:node-var node)
(:generator 10
(with-fixed-allocation
(result value-cell-header-type value-cell-size temp node))
(storew value result value-cell-value-slot other-pointer-type)))
;;;; Automatic allocators for primitive objects.
(define-vop (make-unbound-marker)
(:args)
(:results (result :scs (any-reg)))
(:generator 1
(inst mov result unbound-marker-type)))
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag dynamic-extent)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:temporary (:sc any-reg) temp)
(:node-var node)
(:generator 50
(let ((*enable-pseudo-atomic* (unless dynamic-extent
*enable-pseudo-atomic*)))
(pseudo-atomic
(allocation result (pad-data-block words) temp node dynamic-extent)
(inst lea result (make-ea :byte :base result :disp lowtag))
(when type
(storew (logior (ash (1- words) type-bits) type) result 0 lowtag))))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(:arg-types positive-fixnum)
(:info name words type lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg) :from (:eval 1)))
(:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
(:temporary (:sc any-reg :from :eval :to :result) header)
(:temporary (:sc any-reg) temp)
(:node-var node)
(:generator 50
(inst lea bytes
(make-ea :qword :index extra :scale 2 :disp (* (1+ words) word-bytes)))
(inst mov header bytes)
(inst shl header (- type-bits 3)) ; w+1 to length field
(inst lea header ; (w-1 << 8) | type
(make-ea :qword :base header :disp (+ (ash -2 type-bits) type)))
(inst and bytes (lognot 15)) ; alignment
(pseudo-atomic
(allocation result bytes temp node)
(inst lea result (make-ea :byte :base result :disp lowtag))
(storew header result 0 lowtag))))
(define-vop (make-symbol)
(:policy :fast-safe)
(:translate make-symbol)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:sc unsigned-reg) temp) ; this cannot be the same register as name
(:temporary (:sc unsigned-reg :from :eval) state-addr)
(:results (result :scs (descriptor-reg) :from :argument))
(:node-var node)
(:generator 37
(with-fixed-allocation (result symbol-header-type symbol-size temp node)
(storew name result symbol-name-slot other-pointer-type)
(storew unbound-marker-type result symbol-value-slot other-pointer-type)
;; Setup a random hash value for the symbol. Perhaps the object
;; address could be used for even faster and smaller code!
(load-foreign-data-symbol2 state-addr "fast_random_state" temp)
(inst imul temp
(make-ea :qword :base state-addr)
1103515245)
(inst add temp 12345)
(inst mov (make-ea :qword :base state-addr) temp)
;; Want a positive fixnum for the hash value, discard the LS bits.
(inst shr temp 1)
(inst and temp #xfffffffc)
(storew temp result symbol-hash-slot other-pointer-type)
(storew nil-value result symbol-plist-slot other-pointer-type)
(storew nil-value result symbol-package-slot other-pointer-type))))
This diff is collapsed.
This diff is collapsed.
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/c-call.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the VOPs and other necessary machine specific support
;;; routines for call-out to C.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Debugging and Enhancements by Douglas Crosher 1996,1997,1998,1999.
;;;
(in-package :amd64)
(use-package :alien)
(use-package :alien-internals)
;; The move-argument vop is going to store args on the stack for
;; call-out. These tn's will be used for that. move-arg is normally
;; used for things going down the stack but C wants to have args
;; indexed in the positive direction.
(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
(sc-number-or-lose sc-name *backend*)
offset))
(defstruct arg-state
(register-args 0)
(stack-frame-size 0))
(defun int-arg (state prim-type reg-sc stack-sc)
(let ((reg-args (arg-state-register-args state)))
(cond ((< reg-args 4) ; Should be 6 (r8 and r9)
(setf (arg-state-register-args state) (1+ reg-args))
(my-make-wired-tn prim-type reg-sc (ecase reg-args
(0 #.rdi-offset)
(1 #.rsi-offset)
(2 #.rdx-offset)
(3 #.rcx-offset))))
(t
(let ((frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ frame-size))
(my-make-wired-tn prim-type stack-sc frame-size))))))
(def-alien-type-method (integer :arg-tn) (type state)
(if (alien-integer-type-signed type)
(int-arg state 'signed-byte-64 'signed-reg 'signed-stack)
(int-arg state 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)))
(def-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
#+long-float
(def-alien-type-method (long-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
(my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
(def-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
(my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
(def-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
(defstruct result-state
(num-results 0))
(defun result-reg-offset (slot)
(ecase slot
(0 rax-offset)
(1 rdx-offset)))
(def-alien-type-method (integer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind
(ptype reg-sc)
(if (alien-integer-type-signed type)
(values 'signed-byte-64 'signed-reg)
(values 'unsigned-byte-64 'unsigned-reg))
(my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
(def-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'system-area-pointer 'sap-reg
(result-reg-offset num-results))))
#+long-float
(def-alien-type-method (long-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'long-float 'long-reg (* num-results 2))))
(def-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
(def-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
(def-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
(when (> (length values) 2)
(error "Too many result values from c-call."))
(mapcar #'(lambda (type)
(invoke-alien-type-method :result-tn type state))
(alien-values-type-values type))))
(def-vm-support-routine make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-function-type-arg-types type))
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (my-make-wired-tn 'positive-fixnum 'any-reg rsp-offset)
(* (arg-state-stack-frame-size arg-state) word-bytes)
(arg-tns)
(invoke-alien-type-method :result-tn
(alien-function-type-result-type type)
(make-result-state))))))
(deftransform %alien-funcall ((function type &rest args))
(assert (c::constant-continuation-p type))
(let* ((type (c::continuation-value type))
(arg-types (alien-function-type-arg-types type))
(result-type (alien-function-type-result-type type)))
(assert (= (length arg-types) (length args)))
(if (or (some #'(lambda (type)
(and (alien-integer-type-p type)
(> (alien::alien-integer-type-bits type) 32)))
arg-types)
(and (alien-integer-type-p result-type)
(> (alien::alien-integer-type-bits result-type) 32)))
(collect ((new-args) (lambda-vars) (new-arg-types))
(dolist (type arg-types)
(let ((arg (gensym)))
(lambda-vars arg)
(cond ((and (alien-integer-type-p type)
(> (alien::alien-integer-type-bits type) 32))
(new-args `(logand ,arg #xffffffff))
(new-args `(ash ,arg -32))
(new-arg-types (parse-alien-type '(unsigned 32)))
(if (alien-integer-type-signed type)
(new-arg-types (parse-alien-type '(signed 32)))
(new-arg-types (parse-alien-type '(unsigned 32)))))
(t
(new-args arg)
(new-arg-types type)))))
(cond ((and (alien-integer-type-p result-type)
(> (alien::alien-integer-type-bits result-type) 32))
(let ((new-result-type
(let ((alien::*values-type-okay* t))
(parse-alien-type
(if (alien-integer-type-signed result-type)
'(values (unsigned 32) (signed 32))
'(values (unsigned 32) (unsigned 32)))))))
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(multiple-value-bind (low high)
(%alien-funcall function
',(make-alien-function-type
:arg-types (new-arg-types)
:result-type new-result-type)
,@(new-args))
(logior low (ash high 32))))))
(t
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(%alien-funcall function
',(make-alien-function-type
:arg-types (new-arg-types)
:result-type result-type)
,@(new-args))))))
(c::give-up))))
(define-vop (foreign-symbol-code-address)
(:translate #+linkage-table foreign-symbol-code-address
#-linkage-table foreign-symbol-address)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(inst mov-imm res (make-fixup (extern-alien-name foreign-symbol)
:foreign))))
(define-vop (foreign-symbol-data-address)
(:translate foreign-symbol-data-address)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(inst mov res (make-fixup (extern-alien-name foreign-symbol)
:foreign-data))))
(define-vop (call-out)
(:args (function :scs (sap-reg))
(args :more t))
(:results (results :more t))
(:temporary (:sc unsigned-reg :offset rax-offset
:from :eval :to :result) rax)
(:temporary (:sc unsigned-reg :offset rbx-offset
:from :eval :to :result) rbx)
(:temporary (:sc unsigned-reg :offset rcx-offset
:from :eval :to :result) rcx)
(:temporary (:sc unsigned-reg :offset rdx-offset
:from :eval :to :result) rdx)
(:node-var node)
(:vop-var vop)
(:save-p t)
(:ignore args rcx rdx)
(:generator 0
(cond ((policy node (> space speed))
(move rax function)
(inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
(t
(move rbx function)
;; With variable arguments, rax passes information about the number of
;; SSE register used. This is unnecessary for normal functions, but
;; I don't know how to distinguish them.
(inst xor rax rax)
;; Setup the NPX for C; all the FP registers need to be
;; empty; pop them all.
(dotimes (i 8)
(fp-pop))
(inst call rbx)
;; To give the debugger a clue. XX not really internal-error?
(note-this-location vop :internal-error)
;; Restore the NPX for lisp; insure no regs are empty.
(dotimes (i 7)
(inst fldz))
(if (and results
(location= (tn-ref-tn results) fr0-tn))
;; The return result is in fr0.
(inst fxch fr7-tn) ; move the result back to fr0
(inst fldz)) ; insure no regs are empty
))))
(define-vop (alloc-number-stack-space)
(:info amount)
(:results (result :scs (sap-reg any-reg)))
(:generator 0
(assert (location= result rsp-tn))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst sub rsp-tn delta)))
(move result rsp-tn)))
(define-vop (dealloc-number-stack-space)
(:info amount)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst add rsp-tn delta)))))
(define-vop (alloc-alien-stack-space)
(:info amount)
(:results (result :scs (sap-reg any-reg)))
(:generator 0
(assert (not (location= result rsp-tn)))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst mov result (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
(- other-pointer-type)))
(inst sub (make-ea :qword :base result)
delta)))
(load-symbol-value result *alien-stack*)))
(define-vop (dealloc-alien-stack-space)
(:temporary (:sc any-reg) temp-tn) ; from/to?
(:info amount)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst mov temp-tn (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
(- other-pointer-type)))
(inst add (make-ea :qword :base temp-tn)
delta)))))
;;; Support for callbacks to Lisp.
(export '(make-callback-trampoline callback-accessor-form))
(defun callback-accessor-form (type sp offset)
`(alien:deref (sap-alien
(sys:sap+ ,sp ,offset)
(* ,type))))
(defun make-callback-trampoline (index return-type)
"Cons up a piece of code which calls call-callback with INDEX and a
pointer to the arguments."
(let* ((segment (make-segment))
(rax amd64::rax-tn)
(rdx amd64::rdx-tn)
(rbp amd64::rbp-tn)
(rsp amd64::rsp-tn)
([rbp-8] (amd64::make-ea :qword :base rbp :disp -8))
([rbp-4] (amd64::make-ea :qword :base rbp :disp -4)))
(assemble (segment)
(inst push rbp) ; save old frame pointer
(inst mov rbp rsp) ; establish new frame
(inst mov rax rsp) ;
(inst sub rax 8) ; place for result
(inst push rax) ; arg2
(inst add rax 16) ; arguments
(inst push rax) ; arg1
(inst push (ash index 2)) ; arg0
(inst push (alien::address-of-call-callback)) ; function
(inst mov rax (alien::address-of-funcall3))
(inst call rax)
;; now put the result into the right register
(etypecase return-type
(alien::integer-64$
(inst mov rax [rbp-8])
(inst mov rdx [rbp-4]))
((or alien::integer$ alien::pointer$ alien::sap$)
(inst mov rax [rbp-8]))
(alien::single$
(inst fld [rbp-8]))
(alien::double$
(inst fldd [rbp-8]))
(alien::void$ ))
(inst mov rsp rbp) ; discard frame
(inst pop rbp) ; restore frame pointer
(inst ret))
(let* ((length (finalize-segment segment)))
(prog1 (alien::segment-to-trampoline segment length)
(release-segment segment)))))
This diff is collapsed.
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/cell.lisp,v 1.1 2004/05/24 22:34:59 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the VM definition of various primitive memory access
;;; VOPs for the amd64.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1999.
;;;
(in-package :amd64)
;;;; Data object ref/set stuff.
(define-vop (slot)
(:args (object :scs (descriptor-reg)))
(:info name offset lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg any-reg)))
(:generator 1
(loadw result object offset lowtag)))
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg immediate)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:generator 1
(if (sc-is value immediate)
(let ((val (tn-value value)))
(etypecase val
(integer
(inst mov
(make-ea :qword :base object
:disp (- (* offset word-bytes) lowtag))
(fixnumize val)))
(symbol
(inst mov
(make-ea :qword :base object
:disp (- (* offset word-bytes) lowtag))
(+ nil-value (static-symbol-offset val))))
(character
(inst mov
(make-ea :qword :base object
:disp (- (* offset word-bytes) lowtag))
(logior (ash (char-code val) type-bits)
base-char-type)))))
;; Else, value not immediate.
(storew value object offset lowtag))))
;;;; Symbol hacking VOPs:
;;; these next two cf the sparc version, by jrd.
;;; The compiler likes to be able to directly SET symbols.
;;;
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-type))
;;; Do a cell ref with an error check for being unbound.
;;;
(define-vop (checked-cell-ref)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
;;; With Symbol-Value, we check that the value isn't the trap object. So
;;; Symbol-Value of NIL is NIL.
;;;
(define-vop (symbol-value)
(:translate symbol-value)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 9
(let ((err-lab (generate-error-code vop unbound-symbol-error object)))
(loadw value object symbol-value-slot other-pointer-type)
(inst cmp value unbound-marker-type)
(inst jmp :e err-lab))))
(define-vop (fast-symbol-value cell-ref)
(:variant symbol-value-slot other-pointer-type)
(:policy :fast)
(:translate symbol-value))
(export 'kernel::set-symbol-value-conditional "KERNEL")
(defknown kernel::set-symbol-value-conditional (symbol t t) t (unsafe))
(define-vop (set-symbol-value-conditional cell-set-conditional)
(:translate kernel::set-symbol-value-conditional)
(:variant symbol-value-slot other-pointer-type)
(:policy :fast-safe))
(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
(define-vop (fast-symbol-value-xadd cell-xadd)
(:variant symbol-value-slot other-pointer-type)
(:policy :fast)
(:translate fast-symbol-value-xadd)
(:arg-types * tagged-num))
(define-vop (boundp)
(:translate boundp)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:conditional)
(:info target not-p)
(:temporary (:sc descriptor-reg :from (:argument 0)) value)
(:generator 9
(loadw value object symbol-value-slot other-pointer-type)
(inst cmp value unbound-marker-type)
(inst jmp (if not-p :e :ne) target)))
(define-vop (symbol-hash)
(:policy :fast-safe)
(:translate symbol-hash)
(:args (symbol :scs (descriptor-reg)))
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 2
;; the symbol-hash slot of NIL holds NIL because it is also the cdr
;; slot, so we have to strip off the two low bits to make sure it is
;; a fixnum.
(loadw res symbol symbol-hash-slot other-pointer-type)
(inst and res (lognot #b11))))
;;;; Fdefinition (fdefn) objects.
(define-vop (fdefn-function cell-ref) ; /pfw - alpha
(:variant fdefn-function-slot other-pointer-type))
(define-vop (safe-fdefn-function)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 10
(loadw value object fdefn-function-slot other-pointer-type)
(inst cmp value nil-value)
(let ((err-lab (generate-error-code vop undefined-symbol-error object)))
(inst jmp :e err-lab))))
(define-vop (set-fdefn-function)
(:policy :fast-safe)
(:translate (setf fdefn-function))
(:args (function :scs (descriptor-reg) :target result)
(fdefn :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) raw)
(:temporary (:sc byte-reg) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
(load-type type function (- function-pointer-type))
(inst lea raw
(make-ea :byte :base function
:disp (- (* function-code-offset word-bytes)
function-pointer-type)))
(inst cmp type function-header-type)
(inst jmp :e normal-fn)
(inst mov-imm raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
NORMAL-FN
(storew function fdefn fdefn-function-slot other-pointer-type)
(storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
(move result function)))
(define-vop (fdefn-makunbound)
(:policy :fast-safe)
(:translate fdefn-makunbound)
(:args (fdefn :scs (descriptor-reg) :target result))
(:results (result :scs (descriptor-reg)))
(:generator 38
(storew nil-value fdefn fdefn-function-slot other-pointer-type)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
fdefn fdefn-raw-addr-slot other-pointer-type)
(move result fdefn)))
;;;; Binding and Unbinding.
;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
;;; the symbol on the binding stack and stuff the new value into the
;;; symbol.
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
(symbol :scs (descriptor-reg)))
(:temporary (:sc descriptor-reg) temp)
(:temporary (:sc any-reg) bsp)
(:temporary (:sc any-reg) temp2)
(:generator 5
(load-symbol-value bsp *binding-stack-pointer*)
(loadw temp symbol symbol-value-slot other-pointer-type)
(inst add bsp (* binding-size word-bytes))
(store-symbol-value bsp *binding-stack-pointer* temp2)
(storew temp bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
(storew val symbol symbol-value-slot other-pointer-type)))
(define-vop (unbind)
(:temporary (:sc descriptor-reg) symbol value)
(:temporary (:sc any-reg) bsp)
(:generator 0
(load-symbol-value bsp *binding-stack-pointer*)
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-type)
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size word-bytes))
(store-symbol-value bsp *binding-stack-pointer* symbol)))
(define-vop (unbind-to-here)
(:args (where :scs (descriptor-reg any-reg)))
(:temporary (:sc descriptor-reg) symbol value)
(:temporary (:sc any-reg) bsp)
(:generator 0
(load-symbol-value bsp *binding-stack-pointer*)
(inst cmp where bsp)
(inst jmp :e done)
LOOP
(loadw symbol bsp (- binding-symbol-slot binding-size))
(inst or symbol symbol)
(inst jmp :z skip)
(loadw value bsp (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-type)
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
(inst sub bsp (* binding-size word-bytes))
(inst cmp where bsp)
(inst jmp :ne loop)
(store-symbol-value bsp *binding-stack-pointer* symbol)
DONE))
;;;; Closure indexing.
(define-full-reffer closure-index-ref *
closure-info-offset function-pointer-type
(any-reg descriptor-reg) * %closure-index-ref)
(define-full-setter set-funcallable-instance-info *
funcallable-instance-info-offset function-pointer-type
(any-reg descriptor-reg) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
funcallable-instance-info-offset function-pointer-type
(descriptor-reg any-reg) * %funcallable-instance-info)
(define-vop (funcallable-instance-lexenv cell-ref)
(:variant funcallable-instance-lexenv-slot function-pointer-type))
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset function-pointer-type))
(define-vop (closure-init slot-set)
(:variant closure-info-offset function-pointer-type))
;;;; Value Cell hackery.
(define-vop (value-cell-ref cell-ref)
(:variant value-cell-value-slot other-pointer-type))
(define-vop (value-cell-set cell-set)
(:variant value-cell-value-slot other-pointer-type))
;;;; Structure hackery:
(define-vop (instance-length)
(:policy :fast-safe)
(:translate %instance-length)
(:args (struct :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 4
(loadw res struct 0 instance-pointer-type)
(inst shr res type-bits)))
(define-vop (instance-ref slot-ref)
(:variant instance-slots-offset instance-pointer-type)
(:policy :fast-safe)
(:translate %instance-ref)
(:arg-types instance (:constant index)))
(define-vop (instance-set slot-set)
(:policy :fast-safe)
(:translate %instance-set)
(:variant instance-slots-offset instance-pointer-type)
(:arg-types instance (:constant index) *))
(define-full-reffer instance-index-ref * instance-slots-offset
instance-pointer-type (any-reg descriptor-reg) * %instance-ref)
(define-full-setter instance-index-set * instance-slots-offset
instance-pointer-type (any-reg descriptor-reg) * %instance-set)
(export 'kernel::%instance-set-conditional "KERNEL")
(defknown kernel::%instance-set-conditional (instance index t t) t
(unsafe))
(define-vop (instance-set-conditional-c slot-set-conditional)
(:policy :fast-safe)
(:translate kernel::%instance-set-conditional)
(:variant instance-slots-offset instance-pointer-type)
(:arg-types instance (:constant index) * *))
(define-vop (instance-set-conditional)
(:translate kernel::%instance-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
(slot :scs (any-reg) :to :result)
(old-value :scs (descriptor-reg any-reg) :target rax)
(new-value :scs (descriptor-reg any-reg)))
(:arg-types instance positive-fixnum * *)
(:temporary (:sc descriptor-reg :offset rax-offset
:from (:argument 2) :to :result :target result) rax)
(:results (result :scs (descriptor-reg any-reg)))
(:guard (backend-featurep :i486))
(:policy :fast-safe)
(:generator 5
(move rax old-value)
(inst cmpxchg (make-ea :qword :base object :index slot :scale 1
:disp (- (* instance-slots-offset word-bytes)
instance-pointer-type))
new-value)
(move result rax)))
(defknown %instance-xadd (instance index fixnum) fixnum ())
(define-vop (instance-xadd-c slot-xadd)
(:policy :fast-safe)
(:translate %instance-xadd)
(:variant instance-slots-offset instance-pointer-type)
(:arg-types instance (:constant index) tagged-num))
;;;; Code object frobbing.
(define-full-reffer code-header-ref * 0 other-pointer-type
(any-reg descriptor-reg) * code-header-ref)
(define-full-setter code-header-set * 0 other-pointer-type
(any-reg descriptor-reg) * code-header-set)
;;;; Cons conditional setters.
(export 'kernel::rplaca-conditional "KERNEL")
(defknown kernel::rplaca-conditional (cons t t) t
(unsafe))
(define-vop (rplaca-conditional cell-set-conditional)
(:policy :fast-safe)
(:translate kernel::rplaca-conditional)
(:variant cons-car-slot list-pointer-type)
(:arg-types list * *))
(export 'kernel::rplacd-conditional "KERNEL")
(defknown kernel::rplacd-conditional (cons t t) t
(unsafe))
(define-vop (rplacd-conditional cell-set-conditional)
(:policy :fast-safe)
(:translate kernel::rplacd-conditional)
(:variant cons-cdr-slot list-pointer-type)
(:arg-types list * *))
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/char.lisp,v 1.1 2004/05/24 22:34:59 cwang Rel $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the x86 VM definition of character operations.
;;;
;;; Written by Rob MacLachlan
;;; Converted for the MIPS R2000 by Christopher Hoover.
;;; And then to the SPARC by William Lott.
;;; And then to the x86, again by William.
;;;
;;; Debugged by Paul F. Werkowski, June-95.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
;;;
(in-package :amd64)
;;;; Moves and coercions:
;;; Move a tagged char to an untagged representation.
;;;
(define-vop (move-to-base-char)
(:args (x :scs (any-reg control-stack) :target al))
(:temporary (:sc byte-reg :offset al-offset
:from (:argument 0) :to (:eval 0)) al)
(:ignore al)
(:temporary (:sc byte-reg :offset ah-offset :target y
:from (:argument 0) :to (:result 0)) ah)
(:results (y :scs (base-char-reg base-char-stack)))
(:note "character untagging")
(:generator 1
(move rax-tn x)
(move y ah)))
;;;
(define-move-vop move-to-base-char :move
(any-reg control-stack) (base-char-reg base-char-stack))
;;; Move an untagged char to a tagged representation.
;;;
(define-vop (move-from-base-char)
(:args (x :scs (base-char-reg base-char-stack) :target ah))
(:temporary (:sc byte-reg :offset al-offset :target y
:from (:argument 0) :to (:result 0)) al)
(:temporary (:sc byte-reg :offset ah-offset
:from (:argument 0) :to (:result 0)) ah)
(:results (y :scs (any-reg descriptor-reg control-stack)))
(:note "character tagging")
(:generator 1
(move ah x) ; maybe move char byte
(inst mov al base-char-type) ; #x86 to type bits
(inst and rax-tn #xffff) ; remove any junk bits
(move y rax-tn)))
;;;
(define-move-vop move-from-base-char :move
(base-char-reg base-char-stack) (any-reg descriptor-reg control-stack))
;;; Move untagged base-char values.
;;;
(define-vop (base-char-move)
(:args (x :target y
:scs (base-char-reg)
:load-if (not (location= x y))))
(:results (y :scs (base-char-reg base-char-stack)
:load-if (not (location= x y))))
(:note "character move")
(:effects)
(:affected)
(:generator 0
(move y x)))
;;;
(define-move-vop base-char-move :move
(base-char-reg) (base-char-reg base-char-stack))
;;; Move untagged base-char arguments/return-values.
;;;
(define-vop (move-base-char-argument)
(:args (x :target y
:scs (base-char-reg))
(fp :scs (any-reg)
:load-if (not (sc-is y base-char-reg))))
(:results (y))
(:note "character arg move")
(:generator 0
(sc-case y
(base-char-reg
(move y x))
(base-char-stack
(inst mov
(make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) word-bytes)))
x)))))
;;;
(define-move-vop move-base-char-argument :move-argument
(any-reg base-char-reg) (base-char-reg))
;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
;;; to a descriptor passing location.
;;;
(define-move-vop move-argument :move-argument
(base-char-reg) (any-reg descriptor-reg))
;;;; Other operations:
(define-vop (char-code)
(:translate char-code)
(:policy :fast-safe)
(:args (ch :scs (base-char-reg base-char-stack)))
(:arg-types base-char)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
;; ah to dh are not addressable when a rex prefix is used
;; The high 32 bits of doubleword operands are
;; zero-extended to 64-bits.
(inst movzx (64-bit-to-32-bit-tn res) ch)))
(define-vop (code-char)
(:translate code-char)
(:policy :fast-safe)
(:args (code :scs (unsigned-reg unsigned-stack) :target rax))
(:arg-types positive-fixnum)
(:temporary (:sc unsigned-reg :offset rax-offset :target res
:from (:argument 0) :to (:result 0))
rax)
(:results (res :scs (base-char-reg)))
(:result-types base-char)
(:generator 1
(move rax code)
(move res al-tn)))
;;; Comparison of base-chars.
;;;
(define-vop (base-char-compare)
(:args (x :scs (base-char-reg base-char-stack))
(y :scs (base-char-reg)
:load-if (not (and (sc-is x base-char-reg)
(sc-is y base-char-stack)))))
(:arg-types base-char base-char)
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:note "inline comparison")
(:variant-vars condition not-condition)
(:generator 3
(inst cmp x y)
(inst jmp (if not-p not-condition condition) target)))
(define-vop (fast-char=/base-char base-char-compare)
(:translate char=)
(:variant :e :ne))
(define-vop (fast-char</base-char base-char-compare)
(:translate char<)
(:variant :b :nb))
(define-vop (fast-char>/base-char base-char-compare)
(:translate char>)
(:variant :a :na))
(define-vop (base-char-compare-c)
(:args (x :scs (base-char-reg)))
(:arg-types base-char (:constant base-char))
(:conditional)
(:info target not-p y)
(:policy :fast-safe)
(:note "inline comparison")
(:variant-vars condition not-condition)
(:generator 2
(inst cmp x (char-code y))
(inst jmp (if not-p not-condition condition) target)))
(define-vop (fast-char=-c/base-char base-char-compare-c)
(:translate char=)
(:variant :eq :ne))
(define-vop (fast-char<-c/base-char base-char-compare-c)
(:translate char<)
(:variant :b :nb))
(define-vop (fast-char>-c/base-char base-char-compare-c)
(:translate char>)
(:variant :a :na))
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/debug.lisp,v 1.1 2004/05/24 22:34:59 cwang Rel $")
;;;
;;; **********************************************************************
;;;
;;; Compiler support for the new whizzy debugger.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
;;;
(in-package :amd64)
(define-vop (debug-cur-sp)
(:translate current-sp)
(:policy :fast-safe)
(:results (res :scs (sap-reg sap-stack)))
(:result-types system-area-pointer)
(:generator 1
(move res rsp-tn)))
(define-vop (debug-cur-fp)
(:translate current-fp)
(:policy :fast-safe)
(:results (res :scs (sap-reg sap-stack)))
(:result-types system-area-pointer)
(:generator 1
(move res rbp-tn)))
;;; Stack-ref and %set-stack-ref can be used to read and store
;;; descriptor objects on the control stack. Use the sap-ref
;;; functions to access other data types.
(define-vop (read-control-stack)
(:translate stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to :eval)
(offset :scs (any-reg) :target temp))
(:arg-types system-area-pointer positive-fixnum)
(:temporary (:sc unsigned-reg :from (:argument 1)) temp)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 9
(move temp offset)
(inst neg temp)
(inst mov result
(make-ea :qword :base sap :disp (- word-bytes) :index temp))))
(define-vop (read-control-stack-c)
(:translate stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg)))
(:info index)
(:arg-types system-area-pointer (:constant (signed-byte 30)))
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
(inst mov result (make-ea :qword :base sap
:disp (- (* (1+ index) word-bytes))))))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to :eval)
(offset :scs (any-reg) :target temp)
(value :scs (descriptor-reg) :to :result :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 9
(move temp offset)
(inst neg temp)
(inst mov
(make-ea :qword :base sap :disp (- word-bytes) :index temp) value)
(move result value)))
(define-vop (write-control-stack-c)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
(value :scs (descriptor-reg) :target result))
(:info index)
(:arg-types system-area-pointer (:constant (signed-byte 30)) *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
(inst mov (make-ea :qword :base sap
:disp (- (* (1+ index) word-bytes)))
value)
(move result value)))
(define-vop (code-from-mumble)
(:policy :fast-safe)
(:args (thing :scs (descriptor-reg)))
(:results (code :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:variant-vars lowtag)
(:generator 5
(let ((bogus (gen-label))
(done (gen-label)))
(loadw temp thing 0 lowtag)
(inst shr temp type-bits)
(inst jmp :z bogus)
(inst shl temp (1- (integer-length word-bytes)))
(unless (= lowtag other-pointer-type)
(inst add temp (- lowtag other-pointer-type)))
(move code thing)
(inst sub code temp)
(emit-label done)
(assemble (*elsewhere*)
(emit-label bogus)
(inst mov code nil-value)
(inst jmp done)))))
(define-vop (code-from-lra code-from-mumble)
(:translate di::lra-code-header)
(:variant other-pointer-type))
(define-vop (code-from-function code-from-mumble)
(:translate di::function-code-header)
(:variant function-pointer-type))
(define-vop (make-lisp-obj)
(:policy :fast-safe)
(:translate di::make-lisp-obj)
(:args (value :scs (unsigned-reg unsigned-stack) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)
:load-if (not (sc-is value unsigned-reg))
))
(:generator 1
(move result value)))
(define-vop (get-lisp-obj-address)
(:policy :fast-safe)
(:translate di::get-lisp-obj-address)
(:args (thing :scs (descriptor-reg control-stack) :target result))
(:results (result :scs (unsigned-reg)
:load-if (not (and (sc-is thing descriptor-reg)
(sc-is result unsigned-stack)))))
(:result-types unsigned-num)
(:generator 1
(move result thing)))
(define-vop (function-word-offset)
(:policy :fast-safe)
(:translate di::function-word-offset)
(:args (fun :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 5
(loadw res fun 0 function-pointer-type)
(inst shr res type-bits)))
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/memory.lisp,v 1.1 2004/05/24 22:35:00 cwang Rel $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the x86 definitions of some general purpose memory
;;; reference VOPs inherited by basic memory reference operations.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1999.
;;;
(in-package :amd64)
;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
;;; be read or written is a property of the VOP used. Cell-Setf is similar to
;;; Cell-Set, but delivers the new value as the result. Cell-Setf-Function
;;; takes its arguments as if it were a setf function (new value first, as
;;; apposed to a setf macro, which takes the new value last).
;;;
(define-vop (cell-ref)
(:args (object :scs (descriptor-reg)))
(:results (value :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(loadw value object offset lowtag)))
;;;
(define-vop (cell-set)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(storew value object offset lowtag)))
;;;
(define-vop (cell-setf)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg) :target result))
(:results (result :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(storew value object offset lowtag)
(move result value)))
;;;
(define-vop (cell-setf-function)
(:args (value :scs (descriptor-reg any-reg) :target result)
(object :scs (descriptor-reg)))
(:results (result :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(storew value object offset lowtag)
(move result value)))
;;; Define-Cell-Accessors -- Interface
;;;
;;; Define accessor VOPs for some cells in an object. If the operation name
;;; is NIL, then that operation isn't defined. If the translate function is
;;; null, then we don't define a translation.
;;;
(defmacro define-cell-accessors (offset lowtag
ref-op ref-trans set-op set-trans)
`(progn
,@(when ref-op
`((define-vop (,ref-op cell-ref)
(:variant ,offset ,lowtag)
,@(when ref-trans
`((:translate ,ref-trans))))))
,@(when set-op
`((define-vop (,set-op cell-setf)
(:variant ,offset ,lowtag)
,@(when set-trans
`((:translate ,set-trans))))))))
(define-vop (cell-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
(old-value :scs (descriptor-reg any-reg) :target rax)
(new-value :scs (descriptor-reg any-reg)))
(:temporary (:sc descriptor-reg :offset rax-offset
:from (:argument 1) :to :result :target result) rax)
(:variant-vars offset lowtag)
(:results (result :scs (descriptor-reg any-reg)))
(:guard (backend-featurep :i486))
(:generator 4
(move rax old-value)
(inst cmpxchg (make-ea :qword :base object
:disp (- (* offset word-bytes) lowtag))
new-value)
(move result rax)))
;;; X86 special
(define-vop (cell-xadd)
(:args (object :scs (descriptor-reg) :to :result)
(value :scs (any-reg) :target result))
(:results (result :scs (any-reg) :from (:argument 1)))
(:result-types tagged-num)
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(move result value)
(inst xadd (make-ea :qword :base object
:disp (- (* offset word-bytes) lowtag))
value)))
;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
;;; offset is constant at compile time, but varies for different uses.
;;;
(define-vop (slot-ref)
(:args (object :scs (descriptor-reg)))
(:results (value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(loadw value object (+ base offset) lowtag)))
;;;
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg immediate)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(if (sc-is value immediate)
(let ((val (tn-value value)))
(etypecase val
(integer
(inst mov
(make-ea :qword :base object
:disp (- (* (+ base offset) word-bytes) lowtag))
(fixnumize val)))
(symbol
(inst mov
(make-ea :qword :base object
:disp (- (* (+ base offset) word-bytes) lowtag))
(+ nil-value (static-symbol-offset val))))
(character
(inst mov
(make-ea :qword :base object
:disp (- (* (+ base offset) word-bytes) lowtag))
(logior (ash (char-code val) type-bits)
base-char-type)))))
;; Else, value not immediate.
(storew value object (+ base offset) lowtag))))
(define-vop (slot-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
(old-value :scs (descriptor-reg any-reg) :target rax)
(new-value :scs (descriptor-reg any-reg)))
(:temporary (:sc descriptor-reg :offset rax-offset
:from (:argument 1) :to :result :target result) rax)
(:variant-vars base lowtag)
(:results (result :scs (descriptor-reg any-reg)))
(:info offset)
(:guard (backend-featurep :i486))
(:generator 4
(move rax old-value)
(inst cmpxchg (make-ea :qword :base object
:disp (- (* (+ base offset) word-bytes) lowtag))
new-value)
(move result rax)))
;;; X86 special
(define-vop (slot-xadd)
(:args (object :scs (descriptor-reg) :to :result)
(value :scs (any-reg) :target result))
(:results (result :scs (any-reg) :from (:argument 1)))
(:result-types tagged-num)
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(move result value)
(inst xadd (make-ea :qword :base object
:disp (- (* (+ base offset) word-bytes) lowtag))
value)))
This diff is collapsed.
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/nlx.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the VM definition of non-local exit for the x86.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998.
;;;
(in-package :amd64)
;;; MAKE-NLX-SP-TN -- Interface
;;;
;;; Make an environment-live stack TN for saving the SP for NLX entry.
;;;
(def-vm-support-routine make-nlx-sp-tn (env)
(environment-live-tn
(make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
env))
;;; Make-NLX-Entry-Argument-Start-Location -- Interface
;;;
;;; Make a TN for the argument count passing location for a
;;; non-local entry.
;;;
(def-vm-support-routine make-nlx-entry-argument-start-location ()
(make-wired-tn *fixnum-primitive-type* any-reg-sc-number rbx-offset))
(defun catch-block-ea (tn)
(assert (sc-is tn catch-block))
(make-ea :qword :base rbp-tn
:disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes))))
;;; Save and restore dynamic environment.
;;;
;;; These VOPs are used in the reentered function to restore the
;;; appropriate dynamic environment. Currently we only save the
;;; Current-Catch, the eval stack pointer, and the alien stack
;;; pointer.
;;;
;;; We don't need to save/restore the current unwind-protect, since
;;; unwind-protects are implicitly processed during unwinding.
;;;
;;; We don't need to save the BSP, because that is handled automatically.
;;; Make-Dynamic-State-TNs -- Interface
;;;
;;; Return a list of TNs that can be used to snapshot the dynamic state for
;;; use with the Save/Restore-Dynamic-Environment VOPs.
;;;
(def-vm-support-routine make-dynamic-state-tns ()
(make-n-tns 3 *any-primitive-type*))
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
(eval :scs (descriptor-reg))
(alien-stack :scs (descriptor-reg)))
(:generator 13
(load-symbol-value catch lisp::*current-catch-block*)
(load-symbol-value eval lisp::*eval-stack-top*)
(load-symbol-value alien-stack *alien-stack*)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
(eval :scs (descriptor-reg))
(alien-stack :scs (descriptor-reg)))
(:temporary (:sc descriptor-reg) temp)
(:generator 10
(store-symbol-value catch lisp::*current-catch-block* temp)
(store-symbol-value eval lisp::*eval-stack-top* temp)
(store-symbol-value alien-stack *alien-stack* temp)))
(define-vop (current-stack-pointer)
(:results (res :scs (any-reg control-stack)))
(:generator 1
(move res rsp-tn)))
(define-vop (current-binding-pointer)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
(load-symbol-value res *binding-stack-pointer*)))
;;;; Unwind block hackery:
;;; Compute the address of the catch block from its TN, then store into the
;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
(define-vop (make-unwind-block)
(:args (tn))
(:info entry-label)
(:temporary (:sc unsigned-reg) temp)
(:results (block :scs (any-reg)))
(:generator 22
(inst lea block (catch-block-ea tn))
(load-symbol-value temp lisp::*current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew rbp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)))
;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
;;; link the block into the Current-Catch list.
;;;
(define-vop (make-catch-block)
(:args (tn)
(tag :scs (descriptor-reg any-reg) :to (:result 1)))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:sc descriptor-reg) temp)
(:generator 44
(inst lea block (catch-block-ea tn))
(load-symbol-value temp lisp::*current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew rbp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)
(storew tag block catch-block-tag-slot)
(load-symbol-value temp lisp::*current-catch-block*)
(storew temp block catch-block-previous-catch-slot)
(store-symbol-value block lisp::*current-catch-block* temp)))
;;; Just set the current unwind-protect to TN's address. This instantiates an
;;; unwind block as an unwind-protect.
;;;
(define-vop (set-unwind-protect)
(:args (tn))
(:temporary (:sc unsigned-reg) new-uwp)
(:generator 7
(inst lea new-uwp (catch-block-ea tn))
(store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
(define-vop (unlink-catch-block)
(:temporary (:sc unsigned-reg) block)
(:policy :fast-safe)
(:translate %catch-breakup)
(:generator 17
(load-symbol-value block lisp::*current-catch-block*)
(loadw block block catch-block-previous-catch-slot)
(store-symbol-value block lisp::*current-catch-block*)))
(define-vop (unlink-unwind-protect)
(:temporary (:sc unsigned-reg) block)
(:policy :fast-safe)
(:translate %unwind-protect-breakup)
(:generator 17
(load-symbol-value block lisp::*current-unwind-protect-block*)
(loadw block block unwind-block-current-uwp-slot)
(store-symbol-value block lisp::*current-unwind-protect-block*)))
;;;; NLX entry VOPs:
(define-vop (nlx-entry)
;; Note: we can't list an sc-restriction, 'cause any load vops would
;; be inserted before the return-pc label.
(:args (sp)
(start)
(count))
(:results (values :more t))
(:temporary (:sc descriptor-reg) move-temp)
(:info label nvals)
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-label label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
((= nvals 1)
(let ((no-values (gen-label)))
(inst mov (tn-ref-tn values) nil-value)
(inst jecxz no-values)
(loadw (tn-ref-tn values) start -1)
(emit-label no-values)))
(t
(collect ((defaults))
(do ((i 0 (1+ i))
(tn-ref values (tn-ref-across tn-ref)))
((null tn-ref))
(let ((default-lab (gen-label))
(tn (tn-ref-tn tn-ref)))
(defaults (cons default-lab tn))
(inst cmp count (fixnumize i))
(inst jmp :le default-lab)
(sc-case tn
((descriptor-reg any-reg)
(loadw tn start (- (1+ i))))
((control-stack)
(loadw move-temp start (- (1+ i)))
(inst mov tn move-temp)))))
(let ((defaulting-done (gen-label)))
(emit-label defaulting-done)
(assemble (*elsewhere*)
(dolist (def (defaults))
(emit-label (car def))
(inst mov (cdr def) nil-value))
(inst jmp defaulting-done))))))
(inst mov rsp-tn sp)))
(define-vop (nlx-entry-multiple)
(:args (top)
(source)
(count :target rcx))
;; Again, no SC restrictions for the args, 'cause the loading would
;; happen before the entry label.
(:info label)
(:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 2)) rcx)
(:temporary (:sc unsigned-reg :offset rsi-offset) rsi)
(:temporary (:sc unsigned-reg :offset rdi-offset) rdi)
(:results (result :scs (any-reg) :from (:argument 0))
(num :scs (any-reg control-stack)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-label label)
(note-this-location vop :non-local-entry)
(inst lea rsi (make-ea :qword :base source :disp (- word-bytes)))
;; The 'top' arg contains the %esp value saved at the time the
;; catch block was created and points to where the thrown values
;; should sit.
(move rdi top)
(move result rdi)
(inst sub rdi word-bytes)
(move rcx count) ; fixnum words == bytes
(move num rcx)
(inst shr rcx word-shift) ; word count for <rep movs>
;; If we got zero, we be done.
(inst jecxz done)
;; Copy them down.
(inst std)
(inst rep)
(inst movs :qword)
DONE
;; Reset the CSP at last moved arg.
(inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes))))
;;; This VOP is just to force the TNs used in the cleanup onto the stack.
;;;
(define-vop (uwp-entry)
(:info label)
(:save-p :force-to-stack)
(:results (block) (start) (count))
(:ignore block start count)
(:vop-var vop)
(:generator 0
(emit-label label)
(note-this-location vop :non-local-entry)))
This diff is collapsed.
This diff is collapsed.
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/print.lisp,v 1.1 2004/05/24 22:35:00 cwang Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the print VOP, which is used while booting the kernel
;;; core to keep the user entertained.
;;;
;;; Written by William Lott.
;;; Enhancements/debugging by Douglas T. Crosher 1996.
;;;
(in-package :amd64)
(define-vop (print)
(:args (object :scs (descriptor-reg any-reg)))
(:temporary (:sc unsigned-reg :offset rax-offset :target result
:from :eval :to :result) rax)
(:temporary (:sc unsigned-reg :offset rdi-offset) rdi) ; from/to?
(:results (result :scs (descriptor-reg)))
(:save-p t)
(:generator 100
(move rdi object) ;; C arg 1
;; LEA can't be used because it can only do sign-extended 32 bit argument.
;; We need to specify immediate here because we don't want to be indirected
(inst mov-imm rax (make-fixup (extern-alien-name "debug_print") :foreign))
(inst call (make-fixup (extern-alien-name "call_into_c") :foreign))
(move result rax)))
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment