collect type propagtors in *inl-hash*, close parallel build race - gcl.git - GNU Common Lisp

diff --git a/gcl/Makefile.am b/gcl/Makefile.am
index 53d7d763b..583d0ce3b 100644
--- a/gcl/Makefile.am
+++ b/gcl/Makefile.am

@@ -270,7 +270,7 @@ unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXME necessary?

touch $@

unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/%

echo "(mapc (quote load) (directory \"$*/*.hsh\"))" \

- "(compiler::dump-inl-hash \"$@\")" | $|

+ "(compiler::dump-inl-hash \"$@\" t)" | $|

$(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \

unixport/lib%.a: lib/libbase_gcl.a $(LIBGPROF) unixport/sys_%.o

@@ -302,7 +302,7 @@ unixport/lib%.a: | xbin/ar_merge

%/recompile: | unixport/%

$| -batch \

-eval "(let ((si::*do-recomp-output-dir* \"$(@D)\")) (si::do-recomp t))" \

- -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\")"

+ -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\" t)"

touch $@

unixport/sys_%.o: unixport/sys_init.c

@@ -418,7 +418,7 @@ mod_gcl/%.o: mod_gcl0/%.o | unixport/mod_gcl

rm -rf $*/*.o

echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \

"(pcl::compile-pcl)" \

- "(compiler::dump-inl-hash \"$@\")" | $|

+ "(compiler::dump-inl-hash \"$@\" t)" | $|

%/all.hsh: %/p1.lisp %/all.hs1 | unixport/pcl_gcl

echo "pcl conflicts:"

diff --git a/gcl/Makefile.in b/gcl/Makefile.in
index 41a7208ab..b218211b2 100644
--- a/gcl/Makefile.in
+++ b/gcl/Makefile.in

@@ -4701,7 +4701,7 @@ unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXME necessary?

touch $@

unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/%

echo "(mapc (quote load) (directory \"$*/*.hsh\"))" \

- "(compiler::dump-inl-hash \"$@\")" | $|

+ "(compiler::dump-inl-hash \"$@\" t)" | $|

$(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \

unixport/lib%.a: lib/libbase_gcl.a $(LIBGPROF) unixport/sys_%.o

@@ -4728,7 +4728,7 @@ unixport/lib%.a: | xbin/ar_merge

%/recompile: | unixport/%

$| -batch \

-eval "(let ((si::*do-recomp-output-dir* \"$(@D)\")) (si::do-recomp t))" \

- -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\")"

+ -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\" t)"

touch $@

unixport/sys_%.o: unixport/sys_init.c

@@ -4843,7 +4843,7 @@ mod_gcl/%.o: mod_gcl0/%.o | unixport/mod_gcl

rm -rf $*/*.o

echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \

"(pcl::compile-pcl)" \

- "(compiler::dump-inl-hash \"$@\")" | $|

+ "(compiler::dump-inl-hash \"$@\" t)" | $|

%/all.hsh: %/p1.lisp %/all.hs1 | unixport/pcl_gcl

echo "pcl conflicts:"

diff --git a/gcl/cmpnew/gcl_cmpeval.lsp b/gcl/cmpnew/gcl_cmpeval.lsp
index 16898b353..663b93cca 100644
--- a/gcl/cmpnew/gcl_cmpeval.lsp
+++ b/gcl/cmpnew/gcl_cmpeval.lsp

@@ -648,6 +648,7 @@

(list (this-safety-level)

(mapcar (lambda (x) (assert (eq (car x) 'ub)) (third x)) (when lf (fifth form)))

(cons (when lf (third form)) (info-type (cadr form)))

+ (ninth form)

(if lf (remove-comment (fourth form)) "")))

(defun cl-to-fn (cl)

@@ -672,33 +673,77 @@

(when (eql (length x) (length cy))

(every 'type<= x cy))))))))

+(defun skip-inl (fm tps tr)

+ (or (member-if 'atomic-tp tps)

+ (atomic-tp (info-type (cadr fm)))

+ (exit-to-fmla-p)

+ (member nil tr)

+ (set-difference

+ (let ((i -1)) (mapcan (lambda (x &aux (y (incf i))) (unless (atomic-tp x) (list y))) tps))

+ tr)))

+

+(defun ?update-fm-propagator (fm cl tr tps)

+ (when (symbolp (car cl))

+ (when (get (car cl) 'type-propagator);?more

+ (when (eq (car fm) 'lit)

+ (when (member-if 'integerp tr) ;otherwise no point

+ (push (list (car cl) tr tps) (ninth fm)))))))

+

+(defun merge-inl (cl inl pl &aux (tps (pop inl))(tr (pop inl)))

+ (let ((z (member-if (lambda (x) (can-coalesce x tr inl tps)) (car pl))))

+ (cond (z (coalesce-inl cl (car z) tps (cdr (third inl)))

+ (setf (cdr z) (remove-if (lambda (x) (can-coalesce x tr inl tps)) (cdr z))))

+ (pl (let ((x (list* tps tr inl)))

+ (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-add)

+ "Adding inl-hash ~s: ~s" (car cl) x)

+ (push x (car pl)))))))

+

+(defun merge-inls (s inls &aux (cl (list s))(pl (get-inl-list cl t)))

+ (mapc (lambda (x) (merge-inl cl x pl)) inls))

+

(defun ?add-inl (cl fms fm)

- (unless (or (member-if 'atomic-tp fms :key (lambda (x) (info-type (caddr x))))

- (atomic-tp (info-type (cadr fm))) (exit-to-fmla-p)); (inls-match cl fms)

- (let* ((tps (mapcar (lambda (x) (info-type (caddr x))) fms))

- (tr (mapcar (lambda (x &aux (v (car (last x))))

- (when (and (consp v) (eq (car v) 'var))

- (position (cddr v) fms :key 'cdddr :test 'equalp)));FIXME

- (if (eq (car fm) 'var) (list (list fm)) (fifth fm))))

- (nat (let ((i -1)) (mapcan (lambda (x &aux (y (incf i))) (unless (atomic-tp x) (list y))) tps))))

- (unless (or (member nil tr) (set-difference nat tr))

- (let* ((pl (get-inl-list cl t))

- (inl (lit-inl2 fm))

- (z (member-if (lambda (x) (can-coalesce x tr inl tps)) (car pl))))

- (cond (z (coalesce-inl cl (car z) tps (cdr (third inl)))

- (setf (cdr z) (remove-if (lambda (x) (can-coalesce x tr inl tps)) (cdr z))))

- (pl

- (let ((x (list* tps tr inl)))

- (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-add)

- "Adding inl-hash ~s: ~s" (car cl) x)

- (push x (car pl))))))))))

+ (let* ((tps (mapcar (lambda (x) (info-type (caddr x))) fms))

+ (tr (mapcar (lambda (x &aux (v (car (last x))))

+ (when (and (consp v) (eq (car v) 'var))

+ (position (cddr v) fms :key 'cdddr :test 'equalp)));FIXME

+ (if (eq (car fm) 'var) (list (list fm)) (fifth fm)))))

+ (?update-fm-propagator fm cl tr tps)

+ (unless (skip-inl fm tps tr)

+ (merge-inl cl (list* tps tr (lit-inl2 fm)) (get-inl-list cl t)))))

(defun prepend-comment (form s)

(if *annotate*

- (si::string-concatenate "/* " (prin1-to-string form) " */" (remove-comment s))

+ (si::string-concatenate "/* " (prin1-to-string (subst #\a #\^@ form)) " */" (remove-comment s))

s))

-(defun apply-inl (cl fms &aux (inl (inls-match cl fms)))

+(defvar *apply-inl-hash* t)

+

+(defun update-info-type-from-inl (i inl fms &aux (tps (mapcar (lambda (x) (info-type (caddr x))) fms)))

+ (setf (info-type i)

+ (reduce 'type-and

+ (cons (cdr (fifth inl))

+ (mapcar (lambda (x)

+ (or

+ (result-type-from-args

+ (pop x)

+ (let ((i -1))

+ (mapcar (lambda (tp &aux (p (position (incf i) (car x))))

+ (if p (nth (nth p (second inl)) tps) tp))

+ (cadr x))))

+ t))

+ (sixth inl)))

+ :initial-value (info-type i))))

+

+(defun merge-fm-propagator (x fms inl)

+ (let* ((tr (mapcar (lambda (x &aux (v (car (last x))))

+ (when (and (consp v) (eq (car v) 'var))

+ (position (cddr v) fms :key 'cdddr :test 'equalp)));FIXME

+ (fifth x))))

+ (mapc (lambda (y) (?update-fm-propagator x y tr (caddr y)))

+ (sixth inl))))

+

+

+(defun apply-inl (cl fms &aux (inl (when *apply-inl-hash* (inls-match cl fms))))

(when inl

(let* ((c1fms (mapcar (lambda (x) (cdr (nth x fms))) (second inl))))

(unless (member-if-not (lambda (x)

@@ -706,35 +751,56 @@

(var (eq (var-kind (caaddr x)) 'lexical))

((lit location) t)))

c1fms)

- (cond ((zerop (length (car (last inl))))

- (let* ((x (car c1fms))(h (pop x))

- (i (copy-info (pop x))))

- (setf (info-type i) (type-and (cdr (fifth inl)) (info-type i)))

- (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-apply)

- "Applying var inl-hash ~s" (car cl))

- (list* h i x)))

- ((let ((x (c1lit (list (car (fifth inl)) (prepend-comment (cons 'applied cl) (car (last inl)))) (mapcar 'list (fourth inl) c1fms))))

- (setf (info-type (cadr x)) (type-and (cdr (fifth inl)) (info-type (cadr x))))

- (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-apply)

- "Applying inl-hash ~s: ~s: ~s" (car cl) (fourth x))

- x)))))))

-

-(defun dump-inl-hash (f)

+ (let* ((z (zerop (length (car (last inl)))))

+ (x (if z

+ (list* (caar c1fms) (copy-info (cadar c1fms)) (cddar c1fms))

+ (c1lit (list (car (fifth inl)) (prepend-comment (cons 'applied cl) (car (last inl))))

+ (mapcar 'list (fourth inl) c1fms)))))

+ (unless z (merge-fm-propagator x fms inl))

+ (update-info-type-from-inl (cadr x) inl fms)

+ (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-apply)

+ "Applying inl-hash ~s: ~s" (car cl) (unless z (fourth x)))

+ x)))))

+

+

+(defun compress-inl (s &aux (i (car (gethash s *inl-hash*))))

+ (when (> (length i) 1)

+ (let ((l (length i))

+ (x (reduce (lambda (y x)

+ (list

+ (mapl (lambda (z w) (setf (car z) (type-or1 (car z) (car w))))

+ (car y) (car x))

+ (max (cadr y) (third x))))

+ (cdr i) :initial-value (list (copy-list (caar i)) (third (car i)))))

+ (syms (mapcar (lambda (x) (declare (ignore x)) (gensym)) (make-list (length (caar i))))))

+ (compile nil `(lambda ,syms

+ (declare (optimize (safety ,(cadr x)))

+ ,@(mapcar (lambda (x y) (list (cmp-unnorm-tp x) y)) (car x) syms))

+ (,s ,@syms)))

+ (when (< (length (car (gethash s *inl-hash*))) l)

+ (format t "compress-inl ~s: ~s -> ~s~%" s l (length (car (gethash s *inl-hash*))))))))

+

+(defun dump-inl-hash (f &optional compress &aux (si::*print-package* t))

+ (when compress (maphash (lambda (x y) (declare (ignore y)) (compress-inl x)) *inl-hash*))

(with-open-file (s f :direction :output)

(prin1 '(in-package :compiler) s)

(terpri s)

(maphash (lambda (x y)

(prin1

- `(setf (gethash ',x *inl-hash*)

- (list

- (list

- ,@(mapcar (lambda (z)

- `(list (mapcar 'uniq-tp ',(mapcar 'export-type (pop z)))

- ',(pop z) ',(pop z) ',(pop z)

- (cons ',(caar z) (uniq-tp ',(cdar z)))

- ,(cadr z)))

- (car y)))))

- s)

+ `(merge-inls

+ ',x

+ (list

+ ,@(mapcar (lambda (z)

+ `(list (mapcar 'uniq-tp ',(mapcar 'export-type (pop z)))

+ ',(pop z) ',(pop z) ',(pop z)

+ (cons ',(caar z) (uniq-tp ',(cdar z)))

+ (list ,@(mapcan

+ (lambda (x)

+ `((list ',(pop x) ',(pop x) ',(mapcar 'export-type (car x)))))

+ (cadr z)))

+ ,(caddr z)))

+ (car y))))

+ s)

(terpri s))

*inl-hash*))

nil)

diff --git a/gcl/cmpnew/gcl_cmpinline.lsp b/gcl/cmpnew/gcl_cmpinline.lsp
index bea3790c0..141fb7517 100644
--- a/gcl/cmpnew/gcl_cmpinline.lsp
+++ b/gcl/cmpnew/gcl_cmpinline.lsp

@@ -355,7 +355,7 @@

(coerce-loc *value-to-go* type)))

-(defun lit-loc (key inl args bind safety oargs stores &aux (tp (get key 'cmp-lisp-type)))

+(defun lit-loc (key inl args bind safety oargs syms stores &aux (tp (get key 'cmp-lisp-type)))

(declare (ignore bind safety oargs stores))

(let ((sig (list (mapcar (lambda (x) (info-type (cadr x))) args) tp)))

(get-inline-loc (list (car sig) (cadr sig) (flags rfa) inl) args)))

diff --git a/gcl/cmpnew/gcl_cmptop.lsp b/gcl/cmpnew/gcl_cmptop.lsp
index d8d7d4545..ad44c5665 100644
--- a/gcl/cmpnew/gcl_cmptop.lsp
+++ b/gcl/cmpnew/gcl_cmptop.lsp

@@ -865,14 +865,14 @@

(incf i lff)(copy-list ff));FIXME?

((incf i)(list x))))

nargs))

- (form (list 'lit info key inl nargs nil lev oargs (make-vs info))))

+ (form (list 'lit info key inl nargs nil lev oargs nil (make-vs info))))

(when (find #\= inl)

(c1side-effects nil)

(setf (info-flags info) (logior (iflags side-effects) (info-flags info))))

(setf (sixth form) (new-bind form))

form))

-(defun c2lit (key inl args bind safety &rest r &aux (oargs (pop r)) (stores (car r)) (tp (get key 'cmp-lisp-type :opaque)))

+(defun c2lit (key inl args bind safety &rest r &aux (oargs (pop r)) (syms (pop r)) (stores (car r)) (tp (get key 'cmp-lisp-type :opaque)))

(declare (dynamic-extent r))

(let* ((*inline-blocks* 0)

(*restore-avma* *restore-avma*)

@@ -881,7 +881,7 @@

(*compiler-new-safety* *compiler-new-safety*)

(*compiler-push-events* *compiler-push-events*))

(local-compile-decls `((safety ,safety)))

- (unwind-exit (lit-loc key inl args bind safety oargs stores) nil

+ (unwind-exit (lit-loc key inl args bind safety oargs syms stores) nil

(cons 'values (if (equal tp #t(returns-exactly)) 0 1)))

(close-inline-blocks)))