From 18abdba4e1aac0bad1839efcde777177e415db0a Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sat, 2 Jun 2012 10:54:43 +0200 Subject: [PATCH] The CALL-NORMAL location in the compiler now remembers the type of its output (needed by wt-coerce-loc) --- src/cmp/cmpcall.lsp | 19 +++++++++++-------- src/cmp/cmpffi.lsp | 1 + src/cmp/cmpflet.lsp | 3 ++- src/cmp/cmploc.lsp | 2 +- 4 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index f222be7b3..bfa7a56f0 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -127,7 +127,7 @@ (and (null fun) (setf fun (find fname *global-funs* :test #'same-fname-p :key #'fun-name))))) - (return-from call-global-loc (call-loc fname fun args))) + (return-from call-global-loc (call-loc fname fun args return-type))) ;; Call to a global (SETF ...) function (when (not (symbolp fname)) @@ -143,21 +143,24 @@ (return-from call-global-loc (call-exported-function-loc fname args fd minarg maxarg - (member fname *in-all-symbols-functions*))))))) + (member fname *in-all-symbols-functions*) + return-type)))))) (multiple-value-bind (found fd minarg maxarg) (si::mangle-name fname t) (when found (return-from call-global-loc - (call-exported-function-loc fname args fd minarg maxarg t)))) + (call-exported-function-loc fname args fd minarg maxarg t + return-type)))) (call-unknown-global-loc fname nil args)) -(defun call-loc (fname fun args) +(defun call-loc (fname fun args type) (declare (ignore fname)) - `(CALL-NORMAL ,fun ,(coerce-locs args))) + `(CALL-NORMAL ,fun ,(coerce-locs args) ,type)) -(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core) +(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core + return-type) (unless in-core ;; We only write declarations for functions which are not in lisp_external.h (multiple-value-bind (val declared) @@ -180,7 +183,7 @@ (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) (let ((fun (make-fun :name fname :global t :cfun fun-c-name :lambda 'NIL :minarg minarg :maxarg maxarg))) - (call-loc fname fun args))) + (call-loc fname fun args return-type))) ;;; ;;; call-unknown-global-loc @@ -252,7 +255,7 @@ (wt ")") (when fname (wt-comment fname)))) -(defun wt-call-normal (fun args) +(defun wt-call-normal (fun args type) (unless (fun-cfun fun) (baboon "Function without a C name: ~A" (fun-name fun))) (let* ((minarg (fun-minarg fun)) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 7dd13f0d1..8fbe11a11 100755 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -288,6 +288,7 @@ (BIND (var-type (second loc))) (LCL (or (third loc) T)) (THE (second loc)) + (CALL-NORMAL (fourth loc)) (otherwise T))))) (defun loc-representation-type (loc) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index e1e8fecd7..c286f62c1 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -263,5 +263,6 @@ (unless (c2try-tail-recursive-call fun args) (let ((*inline-blocks* 0) (*temp* *temp*)) - (unwind-exit (list 'CALL-NORMAL fun (coerce-locs (inline-args args)))) + (unwind-exit (call-loc (fun-name fun) fun (inline-args args) + (c1form-primary-type c1form))) (close-inline-blocks)))) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 0c74ac5b3..f59e0f0de 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -29,7 +29,7 @@ ;;; ( TEMP temp ) local variable, type object ;;; ( FRAME ndx ) variable in local frame stack ;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments -;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed +;;; ( CALL-NORMAL fun locs 1st-type ) similar as CALL, but number of arguments is fixed ;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function ;;; ( C-INLINE output-type fun/string locs side-effects output-var ) ;;; ( COERCE-LOC representation-type location)