#!+x86 "SET-FPU-WORD-FOR-C"
#!+x86 "SET-FPU-WORD-FOR-LISP"
+ "ALIGN-STACK-POINTER"
"ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE"
"ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME"
"ALLOCATE-DYNAMIC-CODE-OBJECT" "ALLOCATE-FULL-CALL-FRAME"
"COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUN"
"COMPUTE-OLD-NFP" "COPY-MORE-ARG"
"CURRENT-BINDING-POINTER" "CURRENT-NFP-TN"
- "CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE"
+ "CURRENT-STACK-POINTER"
+ "DEALLOC-ALIEN-STACK-SPACE"
"DEALLOC-NUMBER-STACK-SPACE"
"DEBUG-CATCH-TAG"
"DEF-IR1-TRANSLATOR"
(/noshow (local-alien-info-force-to-memory-p info))
(/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
(if (local-alien-info-force-to-memory-p info)
- #!+(or x86 x86-64) `(truly-the system-area-pointer
- (%primitive alloc-alien-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
- #!-(or x86 x86-64) `(truly-the system-area-pointer
- (%primitive alloc-number-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
+ #!+(or x86 x86-64)
+ `(truly-the system-area-pointer
+ (%primitive alloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits)))
+ #!-(or x86 x86-64)
+ `(truly-the system-area-pointer
+ (%primitive alloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits)))
(let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
(alien-rep-type (specifier-type alien-rep-type-spec)))
(cond ((csubtypep (specifier-type 'system-area-pointer)
(error "Something is broken.")))
(lvar (node-lvar call))
(args args)
- #!+(or (and x86 darwin) win32) (stack-pointer (make-stack-pointer-tn)))
+ #!+x86
+ (stack-pointer (make-stack-pointer-tn)))
(multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
(make-call-out-tns type)
- #!+x86 (vop set-fpu-word-for-c call block)
- #!+(or (and x86 darwin) win32) (vop current-stack-pointer call block stack-pointer)
+ #!+x86
+ (progn
+ (vop set-fpu-word-for-c call block)
+ (vop current-stack-pointer call block stack-pointer))
(vop alloc-number-stack-space call block stack-frame-size nsp)
(dolist (tn arg-tns)
;; On PPC, TN might be a list. This is used to indicate
(unless (= (length move-arg-vops) 1)
(error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
#!+(or x86 x86-64) (emit-move-arg-template call
- block
- (first move-arg-vops)
- (lvar-tn call block arg)
- nsp
- first-tn)
+ block
+ (first move-arg-vops)
+ (lvar-tn call block arg)
+ nsp
+ first-tn)
#!-(or x86 x86-64) (progn
- (emit-move call
- block
- (lvar-tn call block arg)
- temp-tn)
- (emit-move-arg-template call
- block
- (first move-arg-vops)
- temp-tn
- nsp
- first-tn))
+ (emit-move call
+ block
+ (lvar-tn call block arg)
+ temp-tn)
+ (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ temp-tn
+ nsp
+ first-tn))
#!+(and ppc darwin)
(when (listp tn)
;; This means that we have a float arg that we need to
((lvar-tn call block function)
(reference-tn-list arg-tns nil))
((reference-tn-list result-tns t))))
- #!-(or (and darwin x86) win32) (vop dealloc-number-stack-space call block stack-frame-size)
- #!+(or (and darwin x86) win32) (vop reset-stack-pointer call block stack-pointer)
- #!+x86 (vop set-fpu-word-for-lisp call block)
+ #!-x86
+ (vop dealloc-number-stack-space call block stack-frame-size)
+ #!+x86
+ (progn
+ (vop reset-stack-pointer call block stack-pointer)
+ (vop set-fpu-word-for-lisp call block))
(move-lvar-result call block result-tns lvar))))
:from :eval :to :result) ecx)
(:temporary (:sc unsigned-reg :offset edx-offset
:from :eval :to :result) edx)
- #!+darwin
- (:temporary (:sc unsigned-reg :offset esi-offset) prev-esp)
(:node-var node)
(:vop-var vop)
(:save-p t)
(dotimes (i 8)
(inst fstp fr0-tn))
- #!+win32
+ ;; Clear out DF: Darwin, Windows, and Solaris at least require
+ ;; this, and it should not hurt others either.
(inst cld)
- #!+darwin
- ;; Align stack for C.
- (progn
- (move prev-esp esp-tn)
- (inst and esp-tn -16))
-
(inst call function)
- ;; To give the debugger a clue. XX not really internal-error?
+ ;; To give the debugger a clue. FIXME: not really internal-error?
(note-this-location vop :internal-error)
- #!+darwin
- ;; Restore
- (move esp-tn prev-esp)
-
;; Restore the NPX for lisp; ensure 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
+ (inst fxch fr7-tn) ; move the result back to fr0
+ (inst fldz)) ; insure no regs are empty
))))
;;; While SBCL uses the FPU in 53-bit mode, most C libraries assume that
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst sub esp-tn delta)))
- ;; C stack should probably be 16 byte aligned on Darwin
- #!+darwin (inst and esp-tn -16)
+ (align-stack-pointer esp-tn)
(move result esp-tn)))
-(define-vop (dealloc-number-stack-space)
- (:info amount)
- (:generator 0
- (unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
- (inst add esp-tn delta)))))
-
(define-vop (alloc-alien-stack-space)
(:info amount)
#!+sb-thread (:temporary (:sc unsigned-reg) temp)
(inst mov eax-tn nil-value)
(inst std)
(inst mov ecx-tn (- nvals register-arg-count))
- ;; solaris requires DF being zero.
- #!+sunos (inst cld)
;; Jump into the default loop.
(inst jmp default-stack-vals)
(inst std)
(inst rep)
(inst movs :dword)
- ;; solaris requires DF being zero.
- #!+sunos (inst cld)
;; Restore ESI.
(loadw esi-tn ebx-tn (frame-word-offset 2))
;; Now we have to default the remaining args. Find out how many.
(emit-label default-stack-vals)
(inst rep)
(inst stos eax-tn)
- ;; solaris requires DF being zero.
- #!+sunos (inst cld)
;; Restore EDI, and reset the stack.
(emit-label restore-edi)
(loadw edi-tn ebx-tn (frame-word-offset 1))
(inst jmp :nz loop)
;; NIL out the last cons.
(storew nil-value dst 1 list-pointer-lowtag))
- (emit-label done)
- ;; solaris requires DF being zero.
- #!+sunos (inst cld))))
+ (emit-label done))))
;;; Return the location and size of the &MORE arg glob created by
;;; COPY-MORE-ARG. SUPPLIED is the total number of arguments supplied
`(unless (location= ,n-dst ,n-src)
(inst mov ,n-dst ,n-src))))
+(defmacro align-stack-pointer (tn)
+ #!-darwin (declare (ignore tn))
+ #!+darwin
+ ;; 16 byte alignment.
+ `(inst and ,tn #xfffffff0))
+
(defmacro make-ea-for-object-slot (ptr slot lowtag &optional (size :dword))
`(make-ea ,size :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
(inst movs :dword)
DONE
- ;; solaris requires DF being zero.
- #!+sunos (inst cld)
;; Reset the CSP at last moved arg.
(inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes))))
:from :eval
:to (:result 0))
eax)
- #!+darwin (:temporary (:sc unsigned-reg
- :offset esi-offset)
- prev-stack-pointer)
+ #!+darwin
+ (:temporary (:sc unsigned-reg
+ :offset esi-offset)
+ prev-stack-pointer)
(:results (result :scs (descriptor-reg)))
(:save-p t)
(:generator 100
- ;; the stack should be 16-byte aligned on Darwin
- #!-darwin (inst push object)
- #!+darwin (progn (inst mov prev-stack-pointer esp-tn)
- (inst sub esp-tn n-word-bytes)
- (inst and esp-tn -16)
- (storew object esp-tn))
+ #!-darwin
+ (inst push object)
+ #!+darwin
+ (progn
+ ;; the stack should be 16-byte aligned on Darwin
+ (inst mov prev-stack-pointer esp-tn)
+ (inst sub esp-tn n-word-bytes)
+ (align-stack-pointer esp-tn)
+ (storew object esp-tn))
(inst lea eax (make-fixup "debug_print" :foreign))
(inst call (make-fixup "call_into_c" :foreign))
- #!-darwin (inst add esp-tn n-word-bytes)
- #!+darwin (inst mov esp-tn prev-stack-pointer)
+ #!-darwin
+ (inst add esp-tn n-word-bytes)
+ #!+darwin
+ (inst mov esp-tn prev-stack-pointer)
(move result eax)))
(inst cmp esp-tn esi)
(inst jmp :be loop)
DONE
- ;; solaris requires DF being zero.
- #!+sunos (inst cld)
(inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes))
(inst sub edi esi)
(loop for moved = moved-ptrs then (tn-ref-across moved)
(inst jmp :nz LOOP)
DONE
- ;; solaris requires DF being zero.
- #!+sunos (inst cld)))
+ ))
fstp %st(0)
fstp %st(0)
-#ifdef LISP_FEATURE_WIN32
- cld
-#endif
-
-#ifdef LISP_FEATURE_DARWIN
- andl $0xfffffff0,%esp # align stack to 16-byte boundary before calling C
-#endif
- call *%eax # normal callout using Lisp stack
-
- movl %eax,%ecx # remember integer return value
+ cld # clear out DF: Darwin, Solaris and Win32 at
+ # least need this, and it should not hurt others
+
+ call *%eax # normal callout using Lisp stack
+ movl %eax,%ecx # remember integer return value
/* Check for a return FP value. */
fxam
#+(and ppc linux) 8
#+x86-64 16
#+mips 8
- #+x86 4
+ #+(and x86 (not darwin)) 4
+ #+(and x86 darwin) 16
#-(or x86 x86-64 mips (and ppc (or darwin linux))) (error "Unknown platform"))
;;;; Build the offset-tool as regular excutable, and run it with
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.5.34"
+"1.0.5.35"
projects / sbcl.git / commitdiff