(in-package "XLSCMP")
;;***** rethink substitution of multiple value continuations
;;***** review for multiple value continuations
;;***** add simplifiers for values, values-list and other mulval stuff
;;***** add simplifiers for multiple-value-prog1 stuff
;;;;;
;;;;; Simplification Phase
;;;;;
;;;
;;; Tree simplification rule data base
;;; (assoc list lets rules be redefined during development)
;;;
(defvar *call-rules* nil)
(defvar *lambda-call-rules* nil)
(defvar *simplify-debug* nil)
(defun add-call-rule (name rule)
(let ((c (assoc name *call-rules*)))
(if c
(setf (cdr c) rule)
(push (cons name rule) *call-rules*))))
(defun add-lambda-call-rule (name rule)
(let ((c (assoc name *lambda-call-rules*)))
(if c
(setf (cdr c) rule)
(push (cons name rule) *lambda-call-rules*))))
(defun add-symbol-call-rule (sym name rule)
(let ((c (assoc name (get sym 'call-simplification-rules))))
(if c
(setf (cdr c) rule)
(push (cons name rule) (get sym 'call-simplification-rules)))))
(defmacro define-call-rule (name &rest args)
`(add-call-rule ',name #'(lambda ,@args)))
(defmacro define-lambda-call-rule (name &rest args)
`(add-lambda-call-rule ',name #'(lambda ,@args)))
(defmacro define-symbol-call-rule (sym name &rest args)
`(add-symbol-call-rule ',sym ',name #'(lambda ,@args)))
(defun apply-simplification-rules (n)
(let ((changed nil))
(when (call-node-p n)
(dolist (r *call-rules*)
(let ((old-n (if *simplify-debug* (copy-node-tree n))))
(when (funcall (cdr r) n)
(setf changed t)
(when *simplify-debug* (pp-cps old-n) (pp-cps n))
(if *breakenable* (format t "call rule ~a~%" (car r))))))
(let ((f (call-node-function n)))
(cond
((lambda-node-p f)
(dolist (r *lambda-call-rules*)
(unless (lambda-node-p (call-node-function n)) (return))
(let ((old-n (if *simplify-debug* (copy-node-tree n))))
(when (funcall (cdr r) n)
(setf changed t)
(when *simplify-debug* (pp-cps old-n) (pp-cps n))
(if *breakenable*
(format t "lambda rule ~a~%" (car r)))))))
(t
;;**** make sure it is a global function def!!
(let ((sym (leaf-node-value f)))
(dolist (r (get sym 'call-simplification-rules))
(let ((nf (call-node-function n)))
(unless (gfun-eq nf sym) (return))
(let ((old-n (if *simplify-debug* (copy-node-tree n))))
(when (funcall (cdr r) n)
(setf changed t)
(when *simplify-debug* (pp-cps old-n) (pp-cps n))
(if *breakenable*
(format t "symbol rule ~a ~a~%"
sym (car r))))))))))))
changed))
;;;
;;; Tree simplification control
;;;
(defun simplify-node (n)
(do () ((not (apply-simplification-rules n))))
(if (every #'node-simplified-p (node-children n))
(set-node-simplified n t)))
(defun next-unsimplified-node (n)
(if n
(labels ((next-lower-or-equal (n)
(if (or (null n) (node-simplified-p n))
nil
(dolist (c (node-children n) n)
(let ((lc (next-lower-or-equal c)))
(if lc (return lc)))))))
(let ((nl (next-lower-or-equal n)))
(if nl nl (next-unsimplified-node (node-parent n)))))))
(defun first-unsimplified-child (n)
(dolist (c (node-children n))
(unless (node-simplified-p c) (return c))))
(defun next-lower-or-equal (n)
(loop
(if (or (null n) (node-simplified-p n)) (return nil))
(let ((nc (first-unsimplified-child n)))
(if nc (setf n nc) (return n)))))
(defun next-unsimplified-node (n)
(loop
(if (null n) (return nil))
(let ((nl (next-lower-or-equal n)))
(if nl (return nl) (setf n (next-unsimplified-node (node-parent n)))))))
(defun simplify-tree (tree)
(do ((n (next-unsimplified-node tree) (next-unsimplified-node n)))
((null n) tree)
(simplify-node n)))
;;;
;;; Specific simplification rules
;;;
(defun var-eq (x y) (eq x y))
#|
(defun find-references (var tree)
(let ((refs nil))
(labels ((fr (n)
(do* ((ch (node-children n) (rest ch))
(c (first ch) (first ch))
(i 0 (+ i 1)))
((null ch))
(if (leaf-node-p c)
(if (var-eq var c) (push (cons n i) refs))
(fr c)))))
(fr tree))
refs))
(defmacro do-references (alist &rest body)
(let ((form (first alist))
(pos (second alist))
(var (third alist))
(tree (fourth alist))
(res (nth 4 alist))
(vsym (gensym "VAR"))
(tsym (gensym "TREE"))
(frsym (gensym "FR"))
(nsym (gensym "N"))
(chsym (gensym "CH"))
(csym (gensym "C"))
(isym (gensym "I"))
(start (gensym "START"))
(end (gensym "END")))
`(let ((,vsym ,var)
(,tsym ,tree))
(block nil
(labels ((,frsym (,nsym)
(let* ((,chsym (node-children ,nsym))
(,csym (first ,chsym))
(,isym 0))
(tagbody
,start
(if (null ,chsym) (go ,end))
(if (leaf-node-p ,csym)
(if (var-eq ,vsym ,csym)
(let ((,form ,nsym)
(,pos ,isym))
,@body))
(,frsym ,csym))
(setq ,chsym (rest ,chsym)
,csym (first ,chsym)
,isym (+ ,isym 1))
(go ,start)
,end))))
(,frsym ,tsym)
(return ,res))))))
(defun any-references-p (v n)
(if (leaf-node-p n)
(eq v n)
(dolist (c (node-children n)) (if (any-references-p v c) (return t)))))
(defun any-references-p (v n) (do-references (f i v n) (return t)))
|#
(defun simple-value-p (v)
(or (not (lambda-node-p v)) (simple-lambda-node-p v)))
(defun call-reference-p (r) (= (cdr r) 0))
(defun any-call-references-p (refs)
(dolist (r refs nil) (if (call-reference-p r) (return t))))
;;****** fix for lambda list ++++++
;;**** fix for multiple-value-continuation /////
(defun substitute-value (val ref copy)
(let ((form (car ref))
(pos (cdr ref)))
(unless (or (simple-value-p val) (not (call-reference-p ref)))
(error "can't substitute a non-simple function in call position"))
(insert-node-tree (if copy (copy-node-tree val) val) form pos)
(if (and (lambda-node-p val) (call-reference-p ref))
(fixup-lambda-call-node form))
(do ((p form (node-parent p)))
((not (and p (node-simplified-p p))))
(set-node-simplified p nil))))
;;**** only do lambdas in call position, maybe contin.?
;;
;; ((lambda (... x ...) ... x ...) ... y ...) => ((lambda (...) ... y ...) ...)
;; if x appears zero or one times, or if y is a value node, as long as
;; x is not set.
;;
(define-lambda-call-rule substitute-variables (n)
(lambda-call-substitute-variables n))
#|
;;****** fix for lambda list ++++++
(defun lambda-call-substitute-variables (n &optional all)
(let* ((f (call-node-function n))
(args (copy-list (lambda-node-arglist f)))
(changed nil))
(dolist (var args)
(let* ((refs (find-references var (lambda-node-body f)))
(val-index (position var (lambda-node-arglist f)))
(val (call-node-arg n val-index)))
(cond
((null refs)
(lambda-node-delete-arg f var)
(call-node-delete-arg-index n val-index)
(setf changed t))
((= (length refs) 1)
(when (or (simple-value-p val) (not (any-call-references-p refs)))
(lambda-node-delete-arg f var)
(call-node-delete-arg-index n val-index)
(substitute-value val (first refs) nil)
(setf changed t)))
((or all (leaf-node-p val))
(when (or (simple-value-p val) (not (any-call-references-p refs)))
(lambda-node-delete-arg f var)
(call-node-delete-arg-index n val-index))
(dolist (r refs)
(if (or (simple-value-p val) (call-reference-p r))
(substitute-value val r t)))
(setf changed t)))))
(when (null (lambda-node-arglist f))
(move-node-tree (lambda-node-body f) n)
(setf changed t))
changed))
|#
;;**** make sure these are enough for initial substitution in convert to work
(defun any-set-references-p (refs)
(dolist (r refs)
(if (and (gfun-eq (call-node-function (car r)) '%setq)
(= (cdr r) 2))
(return t))))
(defun safe-set-substitute-value-p (v)
(or (constant-node-p v) (lambda-node-p v) (gfun-node-p v) (gvar-node-p v)))
;;**** fix for multiple-value-continuation /////
(defun lambda-call-substitute-variables (n &optional all not-set)
(let* ((f (call-node-function n))
(args (copy-list (lambda-node-arglist f)))
(changed nil))
(dolist (var args)
(let* ((refs (find-references var (lambda-node-body f)))
(val-index (position var (lambda-node-arglist f)))
(val (call-node-arg n val-index)))
(unless (or ;;(and not-set (any-set-references-p refs))
(and not-set (or (not (safe-set-substitute-value-p val))
(any-set-references-p refs)))
(multiple-value-continuation-node-p val));;**** change /////
(cond
((null refs)
(lambda-node-delete-arg f var)
(call-node-delete-arg-index n val-index)
(setf changed t))
((= (length refs) 1)
(when (or (simple-value-p val)
(not (any-call-references-p refs)))
(lambda-node-delete-arg f var)
(call-node-delete-arg-index n val-index)
(substitute-value val (first refs) nil)
(setf changed t)))
((or (leaf-node-p val)
(and all
(every #'leaf-node-p
(node-children (lambda-node-body val)))))
(when (or (leaf-node-p val) (every #'call-reference-p refs))
(lambda-node-delete-arg f var)
(call-node-delete-arg-index n val-index))
(dolist (r refs)
(if (or (leaf-node-p val) (call-reference-p r))
(substitute-value val r t)))
(setf changed t))))))
(when (null (lambda-node-arglist f))
(move-node-tree (lambda-node-body f) n)
(setf changed t))
changed))
;;
;; ((lambda () <body>)) => <body>
;;
(define-lambda-call-rule no-variables (n)
(let* ((f (call-node-function n))
(args (lambda-node-arglist f)))
(if (null args)
(progn (move-node-tree (lambda-node-body f) n)
t))))
(defun test-call-p (n) (gfun-eq (call-node-function n) '%test))
;;
;; (if (if a b c) d e) => (let ((x (lambda () d))
;; (y (lambda () e)))
;; (if a (if b (x) (y)) (if c (x) (y))))
;;
;;***** this is probably still wrong. It is important, but neds to be
;;***** thought through very carefully.
(defun lambda-node-real-body (n)
(do* ((b (lambda-node-body n) (lambda-node-body f))
(f (call-node-function b) (call-node-function b)))
((not (lambda-node-p f)) b)))
(defun shallow-copy-node-tree (n)
(let ((ncopy (make-node)))
(move-node-tree n ncopy)
ncopy))
;;**** check this over carefully
(defun hoist-intervening-lambdas (n ba bf)
(let* ((a (call-node-arg n 0))
(b (lambda-node-body a)))
(if (lambda-node-p (call-node-function b))
(let ((ncopy (shallow-copy-node-tree n)))
(move-node-tree b n)
(move-node-tree ba b)
(move-node-tree ncopy ba)))))
;;**** use shallow-copy here??
(defun hoist-test-continuations (n)
(let* ((f (call-node-function n))
(nn (node-parent (node-parent (lambda-node-real-body f))))
(ba (lambda-node-body (call-node-arg nn 0)))
(xsym-node (make-leaf-node (gensym "X")))
(ysym-node (make-leaf-node (gensym "Y")))
(xcopy (copy-node-tree (call-node-arg ba 0)))
(ycopy (copy-node-tree (call-node-arg ba 1)))
(ncopy (make-node)))
(insert-node-tree xsym-node ba 1)
(insert-node-tree ysym-node ba 2)
(move-node-tree nn ncopy)
;; This substitution forces insertion of the elligible
;; continuation. Without this you get into a cycle. I have not
;; proved that with it you don't, but I think you don't --
;; something like the number of elligible nodes strictly
;; decreases.
(lambda-call-substitute-variables ncopy t)
(move-node-tree
(make-call-node (make-lambda-node (list xsym-node ysym-node) ncopy)
xcopy
ycopy)
nn)))
(define-lambda-call-rule if-if (n)
(if (= (call-node-arg-count n) 1)
(let ((f (call-node-function n))
(a (call-node-arg n 0)))
(if (lambda-node-p a)
(let ((bf (lambda-node-body f))
(bba (lambda-node-body a))
(ba (lambda-node-real-body a)))
(if (and (test-call-p bf)
(test-call-p ba)
(every #'call-reference-p
(find-references (first (lambda-node-arglist f))
f)))
(let* ((bargs (lambda-node-arglist a))
(v (first bargs))
(vt (call-node-arg ba 2)))
(when (and (= (length bargs) 1)
(var-eq v vt)
(= (length (find-references v bba)) 1))
(hoist-intervening-lambdas n ba bf)
(hoist-test-continuations n)
t))))))))
(defun leaf-node-constant-p (n)
(if (leaf-node-p n)
(let ((v (leaf-node-value n)))
(or (null v) (eq v t) (not (symbolp v)))))) ;**** do this better
(defun constant-fold-numbers (n &optional f)
(let ((args (mapcar #'leaf-node-value (rest (call-node-args n)))))
(if (every #'numberp args)
(let* ((fsym (if f f (leaf-node-value (call-node-function n))))
(v (apply (symbol-function fsym) args))
(k (call-node-arg n 0)))
(move-node-tree
(make-continuation-call-node k (make-constant-node v))
n)
t))))
(defun constant-fold-commutative (n sym ident)
(let* ((k-args (call-node-args n))
(k (first k-args))
(args (rest k-args))
(nums (remove-if-not #'numberp (mapcar #'leaf-node-value args)))
(nnums (remove-if #'(lambda (x) (numberp (leaf-node-value x))) args))
(changed nil))
(case (length nums)
(0 nil)
(1 (when (eql (first nums) ident)
(set-call-node-args n (cons k nnums))
(setf changed t)))
(t
(let ((nv (apply sym nums)))
(setf args
(if (eql nv ident) nnums (cons (make-constant-node nv) nnums)))
(set-call-node-args n (cons k args))
(setf changed t))))
(case (length args)
(0 (move-node-tree
(make-continuation-call-node k (make-constant-node ident))
n)
(setf changed t))
(1 (move-node-tree (make-continuation-call-node k (first args)) n)
(setf changed t)))
changed))
(define-symbol-call-rule + constant-fold (n)
(constant-fold-commutative n '+ 0))
(define-symbol-call-rule * constant-fold (n)
(constant-fold-commutative n '* 1))
;;**** add others
(define-symbol-call-rule - constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule / constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule min constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule max constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule = constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule /= constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule < constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule > constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule <= constant-fold (n) (constant-fold-numbers n))
(define-symbol-call-rule >= constant-fold (n) (constant-fold-numbers n))
(defun change-gfun (n name)
(set-call-node-function n (get-gfun-node name))
t)
(define-symbol-call-rule first rename (n) (change-gfun n 'car))
(define-symbol-call-rule second rename (n) (change-gfun n 'cadr))
(define-symbol-call-rule third rename (n) (change-gfun n 'caddr))
(define-symbol-call-rule rest rename (n) (change-gfun n 'cdr))
;;**** assumes result of f1 is last arg of f2
;;**** this is horrible
;;**** need to check for other uses of variable
;;**** think about not immediate use
(defun merge-gfuns (n f2 f12 &optional argc)
(let ((k (call-node-arg n 0)))
(if (and (lambda-node-p k)
(or (not argc) (= (call-node-arg-count n) (+ argc 1))))
(let* ((b (lambda-node-body k))
(rb (lambda-node-real-body k))
(v (first (lambda-node-arglist k)))
(f (call-node-function rb)))
(if (and (gfun-eq f f2)
(eq v (first (last (call-node-args rb))))
(= 1 (length (find-references v k))))
(let ((nargs (append (butlast (call-node-args rb))
(rest (call-node-args n)))))
(set-call-node-args rb nargs)
(change-gfun rb f12)
(move-node-tree b n)
t))))))
(define-symbol-call-rule car cdr-car=>cdar (n) (merge-gfuns n 'cdr 'cdar))
(define-symbol-call-rule car cdr-car=>caar (n) (merge-gfuns n 'car 'caar))
(define-symbol-call-rule cdr car-cdr=>cadr (n) (merge-gfuns n 'car 'cadr))
(define-symbol-call-rule cdr cdr-cdr=>cddr (n) (merge-gfuns n 'cdr 'cddr))
;;**** more of these??
(define-symbol-call-rule cddr cdr-cddr=>cdddr (n) (merge-gfuns n 'cdr 'cdddr))
(define-symbol-call-rule cdr cddr-cdr=>cdddr (n) (merge-gfuns n 'cddr 'cdddr))
(define-symbol-call-rule cddr car-cddr=>caddr (n) (merge-gfuns n 'car 'caddr))
(define-symbol-call-rule cdr cadr-cdr=>caddr (n) (merge-gfuns n 'cadr 'caddr))
;;
;; constant-fold tests
;;
(define-symbol-call-rule %test constant-fold (n)
(let ((test (call-node-arg n 2)))
(if (leaf-node-constant-p test)
(let ((v (leaf-node-value test))
(consequent (call-node-arg n 0))
(alternative (call-node-arg n 1)))
(if v
(move-node-tree (make-null-call-node consequent) n)
(move-node-tree (make-null-call-node alternative) n))
t))))
(defun make-null-call-node (n)
(if (lambda-node-p n) (lambda-node-body n) (make-continuation-call-node n)))
;;
;; (if a (if a b c) d) => (if a b d)
;;
(define-symbol-call-rule %test propagate1 (n)
(let ((test (call-node-arg n 2))
(consequent (call-node-arg n 0)))
(if (lambda-node-p consequent)
(let ((bc (lambda-node-body consequent)))
(when (and (test-call-p bc) (var-eq test (call-node-arg bc 2)))
(insert-node-tree (call-node-arg bc 0) n 1)
t)))))
;;
;; (if a b (if a c d)) => (if a b d)
;;
(define-symbol-call-rule %test propagate2 (n)
(let ((test (call-node-arg n 2))
(alternative (call-node-arg n 1)))
(if (lambda-node-p alternative)
(let ((bc (lambda-node-body alternative)))
(when (and (test-call-p bc) (var-eq test (call-node-arg bc 2)))
(insert-node-tree (call-node-arg bc 1) n 2)
t)))))
#|
;;
;; (lambda () (f)) => f ????
;;
(define-call-rule null-lambda-null-arg-body (n)
(let ((ch (node-children n))
(changed nil))
(dolist (c ch changed)
(if (and (lambda-node-p c) (null (lambda-node-arglist c)))
(let ((b (lambda-node-body c)))
(if (null (call-node-args b))
(let ((f (call-node-function b)))
(if (leaf-node-p f)
(set-node-children n (subst f c (node-children n)))
(move-node-tree f c))
(setf changed t))))))))
|#
(defun parse-declarations (decls)
(macrolet ((add-decl (x d decls)
`(let ((e (assoc ,x ,decls)))
(if e
(setf (cdr e) (cons ,d (cdr e)))
(push (list ,x ,d) ,decls)))))
(let ((vdecls nil)
(fdecls nil)
(cdecls nil)
(dlist (apply #'append (mapcar #'rest decls))))
(dolist (d dlist)
(let ((dsym (first d))
(dlist (rest d)))
(case dsym
(optimize (dolist (v dlist) (add-decl dsym v cdecls)))
((inline notinline) (dolist (v dlist) (add-decl v dsym fdecls)))
(ftype (dolist (v (rest dlist))
(add-decl v (list 'ftype (first dlist)) vdecls)))
((special ignore) (dolist (v dlist) (add-decl v dsym vdecls)))
(type (dolist (v (rest dlist))
(add-decl v (list 'type (first dlist)) vdecls)))
((array atom bignum bit bit-vector character compiled-function
complex cons double-float
fixnum float function hash-table integer keyword list
long-float nil null number
package pathname random-state ratio rational readtable sequence
short-float signed-byte simple-array simple-bit-vector
simple-string simple-vector single-float standard-char stream
string symbol t unsigned-byte vector
extended-character real)
(dolist (v dlist) (add-decl v (list 'type dsym) vdecls))))))
(list vdecls fdecls cdecls))))
(defun fixup-let-variables (v)
(mapcar #'(lambda (x)
(cond
((symbolp x) (list x nil))
((and (consp x)
(symbolp (first x))
(not (consp (rest x))))
(list (first x) nil))
(t x))) ;**** could do error checking here
v))
(defun unparse-variable-declarations (decls)
(if decls
(let ((s (first decls)))
(flet ((unp (d) (if (symbolp d) `(,d ,s) `(,@d ,s))))
`((declare ,@(mapcar #'unp (rest decls))))))))
(defun unparse-function-declarations (decls)
(if decls
(let ((s (first decls)))
(flet ((unp (d) (if (symbolp d) `(,d ,s) `(,@d ,s))))
`((declare ,@(mapcar #'unp (rest decls))))))))
(defun unparse-compiler-declarations (decls)
(if decls `((declare ,@decls))))
(defun declare-no-side-effects (syms)
(if (symbolp syms)
(setf (get syms 'cmp-no-side-effects) t)
(dolist (s syms) (declare-no-side-effects s)))
nil)
;;**** have to check it is a global function!!!!
(defun no-side-effects-p (s) (get (leaf-node-value s) 'cmp-no-side-effects))
;;**** add others here
(declare-no-side-effects '(+ - * / min max = /= < > <= >= %symval %symfun))
(defun find-y-function (n i)
(let* ((f (call-node-arg n 0))
(b (lambda-node-body f))
(bf (call-node-function b)))
(if (gfun-eq bf '%make-y-closures)
(setf b (lambda-node-body (call-node-arg b 0))))
(call-node-arg b (+ i 1))))
(defun find-y-body (n) (find-y-function n -1))
(defun find-y-list-names (n)
(let* ((p (node-parent n))
(pp (node-parent p))
(ppf (call-node-function pp)))
(if (gfun-eq ppf '%make-y-closures) (setf p (node-parent pp)))
(lambda-node-arglist p)))
(defun find-lambda-binding (n)
(if (local-symbol-node-p n)
(let ((owner (symbol-node-owner n)))
(if (lambda-node-p owner)
(let ((p (node-parent owner)))
(cond
((and (call-node-p p) (eq owner (first (node-children p))))
(let* ((pos (position n (lambda-node-arglist owner)))
(val (call-node-arg p pos)))
(find-lambda-binding val)))
((and (call-node-p p) ;;**** is this right now???
(gfun-member (call-node-function p)
'(%y %make-y-closures)))
(let ((i (position n (lambda-node-arglist owner))))
(find-y-function p i)))))))
n))
(defun find-lambda-variable (f)
(let* ((p (node-parent f))
(g (call-node-function p)))
(cond
((lambda-node-p g)
(if (not (eq f g))
(nth (position f (call-node-args p)) (lambda-node-arglist g))))
((gfun-eq g '%y-list)
(nth (- (position f (call-node-args p)) 1) (find-y-list-names p))))))
(defun unsafe-continuation-lambda-p (form parent)
(and (lambda-node-p form)
(not (continuation-node-p form))
(/= (position form (node-children parent)) 0)))
(defun safe-continuation-reference-p (r)
(let* ((form (car r))
(i (cdr r))
(k (call-node-arg form 0))
(owner (symbol-node-owner k)))
(do* ((f form p)
(p (node-parent f) (node-parent f)))
((eq f owner) t)
(if (unsafe-continuation-lambda-p f p) (return nil)))))
(define-symbol-call-rule %catch-block skip-catch-if-safe (n)
(let* ((k (call-node-arg n 0))
(b (call-node-arg n 2))
(fk (first (lambda-node-arglist b)))
(tag (second (lambda-node-arglist b)))
(refs (find-references tag (lambda-node-body b))))
(when (or (null refs) (every #'safe-continuation-reference-p refs))
;;**** The %throw-return-from must be in a multiple value
;;**** continuation. This replaces the multiple value continuation
;;**** where it occurs (which must be in continuation position)
;;**** by fk. This needs to be revised if the representation of
;;**** multiple value continuations changes.
;;**** there may be a simpler way to do the replacement
(flet ((mvform (n)
(node-parent (node-parent (node-parent (node-parent n))))))
(dolist (r refs)
(let* ((form (car r))
(m (mvform form))
(mf (call-node-function m))
(margs (rest (call-node-args m))))
(move-node-tree (apply #'make-call-node mf fk margs) m))))
(lambda-node-delete-arg b tag)
(move-node-tree (make-call-node b k) n)
t)))
;;
;; Y combinator simplifiers
;;
;;**** check this over carefully !!!
(define-symbol-call-rule %y hoist-non-recursives (n)
(let* ((yf (call-node-arg n 0))
(yvars (copy-list (lambda-node-arglist yf)))
(ybody (lambda-node-body yf))
(yfuns (copy-list (rest (call-node-args ybody))))
(pos nil))
(flet ((not-used (x y)
(every #'(lambda (z) (not (any-references-p x z))) y)))
(dolist (v yvars) (if (not-used v yfuns) (push (position v yvars) pos)))
(when pos
(let ((dvars nil)
(dfuns nil))
(dolist (p pos)
(let ((v (nth p yvars))
(f (nth p yfuns)))
(lambda-node-delete-arg yf v)
(call-node-delete-arg ybody f) ;;**** fix
(push v dvars)
(push f dfuns)))
(let ((m (lambda-node-body (call-node-arg ybody 0))))
(move-node-tree
(apply #'make-call-node
(make-lambda-node dvars (copy-node-tree m))
dfuns)
m)))
t))))
(define-symbol-call-rule %y no-functions (n)
(let ((ybody (lambda-node-body (call-node-arg n 0))))
(if (= (call-node-arg-count ybody) 1)
(let ((b (lambda-node-body (call-node-arg ybody 0))))
(move-node-tree b n)
t))))
;;***** think this stuff through!!!
(defun safe-go-path-p (form y)
(do ((f form (node-parent f)))
((eq f y) t)
(if (and (lambda-node-p f)
(not (continuation-node-p f))
(/= (position f (node-children (node-parent f))) 0))
(return nil))))
(defun safe-go-references-p (refs body)
(dolist (r refs t)
(unless (or (gfun-eq (call-node-function (car r)) '%do-catch-tagbody)
(safe-go-path-p (car r) body))
(return nil))))
(define-symbol-call-rule %catch-tagbody skip-tagbody-catch (n)
(let* ((fun (call-node-arg n 1))
(body (lambda-node-body fun))
(tag (second (lambda-node-arglist fun)))
(refs (find-references tag body)))
(when (safe-go-references-p refs body)
(dolist (r refs)
;; this should work for %throw-go and %do-catch-tagbody references
(move-node-tree (make-call-node (call-node-arg (car r) 1))
(car r)))
(lambda-node-delete-arg fun tag)
(move-node-tree (make-call-node fun (call-node-arg n 0)) n)
t)))
;;**** think these through
;; (funcall #'gfun ...) => (gfun ...)
(define-symbol-call-rule %symfun funcall-symfun-gfun-to-call (n)
(let ((k (call-node-arg n 0)))
(if (lambda-node-p k)
(let* ((v (first (lambda-node-arglist k)))
(b (lambda-node-body k))
(f (call-node-function b)))
(when (and (gfun-eq f 'funcall)
(eq v (call-node-arg b 1)))
(move-node-tree (apply #'make-call-node
(call-node-arg n 1)
(call-node-arg b 0)
(rest (rest (call-node-args b))))
n)
t)))))
;; (funcall fun ...) => (fun ...)
;;**** fixed to use lambda binding
;;**** probably needs to be done other places
;;**** need some utilities to help
#|
(define-symbol-call-rule funcall funcall-function-to-call (n)
(let ((f (call-node-arg n 1)))
(when (or (lambda-node-p f) (gfun-node-p f) (lfun-node-p f))
(call-node-delete-arg-index n 1)
(set-call-node-function n f)
t)))
|#
(define-symbol-call-rule funcall funcall-function-to-call (n)
(let ((f (call-node-arg n 1)))
(when (or (lambda-node-p f) (gfun-node-p f) (lfun-node-p f))
(with-saved-cmp-environments
(let ((fv (new-fenv-node (gensym "F")))
(k (call-node-arg n 0))
(f (call-node-arg n 1))
(args (rest (rest (call-node-args n)))))
(move-node-tree
(make-call-node
(make-lambda-node (list fv) (apply #'make-call-node fv k args))
f)
n)))
t)))
(define-symbol-call-rule funcall quote-symbol-to-gfun (n)
(let ((f (call-node-arg n 1)))
(when (constant-node-p f)
(let ((qfs (leaf-node-value f)))
(unless (and (consp qfs)
(eq (first qfs) 'quote)
(symbolp (second qfs)))
(error "bad FUNCALL argument -- ~s" qfs))
(set-call-node-arg n 1 (get-gfun-node (second qfs)))
t))))
(define-symbol-call-rule %mvc quote-symbol-to-gfun (n)
(let ((f (call-node-arg n 1)))
(when (constant-node-p f)
(let ((qfs (leaf-node-value f)))
(unless (and (consp qfs)
(eq (first qfs) 'quote)
(symbolp (second qfs)))
(error "bad MULTIPLE-VALUE-CALL argument -- ~s" qfs))
(set-call-node-arg n 1 (get-gfun-node (second qfs)))
t))))
;;**** fix if used rest args are allowed
(define-symbol-call-rule %mvc lambda-to-continuation (n)
(let* ((f (call-node-arg n 1))
(rest (nth 5 (lambda-node-lambda-list f))))
(when (and (lambda-node-p f)
(simple-lambda-node-p f))
(with-saved-cmp-environments
(let* ((k (call-node-arg n 0))
(args (rest (lambda-node-arglist f)))
(uargs (if rest (butlast args) args))
(asyms (mapcar #'leaf-node-value uargs))
(targs (mapcar #'new-env-node asyms)))
(move-node-tree
(make-call-node
(get-gfun-node '%mvcc)
(make-continuation-node
targs
(apply #'make-call-node f k targs)))
n)
t)))))
(defun non-tail-continuation-p (k) (lambda-node-p k))
;;**** might need to be redone
(defun multiple-value-continuation-node-p (c)
(and (lambda-node-p c)
(gfun-eq (call-node-function (lambda-node-body c)) '%mv-collect)))
(define-symbol-call-rule values-list non-tail-call (n)
(let ((k (find-lambda-binding (call-node-arg n 0))))
(if (and (non-tail-continuation-p k)
(not (multiple-value-continuation-node-p k)))
(change-gfun n 'car))))
(define-symbol-call-rule values non-tail-call (n)
(let* ((karg (call-node-arg n 0))
(k (find-lambda-binding karg)))
(if (and (non-tail-continuation-p k)
(not (multiple-value-continuation-node-p k)))
(let ((a (if (= (call-node-arg-count n) 1)
(make-constant-node nil)
(call-node-arg n 1))))
(move-node-tree (make-continuation-call-node karg a) n)
t))))
(define-symbol-call-rule values one-value (n)
(when (and (= (call-node-arg-count n) 2)
(not (multiple-value-continuation-node-p (call-node-arg n 0))))
(move-node-tree
(make-continuation-call-node (call-node-arg n 0) (call-node-arg n 1))
n)
t))
;;**** %mvc %mvcc simplifiers for (values ...) form?
;; (multiple-value-call #'(lambda (x) (+ x 1)) y) => (+ y 1)
;; (multiple-value-call #'(lambda (x y) (+ x y)) (values u v)) => (+ u v)
;;**** this stuff should be incorporated in rules
;;**** that means changing the representation of %test expressions
#|
(defun merge-tests (n)
(dolist (c (node-children n)) (merge-tests c))
(if (call-node-p n)
(let ((f (call-node-function n)))
(if (gfun-node-p f)
(case (gfun-symbol f)
(= (merge-gfuns n '%test '%test= 2))
(/= (merge-gfuns n '%test '%test/= 2))
(< (merge-gfuns n '%test '%test< 2))
(> (merge-gfuns n '%test '%test> 2))
(>= (merge-gfuns n '%test '%test>= 2))
(<= (merge-gfuns n '%test '%test<= 2))
(consp (merge-gfuns n '%test '%test-consp 1))
(endp (merge-gfuns n '%test '%test-endp 1))
(eq (merge-gfuns n '%test '%test-eq 2))
(eql (merge-gfuns n '%test '%test-eql 2))
(equal (merge-gfuns n '%test '%test-equal 2))
(%supplied-p (merge-gfuns n '%test '%test-supplied-p 1))))))
n)
|#
;;**** this is an iterative version to avoid argument stack overflows
(defun merge-tests (n)
(let ((todo (cond
((lambda-node-p n) (list (cons (lambda-node-body n) nil)))
((call-node-p n) (list (cons n nil)))
(t nil))))
(loop
(cond
((null todo) (return n))
((null (cdr (first todo)))
(setf (cdr (first todo)) t)
(let ((c (car (first todo))))
(dolist (x (node-children c))
(cond
((lambda-node-p x) (push (cons (lambda-node-body x) nil) todo))
((call-node-p x) (push (cons x nil) todo))))))
(t (let ((c (car (pop todo))))
(unless (call-node-p c) (error "non call node in merge - ~s" c))
(let ((f (call-node-function c)))
(if (gfun-node-p f)
(case (gfun-symbol f)
(= (merge-gfuns c '%test '%test= 2))
(/= (merge-gfuns c '%test '%test/= 2))
(< (merge-gfuns c '%test '%test< 2))
(> (merge-gfuns c '%test '%test> 2))
(>= (merge-gfuns c '%test '%test>= 2))
(<= (merge-gfuns c '%test '%test<= 2))
(consp (merge-gfuns c '%test '%test-consp 1))
(endp (merge-gfuns c '%test '%test-endp 1))
(eq (merge-gfuns c '%test '%test-eq 2))
(eql (merge-gfuns c '%test '%test-eql 2))
(equal (merge-gfuns c '%test '%test-equal 2))
(%supplied-p (merge-gfuns c
'%test
'%test-supplied-p 1)))))))))))
syntax highlighted by Code2HTML, v. 0.9.1