From a475d5bcba7437777d4eb94b7ca3dab3b8438b24 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 15 Feb 2009 23:53:03 +0100 Subject: [PATCH] Simplified c2call-global by taking the type propagation for (SETF AREF)/AREF into separate functions --- src/cmp/cmpcall.lsp | 69 ++++++++++--------------------------------- src/cmp/cmpeval.lsp | 18 +++++------ src/cmp/cmpfun.lsp | 10 +++---- src/cmp/cmpinline.lsp | 2 +- src/cmp/cmpprop.lsp | 46 +++++++++++++++++++++++++++++ src/cmp/cmptop.lsp | 3 +- src/cmp/cmptype.lsp | 2 +- src/cmp/load.lsp.in | 1 + 8 files changed, 80 insertions(+), 71 deletions(-) create mode 100644 src/cmp/cmpprop.lsp diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 728ec84ba..95860aa62 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -89,55 +89,18 @@ ;;; ARGS is the list of arguments ;;; LOC is either NIL or the location of the function object ;;; -(defun c2call-global (fname args loc return-type) - (case fname - (AREF - (let (etype (elttype (c1form-primary-type (car args)))) - (when (or (and (eq elttype 'STRING) - (setq elttype 'CHARACTER)) - (and (consp elttype) - (or (eq (car elttype) 'ARRAY) - (eq (car elttype) 'VECTOR)) - (setq elttype (second elttype)))) - (setq etype (type-and return-type elttype)) - (unless etype - (cmpwarn "Type mismatch found in AREF. Expected output type ~s, array element type ~s." return-type elttype) - (setq etype T)) ; assume no information - (setf return-type etype)))) - (SYS:ASET ; (sys:aset value array i0 ... in) - (let (etype - (valtype (c1form-primary-type (first args))) - (elttype (c1form-primary-type (second args)))) - (when (or (and (eq elttype 'STRING) - (setq elttype 'CHARACTER)) - (and (consp elttype) - (or (eq (car elttype) 'ARRAY) - (eq (car elttype) 'VECTOR)) - (setq elttype (second elttype)))) - (setq etype (type-and return-type (type-and valtype elttype))) - (unless etype - (cmpwarn "Type mismatch found in (SETF AREF). Expected output type ~s, array element type ~s, value type ~s." return-type elttype valtype) - (setq etype T)) - (setf return-type etype) - (setf (c1form-type (first args)) etype))))) - (when (null loc) - (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))) - (when fun - (when (c2try-tail-recursive-call fun args) - (return-from c2call-global)) - (setf loc fun)))) - (let ((*inline-blocks* 0)) - (call-global fname loc (inline-args args) return-type) - (close-inline-blocks))) +(defun c2call-global (fname args &optional (return-type (destination-type))) + (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))) + (when (and fun (c2try-tail-recursive-call fun args)) + (return-from c2call-global)) + (let ((*inline-blocks* 0)) + (unwind-exit (call-global-loc fname fun (inline-args args) return-type)) + (close-inline-blocks)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CALL LOCATIONS ;;; - -(defun call-global (&rest args) - (unwind-exit (apply #'call-global-loc args))) - ;;; ;;; call-global: ;;; FNAME: the name of the function @@ -145,29 +108,29 @@ ;;; ARGS: a list of typed locs with arguments ;;; RETURN-TYPE: the type to which the output is coerced ;;; -(defun call-global-loc (fname loc args return-type &aux found fd minarg maxarg) +(defun call-global-loc (fname fun args return-type &aux loc found fd minarg maxarg) (cond ;; Check whether it is a global function that we cannot call directly. - ((and (or (null loc) (fun-global loc)) (not (inline-possible fname))) + ((and (or (null fun) (fun-global fun)) (not (inline-possible fname))) (call-unknown-global-loc fname nil args)) ;; Open-codable function call. - ((and (or (null loc) (fun-global loc)) + ((and (or (null fun) (fun-global fun)) (setq loc (inline-function fname args return-type))) loc) ;; Call to a function defined in the same file. Direct calls are ;; only emitted for low or neutral values of DEBUG is >= 2. ((and (<= (cmp-env-optimization 'debug) 1) - (or (fun-p loc) - (and (null loc) - (setf loc (find fname *global-funs* :test #'same-fname-p + (or (fun-p fun) + (and (null fun) + (setf fun (find fname *global-funs* :test #'same-fname-p :key #'fun-name))))) - (call-loc fname loc args)) + (call-loc fname fun args)) ;; Call to a global (SETF ...) function ((not (symbolp fname)) - (call-unknown-global-loc fname loc args)) + (call-unknown-global-loc fname fun args)) ;; Call to a function whose C language function name is known, ;; either because it has been proclaimed so, or because it belongs @@ -182,7 +145,7 @@ ((multiple-value-setq (found fd minarg maxarg) (si::mangle-name fname t)) (call-exported-function-loc fname args fd minarg maxarg t)) - (t (call-unknown-global-loc fname loc args)))) + (t (call-unknown-global-loc fname fun args)))) (defun call-loc (fname fun args) `(CALL-NORMAL ,fun ,(coerce-locs args))) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 67c11e333..d273e73fe 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -109,15 +109,15 @@ ;; loc and type are filled by c2expr )))))) -(defun c2expr (form &aux (name (c1form-name form)) (args (c1form-args form))) - (if (eq name 'CALL-GLOBAL) - (c2call-global (first args) (second args) nil (destination-type)) - (let ((dispatch (get-sysprop name 'C2))) - (if (or (eq name 'LET) (eq name 'LET*)) - (let ((*volatile* (c1form-volatile* form))) - (declare (special *volatile*)) - (apply dispatch args)) - (apply dispatch args))))) +(defun c2expr (form) + (let* ((name (c1form-name form)) + (args (c1form-args form)) + (dispatch (get-sysprop name 'C2))) + (if (or (eq name 'LET) (eq name 'LET*)) + (let ((*volatile* (c1form-volatile* form))) + (declare (special *volatile*)) + (apply dispatch args)) + (apply dispatch args)))) (defun c2expr* (form) (let* ((*exit* (next-label)) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 58b3aab42..67559c7f5 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -49,11 +49,11 @@ (t (wt char))))) (wt "\"," stream-var ");"))) (unwind-exit nil)) - ((eql string #\Newline) (c2call-global 'TERPRI (list stream) nil t)) - (t (c2call-global - 'PRINC - (list (make-c1form 'LOCATION *info* (add-object string)) - stream) nil t)))) + ((eql string #\Newline) (c2call-global 'TERPRI (list stream) t)) + (t (c2call-global 'PRINC + (list (make-c1form 'LOCATION *info* (add-object string)) + stream) + t)))) (defun c1terpri (args &aux stream) (check-args-number 'TERPRI args 0 1) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 724523002..3f471842f 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -96,7 +96,7 @@ (*lcl* *lcl*) (*temp* *temp*) (*destination* temp)) - (call-global fname nil arg-locs return-type) + (unwind-exit (call-global-loc fname nil arg-locs return-type)) (wt-label *exit*) (push (list (if (subtypep 'T return-type) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp new file mode 100644 index 000000000..0a9d1547e --- /dev/null +++ b/src/cmp/cmpprop.lsp @@ -0,0 +1,46 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; 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 file '../Copyright' for full details. + +;;;; CMPPROP Type propagation. + +(in-package "COMPILER") + +(defun type-from-array-elt (array) + "Input is a lisp type representing a valid subtype of ARRAY. Output is +either the array element type or NIL, denoting that we are not able to +compute it. This version only handles the simplest cases." + (cond ((eq array 'string) + 'character) + ((eq array 'base-string) + 'base-char) + ((member array '(array vector simple-vector simple-array)) + t) + ((atom array) + nil) + ((not (member (first array) '(array vector simple-vector simple-array))) + nil) + ((null (rest array)) + t) + (t + (second array)))) + +(def-type-propagator si::aset (fname obj array &rest indices) + (let* ((array-type (c1form-primary-type array)) + (elt-type (or (type-from-array-elt array) t))) + (values (list* elt-type array-type (make-list (length indices) :initial-element 'si::index)) + elt-type))) + +(def-type-propagator aref (fname array &rest indices) + (let* ((array-type (c1form-primary-type array)) + (elt-type (or (type-from-array-elt array) t))) + (values (list* array-type (make-list (length indices) :initial-element 'si::index)) + elt-type))) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 9e9831244..8d61691ff 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -687,8 +687,7 @@ (unless (and (not (fun-closure fun)) (eq *destination* 'TRASH)) (return-from c2fset - (c2call-global 'SI:FSET c1forms 'NIL - (c1form-primary-type (second c1forms))))) + (c2call-global 'SI:FSET c1forms 'NIL (c1form-primary-type (second c1forms))))) (let ((*inline-blocks* 0) (loc (data-empty-loc))) (push (list loc fname fun) *global-cfuns-array*) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 233fb3812..76dba60fb 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -433,7 +433,7 @@ (defmacro def-type-propagator (fname lambda-list &body body) `(put-sysprop ',fname 'C1TYPE-PROPAGATOR - #'(ext:lambda-block ,fname ,lambda-list ,body))) + #'(ext:lambda-block ,fname ,lambda-list ,@body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 6712cbe15..7d341e9a8 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -33,6 +33,7 @@ "src:cmp;cmpnum.lsp" "src:cmp;cmpname.lsp" "src:cmp;cmpopt.lsp" + "src:cmp;cmpprop.lsp" "src:cmp;cmpclos.lsp" "src:cmp;cmpstructures.lsp" "src:cmp;cmparray.lsp"