mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-26 06:22:33 -08:00
cmpc: move wt "call" routines to cmpc-wt
This commit is contained in:
Daniel Kochmański
parent
ae6614ebba
commit
ff67ebfa1a
5 changed files with 354 additions and 344 deletions
|
|
@ -62,6 +62,30 @@
|
|||
(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)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-numberp r))))
|
||||
|
||||
(defun c-integer-rep-type-p (rep-type)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-integerp r))))
|
||||
|
||||
(defun c-integer-rep-type-bits (rep-type)
|
||||
(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)))
|
||||
|
||||
(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->c-name (type)
|
||||
(rep-type-c-name (rep-type-record type)))
|
||||
|
||||
;; These types can be used by ECL to unbox data They are sorted from
|
||||
;; the most specific, to the least specific one. All functions must
|
||||
;; be declared in external.h (not internal.h) header file.
|
||||
|
|
|
|||
|
|
@ -72,7 +72,8 @@
|
|||
(defun tail-recursion-possible ()
|
||||
(dolist (ue *unwind-exit*
|
||||
(baboon :format-control "tail-recursion-possible: should never return."))
|
||||
(cond ((eq ue 'TAIL-RECURSION-MARK) (return t))
|
||||
(cond ((eq ue 'TAIL-RECURSION-MARK)
|
||||
(return t))
|
||||
((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME))
|
||||
(return nil))
|
||||
((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV)))
|
||||
|
|
@ -230,58 +231,4 @@
|
|||
function-p t)))
|
||||
`(CALL-INDIRECT ,loc ,(coerce-locs args) ,fname ,function-p))
|
||||
|
||||
|
||||
;;; wt routines
|
||||
|
||||
(defun wt-call (fun args &optional fname env)
|
||||
(if env
|
||||
(progn
|
||||
(setf *aux-closure* t)
|
||||
(wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,")
|
||||
(wt-call fun args)
|
||||
(wt ")"))
|
||||
(progn
|
||||
(wt fun "(")
|
||||
(let ((comma ""))
|
||||
(dolist (arg args)
|
||||
(wt comma arg)
|
||||
(setf comma ", ")))
|
||||
(wt ")")))
|
||||
(when fname (wt-comment fname)))
|
||||
|
||||
(defun wt-call-indirect (fun-loc args fname function-p)
|
||||
(let ((narg (length args)))
|
||||
(if function-p
|
||||
(wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg)
|
||||
(wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg))
|
||||
(dolist (arg args)
|
||||
(wt ", " arg))
|
||||
(wt ")")
|
||||
(when fname (wt-comment fname))))
|
||||
|
||||
(defun wt-call-normal (fun args type)
|
||||
(declare (ignore type))
|
||||
(unless (fun-cfun fun)
|
||||
(baboon "Function without a C name: ~A" (fun-name fun)))
|
||||
(let* ((minarg (fun-minarg fun))
|
||||
(maxarg (fun-maxarg fun))
|
||||
(fun-c-name (fun-cfun fun))
|
||||
(fun-lisp-name (fun-name fun))
|
||||
(narg (length args))
|
||||
(env nil))
|
||||
(case (fun-closure fun)
|
||||
(CLOSURE
|
||||
(when (plusp *max-env*)
|
||||
(setf env (environment-accessor fun))))
|
||||
(LEXICAL
|
||||
(let ((lex-lvl (fun-level fun)))
|
||||
(dotimes (n lex-lvl)
|
||||
(let* ((j (- lex-lvl n 1))
|
||||
(x (lex-env-var-name j)))
|
||||
(push x args))))))
|
||||
(unless (<= minarg narg maxarg)
|
||||
(cmperr "Wrong number of arguments for function ~S"
|
||||
(or fun-lisp-name 'ANONYMOUS)))
|
||||
(when (fun-needs-narg fun)
|
||||
(push narg args))
|
||||
(wt-call fun-c-name args nil env)))
|
||||
|
|
|
|||
|
|
@ -15,170 +15,6 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defun c-number-rep-type-p (rep-type)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-numberp r))))
|
||||
|
||||
(defun c-integer-rep-type-p (rep-type)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-integerp r))))
|
||||
|
||||
(defun c-integer-rep-type-bits (rep-type)
|
||||
(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)))
|
||||
|
||||
(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->c-name (type)
|
||||
(rep-type-c-name (rep-type-record type)))
|
||||
|
||||
(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
|
||||
csfloat-value
|
||||
cdfloat-value
|
||||
clfloat-value)))
|
||||
(wt (third loc)) ;; VV index
|
||||
(return-from wt-to-object-conversion))
|
||||
(let ((record (rep-type-record loc-rep-type)))
|
||||
(unless record
|
||||
(cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type))
|
||||
(wt (rep-type-to-lisp record) "(" loc ")")))
|
||||
|
||||
(defun wt-from-object-conversion (dest-type loc-type rep-type loc)
|
||||
(let* ((record (rep-type-record rep-type))
|
||||
(coercer (and record (rep-type-from-lisp record))))
|
||||
(unless coercer
|
||||
(cmperr "Cannot coerce lisp object to C type ~A" rep-type))
|
||||
(wt (if (or (policy-assume-no-errors)
|
||||
(subtypep loc-type dest-type))
|
||||
(rep-type-from-lisp-unsafe record)
|
||||
coercer)
|
||||
"(" loc ")")))
|
||||
|
||||
(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
|
||||
((:char :unsigned-char :wchar)
|
||||
(case loc-rep-type
|
||||
((:char :unsigned-char :wchar)
|
||||
(wt "(" (rep-type->c-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)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq loc-rep-type :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))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:csfloat :cdfloat :clfloat)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq loc-rep-type :object)
|
||||
;; We relax the check a bit, because it is valid in C to coerce
|
||||
;; between COMPLEX floats of different types.
|
||||
(ensure-valid-object-type 'SI:COMPLEX-FLOAT)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:bool)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "1"))
|
||||
((eq loc-rep-type :object)
|
||||
(wt "(" loc ")!=ECL_NIL"))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:object)
|
||||
(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))))
|
||||
((: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
|
||||
;; At this point we only have coercions to integers
|
||||
(cond
|
||||
((not (c-integer-rep-type-p dest-rep-type))
|
||||
(coercion-error))
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq :object loc-rep-type)
|
||||
(ensure-valid-object-type dest-type)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(t
|
||||
(coercion-error))))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; C/C++ DECLARATIONS AND HEADERS
|
||||
;;;
|
||||
|
|
@ -341,45 +177,6 @@
|
|||
(t
|
||||
`(COERCE-LOC ,rep-type ,loc)))))
|
||||
|
||||
(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars)
|
||||
(declare (ignore output-rep-type side-effects))
|
||||
(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*))))))
|
||||
|
||||
(defun c-inline-safe-string (constant-string)
|
||||
;; Produce a text representation of a string that can be used
|
||||
;; in a C-INLINE form, without triggering the @ or # escape
|
||||
|
|
|
|||
|
|
@ -5,17 +5,18 @@
|
|||
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
||||
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
||||
;;;;
|
||||
;;;; 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 the file 'LICENSE' for the copyright details.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
;;;; CMPLOC Set-loc and Wt-loc.
|
||||
;;;; Set-loc and Wt-loc.
|
||||
|
||||
(in-package "COMPILER")
|
||||
|
||||
|
||||
;;;
|
||||
;;; Mundane locs
|
||||
;;;
|
||||
|
||||
(defun wt-loc (loc)
|
||||
(cond ((consp loc)
|
||||
(let ((fd (gethash (car loc) *wt-loc-dispatch-table*)))
|
||||
|
|
@ -37,8 +38,9 @@
|
|||
(unknown-location 'wt-loc loc))))
|
||||
|
||||
(defun wt-lcl (lcl)
|
||||
(unless (numberp lcl) (baboon :format-control "wt-lcl: ~s NaN"
|
||||
:format-arguments (list lcl)))
|
||||
(unless (numberp lcl)
|
||||
(baboon :format-control "wt-lcl: ~s NaN"
|
||||
:format-arguments (list lcl)))
|
||||
(wt "v" lcl))
|
||||
|
||||
(defun wt-lcl-loc (lcl &optional type name)
|
||||
|
|
@ -79,14 +81,326 @@
|
|||
;; 'char' which have sign problems
|
||||
(wt value))
|
||||
|
||||
(defun wt-value (i) (wt "cl_env_copy->values[" i "]"))
|
||||
(defun wt-value (i)
|
||||
(wt "cl_env_copy->values[" i "]"))
|
||||
|
||||
(defun wt-keyvars (i) (wt "keyvars[" i "]"))
|
||||
(defun wt-keyvars (i)
|
||||
(wt "keyvars[" i "]"))
|
||||
|
||||
(defun wt-the (type loc)
|
||||
(declare (ignore type))
|
||||
(wt-loc loc))
|
||||
|
||||
|
||||
;;;
|
||||
;;; CALL-LOC
|
||||
;;;
|
||||
|
||||
(defun wt-call (fun args &optional fname env)
|
||||
(if env
|
||||
(progn
|
||||
(setf *aux-closure* t)
|
||||
(wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,")
|
||||
(wt-call fun args)
|
||||
(wt ")"))
|
||||
(progn
|
||||
(wt fun "(")
|
||||
(let ((comma ""))
|
||||
(dolist (arg args)
|
||||
(wt comma arg)
|
||||
(setf comma ", ")))
|
||||
(wt ")")))
|
||||
(when fname (wt-comment fname)))
|
||||
|
||||
(defun wt-call-indirect (fun-loc args fname function-p)
|
||||
(let ((narg (length args)))
|
||||
(if function-p
|
||||
(wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg)
|
||||
(wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg))
|
||||
(dolist (arg args)
|
||||
(wt ", " arg))
|
||||
(wt ")")
|
||||
(when fname (wt-comment fname))))
|
||||
|
||||
(defun wt-call-normal (fun args type)
|
||||
(declare (ignore type))
|
||||
(unless (fun-cfun fun)
|
||||
(baboon "Function without a C name: ~A" (fun-name fun)))
|
||||
(let* ((minarg (fun-minarg fun))
|
||||
(maxarg (fun-maxarg fun))
|
||||
(fun-c-name (fun-cfun fun))
|
||||
(fun-lisp-name (fun-name fun))
|
||||
(narg (length args))
|
||||
(env nil))
|
||||
(case (fun-closure fun)
|
||||
(CLOSURE
|
||||
(when (plusp *max-env*)
|
||||
(setf env (environment-accessor fun))))
|
||||
(LEXICAL
|
||||
(let ((lex-lvl (fun-level fun)))
|
||||
(dotimes (n lex-lvl)
|
||||
(let* ((j (- lex-lvl n 1))
|
||||
(x (lex-env-var-name j)))
|
||||
(push x args))))))
|
||||
(unless (<= minarg narg maxarg)
|
||||
(cmperr "Wrong number of arguments for function ~S"
|
||||
(or fun-lisp-name 'ANONYMOUS)))
|
||||
(when (fun-needs-narg fun)
|
||||
(push narg args))
|
||||
(wt-call fun-c-name args nil env)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; FDEFINITION, MAKE-CLOSURE
|
||||
;;;
|
||||
(defun wt-fdefinition (fun-name)
|
||||
(let* ((name (si::function-block-name fun-name))
|
||||
(package (symbol-package name))
|
||||
(safe (or (not (safe-compile))
|
||||
(and (or (eq package (find-package "CL"))
|
||||
(eq package (find-package "CLOS"))
|
||||
(eq package (find-package "SI")))
|
||||
(fboundp fun-name)
|
||||
(functionp (fdefinition fun-name))))))
|
||||
(if (eq name fun-name)
|
||||
;; #'symbol
|
||||
(let ((vv (add-symbol name)))
|
||||
(if safe
|
||||
(wt "(" vv "->symbol.gfdef)")
|
||||
(wt "ecl_fdefinition(" vv ")")))
|
||||
;; #'(SETF symbol)
|
||||
(if safe
|
||||
#+(or)
|
||||
(let ((set-loc (assoc name *setf-definitions*)))
|
||||
(unless set-loc
|
||||
(let* ((setf-vv (data-empty-loc))
|
||||
(name-vv (add-symbol name))
|
||||
(setf-form-vv (add-object fun-name)))
|
||||
(setf set-loc (list name setf-vv name-vv setf-form-vv))
|
||||
(push set-loc *setf-definitions*)))
|
||||
(wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")"))
|
||||
(let ((set-loc (assoc name *setf-definitions*)))
|
||||
(unless set-loc
|
||||
(let* ((setf-vv (data-empty-loc))
|
||||
(name-vv (add-symbol name)))
|
||||
(setf set-loc (list name setf-vv name-vv))
|
||||
(push set-loc *setf-definitions*)))
|
||||
(wt "ECL_CONS_CAR(" (second set-loc) ")"))
|
||||
(let ((vv (add-symbol fun-name)))
|
||||
(wt "ecl_fdefinition(" vv ")"))))))
|
||||
|
||||
(defun environment-accessor (fun)
|
||||
(let* ((env-var (env-var-name *env-lvl*))
|
||||
(expected-env-size (fun-env fun)))
|
||||
(if (< expected-env-size *env*)
|
||||
(format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var)
|
||||
env-var)))
|
||||
|
||||
(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)))
|
||||
(declare (type fun fun))
|
||||
(let* ((closure (fun-closure fun))
|
||||
narg)
|
||||
(cond ((eq closure 'CLOSURE)
|
||||
(wt "ecl_make_cclosure_va((cl_objectfn)" cfun ","
|
||||
(environment-accessor fun)
|
||||
",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")"))
|
||||
((eq closure 'LEXICAL)
|
||||
(baboon :format-control "wt-make-closure: lexical closure detected."))
|
||||
((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args
|
||||
(wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")"))
|
||||
(t ; empty environment variable number of args
|
||||
(wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock,"
|
||||
(min (fun-minarg fun) si:c-arguments-limit) ")")))))
|
||||
|
||||
;;;
|
||||
;;; COERCE-LOC
|
||||
;;;
|
||||
|
||||
(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
|
||||
csfloat-value
|
||||
cdfloat-value
|
||||
clfloat-value)))
|
||||
(wt (third loc)) ;; VV index
|
||||
(return-from wt-to-object-conversion))
|
||||
(let ((record (rep-type-record loc-rep-type)))
|
||||
(unless record
|
||||
(cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type))
|
||||
(wt (rep-type-to-lisp record) "(" loc ")")))
|
||||
|
||||
(defun wt-from-object-conversion (dest-type loc-type rep-type loc)
|
||||
(let* ((record (rep-type-record rep-type))
|
||||
(coercer (and record (rep-type-from-lisp record))))
|
||||
(unless coercer
|
||||
(cmperr "Cannot coerce lisp object to C type ~A" rep-type))
|
||||
(wt (if (or (policy-assume-no-errors)
|
||||
(subtypep loc-type dest-type))
|
||||
(rep-type-from-lisp-unsafe record)
|
||||
coercer)
|
||||
"(" loc ")")))
|
||||
|
||||
(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
|
||||
((:char :unsigned-char :wchar)
|
||||
(case loc-rep-type
|
||||
((:char :unsigned-char :wchar)
|
||||
(wt "(" (rep-type->c-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)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq loc-rep-type :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))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:csfloat :cdfloat :clfloat)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq loc-rep-type :object)
|
||||
;; We relax the check a bit, because it is valid in C to coerce
|
||||
;; between COMPLEX floats of different types.
|
||||
(ensure-valid-object-type 'SI:COMPLEX-FLOAT)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:bool)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "1"))
|
||||
((eq loc-rep-type :object)
|
||||
(wt "(" loc ")!=ECL_NIL"))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:object)
|
||||
(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))))
|
||||
((: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
|
||||
;; At this point we only have coercions to integers
|
||||
(cond
|
||||
((not (c-integer-rep-type-p dest-rep-type))
|
||||
(coercion-error))
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq :object loc-rep-type)
|
||||
(ensure-valid-object-type dest-type)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(t
|
||||
(coercion-error))))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; INLINE-LOC
|
||||
;;;
|
||||
|
||||
(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars)
|
||||
(declare (ignore output-rep-type side-effects))
|
||||
(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*))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; SET-LOC
|
||||
;;;
|
||||
|
|
@ -113,7 +427,8 @@
|
|||
(if fd
|
||||
(apply fd loc (rest destination))
|
||||
(progn
|
||||
(wt-nl) (wt-loc destination) (wt " = ")
|
||||
(wt-nl)
|
||||
(wt-loc destination) (wt " = ")
|
||||
(wt-coerce-loc (loc-representation-type *destination*) loc)
|
||||
(wt ";"))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
(declare (ignore c1form funob))
|
||||
(case kind
|
||||
(GLOBAL
|
||||
(unwind-exit (list 'FDEFINITION fun)))
|
||||
(unwind-exit `(FDEFINITION ,fun)))
|
||||
(CLOSURE
|
||||
;; XXX: we have some code after baboon – is CLOSURE legal or not?
|
||||
(baboon :format-control "c2function: c1form is of unexpected kind.")
|
||||
|
|
@ -44,77 +44,4 @@
|
|||
(fun-env fun) 0))
|
||||
(otherwise
|
||||
(setf (fun-env fun) 0 (fun-level fun) 0)))
|
||||
(let ((previous
|
||||
nil
|
||||
#+(or)
|
||||
(dolist (old *local-funs*)
|
||||
(when (similar fun old)
|
||||
(return old)))))
|
||||
(if previous
|
||||
(progn
|
||||
(if (eq (fun-closure fun) 'CLOSURE)
|
||||
(cmpnote "Sharing code for closure")
|
||||
(cmpnote "Sharing code for local function ~A" (fun-name fun)))
|
||||
(setf (fun-cfun fun) (fun-cfun previous)
|
||||
(fun-lambda fun) nil)
|
||||
previous)
|
||||
(push fun *local-funs*))))
|
||||
|
||||
(defun wt-fdefinition (fun-name)
|
||||
(let* ((name (si::function-block-name fun-name))
|
||||
(package (symbol-package name))
|
||||
(safe (or (not (safe-compile))
|
||||
(and (or (eq package (find-package "CL"))
|
||||
(eq package (find-package "CLOS"))
|
||||
(eq package (find-package "SI")))
|
||||
(fboundp fun-name)
|
||||
(functionp (fdefinition fun-name))))))
|
||||
(if (eq name fun-name)
|
||||
;; #'symbol
|
||||
(let ((vv (add-symbol name)))
|
||||
(if safe
|
||||
(wt "(" vv "->symbol.gfdef)")
|
||||
(wt "ecl_fdefinition(" vv ")")))
|
||||
;; #'(SETF symbol)
|
||||
(if safe
|
||||
#+(or)
|
||||
(let ((set-loc (assoc name *setf-definitions*)))
|
||||
(unless set-loc
|
||||
(let* ((setf-vv (data-empty-loc))
|
||||
(name-vv (add-symbol name))
|
||||
(setf-form-vv (add-object fun-name)))
|
||||
(setf set-loc (list name setf-vv name-vv setf-form-vv))
|
||||
(push set-loc *setf-definitions*)))
|
||||
(wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")"))
|
||||
(let ((set-loc (assoc name *setf-definitions*)))
|
||||
(unless set-loc
|
||||
(let* ((setf-vv (data-empty-loc))
|
||||
(name-vv (add-symbol name)))
|
||||
(setf set-loc (list name setf-vv name-vv))
|
||||
(push set-loc *setf-definitions*)))
|
||||
(wt "ECL_CONS_CAR(" (second set-loc) ")"))
|
||||
(let ((vv (add-symbol fun-name)))
|
||||
(wt "ecl_fdefinition(" vv ")"))))))
|
||||
|
||||
(defun environment-accessor (fun)
|
||||
(let* ((env-var (env-var-name *env-lvl*))
|
||||
(expected-env-size (fun-env fun)))
|
||||
(if (< expected-env-size *env*)
|
||||
(format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var)
|
||||
env-var)))
|
||||
|
||||
(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)))
|
||||
(declare (type fun fun))
|
||||
(let* ((closure (fun-closure fun))
|
||||
narg)
|
||||
(cond ((eq closure 'CLOSURE)
|
||||
(wt "ecl_make_cclosure_va((cl_objectfn)" cfun ","
|
||||
(environment-accessor fun)
|
||||
",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")"))
|
||||
((eq closure 'LEXICAL)
|
||||
(baboon :format-control "wt-make-closure: lexical closure detected."))
|
||||
((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args
|
||||
(wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")"))
|
||||
(t ; empty environment variable number of args
|
||||
(wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock,"
|
||||
(min (fun-minarg fun) si:c-arguments-limit) ")")))))
|
||||
(push fun *local-funs*))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue