mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 23:32:17 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: merge AST nodes CALL-LOCAL and CALL-GLOBAL into FCALL

Browse source 
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.
This commit is contained in:
Daniel Kochmański 2023-06-16 14:53:08 +02:00
parent 29a37c339e
commit da985b945b
4 changed files with 41 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

27
src/cmp/cmpbackend-cxx/cmppass2-call.lsp
View file

@ -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
;;;

20
src/cmp/cmppass1-call.lsp
View file

@ -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

17
src/cmp/cmpprop.lsp
View file

@ -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))

14
src/cmp/cmptables.lsp
View file

@ -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)