From 2a631151fdb7a47c438daa9c9e6bb2db78e1a6aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 11 Sep 2023 17:04:17 +0200 Subject: [PATCH] cmp: mcall: implement the type propagation, make similar to fcall While there is less we can doc compared FCALL, we still can infer the function type and propagate it. Both AST nodes FCALL and MCALL accept now the same set of arguments and MCALL has a new type propagator. --- src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 4 +- src/cmp/cmppass1-call.lsp | 83 +++++++++++++++++++----- src/cmp/cmpprop.lsp | 9 +++ src/cmp/cmptables.lsp | 4 +- 4 files changed, 80 insertions(+), 20 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index 8e334541b..5ecad4e65 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -46,9 +46,7 @@ (: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) +(defun c2mcall (c1form form args fun-val call-type) (c2call-stack c1form form args t)) ;;; diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index c984de271..e4aafaaaf 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -80,23 +80,76 @@ ;; (FUNCALL lisp-expression ...) or (FUNCALL atomic-expression ...) (unoptimized-funcall fun arguments)))) +;;; Further optimization opportunities: +;;; - expand macros +;;; - expand compiler macros +;;; - rely on the function proclamations +;;; - rely on the inferred argument type +(defun try-spill-values-funcall (fun arguments) + (flet ((values-form (arg) + (setq arg (chk-symbol-macrolet arg)) + (if (or (atom arg) + (eq (car arg) 'CL:VALUES)) + arg + (return-from try-spill-values-funcall nil)))) + (loop for arg in arguments + for val = (values-form arg) + if (atom val) + collect val into values + else + append (cdr val) into values + finally (return (c1funcall (list* fun values)))))) + +(defun try-macro-expression-mvc (fun arguments) + (unless (consp fun) + (return-from try-macro-expression-mvc nil)) + (let* ((name (first fun)) + (fd (and (symbolp name) + ;; We do not want to macroexpand 'CL:THE + (not (eq name 'CL:THE)) + (cmp-macro-function name)))) + (if fd + (c1multiple-value-call (list* (cmp-expand-macro fd fun) arguments)) + nil))) + +(defun try-function-special-mvc (fun arguments) + (unless (function-form-p fun) + (return-from try-function-special-mvc nil)) + (let ((fname (second fun))) + (if (si:valid-function-name-p fname) + (ext:if-let ((funob (local-function-ref fname))) + (make-c1form* 'MCALL + :sp-change t ; conservative estimate + :side-effects t ; conservative estimate + :args (c1expr fun) (c1args* arguments) funob :local) + (make-c1form* 'MCALL + :sp-change (function-may-change-sp fname) + :side-effects (function-may-have-side-effects fname) + :args (c1expr fun) (c1args* arguments) fname :global)) + (if (lambda-form-p fun) + nil + (cmperr "Malformed function name: ~A." fname))))) + +(defun unoptimized-mvc (fun arguments) + (let ((fun-form (c1expr fun)) + (fun-args (c1args* arguments))) + (make-c1form* 'MCALL + :sp-change t + :side-effects t + :args fun-form fun-args nil :unknown))) + (defun c1multiple-value-call (args &aux forms) (check-args-number 'CL:MULTIPLE-VALUE-CALL args 1) - (cond - ;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION) - ((endp (rest args)) - (c1funcall args)) - ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) - ((and (= (length args) 2) - (consp (setq forms (second args))) - (eq 'CL:VALUES (first forms))) - (c1funcall (list* (first args) (rest forms)))) - ;; More complicated case. - (t - (make-c1form* 'MCALL - :sp-change t - :side-effects t - :args (c1expr (first args)) (c1args* (rest args)))))) + (destructuring-bind (fun . arguments) args + (or ;; (M-V-C expression (VALUES A B) (VALUES X Y Z) ...) + ;; => (FUNCALL expression A B X Y Z ...) + (try-spill-values-funcall fun arguments) + ;; (M-V-C macro-expression ...) + (try-macro-expression-mvc fun arguments) + ;; (M-V-C (FUNCTION function-name) ...) + (try-function-special-mvc fun arguments) + ;; (M-V-C lisp-expression ...) or (M-V-C atomic-expression ...) + (unoptimized-mvc fun arguments)))) (defun c1apply (args) (check-args-number 'CL:APPLY args 2) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 843534154..4021f05a2 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -115,6 +115,15 @@ (:unknown (p1trivial c1form)))) +(defun p1mcall (c1form fun args fun-val call-type) + (declare (ignore fun)) + (p1propagate fun) + (p1propagate-list args) + (ecase call-type + (:global (or (get-return-type fun-val) '(VALUES &REST T))) + (:local (or (get-local-return-type fun-val) '(VALUES &REST T))) + (:unknown (p1trivial c1form)))) + (defun p1catch (c1form tag body) (declare (ignore c1form)) (p1propagate tag) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 405cc4623..b22ac32ca 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -33,7 +33,7 @@ (CL:TAGBODY tag-var tag-body :pure) (CL:RETURN-FROM blk-var nonlocal value :side-effects) (FCALL fun-form (arg-value*) fun-val call-type :side-effects) - (MCALL fun-form (arg-value*) :side-effects) + (MCALL fun-form (arg-value*) fun-val call-type :side-effects) (CL:CATCH catch-value body :side-effects) (CL:UNWIND-PROTECT protected-c1form body :side-effects) @@ -263,7 +263,7 @@ '((cl:block . p1block) (cl:return-from . p1return-from) (fcall . p1fcall) - (mcall . p1trivial) + (mcall . p1mcall) (cl:catch . p1catch) (cl:throw . p1throw) (cl:if . p1if)