From da985b945bfa8bb3581801c98bf97fa4e46a4356 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 16 Jun 2023 14:53:08 +0200 Subject: [PATCH] cmp: merge AST nodes CALL-LOCAL and CALL-GLOBAL into FCALL This yields simpler AST that is easier to reason about. One of the benefits is that we propagate argument types for FCALL disregarding of whether it is a short or long call. --- src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 27 ++++++++++++++++++++---- src/cmp/cmppass1-call.lsp | 20 ++++++++++-------- src/cmp/cmpprop.lsp | 17 ++------------- src/cmp/cmptables.lsp | 14 +++++------- 4 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index 0f8c70141..8e334541b 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -25,16 +25,35 @@ (c2expr* value) temp))))) -(defun c2fcall (c1form form args) - (if (> (length args) si:c-arguments-limit) - (c2call-stack c1form form args nil) - (c2call-unknown c1form form args))) +;;; FIXME functions declared as SI::C-LOCAL can't be called from the stack +;;; because they are not installed in the environment. That means that if we +;;; have such function and call it with too many arguments it will be +;;; "undefined". This is a defect (but not a regression). -- jd 2023-06-16 +;;; +;;; c2fcall: +;;; +;;; FUN the function to be called +;;; ARGS is the list of arguments +;;; FUN-VAL depends on the particular call type +;;; CALL-TYPE is (member :LOCAL :GLOBAL :UKNOWN) +;;; +(defun c2fcall (c1form fun args fun-val call-type) + (if (> (length args) si:c-arguments-limit) + (c2call-stack c1form fun args nil) + (ecase call-type + (:local (c2call-local c1form fun-val args)) + (:global (c2call-global c1form fun-val args)) + (:unknown (c2call-unknown c1form fun args))))) + +;;; FIXME now we could incorporate the call type for MCALL to faciliate the +;;; type propagation. (defun c2mcall (c1form form args) (c2call-stack c1form form args t)) ;;; ;;; c2call-global: +;;; ;;; ARGS is the list of arguments ;;; LOC is either NIL or the location of the function object ;;; diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index 322554327..9d4f1e1e6 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -10,8 +10,10 @@ (in-package #:compiler) (defun unoptimized-funcall (fun arguments) - (make-c1form* 'FCALL :sp-change t :side-effects t - :args (c1expr fun) (c1args* arguments))) + (let ((fun-form (c1expr fun)) + (fun-args (c1args* arguments))) + (make-c1form* 'FCALL :sp-change t :side-effects t + :args fun-form fun-args nil :unknown))) (defun optimized-lambda-call (lambda-form arguments apply-p) (multiple-value-bind (bindings body) @@ -87,8 +89,8 @@ ;; More complicated case. (t (make-c1form* 'MCALL - :sp-change t :side-effects t :args (c1expr (first args)) - (c1args* (rest args)))))) + :sp-change t :side-effects t + :args (c1expr (first args)) (c1args* (rest args)))))) (defun c1apply (args) (check-args-number 'CL:APPLY args 2) @@ -190,11 +192,11 @@ (pop arg-types) (pop args)))) (setq forms (nreverse fl)))) - (make-c1form* 'CALL-LOCAL + (make-c1form* 'FCALL :sp-change t ; conservative estimate :side-effects t ; conservative estimate :type return-type - :args fun forms))) + :args (c1expr `(function ,fname)) forms fun :local))) (defun c1call-global (fname args) (let* ((forms (c1args* args))) @@ -205,11 +207,11 @@ (when value (return-from c1call-global value))) ;; Otherwise emit a global function call - (make-c1form* 'CALL-GLOBAL + (make-c1form* 'FCALL :sp-change (function-may-change-sp fname) :side-effects (function-may-have-side-effects fname) :type (propagate-types fname forms) - :args fname forms + :args (c1expr `(function ,fname)) forms fname :global ;; loc and type are filled by c2expr ))) @@ -233,7 +235,7 @@ (c1constant-value (first results)) (let ((results (mapcar #'c1constant-value results))) (when (every #'identity results) - (make-c1form* 'values :args results))))))) + (make-c1form* 'CL:VALUES :args results))))))) (error (c) (cmpdebug "Can't constant-fold ~s ~s: ~a~%" fname forms c))))) ;;; Transform a (funcall lambda-form arguments) or (apply lambda-form diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 63d93aa42..4b478ef52 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -90,21 +90,8 @@ values-type)) values-type)) -(defun p1call-global (c1form fname args) - (declare (ignore c1form)) - (loop for v in args - do (p1propagate v) - finally (let ((type (propagate-types fname args))) - (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" - fname (mapcar #'c1form-primary-type args) - type (c1form-type c1form)) - (return type)))) - -(defun p1call-local (c1form fun args) - (declare (ignore c1form)) - (loop for v in args - do (p1propagate v) - finally (return (fun-return-type fun)))) +(defun p1fcall (c1form fun args fun-val call-type) + (p1trivial c1form fun args fun-val call-type)) (defun p1catch (c1form tag body) (declare (ignore c1form)) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 9b3c9eb14..405cc4623 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -32,10 +32,9 @@ (CL:PROGV symbols values form :side-effects) (CL:TAGBODY tag-var tag-body :pure) (CL:RETURN-FROM blk-var nonlocal value :side-effects) - (FCALL fun-value (arg-value*) :side-effects) - (MCALL fun-value (arg-value*) :side-effects) - (CALL-LOCAL obj-fun (arg-value*) :side-effects) - (CALL-GLOBAL fun-name (arg-value*)) + (FCALL fun-form (arg-value*) fun-val call-type :side-effects) + (MCALL fun-form (arg-value*) :side-effects) + (CL:CATCH catch-value body :side-effects) (CL:UNWIND-PROTECT protected-c1form body :side-effects) (CL:THROW catch-value output-value :side-effects) @@ -210,7 +209,7 @@ (cl:return-from . c2return-from) (fcall . c2fcall) (mcall . c2mcall) - (call-global . c2call-global) + (cl:catch . c2catch) (cl:unwind-protect . c2unwind-protect) (cl:throw . c2throw) @@ -218,7 +217,6 @@ (ffi:c-inline . c2c-inline) (ffi:c-progn . c2c-progn) (locals . c2locals) - (call-local . c2call-local) (cl:if . c2if) (fmla-not . c2fmla-not) @@ -264,10 +262,8 @@ (defconstant +p1-dispatch-alist+ '((cl:block . p1block) (cl:return-from . p1return-from) - (fcall . p1trivial) + (fcall . p1fcall) (mcall . p1trivial) - (call-global . p1call-global) - (call-local . p1call-local) (cl:catch . p1catch) (cl:throw . p1throw) (cl:if . p1if)