0.9.0.9:

[sbcl.git] / src / compiler / ppc / c-call.lisp

diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp
index def38fe..07f6b02 100644 (file)
--- a/src/compiler/ppc/c-call.lisp
+++ b/src/compiler/ppc/c-call.lisp
@@ -1,15 +1,21 @@
-;;; routines for call-out to C.
-;;;
-;;; Written by William Lott.
-;;;
+;;;; VOPs and other machine-specific support routines for call-out to C
+
+;;;; 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")
 
-;;; Return the number of bytes needed for the current non-descriptor stack
-;;; frame.  Non-descriptor stack frames must be multiples of 16 bytes under
-;;; the PPC SVr4 ABI (though the EABI may be less restrictive.)  Two words
-;;; are reserved for the stack backlink and saved LR (see SB!VM::NUMBER-STACK-
-;;; DISPLACEMENT.)
-;;;
+;;; Return the number of bytes needed for the current non-descriptor
+;;; stack frame.  Non-descriptor stack frames must be multiples of 16
+;;; bytes under the PPC SVr4 ABI (though the EABI may be less
+;;; restrictive).  On linux, two words are reserved for the stack
+;;; backlink and saved LR (see SB!VM::NUMBER-STACK-DISPLACEMENT).
 
 (defconstant +stack-alignment-bytes+
   ;; Duh.  PPC Linux (and VxWorks) adhere to the EABI.
@@ -234,8 +240,8 @@
 
 #!+darwin
 (deftransform %alien-funcall ((function type &rest args))
-  (assert (sb!c::constant-continuation-p type))
-  (let* ((type (sb!c::continuation-value type))
+  (assert (sb!c::constant-lvar-p type))
+  (let* ((type (sb!c::lvar-value type))
         (arg-types (alien-fun-type-arg-types type))
         (result-type (alien-fun-type-result-type type)))
     (assert (= (length arg-types) (length args)))
@@ -297,12 +303,26 @@
   (:translate foreign-symbol-address)
   (:policy :fast-safe)
   (:args)
-  (:arg-types (:constant simple-base-string))
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (inst lr res  (make-fixup foreign-symbol :foreign))))
+
+#!+linkage-table
+(define-vop (foreign-symbol-dataref-address)
+  (:translate foreign-symbol-dataref-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
   (:info foreign-symbol)
   (:results (res :scs (sap-reg)))
   (:result-types system-area-pointer)
+  (:temporary (:scs (non-descriptor-reg)) addr)
   (:generator 2
-    (inst lr res  (make-fixup (extern-alien-name foreign-symbol) :foreign))))
+    (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
+    (loadw res addr)))
 
 (define-vop (call-out)
   (:args (function :scs (sap-reg) :target cfunc)
@@ -319,7 +339,7 @@
     (let ((cur-nfp (current-nfp-tn vop)))
       (when cur-nfp
        (store-stack-tn nfp-save cur-nfp))
-      (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign))
+      (inst lr temp (make-fixup "call_into_c" :foreign))
       (inst mtctr temp)
       (move cfunc function)
       (inst bctrl)
@@ -333,7 +353,11 @@
   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:generator 0
     (unless (zerop amount)
-      (let ((delta (- (logandc2 (+ amount 8 +stack-alignment-bytes+) 
+      ;; FIXME: I don't understand why we seem to be adding
+      ;; NUMBER-STACK-DISPLACEMENT twice here.  Weird.  -- CSR,
+      ;; 2003-08-20
+      (let ((delta (- (logandc2 (+ amount number-stack-displacement
+                                  +stack-alignment-bytes+)
                                +stack-alignment-bytes+))))
        (cond ((>= delta (ash -1 16))
               (inst stwu nsp-tn nsp-tn delta))
@@ -351,7 +375,8 @@
   (:policy :fast-safe)
   (:generator 0
     (unless (zerop amount)
-      (let ((delta (logandc2 (+ amount 8 +stack-alignment-bytes+) 
+      (let ((delta (logandc2 (+ amount number-stack-displacement
+                               +stack-alignment-bytes+) 
                             +stack-alignment-bytes+)))
        (cond ((< delta (ash 1 16))
               (inst addi nsp-tn nsp-tn delta))