mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-15 13:52:16 -08:00
663 lines
24 KiB
Common Lisp
Executable file
663 lines
24 KiB
Common Lisp
Executable file
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; CMPFFI -- Foreign functions interface.
|
|
|
|
;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll.
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; REPRESENTATION TYPES
|
|
;;
|
|
|
|
(defconstant +all-integer-rep-type-pairs+
|
|
'((:byte . -8)
|
|
(:unsigned-byte . 8)
|
|
(:unsigned-short . #.(logcount si::c-ushort-max))
|
|
(:short . #.(- (logcount si::c-ushort-max)))
|
|
(:unsigned-int . #.(logcount si::c-uint-max))
|
|
(:int . #.(logcount si::c-uint-max))
|
|
(:unsigned-long . #.(logcount si::c-ulong-max))
|
|
(:long . #.(logcount si::c-ulong-max))
|
|
#+long-long
|
|
(:unsigned-long-long . #.(logcount si::c-ulong-long-max))
|
|
#+long-long
|
|
(:long-long . #.(logcount si::c-ulong-long-max))
|
|
(:cl-index . #.si::cl-fixnum-bits)
|
|
(:fixnum . #.(- si::cl-fixnum-bits))
|
|
(:uint8-t . 8)
|
|
(:int8-t . -8)
|
|
(:uint16-t . 16)
|
|
(:int16-t . -16)
|
|
(:uint32-t . 32)
|
|
(:int32-t . -32)
|
|
(:uint64-t . 64)
|
|
(:int64-t . -64)))
|
|
|
|
(defconstant +all-integer-rep-types+
|
|
(mapcar #'car +all-integer-rep-type-pairs+))
|
|
|
|
(defconstant +all-number-rep-types+
|
|
(append +all-integer-rep-types+ '(:float :double :long-double)))
|
|
|
|
(defconstant +representation-types+
|
|
'(;; These types can be used by ECL to unbox data
|
|
;; They are sorted from the most specific, to the least specific one.
|
|
:byte
|
|
#1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fix")
|
|
:unsigned-byte
|
|
#2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fix")
|
|
:fixnum
|
|
(fixnum "cl_fixnum" "MAKE_FIXNUM" "ecl_to_fixnum" "ecl_fix")
|
|
:int
|
|
((integer #.si:c-int-min #.si:c-int-max) "int"
|
|
"ecl_make_int" "ecl_to_int" "ecl_to_int")
|
|
:unsigned-int
|
|
((integer 0 #.si:c-uint-max) "unsigned int"
|
|
"ecl_make_uint" "ecl_to_uint" "ecl_to_uint")
|
|
:long
|
|
((integer #.si:c-long-min #.si:c-long-max) "long" "ecl_make_long" "ecl_to_long"
|
|
#.(if (<= si::c-long-min most-negative-fixnum most-positive-fixnum si::c-long-max)
|
|
"ecl_fix"
|
|
"ecl_to_long"))
|
|
:unsigned-long
|
|
((integer 0 #.si:c-ulong-max) "unsigned long"
|
|
"ecl_make_ulong" "ecl_to_ulong"
|
|
#.(if (<= most-positive-fixnum si::c-long-max) "ecl_fix" "ecl_to_ulong"))
|
|
:cl-index
|
|
((integer 0 #.most-positive-fixnum) "cl_index"
|
|
"ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fix")
|
|
#+long-long
|
|
:long-long
|
|
#+long-long
|
|
((signed-byte #.si:c-long-long-bit) "ecl_long_long_t" "ecl_make_long_long"
|
|
"ecl_to_long_long" "ecl_to_long_long")
|
|
#+long-long
|
|
:unsigned-long-long
|
|
#+long-long
|
|
((unsigned-byte #.si:c-long-long-bit) "ecl_ulong_long_t"
|
|
"ecl_make_unsigned_long_long"
|
|
"ecl_to_unsigned_long_long" "ecl_to_unsigned_long_long")
|
|
:float
|
|
(single-float "float" "ecl_make_singlefloat" "ecl_to_float" "ecl_single_float")
|
|
:double
|
|
(double-float "double" "ecl_make_doublefloat" "ecl_to_double" "ecl_double_float")
|
|
#+:long-float
|
|
:long-double
|
|
#+:long-float
|
|
(long-float "long double" "ecl_make_longfloat" "ecl_to_long_double" "ecl_long_float")
|
|
:unsigned-char
|
|
(base-char "unsigned char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE")
|
|
:char
|
|
(base-char "char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE")
|
|
:wchar
|
|
(character "ecl_character" "CODE_CHAR" "ecl_char_code" "CHAR_CODE")
|
|
#+sse2
|
|
:float-sse-pack
|
|
#+sse2
|
|
(ext:float-sse-pack "__m128" "ecl_make_float_sse_pack"
|
|
"ecl_unbox_float_sse_pack" "ecl_unbox_float_sse_pack_unsafe")
|
|
#+sse2
|
|
:double-sse-pack
|
|
#+sse2
|
|
(ext:double-sse-pack "__m128d" "ecl_make_double_sse_pack"
|
|
"ecl_unbox_double_sse_pack" "ecl_unbox_double_sse_pack_unsafe")
|
|
#+sse2
|
|
:int-sse-pack
|
|
#+sse2
|
|
(ext:sse-pack #|<-intentional|# "__m128i" "ecl_make_int_sse_pack"
|
|
"ecl_unbox_int_sse_pack" "ecl_unbox_int_sse_pack_unsafe")
|
|
:object
|
|
(t "cl_object")
|
|
:bool
|
|
(t "bool" "ecl_make_bool" "ecl_to_bool" "ecl_to_bool")
|
|
;; These types are never selected to unbox data.
|
|
;; They are here, because we need to know how to print them.
|
|
:void
|
|
(nil "void")
|
|
:pointer-void
|
|
(si::foreign-data "void*" "ecl_make_pointer" "ecl_to_pointer" "ecl_to_pointer")
|
|
:cstring
|
|
(string "char*" "ecl_cstring_to_base_string_or_nil")
|
|
:char*
|
|
(string "char*")
|
|
:int8-t
|
|
#1#
|
|
:uint8-t
|
|
#2#
|
|
#+:uint16-t
|
|
:int16-t
|
|
#+:uint16-t
|
|
((unsigned-byte 16) "ecl_int16_t" "ecl_make_int16_t" "ecl_to_int16_t"
|
|
#.(if (subtypep '(unsigned-byte 16) 'fixnum) "ecl_fix" "ecl_to_int32_t"))
|
|
#+:uint16-t
|
|
:uint16-t
|
|
#+:uint16-t
|
|
((signed-byte 16) "ecl_uint16_t" "ecl_make_uint16_t" "ecl_to_uint16_t" "ecl_fix"
|
|
#.(if (subtypep '(signed-byte 16) 'fixnum) "ecl_fix" "ecl_to_unt16_t"))
|
|
#+:uint32-t
|
|
:int32-t
|
|
#+:uint32-t
|
|
((unsigned-byte 32) "ecl_int32_t" "ecl_make_int32_t" "ecl_to_int32_t"
|
|
#.(if (subtypep '(unsigned-byte 32) 'fixnum) "ecl_fix" "ecl_to_int32_t"))
|
|
#+:uint32-t
|
|
:uint32-t
|
|
#+:uint32-t
|
|
((signed-byte 32) "ecl_uint32_t" "ecl_make_uint32_t" "ecl_to_uint32_t"
|
|
#.(if (subtypep '(signed-byte 32) 'fixnum) "ecl_fix" "ecl_to_uint32_t"))
|
|
#+:uint64-t
|
|
:int64-t
|
|
#+:uint64-t
|
|
((signed-byte 64) "ecl_int64_t" "ecl_make_int64_t" "ecl_to_int64_t" "ecl_to_int64_t")
|
|
#+:uint64-t
|
|
:uint64-t
|
|
#+:uint64-t
|
|
((signed-byte 64) "ecl_uint64_t" "ecl_make_uint64_t" "ecl_to_uint64_t" "ecl_to_uint64_t")
|
|
:short
|
|
((integer #.si:c-short-min #.si:c-short-max) "short"
|
|
"ecl_make_short" "ecl_to_short" "ecl_fix")
|
|
:unsigned-short
|
|
((integer 0 #.si:c-ushort-max) "unsigned short"
|
|
"ecl_make_ushort" "ecl_to_ushort" "ecl_fix")
|
|
))
|
|
|
|
(defparameter +representation-type-hash+
|
|
(loop with table = (make-hash-table :size 128 :test 'eq)
|
|
for record on +representation-types+ by #'cddr
|
|
for rep-type = (first record)
|
|
for information = (second record)
|
|
do (setf (gethash rep-type table) information)
|
|
finally (progn
|
|
#+sse2 ; hack: sse-pack -> int, but int -> int-sse-pack
|
|
(setf (gethash :int-sse-pack table)
|
|
(list* 'ext:int-sse-pack (cdr (gethash :int-sse-pack table))))
|
|
(return table))))
|
|
|
|
(defun c-number-rep-type-p (rep-type)
|
|
(member rep-type +all-number-rep-types+))
|
|
|
|
(defun c-integer-rep-type-p (rep-type)
|
|
(member rep-type +all-integer-rep-types+))
|
|
|
|
(defun c-integer-rep-type-bits (rep-type)
|
|
(abs (cdr (assoc rep-type +all-integer-rep-type-pairs+))))
|
|
|
|
(defun c-number-type-p (type)
|
|
(c-number-rep-type-p (lisp-type->rep-type type)))
|
|
|
|
(defun c-integer-type-p (type)
|
|
(c-integer-rep-type-p (lisp-type->rep-type type)))
|
|
|
|
(defun c-integer-type-bits (type)
|
|
(c-number-rep-type-bits (lisp-type->rep-type type)))
|
|
|
|
(defun rep-type-record (rep-type)
|
|
(gethash rep-type +representation-type-hash+))
|
|
|
|
(defun rep-type->lisp-type (rep-type)
|
|
(let ((output (rep-type-record rep-type)))
|
|
(cond (output
|
|
(if (eq rep-type :void) nil
|
|
(or (first output)
|
|
(cmperr "Representation type ~S cannot be coerced to lisp"
|
|
rep-type))))
|
|
((lisp-type-p rep-type) rep-type)
|
|
(t (cmperr "Unknown representation type ~S" rep-type)))))
|
|
|
|
(defun lisp-type->rep-type (type)
|
|
(cond
|
|
;; We expect type = NIL when we have no information. Should be fixed. FIXME!
|
|
((null type)
|
|
:object)
|
|
((rep-type-record type)
|
|
type)
|
|
(t
|
|
(do ((l +representation-types+ (cddr l)))
|
|
((endp l) :object)
|
|
(when (subtypep type (first (second l)))
|
|
(return-from lisp-type->rep-type (first l)))))))
|
|
|
|
(defun rep-type-name (type)
|
|
(or (second (rep-type-record type))
|
|
(cmperr "Not a valid C type name ~S" type)))
|
|
|
|
(defun lisp-type-p (type)
|
|
(subtypep type 'T))
|
|
|
|
(defun wt-to-object-conversion (loc-rep-type loc)
|
|
(when (and (consp loc) (member (first loc) '(single-float-value
|
|
double-float-value
|
|
long-float-value)))
|
|
(wt (third loc)) ;; VV index
|
|
(return-from wt-to-object-conversion))
|
|
(let ((x (third (rep-type-record loc-rep-type))))
|
|
(unless x
|
|
(cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type))
|
|
(wt x "(" loc ")")))
|
|
|
|
(defun wt-from-object-conversion (dest-type loc-type rep-type loc)
|
|
(let ((x (cdddr (rep-type-record rep-type))))
|
|
(unless x
|
|
(cmperr "Cannot coerce lisp object to C type ~A" rep-type))
|
|
(wt (if (or (policy-assume-no-errors)
|
|
(subtypep loc-type dest-type))
|
|
(second x)
|
|
(first x))
|
|
"(" loc ")")))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; LOCATIONS and representation types
|
|
;;
|
|
;; Locations are lisp expressions which represent actual C data. To each
|
|
;; location we can associate a representation type, which is the type of
|
|
;; the C data. The following routines help in determining these types,
|
|
;; and also in moving data from one location to another.
|
|
|
|
(defun loc-movable-p (loc)
|
|
(if (atom loc)
|
|
t
|
|
(case (first loc)
|
|
((CALL CALL-LOCAL) NIL)
|
|
((C-INLINE) (not (fifth loc))) ; side effects?
|
|
(otherwise t))))
|
|
|
|
(defun loc-type (loc)
|
|
(cond ((eq loc NIL) 'NULL)
|
|
((var-p loc) (var-type loc))
|
|
((vv-p loc) (vv-type loc))
|
|
((si::fixnump loc) 'fixnum)
|
|
((atom loc) 'T)
|
|
(t
|
|
(case (first loc)
|
|
(FIXNUM-VALUE 'FIXNUM)
|
|
(CHARACTER-VALUE (type-of (code-char (second loc))))
|
|
(DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT)
|
|
(SINGLE-FLOAT-VALUE 'SINGLE-FLOAT)
|
|
(LONG-FLOAT-VALUE 'LONG-FLOAT)
|
|
(C-INLINE (let ((type (first (second loc))))
|
|
(cond ((and (consp type) (eq (first type) 'VALUES)) T)
|
|
((lisp-type-p type) type)
|
|
(t (rep-type->lisp-type type)))))
|
|
(BIND (var-type (second loc)))
|
|
(LCL (or (third loc) T))
|
|
(THE (second loc))
|
|
(CALL-NORMAL (fourth loc))
|
|
(otherwise T)))))
|
|
|
|
(defun loc-representation-type (loc)
|
|
(cond ((member loc '(NIL T)) :object)
|
|
((var-p loc) (var-rep-type loc))
|
|
((vv-p loc) :object)
|
|
((si::fixnump loc) :fixnum)
|
|
((eq loc 'TRASH) :void)
|
|
((atom loc) :object)
|
|
(t
|
|
(case (first loc)
|
|
(FIXNUM-VALUE :fixnum)
|
|
(CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar))
|
|
(DOUBLE-FLOAT-VALUE :double)
|
|
(SINGLE-FLOAT-VALUE :float)
|
|
(LONG-FLOAT-VALUE :long-double)
|
|
(C-INLINE (let ((type (first (second loc))))
|
|
(cond ((and (consp type) (eq (first type) 'VALUES)) :object)
|
|
((lisp-type-p type) (lisp-type->rep-type type))
|
|
(t type))))
|
|
(BIND (var-rep-type (second loc)))
|
|
(LCL (lisp-type->rep-type (or (third loc) T)))
|
|
((JUMP-TRUE JUMP-FALSE) :bool)
|
|
(THE (loc-representation-type (third loc)))
|
|
(otherwise :object)))))
|
|
|
|
(defun wt-coerce-loc (dest-rep-type loc)
|
|
(setq dest-rep-type (lisp-type->rep-type dest-rep-type))
|
|
;(print dest-rep-type)
|
|
;(print loc)
|
|
(let* ((dest-type (rep-type->lisp-type dest-rep-type))
|
|
(loc-type (loc-type loc))
|
|
(loc-rep-type (loc-representation-type loc)))
|
|
(labels ((coercion-error ()
|
|
(cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~
|
|
to C/C++ type (~S,~S)"
|
|
loc-type loc-rep-type dest-type dest-rep-type))
|
|
(ensure-valid-object-type (a-lisp-type)
|
|
(when (subtypep `(AND ,loc-type ,a-lisp-type) NIL)
|
|
(coercion-error))))
|
|
(when (eq dest-rep-type loc-rep-type)
|
|
(wt loc)
|
|
(return-from wt-coerce-loc))
|
|
(case dest-rep-type
|
|
(#.+all-integer-rep-types+
|
|
(case loc-rep-type
|
|
(#.+all-number-rep-types+
|
|
(wt "(" (rep-type-name dest-rep-type) ")(" loc ")"))
|
|
((:object)
|
|
(ensure-valid-object-type dest-type)
|
|
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
|
(otherwise
|
|
(coercion-error))))
|
|
((:char :unsigned-char :wchar)
|
|
(case loc-rep-type
|
|
((:char :unsigned-char :wchar)
|
|
(wt "(" (rep-type-name dest-rep-type) ")(" loc ")"))
|
|
((:object)
|
|
(ensure-valid-object-type dest-type)
|
|
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
|
(otherwise
|
|
(coercion-error))))
|
|
((:float :double :long-double)
|
|
(case loc-rep-type
|
|
(#.+all-number-rep-types+
|
|
(wt "(" (rep-type-name dest-rep-type) ")(" loc ")"))
|
|
((:object)
|
|
;; We relax the check a bit, because it is valid in C to coerce
|
|
;; between floats of different types.
|
|
(ensure-valid-object-type 'FLOAT)
|
|
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
|
(otherwise
|
|
(coercion-error))))
|
|
((:bool)
|
|
(case loc-rep-type
|
|
(#.+all-number-rep-types+ ; number type
|
|
(wt "1"))
|
|
((:object)
|
|
(wt "(" loc ")!=Cnil"))
|
|
(otherwise
|
|
(coercion-error))))
|
|
((:object)
|
|
#+sse2
|
|
(case loc-rep-type
|
|
((:int-sse-pack :float-sse-pack :double-sse-pack)
|
|
(when (>= (cmp-env-optimization 'speed) 1)
|
|
(cmpwarn-style "Boxing a value of type ~S - performance degraded."
|
|
loc-rep-type))))
|
|
(wt-to-object-conversion loc-rep-type loc))
|
|
((:pointer-void)
|
|
(case loc-rep-type
|
|
((:object)
|
|
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
|
((:cstring)
|
|
(wt "(char *)(" loc ")"))
|
|
(otherwise
|
|
(coercion-error))))
|
|
((:cstring)
|
|
(coercion-error))
|
|
((:char*)
|
|
(case loc-rep-type
|
|
((:object)
|
|
(wt "ecl_base_string_pointer_safe(" loc ")"))
|
|
((:pointer-void)
|
|
(wt "(char *)(" loc ")"))
|
|
(otherwise
|
|
(coercion-error))))
|
|
#+sse2
|
|
((:int-sse-pack :float-sse-pack :double-sse-pack)
|
|
(case loc-rep-type
|
|
((:object)
|
|
(wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc))
|
|
;; Implicitly cast between SSE subtypes
|
|
((:int-sse-pack :float-sse-pack :double-sse-pack)
|
|
(wt (ecase dest-rep-type
|
|
(:int-sse-pack (ecase loc-rep-type
|
|
(:float-sse-pack "_mm_castps_si128")
|
|
(:double-sse-pack "_mm_castpd_si128")))
|
|
(:float-sse-pack (ecase loc-rep-type
|
|
(:int-sse-pack "_mm_castsi128_ps")
|
|
(:double-sse-pack "_mm_castpd_ps")))
|
|
(:double-sse-pack (ecase loc-rep-type
|
|
(:int-sse-pack "_mm_castsi128_pd")
|
|
(:float-sse-pack "_mm_castps_pd"))))
|
|
"(" loc ")"))
|
|
(otherwise
|
|
(coercion-error))))
|
|
(t
|
|
(coercion-error))))))
|
|
|
|
;;; ----------------------------------------------------------------------
|
|
;;; C/C++ DECLARATIONS AND HEADERS
|
|
;;;
|
|
;;; All lines from CLINES statements are grouped at the beginning of the header
|
|
;;; Notice that it does not make sense to guarantee that c-lines statements
|
|
;;; are produced in-between the function definitions, because two functions
|
|
;;; might be collapsed into one, or we might not produce that function at all
|
|
;;; and rather inline it.
|
|
;;;
|
|
(defun c1clines (args)
|
|
(unless (every #'stringp args)
|
|
(cmperr "The argument to CLINES, ~s, is not a list of strings." args))
|
|
(setf *clines-string-list* (nconc *clines-string-list* (copy-list args)))
|
|
'(progn))
|
|
|
|
(defun output-clines (output-stream)
|
|
(flet ((parse-one-string (s output-stream)
|
|
(with-input-from-string (stream s)
|
|
(loop for c = (read-char stream nil nil)
|
|
while c
|
|
do (if (eq c #\@)
|
|
(let ((object (handler-case (read stream)
|
|
(serious-condition (c)
|
|
(cmperr "Unable to parse FFI:CLINES string~& ~S"
|
|
s)))))
|
|
(let ((*compiler-output1* output-stream))
|
|
(wt (add-object object :permanent t))))
|
|
(write-char c output-stream))))))
|
|
(loop for s in *clines-string-list*
|
|
do (terpri output-stream)
|
|
do (if (find #\@ s)
|
|
(parse-one-string s output-stream)
|
|
(write-string s output-stream)))
|
|
(terpri output-stream)
|
|
(setf *clines-string-list* nil)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; C/C++ INLINE CODE
|
|
;;
|
|
|
|
(defun c1c-inline (args)
|
|
;; We are on the safe side by assuming that the form has side effects
|
|
(destructuring-bind (arguments arg-types output-type c-expression
|
|
&rest rest
|
|
&key (side-effects t) one-liner
|
|
&aux output-rep-type)
|
|
args
|
|
(unless (= (length arguments) (length arg-types))
|
|
(cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S"
|
|
`(C-INLINE ,@args)))
|
|
;; We cannot handle :cstrings as input arguments. :cstrings are
|
|
;; null-terminated strings, but not all of our lisp strings will
|
|
;; be null terminated. In particular, those with a fill pointer
|
|
;; will not.
|
|
(let ((ndx (position :cstring arg-types)))
|
|
(when ndx
|
|
(let* ((var (gensym))
|
|
(arguments (copy-list arguments))
|
|
(value (elt arguments ndx)))
|
|
(setf (elt arguments ndx) var
|
|
(elt arg-types ndx) :char*)
|
|
(return-from c1c-inline
|
|
(c1expr
|
|
`(ffi::with-cstring (,var ,value)
|
|
(c-inline ,arguments ,arg-types ,output-type ,c-expression
|
|
,@rest)))))))
|
|
;; Find out the output types of the inline form. The syntax is rather relaxed
|
|
;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*)
|
|
(flet ((produce-type-pair (type)
|
|
(if (lisp-type-p type)
|
|
(cons type (lisp-type->rep-type type))
|
|
(cons (rep-type->lisp-type type) type))))
|
|
(cond ((eq output-type ':void)
|
|
(setf output-rep-type '()
|
|
output-type 'NIL))
|
|
((equal output-type '(VALUES &REST t))
|
|
(setf output-rep-type '((VALUES &REST t))))
|
|
((and (consp output-type) (eql (first output-type) 'VALUES))
|
|
(let ((x (mapcar #'produce-type-pair (rest output-type))))
|
|
(setf output-rep-type (mapcar #'cdr x)
|
|
output-type `(VALUES ,@(mapcar #'car x)))))
|
|
(t
|
|
(let ((x (produce-type-pair output-type)))
|
|
(setf output-type (car x)
|
|
output-rep-type (list (cdr x)))))))
|
|
(let* ((processed-arguments '()))
|
|
(unless (and (listp arguments)
|
|
(listp arg-types)
|
|
(stringp c-expression))
|
|
(cmperr "C-INLINE: syntax error in ~S"
|
|
(list* 'c-inline args)))
|
|
(do ((processed-arguments '())
|
|
(processed-arg-types '()))
|
|
((and (endp arguments) (endp arg-types))
|
|
(make-c1form* 'C-INLINE :type output-type
|
|
:side-effects side-effects
|
|
:args
|
|
(nreverse processed-arguments)
|
|
(nreverse processed-arg-types)
|
|
output-rep-type
|
|
c-expression
|
|
side-effects
|
|
one-liner))
|
|
(push (or (pop arg-types) 'T) processed-arg-types)
|
|
(push (c1expr (pop arguments)) processed-arguments)))))
|
|
|
|
(defun produce-inline-loc (inlined-arguments arg-types output-rep-type
|
|
c-expression side-effects one-liner)
|
|
(let* (args-to-be-saved
|
|
coerced-arguments)
|
|
;; If the expression begins with @[0-9a-z]*, this means we are
|
|
;; saving some variables.
|
|
(when (and (> (length c-expression) 1)
|
|
(eq (char c-expression 0) #\@))
|
|
(do ((ndx 1 (1+ ndx)))
|
|
((>= ndx (length c-expression)))
|
|
(let ((c (char c-expression ndx)))
|
|
(when (eq c #\;)
|
|
(setf c-expression (subseq c-expression (1+ ndx)))
|
|
(return))
|
|
(unless (alphanumericp c)
|
|
(setf args-to-be-saved nil)
|
|
(return))
|
|
(push (- (char-code c) (char-code #\0))
|
|
args-to-be-saved))))
|
|
|
|
(setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved))
|
|
;;(setf output-rep-type (lisp-type->rep-type output-rep-type))
|
|
|
|
;; If the form does not output any data, and there are no side
|
|
;; effects, try to omit it.
|
|
(when (null output-rep-type)
|
|
(if side-effects
|
|
(progn
|
|
(wt-nl)
|
|
(wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil)
|
|
(when one-liner (wt ";")))
|
|
(cmpwarn "Ignoring form ~S" c-expression))
|
|
(return-from produce-inline-loc NIL))
|
|
|
|
;; If the form is a one-liner, we can simply propagate this expression until the
|
|
;; place where the value is used.
|
|
(when one-liner
|
|
(return-from produce-inline-loc
|
|
`(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects
|
|
,(if (equalp output-rep-type '((VALUES &REST T)))
|
|
'VALUES NIL))))
|
|
|
|
;; If the output is a in the VALUES vector, just write down the form and output
|
|
;; the location of the data.
|
|
(when (equalp output-rep-type '((VALUES &REST T)))
|
|
(wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects
|
|
'VALUES)
|
|
(return-from produce-inline-loc 'VALUES))
|
|
|
|
;; Otherwise we have to set up variables for holding the output.
|
|
(flet ((make-output-var (type)
|
|
(let ((var (make-lcl-var :rep-type type)))
|
|
(wt-nl (rep-type-name type) " " var ";")
|
|
var)))
|
|
(incf *inline-blocks*)
|
|
(wt-nl "{")
|
|
(let ((output-vars (mapcar #'make-output-var output-rep-type)))
|
|
(wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars)
|
|
(cond ((= (length output-vars) 1)
|
|
(first output-vars))
|
|
(t
|
|
(loop for v in output-vars
|
|
for i from 0
|
|
do (let ((*destination* `(VALUE ,i))) (set-loc v)))
|
|
(wt "cl_env_copy->nvalues=" (length output-vars) ";")
|
|
'VALUES))))))
|
|
|
|
(defun c2c-inline (c1form arguments &rest rest)
|
|
(declare (ignore c1form))
|
|
(let ((*inline-blocks* 0)
|
|
(*temp* *temp*))
|
|
(unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))
|
|
(close-inline-blocks)))
|
|
|
|
(defun coerce-locs (inlined-args &optional types args-to-be-saved)
|
|
(do* ((l inlined-args (cdr l))
|
|
(item (first l) (first l))
|
|
(i 0 (1+ i))
|
|
(block-opened nil))
|
|
((endp l)
|
|
inlined-args)
|
|
(let* ((type (if types (pop types) :object))
|
|
(rep-type (lisp-type->rep-type type))
|
|
(lisp-type (first item))
|
|
(loc (second item)))
|
|
(cond ((and (not (loc-movable-p loc)) (member i args-to-be-saved))
|
|
(let ((lcl (make-lcl-var :rep-type rep-type)))
|
|
(wt-nl)
|
|
(unless block-opened
|
|
(incf *inline-blocks*)
|
|
(wt-nl "{"))
|
|
(wt (rep-type-name rep-type) " " lcl "= ")
|
|
(wt-coerce-loc rep-type loc)
|
|
(wt ";")
|
|
(setq loc lcl)))
|
|
((and (not (equal rep-type (loc-representation-type loc))))
|
|
(setq loc `(COERCE-LOC ,rep-type ,loc))))
|
|
(setf (first l) loc))))
|
|
|
|
(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars)
|
|
(with-input-from-string (s c-expression)
|
|
(when (and output-vars (not (eq output-vars 'VALUES)))
|
|
(wt-nl))
|
|
(do ((c (read-char s nil nil)
|
|
(read-char s nil nil)))
|
|
((null c))
|
|
(case c
|
|
(#\@
|
|
(let ((object (read s)))
|
|
(cond ((and (consp object) (equal (first object) 'RETURN))
|
|
(if (eq output-vars 'VALUES)
|
|
(cmperr "User @(RETURN ...) in a C-INLINE form with no output values")
|
|
(let ((ndx (or (second object) 0))
|
|
(l (length output-vars)))
|
|
(if (< ndx l)
|
|
(wt (nth ndx output-vars))
|
|
(cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values"
|
|
ndx l)))))
|
|
(t
|
|
(when (and (consp object) (eq (first object) 'QUOTE))
|
|
(setq object (second object)))
|
|
(wt (add-object object :permanent t))))))
|
|
(#\#
|
|
(let* ((k (read-char s))
|
|
(next-char (peek-char nil s nil nil))
|
|
(index (digit-char-p k 36)))
|
|
(cond ((eq k #\#)
|
|
(wt #\#))
|
|
((or (null index) (and next-char (alphanumericp next-char)))
|
|
(wt #\# k))
|
|
((< index (length coerced-arguments))
|
|
(wt (nth index coerced-arguments)))
|
|
(t
|
|
(cmperr "C-INLINE: Variable code exceeds number of arguments")))))
|
|
(otherwise
|
|
(write-char c *compiler-output1*))))))
|