X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=3a4542fa835026bd59b20fa290b55b08b895c750;hb=51cf665f514935c8067f86f3850fd917731cada0;hp=04b73a828f297f3f9132feef72156b2f5f90a0ff;hpb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 04b73a8..3a4542f 100644
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -12,7 +12,7 @@
 
 (in-package "SB!VM")
 
-;; The MOVE-ARGUMENT vop is going to store args on the stack for
+;; The MOVE-ARG 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.
@@ -132,11 +132,71 @@
 					(alien-fun-type-result-type type)
 					(make-result-state))))))
 
+
+(deftransform %alien-funcall ((function type &rest args) * * :node node)
+  (aver (sb!c::constant-continuation-p type))
+  (let* ((type (sb!c::continuation-value type))
+	 (env (sb!c::node-lexenv node))
+         (arg-types (alien-fun-type-arg-types type))
+         (result-type (alien-fun-type-result-type type)))
+    (aver (= (length arg-types) (length args)))
+    (if (or (some #'(lambda (type)
+                      (and (alien-integer-type-p type)
+                           (> (sb!alien::alien-integer-type-bits type) 32)))
+                  arg-types)
+            (and (alien-integer-type-p result-type)
+                 (> (sb!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)
+                          (> (sb!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) env))
+                     (if (alien-integer-type-signed type)
+                         (new-arg-types (parse-alien-type '(signed 32) env))
+                         (new-arg-types (parse-alien-type '(unsigned 32) env))))
+                    (t
+                     (new-args arg)
+                     (new-arg-types type)))))
+          (cond ((and (alien-integer-type-p result-type)
+                      (> (sb!alien::alien-integer-type-bits result-type) 32))
+                 (let ((new-result-type
+                        (let ((sb!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)))
+			   env))))
+                   `(lambda (function type ,@(lambda-vars))
+                      (declare (ignore type))
+                      (multiple-value-bind (low high)
+                          (%alien-funcall function
+                                          ',(make-alien-fun-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-fun-type
+                                       :arg-types (new-arg-types)
+                                       :result-type result-type)
+                                    ,@(new-args))))))
+        (sb!c::give-up-ir1-transform))))
+
+
+
+
 (define-vop (foreign-symbol-address)
   (:translate foreign-symbol-address)
   (:policy :fast-safe)
   (:args)
-  (:arg-types (:constant simple-string))
+  (:arg-types (:constant simple-base-string))
   (:info foreign-symbol)
   (:results (res :scs (sap-reg)))
   (:result-types system-area-pointer)
@@ -209,27 +269,57 @@
 
 (define-vop (alloc-alien-stack-space)
   (:info amount)
+  #!+sb-thread (:temporary (:sc unsigned-reg) temp)
   (:results (result :scs (sap-reg any-reg)))
+  #!+sb-thread
   (:generator 0
     (aver (not (location= result esp-tn)))
     (unless (zerop amount)
       (let ((delta (logandc2 (+ amount 3) 3)))
-	(inst sub (make-ea :dword
-			   :disp (+ nil-value
-				    (static-symbol-offset '*alien-stack*)
-				    (ash symbol-value-slot word-shift)
-				    (- other-pointer-lowtag)))
-	      delta)))
+	(inst mov temp
+	      (make-ea :dword
+		       :disp (+ nil-value
+				(static-symbol-offset '*alien-stack*)
+				(ash symbol-tls-index-slot word-shift)
+				(- other-pointer-lowtag))))
+	(inst fs-segment-prefix)
+	(inst sub (make-ea :dword :scale 1 :index temp) delta)))
+    (load-tl-symbol-value result *alien-stack*))
+  #!-sb-thread
+  (:generator 0
+    (aver (not (location= result esp-tn)))
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+        (inst sub (make-ea :dword
+                           :disp (+ nil-value
+                                    (static-symbol-offset '*alien-stack*)
+                                    (ash symbol-value-slot word-shift)
+                                    (- other-pointer-lowtag)))
+              delta)))
     (load-symbol-value result *alien-stack*)))
 
 (define-vop (dealloc-alien-stack-space)
   (:info amount)
+  #!+sb-thread (:temporary (:sc unsigned-reg) temp)
+  #!+sb-thread
   (:generator 0
     (unless (zerop amount)
       (let ((delta (logandc2 (+ amount 3) 3)))
-	(inst add (make-ea :dword
+	(inst mov temp
+	      (make-ea :dword
 			   :disp (+ nil-value
 				    (static-symbol-offset '*alien-stack*)
-				    (ash symbol-value-slot word-shift)
-				    (- other-pointer-lowtag)))
-	      delta)))))
+				(ash symbol-tls-index-slot word-shift)
+				(- other-pointer-lowtag))))
+	(inst fs-segment-prefix)
+	(inst add (make-ea :dword :scale 1 :index temp) delta))))
+  #!-sb-thread
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+        (inst add (make-ea :dword
+                           :disp (+ nil-value
+                                    (static-symbol-offset '*alien-stack*)
+                                    (ash symbol-value-slot word-shift)
+                                    (- other-pointer-lowtag)))
+              delta)))))