src/compiler/hppa/c-call.lisp

   1 ;;;; VOPs and other machine-specific support routines for call-out to C
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 ;;; beware that we deal alot here with register-offsets directly
  15 ;;; instead of their symbol-name in vm.lisp
  16 ;;; offset works differently depending on sc-type
  17 (defun my-make-wired-tn (prim-type-name sc-name offset state)
  18   (make-wired-tn (primitive-type-or-lose prim-type-name)
  19                  (sc-number-or-lose sc-name)
  20                  ;; try to utilize vm.lisp definitions of registers:
  21                  (ecase sc-name
  22                    ((any-reg sap-reg signed-reg unsigned-reg)
  23                      (ecase offset ; FIX: port to other arch ???
  24                        ;(:nfp-offset offset)
  25                        (0 nl0-offset) ; On other arch we can
  26                        (1 nl1-offset) ; just add an offset to
  27                        (2 nl2-offset) ; beginning of args, but on
  28                        (3 nl3-offset) ; hppa c-args are spread.
  29                        (4 nl4-offset) ; These two are for
  30                        (5 nl5-offset))) ; c-return values
  31                    ((single-int-carg-reg double-int-carg-reg)
  32                      (ecase offset ; FIX: port to other arch ???
  33                        (0 nl0-offset)
  34                        (1 nl1-offset)
  35                        (2 nl2-offset)
  36                        (3 nl3-offset)))
  37                    ((single-reg double-reg) ; only for return
  38                      (+ 4 offset))
  39                    ;; A tn of stack type tells us that we have data on
  40                    ;; stack. This offset is current argument number so
  41                    ;; -1 points to the correct place to write that data
  42                    ((sap-stack signed-stack unsigned-stack)
  43                      (- (arg-state-nargs state) offset 8 1)))))
  44
  45 (defstruct arg-state
  46   (stack-frame-size 0)
  47   (float-args 0)
  48   nargs)
  49
  50 (define-alien-type-method (integer :arg-tn) (type state)
  51   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  52     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  53     (multiple-value-bind
  54       (ptype reg-sc stack-sc)
  55       (if (alien-integer-type-signed type)
  56         (values 'signed-byte-32 'signed-reg 'signed-stack)
  57         (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
  58       (if (< stack-frame-size 4)
  59         (my-make-wired-tn ptype reg-sc stack-frame-size state)
  60         (my-make-wired-tn ptype stack-sc stack-frame-size state)))))
  61
  62 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  63   (declare (ignore type))
  64   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  65     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  66     (if (< stack-frame-size 4)
  67       (my-make-wired-tn 'system-area-pointer
  68                         'sap-reg
  69                         stack-frame-size state)
  70       (my-make-wired-tn 'system-area-pointer
  71                         'sap-stack
  72                         stack-frame-size state))))
  73
  74 (define-alien-type-method (double-float :arg-tn) (type state)
  75   (declare (ignore type))
  76   (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
  77         (float-args (arg-state-float-args state)))
  78     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
  79     (setf (arg-state-float-args state) (1+ float-args))
  80     (cond ((>= stack-frame-size 4)
  81            (my-make-wired-tn 'double-float
  82                              'double-stack
  83                              stack-frame-size state))
  84           (t
  85             (my-make-wired-tn 'double-float
  86                               'double-int-carg-reg
  87                               (1+ (* float-args 2)) state)))))
  88
  89 (define-alien-type-method (single-float :arg-tn) (type state)
  90   (declare (ignore type))
  91   (let ((stack-frame-size (arg-state-stack-frame-size state))
  92         (float-args (arg-state-float-args state)))
  93     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  94     (setf (arg-state-float-args state) (1+ float-args))
  95     (cond ((>= stack-frame-size 4)
  96            (my-make-wired-tn 'single-float
  97                              'single-stack
  98                              stack-frame-size state))
  99           (t
 100             (my-make-wired-tn 'double-float
 101                               'single-int-carg-reg
 102                               (* float-args 2) state)))))
 103
 104 (defstruct result-state
 105   (num-results 0))
 106
 107 (define-alien-type-method (integer :result-tn) (type state)
 108   (let ((num-results (result-state-num-results state)))
 109     (setf (result-state-num-results state) (1+ num-results))
 110     (multiple-value-bind (ptype reg-sc)
 111       (if (alien-integer-type-signed type)
 112         (values 'signed-byte-32 'signed-reg)
 113         (values 'unsigned-byte-32 'unsigned-reg))
 114       (if (> num-results 1) (error "Too many result values from c-call."))
 115       (my-make-wired-tn ptype reg-sc (+ num-results 4) state))))
 116
 117 (define-alien-type-method (system-area-pointer :result-tn) (type state)
 118   (declare (ignore type))
 119   (let ((num-results (result-state-num-results state)))
 120     (setf (result-state-num-results state) (1+ num-results))
 121     (if (> num-results 1) (error "Too many result values from c-call."))
 122     (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 4) state)))
 123
 124 (define-alien-type-method (double-float :result-tn) (type state)
 125   (declare (ignore type))
 126   (let ((num-results (result-state-num-results state)))
 127     (setf (result-state-num-results state) (1+ num-results))
 128     (my-make-wired-tn 'double-float 'double-reg (* num-results 2) state)))
 129
 130 (define-alien-type-method (single-float :result-tn) (type state)
 131   (declare (ignore type))
 132   (let ((num-results (result-state-num-results state)))
 133     (setf (result-state-num-results state) (1+ num-results))
 134     (my-make-wired-tn 'single-float 'single-reg (* num-results 2) state)))
 135
 136 (define-alien-type-method (values :result-tn) (type state)
 137   (let ((values (alien-values-type-values type)))
 138     (when (> (length values) 2)
 139       (error "Too many result values from c-call."))
 140     (mapcar (lambda (type)
 141               (invoke-alien-type-method :result-tn type state))
 142             values)))
 143
 144 (defun make-call-out-tns (type)
 145   (let ((arg-state (make-arg-state))
 146         (nargs 0))
 147     (dolist (arg-type (alien-fun-type-arg-types type))
 148       (cond
 149         ((alien-double-float-type-p arg-type)
 150           (incf nargs (logior (1+ nargs) 1)))
 151         (t (incf nargs))))
 152     (setf (arg-state-nargs arg-state) (logandc2 (+ nargs 8 15) 15))
 153     (collect ((arg-tns))
 154       (dolist (arg-type (alien-fun-type-arg-types type))
 155         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 156       (values (make-normal-tn *fixnum-primitive-type*)
 157               (* n-word-bytes (logandc2 (+ nargs 8 15) 15))
 158               (arg-tns)
 159               (invoke-alien-type-method :result-tn
 160                                         (alien-fun-type-result-type type)
 161                                         (make-result-state))))))
 162
 163 (deftransform %alien-funcall ((function type &rest args))
 164   (aver (sb!c::constant-lvar-p type))
 165   (let* ((type (sb!c::lvar-value type))
 166          (env (sb!kernel:make-null-lexenv))
 167          (arg-types (alien-fun-type-arg-types type))
 168          (result-type (alien-fun-type-result-type type)))
 169     (aver (= (length arg-types) (length args)))
 170     ;; We need to do something special for 64-bit integer arguments
 171     ;; and results.
 172     (if (or (some (lambda (type)
 173                     (and (alien-integer-type-p type)
 174                          (> (sb!alien::alien-integer-type-bits type) 32)))
 175                   arg-types)
 176             (and (alien-integer-type-p result-type)
 177                  (> (sb!alien::alien-integer-type-bits result-type) 32)))
 178         (collect ((new-args) (lambda-vars) (new-arg-types))
 179                  (dolist (type arg-types)
 180                    (let ((arg (gensym)))
 181                      (lambda-vars arg)
 182                      (cond ((and (alien-integer-type-p type)
 183                                  (> (sb!alien::alien-integer-type-bits type) 32))
 184                             ;; 64-bit long long types are stored in
 185                             ;; consecutive locations, endian word order,
 186                             ;; aligned to 8 bytes.
 187                             (when (oddp (length (new-args)))
 188                               (new-args nil))
 189                             (progn (new-args `(ash ,arg -32))
 190                                    (new-args `(logand ,arg #xffffffff))
 191                                    (if (oddp (length (new-arg-types)))
 192                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
 193                                    (if (alien-integer-type-signed type)
 194                                        (new-arg-types (parse-alien-type '(signed 32) env))
 195                                        (new-arg-types (parse-alien-type '(unsigned 32) env)))
 196                                    (new-arg-types (parse-alien-type '(unsigned 32) env))))
 197                            (t
 198                             (new-args arg)
 199                             (new-arg-types type)))))
 200                  (cond ((and (alien-integer-type-p result-type)
 201                              (> (sb!alien::alien-integer-type-bits result-type) 32))
 202                         (let ((new-result-type
 203                                (let ((sb!alien::*values-type-okay* t))
 204                                  (parse-alien-type
 205                                   (if (alien-integer-type-signed result-type)
 206                                       '(values (signed 32) (unsigned 32))
 207                                       '(values (unsigned 32) (unsigned 32)))
 208                                   env))))
 209                           `(lambda (function type ,@(lambda-vars))
 210                             (declare (ignore type))
 211                              (multiple-value-bind
 212                                (high low)
 213                                (%alien-funcall function
 214                                   ',(make-alien-fun-type
 215                                        :arg-types (new-arg-types)
 216                                        :result-type new-result-type)
 217                                   ,@(new-args))
 218                                (logior low (ash high 32))))))
 219                        (t
 220                         `(lambda (function type ,@(lambda-vars))
 221                           (declare (ignore type))
 222                           (%alien-funcall function
 223                            ',(make-alien-fun-type
 224                               :arg-types (new-arg-types)
 225                               :result-type result-type)
 226                            ,@(new-args))))))
 227         (sb!c::give-up-ir1-transform))))
 228
 229 (define-vop (foreign-symbol-sap)
 230   (:translate foreign-symbol-sap)
 231   (:policy :fast-safe)
 232   (:args)
 233   (:arg-types (:constant simple-string))
 234   (:info foreign-symbol)
 235   (:results (res :scs (sap-reg)))
 236   (:result-types system-area-pointer)
 237   (:generator 2
 238     (inst li (make-fixup foreign-symbol :foreign) res)))
 239
 240 #!+linkage-table
 241 (define-vop (foreign-symbol-dataref-sap)
 242   (:translate foreign-symbol-dataref-sap)
 243   (:policy :fast-safe)
 244   (:args)
 245   (:arg-types (:constant simple-string))
 246   (:info foreign-symbol)
 247   (:results (res :scs (sap-reg)))
 248   (:result-types system-area-pointer)
 249   (:temporary (:scs (non-descriptor-reg)) addr)
 250   (:generator 2
 251     (inst li (make-fixup foreign-symbol :foreign-dataref) addr)
 252     (loadw res addr)))
 253
 254 (define-vop (call-out)
 255   (:args (function :scs (sap-reg) :target cfunc)
 256          (args :more t))
 257   (:results (results :more t))
 258   (:ignore args results)
 259   (:save-p t)
 260   (:temporary (:sc any-reg :offset cfunc-offset
 261                    :from (:argument 0) :to (:result 0)) cfunc)
 262   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 263   ;; Not sure if using nargs is safe ( have we saved it ).
 264   ;; but we cant use any non-descriptor-reg because c-args nl-4 is of that type
 265   (:temporary (:sc non-descriptor-reg :offset nargs-offset) temp)
 266   (:vop-var vop)
 267   (:generator 0
 268     (let ((cur-nfp (current-nfp-tn vop)))
 269       (when cur-nfp
 270         (store-stack-tn nfp-save cur-nfp))
 271       (let ((fixup (make-fixup "call_into_c" :foreign)))
 272         (inst ldil fixup temp)
 273         (inst ble fixup c-text-space temp)
 274         (move function cfunc t))
 275       (when cur-nfp
 276         (load-stack-tn cur-nfp nfp-save)))))
 277
 278 (define-vop (alloc-number-stack-space)
 279   (:info amount)
 280   (:result-types system-area-pointer)
 281   (:results (result :scs (sap-reg any-reg)))
 282   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 283   (:generator 0
 284     ;; Because stack grows to higher addresses, we have the result
 285     ;; pointing to an lowerer address than nsp
 286     (move nsp-tn result)
 287     (unless (zerop amount)
 288       ;; hp-ux stack grows towards larger addresses and stack must be
 289       ;; allocated in blocks of 64 bytes
 290       (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
 291         (cond ((< delta (ash 1 10))
 292                (inst addi delta nsp-tn nsp-tn))
 293               (t
 294                (inst li delta temp)
 295                (inst add nsp-tn temp nsp-tn)))))))
 296
 297 (define-vop (dealloc-number-stack-space)
 298   (:info amount)
 299   (:policy :fast-safe)
 300   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 301   (:generator 0
 302     (unless (zerop amount)
 303       (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
 304         (cond ((< delta (ash 1 10))
 305                (inst addi (- delta) nsp-tn nsp-tn))
 306               (t
 307                (inst li (- delta) temp)
 308                (inst sub nsp-tn temp nsp-tn)))))))
 309
 310 #-sb-xc-host
 311 (defun alien-callback-accessor-form (type sap offset)
 312   (let ((parsed-type type))
 313     (if (alien-integer-type-p parsed-type)
 314         (let ((bits (sb!alien::alien-integer-type-bits parsed-type)))
 315                (let ((byte-offset
 316                       (cond ((< bits n-word-bits)
 317                              (- n-word-bytes
 318                                 (ceiling bits n-byte-bits)))
 319                             (t 0))))
 320                  `(deref (sap-alien (sap+ ,sap
 321                                           ,(+ byte-offset offset))
 322                                     (* ,type)))))
 323         `(deref (sap-alien (sap+ ,sap ,offset) (* ,type))))))
 324