Commit e92f8c41 authored by Juan Jose Garcia Ripoll's avatar Juan Jose Garcia Ripoll
Browse files

Added a 'machine' object that represents the features of a cross compilation...

Added a 'machine' object that represents the features of a cross compilation target in the compiler. Inline forms now are created with one such machine on mind, and recreated if the machine changes.
parent 7801dba3
......@@ -90,20 +90,20 @@
(declare (si::c-local))
(let ((output nil))
(unless (safe-compile)
(dolist (x (get-sysprop fname ':INLINE-UNSAFE))
(dolist (x (inline-information fname ':INLINE-UNSAFE))
(let ((other (inline-type-matches x types return-type)))
(when other
(setf output (choose-inline-info output other return-type return-rep-type))))))
(dolist (x (get-sysprop fname ':INLINE-SAFE))
(dolist (x (inline-information fname ':INLINE-SAFE))
(let ((other (inline-type-matches x types return-type)))
(when other
(setf output (choose-inline-info output other return-type return-rep-type)))))
(dolist (x (get-sysprop fname ':INLINE-ALWAYS))
(dolist (x (inline-information fname ':INLINE-ALWAYS))
(let ((other (inline-type-matches x types return-type)))
(when other
(setf output (choose-inline-info output other return-type return-rep-type)))))
(when (and (null output)
(get-sysprop fname 'should-be-inlined)
(inline-information fname 'should-be-inlined)
(>= (cmp-env-optimization 'speed) 1))
(cmpwarn-style "Could not inline call to ~S ~S - performance may be degraded."
fname types))
......
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2010, 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.
;;;;
;;;; CMPC-MACHINE -- Abstract target machine details
;;;;
(in-package #-new-cmp "COMPILER" #+new-cmp "C-BACKEND")
(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_fixnum"))
(:unsigned-byte .
#2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum"))
(:fixnum integer "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum")
(:int integer "int" "ecl_make_int" "ecl_to_int" "ecl_to_int")
(:unsigned-int integer "unsigned int" "ecl_make_uint" "ecl_to_uint" "ecl_to_uint")
(:long integer "long" "ecl_make_long" "ecl_to_long" "ecl_to_long")
(:unsigned-long integer "unsigned long" "ecl_make_ulong" "ecl_to_ulong" "ecl_to_ulong")
(:cl-index integer "cl_index" "ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fixnum")
(:long-long integer "ecl_long_long_t" "ecl_make_long_long" "ecl_to_long_long" "ecl_to_long_long")
(:unsigned-long-long integer "ecl_ulong_long_t" "ecl_make_ulong_long" "ecl_to_ulong_long" "ecl_to_ulong_long")
(:float single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float")
(:double double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float")
(:long-double long-float "long double" "ecl_make_long_float" "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")
(:float-sse-pack ext::float-sse-pack "__m128" "ecl_make_float_sse_pack"
"ecl_unbox_float_sse_pack" "ecl_unbox_float_sse_pack_unsafe")
(:double-sse-pack ext::double-sse-pack "__m128d" "ecl_make_double_sse_pack"
"ecl_unbox_double_sse_pack" "ecl_unbox_double_sse_pack_unsafe")
(:int-sse-pack 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#)
(:int16-t integer "ecl_int16_t" "ecl_make_int16_t" "ecl_to_int16_t" "ecl_to_int16_t")
(:uint16-t integer "ecl_uint16_t" "ecl_make_uint16_t" "ecl_to_uint16_t" "ecl_to_unt16_t")
(:int32-t integer "ecl_int32_t" "ecl_make_int32_t" "ecl_to_int32_t" "ecl_to_int32_t")
(:uint32-t integer "ecl_uint32_t" "ecl_make_uint32_t" "ecl_to_uint32_t" "ecl_to_uint32_t")
(:int64-t integer "ecl_int64_t" "ecl_make_int64_t" "ecl_to_int64_t" "ecl_to_int64_t")
(:uint64-t integer "ecl_uint64_t" "ecl_make_uint64_t" "ecl_to_uint64_t" "ecl_to_uint64_t")
(:short integer "short" "ecl_make_short" "ecl_to_short" "ecl_fixnum")
(:unsigned-short integer "unsigned short" "ecl_make_ushort" "ecl_to_ushort" "ecl_fixnum")
))
(defconstant +this-machine-c-types+
'((:byte . -8)
(:unsigned-byte . 8)
(:unsigned-short . #.(- (logcount ffi:c-ushort-max)))
(:short . #.(- (logcount ffi:c-ushort-max)))
(:unsigned-int . #.(logcount ffi:c-uint-max))
(:int . #.(- (logcount ffi:c-uint-max)))
(:unsigned-long . #.(logcount ffi:c-ulong-max))
(:long . #.(- (logcount ffi:c-ulong-max)))
#+long-long
(:unsigned-long-long . #.(logcount ffi:c-ulong-long-max))
#+long-long
(:long-long . #.(- (logcount ffi:c-ulong-long-max)))
(:cl-index . #.(logcount most-positive-fixnum))
(:fixnum . #.(- -1 (logcount most-positive-fixnum)))
(:uint8-t . 8)
(:int8-t . -8)
#+:uint16-t
(:uint16-t . 16)
#+:uint16-t
(:int16-t . -16)
#+:uint32-t
(:uint32-t . 32)
#+:uint32-t
(:int32-t . -32)
#+:uint64-t
(:uint64-t . 64)
#+:uint64-t
(:int64-t . -64)
#+:sse2 (:float-sse-pack . nil)
#+:sse2 (:double-sse-pack . nil)
#+:sse2 (:int-sse-pack . nil)
#+:long-float (:long-double . nil)
))
(defconstant +all-machines-c-types+
'((:object)
(:float)
(:double)
(:char)
(:unsigned-char)
(:wchar)
(:char*)
(:cstring)
(:bool)
(:void)
(:pointer-void)))
(defun make-rep-type (all-c-types name lisp-type c-name &optional to-lisp from-lisp from-lisp-unsafe)
(let* ((record (assoc name all-c-types))
(bits (cdr record)))
(when record
;; For integer bits we get extra information from ALL-C-TYPES
(when bits
(if (plusp bits)
(setf lisp-type `(unsigned-byte ,bits))
(setf bits (- bits)
lisp-type `(signed-byte ,bits))))
(%make-rep-type
:name name
:lisp-type lisp-type
:bits bits
:numberp (subtypep lisp-type 'number)
:integerp (subtypep lisp-type 'integer)
:c-name c-name
:to-lisp to-lisp
:from-lisp from-lisp
:from-lisp-unsafe from-lisp-unsafe))))
(defun make-rep-type-hash (all-c-types)
(let ((table (make-hash-table :size 128 :test 'eq)))
table))
(defun default-machine ()
(let* ((all-c-types (append +this-machine-c-types+ +all-machines-c-types+))
(table (make-hash-table :size 128 :test 'eq))
(sorted-rep-types
;; Create the rep-type objects
(loop for i from 0
for record in +representation-types+
for rep-type = (apply #'make-rep-type all-c-types record)
when rep-type
do (setf (rep-type-index rep-type) i)
and collect (setf (gethash (rep-type-name rep-type) table) rep-type))))
;; hack: sse-pack -> int, but int -> int-sse-pack
(let ((r (gethash :int-sse-pack table)))
(when r
(setf (rep-type-to-lisp r) 'ext:int-sse-pack)))
;; On a second pass, we replace types with more general ones
(loop with fixnum-rep-type = (gethash ':fixnum table)
with fixnum-lisp-type = (rep-type-lisp-type fixnum-rep-type)
for (name . rest) in +representation-types+
for r = (gethash name table)
when (and r (subtypep (rep-type-lisp-type r) fixnum-lisp-type))
do (setf (rep-type-from-lisp-unsafe r) "ecl_fixnum"))
;; Create machine object
(make-machine :c-types all-c-types
:rep-type-hash table
:sorted-types sorted-rep-types)))
(defun machine-c-type-p (name)
(gethash name (machine-rep-type-hash *machine*)))
(defun machine-fixnump (number)
(typep number (rep-type-lisp-type (gethash :fixnum number))))
(defconstant +default-machine+ (setf *machine* (default-machine)))
......@@ -92,7 +92,7 @@
(t
(cmperr "DEFCALLBACK does not support complex return types such as ~A"
return-type)))
(let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type)))
(let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type)))
(fmod (case call-type
(:cdecl "")
(:stdcall "__stdcall ")
......@@ -105,8 +105,8 @@
with comma = ""
do
(progn
(wt-h comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
(wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n)
(wt-h comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n)
(wt comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n)
(setf comma ",")))
(wt ")")
(wt-h ");")
......
......@@ -17,7 +17,7 @@
(defun c1constant-value (val &key always only-small-values)
(cond
((let ((x (assoc val +optimizable-constants+)))
((let ((x (assoc val *optimizable-constants*)))
(when x
(pushnew "#include <float.h>" *clines-string-list*)
(setf x (cdr x))
......@@ -74,82 +74,88 @@
;;; KNOWN OPTIMIZABLE CONSTANTS
;;;
(mapc
#'(lambda (record)
(let* ((name (first record))
(c-value (second record)))
(push
(cond ((symbolp name)
(let* ((value (symbol-value name))
(type (lisp-type->rep-type (type-of value))))
(cons value `(c-inline () () ,type ,c-value
:one-liner t :side-effects nil))))
((floatp name)
(let* ((value name)
(defun make-single-constant-optimizer (name c-value)
(cond ((symbolp name)
(let* ((value (symbol-value name))
(type (lisp-type->rep-type (type-of value))))
(cons value `(c-inline () () ,type ,c-value
:one-liner t :side-effects nil))))
((floatp name)
(let* ((value name)
(type (type-of value))
(loc-type (case type
(single-float 'single-float-value)
(double-float 'double-float-value)
(long-float 'long-float-value)))
(location (make-vv :location c-value :value value)))
(cons value (make-c1form* 'LOCATION :type type
:args (list loc-type value location)))))
(t
(cons name (make-c1form* 'LOCATION :type (type-of name)
:args (make-vv :location c-value
:value name)))))
+optimizable-constants+)))
(reverse
`((MOST-POSITIVE-SHORT-FLOAT "FLT_MAX")
(MOST-POSITIVE-SINGLE-FLOAT "FLT_MAX")
(loc-type (case type
(single-float 'single-float-value)
(double-float 'double-float-value)
(long-float 'long-float-value)))
(location (make-vv :location c-value :value value)))
(cons value (make-c1form* 'LOCATION :type type
:args (list loc-type value location)))))
(t
(cons name (make-c1form* 'LOCATION :type (type-of name)
:args (make-vv :location c-value
:value name))))))
(MOST-NEGATIVE-SHORT-FLOAT "-FLT_MAX")
(MOST-NEGATIVE-SINGLE-FLOAT "-FLT_MAX")
(defun make-optimizable-constants (machine)
(loop for (value name) in (optimizable-constants-list machine)
collect (make-single-constant-optimizer value name)))
(LEAST-POSITIVE-SHORT-FLOAT "FLT_MIN")
(LEAST-POSITIVE-SINGLE-FLOAT "FLT_MIN")
(LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT "FLT_MIN")
(LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" FLT_MIN")
(defun optimizable-constants-list (machine)
(append
;; Constants that appear everywhere
'(
;; Order is important: on platforms where 0.0 and -0.0 are the same
;; the last one is prioritized.
(#.(coerce 0 'single-float) "cl_core.singlefloat_zero")
(#.(coerce 0 'double-float) "cl_core.doublefloat_zero")
(#.(coerce -0.0 'single-float) "cl_core.singlefloat_minus_zero")
(#.(coerce -0.0 'double-float) "cl_core.doublefloat_minus_zero")
#+long-float
(#.(coerce 0 'long-float) "cl_core.longfloat_zero")
#+long-float
(#.(coerce -0.0 'long-float) "cl_core.longfloat_minus_zero")
(LEAST-NEGATIVE-SHORT-FLOAT "-FLT_MIN")
(LEAST-NEGATIVE-SINGLE-FLOAT "-FLT_MIN")
(LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT "-FLT_MIN")
(LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT "-FLT_MIN")
;; We temporarily remove this constant, because the bytecodes compiler
;; does not know how to externalize it.
;;(#.(si::standard-readtable) "cl_core.standard_readtable")
(MOST-POSITIVE-DOUBLE-FLOAT "DBL_MAX")
(MOST-NEGATIVE-DOUBLE-FLOAT "-DBL_MAX")
(LEAST-POSITIVE-DOUBLE-FLOAT "DBL_MIN")
(LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT "DBL_MIN")
(LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_MIN")
(LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN")
(#.(find-package :cl) "cl_core.lisp_package")
(#.(find-package :cl-user) "cl_core.user_package")
(#.(find-package :keyword) "cl_core.keyword_package")
(#.(find-package :clos) "cl_core.clos_package")
#+threads
(#.(find-package :mp) "cl_core.mp_package")
)
(when (eq machine +default-machine+)
;; Constants which are not portable
`((MOST-POSITIVE-SHORT-FLOAT "FLT_MAX")
(MOST-POSITIVE-SINGLE-FLOAT "FLT_MAX")
(MOST-NEGATIVE-SHORT-FLOAT "-FLT_MAX")
(MOST-NEGATIVE-SINGLE-FLOAT "-FLT_MAX")
;; Order is important: on platforms where 0.0 and -0.0 are the same
;; the last one is prioritized.
(#.(coerce 0 'single-float) "cl_core.singlefloat_zero")
(#.(coerce 0 'double-float) "cl_core.doublefloat_zero")
(#.(coerce -0.0 'single-float) "cl_core.singlefloat_minus_zero")
(#.(coerce -0.0 'double-float) "cl_core.doublefloat_minus_zero")
(LEAST-POSITIVE-SHORT-FLOAT "FLT_MIN")
(LEAST-POSITIVE-SINGLE-FLOAT "FLT_MIN")
(LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT "FLT_MIN")
(LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" FLT_MIN")
;; We temporarily remove this constant, because the bytecodes compiler
;; does not know how to externalize it.
;;(#.(si::standard-readtable) "cl_core.standard_readtable")
(LEAST-NEGATIVE-SHORT-FLOAT "-FLT_MIN")
(LEAST-NEGATIVE-SINGLE-FLOAT "-FLT_MIN")
(LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT "-FLT_MIN")
(LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT "-FLT_MIN")
(#.(find-package :cl) "cl_core.lisp_package")
(#.(find-package :cl-user) "cl_core.user_package")
(#.(find-package :keyword) "cl_core.keyword_package")
(#.(find-package :clos) "cl_core.clos_package")
#+threads
(#.(find-package :mp) "cl_core.mp_package")
(MOST-POSITIVE-DOUBLE-FLOAT "DBL_MAX")
(MOST-NEGATIVE-DOUBLE-FLOAT "-DBL_MAX")
(LEAST-POSITIVE-DOUBLE-FLOAT "DBL_MIN")
(LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT "DBL_MIN")
(LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_MIN")
(LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN")
#+long-float
,@'(
(MOST-POSITIVE-LONG-FLOAT "LDBL_MAX")
(MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX")
(LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN")
(LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN")
(LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN")
(LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN")
(#.(coerce 0 'long-float) "cl_core.longfloat_zero")
(#.(coerce -0.0 'long-float) "cl_core.longfloat_minus_zero")
)
)))
#+long-float
,@'(
(MOST-POSITIVE-LONG-FLOAT "LDBL_MAX")
(MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX")
(LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN")
(LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN")
(LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN")
(LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN")
)))))
......@@ -17,180 +17,46 @@
;; REPRESENTATION TYPES
;;
;; All known integer C types, sorted by bit size.
(defconstant +all-integer-rep-type-pairs+
'#.(stable-sort
'((:byte . -8)
(:unsigned-byte . 8)
(:unsigned-short . #.(logcount ffi:c-ushort-max))
(:short . #.(- (logcount ffi:c-ushort-max)))
(:unsigned-int . #.(logcount ffi:c-uint-max))
(:int . #.(logcount ffi:c-uint-max))
(:unsigned-long . #.(logcount ffi:c-ulong-max))
(:long . #.(logcount ffi:c-ulong-max))
#+long-long
(:unsigned-long-long . #.(logcount ffi:c-ulong-long-max))
#+long-long
(:long-long . #.(logcount ffi:c-ulong-long-max))
(:cl-index . #.(logcount most-positive-fixnum))
(:fixnum . #.(- (logcount most-positive-fixnum)))
(:uint8-t . 8)
(:int8-t . -8)
(:uint16-t . 16)
(:int16-t . -16)
(:uint32-t . 32)
(:int32-t . -32)
(:uint64-t . 64)
(:int64-t . -64))
#'< :key #'(lambda (pair) (abs (cdr pair)))))
(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_fixnum")
:unsigned-byte
#2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum")
:fixnum
(fixnum "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum")
:int
((integer #.ffi:c-int-min #.ffi:c-int-max) "int"
"ecl_make_int" "ecl_to_int" "ecl_to_int")
:unsigned-int
((integer 0 #.ffi:c-uint-max) "unsigned int"
"ecl_make_uint" "ecl_to_uint" "ecl_to_uint")
:long
((integer #.ffi:c-long-min #.ffi:c-long-max) "long" "ecl_make_long" "ecl_to_long"
#.(if (<= most-negative-fixnum ffi:c-long-min ffi:c-long-max most-positive-fixnum)
"ecl_fixnum"
"ecl_to_long"))
:unsigned-long
((integer 0 #.ffi:c-ulong-max) "unsigned long"
"ecl_make_ulong" "ecl_to_ulong"
#.(if (<= ffi:c-long-max most-positive-fixnum) "ecl_fixnum" "ecl_to_ulong"))
:cl-index
((integer 0 #.most-positive-fixnum) "cl_index"
"ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fixnum")
#+long-long
:long-long
#+long-long
((signed-byte #.ffi: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 #.ffi:c-long-long-bit) "ecl_ulong_long_t"
"ecl_make_ulong_long"
"ecl_to_ulong_long" "ecl_to_ulong_long")
:float
(single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float")
:double
(double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float")
#+:long-float
:long-double
#+:long-float
(long-float "long double" "ecl_make_long_float" "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_fixnum" "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_fixnum"
#.(if (subtypep '(signed-byte 16) 'fixnum) "ecl_fixnum" "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_fixnum" "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_fixnum" "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 #.ffi:c-short-min #.ffi:c-short-max) "short"
"ecl_make_short" "ecl_to_short" "ecl_fixnum")
:unsigned-short
((integer 0 #.ffi:c-ushort-max) "unsigned short"
"ecl_make_ushort" "ecl_to_ushort" "ecl_fixnum")
))
(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 rep-type-record-unsafe (rep-type)
(gethash rep-type (machine-rep-type-hash *machine*)))
(defun rep-type-record (rep-type)
(let ((record (gethash rep-type (machine-rep-type-hash *machine*))))
(unless record
(cmperr "Not a valid C type name ~A" rep-type))
record))
(defun rep-type->lisp-type (name)
(let ((output (rep-type-record-unsafe name)))
(cond (output
(rep-type-lisp-type output))
((lisp-type-p name) name)
(t (error "Unknown representation type ~S" name)))))
(defun lisp-type->rep-type (type)
(cond
;; We expect type = NIL when we have no information. Should be fixed. FIXME!
((null type)
:object)
((let ((r (rep-type-record-unsafe type)))
(and r (rep-type-name r))))
(t
;; Find the most specific type that fits
(dolist (record (machine-sorted-types *machine*) :object)
(when (subtypep type (rep-type-lisp-type record))
(return-from lisp-type->rep-type (rep-type-name record)))))))
(defun c-number-rep-type-p (rep-type)
(member rep-type +all-number-rep-types+))
(let ((r (rep-type-record-unsafe rep-type)))
(and r (rep-type-numberp r))))
(defun c-integer-rep-type-p (rep-type)
(member rep-type +all-integer-rep-types+))
(let ((r (rep-type-record-unsafe rep-type)))
(and r (rep-type-integerp r))))
(defun c-integer-rep-type-bits (rep-type)
(abs (cdr (assoc rep-type +all-integer-rep-type-pairs+))))
(let ((r (rep-type-record-unsafe rep-type)))
(and r (rep-type-bits r))))
(defun c-number-type-p (type)
(c-number-rep-type-p (lisp-type->rep-type type)))
......@@ -201,58 +67,33 @@
(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 rep-type->c-name (type)
(rep-type-c-name (rep-type-record 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)))
(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
(let ((record (rep-type-record loc-rep-type)))
(unless record