cogen-effect.scm

;;; cogen-effect.scm

;;; copyright © 1996, 1997, 1998, 1999 by Peter Thiemann
;;; non-commercial use is free as long as the original copright notice
;;; remains intact

;;; effect analysis

;;; debugging and trace aids
;;;(define *effect-display-level* 1)
(define-syntax debug-level
  (syntax-rules ()
    ((_ level arg ...)
     (if (>= *effect-display-level* level)
	 (begin arg ...)))))

(define (effect-analysis d* nr-of-ref-labels)
  (debug-level 1 (display "effect analysis:"))
  (set-labset-size! (+ 1 nr-of-ref-labels))
  (set! *access-vector* (make-vector (+ 1 nr-of-ref-labels) #f))
  (set! *initial-effects* '())
  (allocate-effect-variables-d* d*)
  (debug-level 1 (display " fixpointing"))
  (with-output-to-file "/tmp/effect-out.scm"
    (lambda () (effect-fixpoint)))
  (debug-level 1 (display " done") (newline)))

;;; need an access vector that maps labels back to expressions
(define *access-vector* 'undefined-access-vector)
(define (effect-label->type label)
  (node-fetch-type (full-ecr (annExprFetchType (vector-ref *access-vector* label)))))
(define (effect-for-each proc effect)
  (labset-for-each proc (effect->labset effect)))
;;;
(define (node-fetch-effect node)
  (type->effect (node-fetch-type (full-ecr node))))

(define-record effect
  (neighbors labset)
  (constraints #f))
;;; neighbors contains pointers to the super-effects
(define (effect-add-neighbor! esub esuper)
  (let ((n (effect->neighbors esub)))
    (if (not (memq esuper n))
	(effect->neighbors! esub (cons esuper n)))))

(define (allocate-effect-variables-d* d*)
  (for-each (lambda (d)
	      (allocate-effect-variables-t
	       (annDefFetchProcBTVar d))) d*)
  (for-each (lambda (d) (allocate-effect-variables-d d d*)) d*))

(define (allocate-effect-variables-d d d*)
  (allocate-effect-variables-e (annDefFetchProcBody d) d*))

(define (allocate-effect-variables-e e d*)
  ;; returns a list of effect variables that are lower bounds for the current effect 
  (let loop ((e e))
    ;; (display (vector-ref e 1)) (newline)
      (cond
       ((annIsVar? e)
	'())
       ((annIsConst? e)
	'())
       ((annIsCond? e)
	(let ((etest (loop (annFetchCondTest e)))
	      (ethen (loop (annFetchCondThen e)))
	      (eelse (loop (annFetchCondElse e))))
	  (append etest ethen eelse)))
       ((annIsOp? e)
	(apply append (map loop (annFetchOpArgs e))))
       ((annIsLet? e)
	(let ((eheader (loop (annFetchLetHeader e)))
	      (ebody (loop (annFetchLetBody e))))
	  (append eheader ebody)))
       ((annIsBegin? e)
	(let ((eheader (loop (annFetchBeginHeader e)))
	      (ebody (loop (annFetchBeginBody e))))
	  (append eheader ebody)))
       ((annIsCall? e)
	(let* ((name (annFetchCallName e))
	       (defn (annDefLookup name d*))
	       (node (full-ecr (annDefFetchProcBTVar defn)))
	       (etype (node-fetch-effect node)))
	  (cons etype (apply append (map loop (annFetchCallArgs e))))))
       ((annIsApp? e)
	(let* ((rator (annFetchAppRator e))
	       (etype (annExprFetchType rator)))
	  (allocate-effect-variables-t etype)
	  (cons (node-fetch-effect etype)
		(append (loop rator)
			(apply append (map loop (annFetchAppRands e)))))))
       ((annIsCtor? e)
	(vector-set! *access-vector* (annFetchCtorLabel e) e)
	(apply append (map loop (annFetchCtorArgs e))))
       ((annIsSel? e)
	(loop (annFetchSelArg e)))
       ((annIsTest? e)
	(loop (annFetchTestArg e)))
       ((annIsCellEq? e)
	(apply append (map loop (annFetchCellEqArgs e))))
       ((annIsEval? e)
	(loop (annFetchEvalBody e)))
       (else
	(let* ((evar  (make-effect '() empty-labset))
	       (expr-type (annExprFetchType e))
	       (add-neighbor! (lambda (var) (effect-add-neighbor! var evar))))
	  (annExprSetEffect! e evar)
	  (cond
	   ((annIsLambda? e)
	    (vector-set! *access-vector* (annFetchLambdaLabel e) e)
	    (allocate-effect-variables-t expr-type)
	    (let* ((etype (node-fetch-effect expr-type))
		   (ebody (loop (annFetchLambdaBody e)))
		   (ebody-var (make-effect '() empty-labset))
		   (free (annFreeVars e))
		   (efree (apply append (map extract-references free)))
		   (efvar (make-effect (nubq efree) empty-labset)))
	      ;; need to filter the global effects!
	      (for-each (lambda (var) (effect-add-neighbor! var ebody-var)) ebody)
	      (effect->constraints! efvar ebody-var)
	      (effect-add-neighbor! ebody-var etype))
	    '())
	   ;;(annIsVLambda? e)
	   ((annIsRef? e)
	    (vector-set! *access-vector* (annFetchRefLabel e) e)
	    (allocate-effect-variables-t expr-type)
	    (let ((effs (loop (annFetchRefArg e))))
	      (for-each add-neighbor! effs))
	    (let* ((node expr-type)
		   (lab  (annFetchRefLabel e))
		   (eref (make-effect '() (labset-singleton lab)))
		   (etype (node-fetch-effect node)))
	      (initial-effects-add! eref)
	      (effect-add-neighbor! eref evar)
	      (effect-add-neighbor! eref etype))
	    (list evar))
	   ((annIsDeref? e)
	    (let* ((ref (annFetchDerefArg e))
		   (ref-type (annExprFetchType ref)))
	      (allocate-effect-variables-t ref-type)
	      (let ((effs (loop ref)))
		(for-each add-neighbor! effs))
	      (let ((eref (node-fetch-effect ref-type)))
		(effect-add-neighbor! eref evar)))
	    (list evar))
	   ((annIsAssign? e)
	    (vector-set! *access-vector* (annFetchAssignLabel e) e)
	    (let* ((ref (annFetchAssignRef e))
		   (arg (annFetchAssignArg e))
		   (ref-type (annExprFetchType ref)))
	      (allocate-effect-variables-t ref-type)
	      (let ((effs (loop ref)))
		(for-each add-neighbor! effs))
	      (let ((effs (loop arg)))
		(for-each add-neighbor! effs))
	      (let ((eref (node-fetch-effect ref-type)))
		(effect-add-neighbor! eref evar)))
	    (list evar))
	   ((annIsVector? e)
	    (vector-set! *access-vector* (annFetchVectorLabel e) e)
	    (allocate-effect-variables-t expr-type)
	    (let ((effs (loop (annFetchVectorArg e))))
	      (for-each add-neighbor! effs))
	    (let ((effs (loop (annFetchVectorSize e))))
	      (for-each add-neighbor! effs))
	    (let* ((node expr-type)
		   (lab  (annFetchVectorLabel e))
		   (eref (make-effect '() (labset-singleton lab)))
		   (etype (node-fetch-effect node)))
	      (initial-effects-add! eref)
	      (effect-add-neighbor! eref evar)
	      (effect-add-neighbor! eref etype))
	    (list evar))
	   ((annIsVref? e)
	    (let* ((ref (annFetchVrefArg e))
		   (ref-type (annExprFetchType ref)))
	      (allocate-effect-variables-t ref-type)
	      (let ((effs (loop ref)))
		(for-each add-neighbor! effs))
	      (let ((effs (loop (annFetchVrefIndex e))))
		(for-each add-neighbor! effs))
	      (let ((eref (node-fetch-effect ref-type)))
		(effect-add-neighbor! eref evar)))
	    (list evar))
	   ((annIsVlen? e)
	    (let* ((ref (annFetchVlenVec e))
		   (ref-type (annExprFetchType ref)))
	      (allocate-effect-variables-t ref-type)
	      (let ((effs (loop ref)))
		(for-each add-neighbor! effs))
	      (let ((eref (node-fetch-effect ref-type)))
		(effect-add-neighbor! eref evar)))
	    (list evar))
	   ((annIsVset? e)
	    (vector-set! *access-vector* (annFetchVsetLabel e) e)
	    (let* ((ref (annFetchVsetVec e))
		   (arg (annFetchVsetArg e))
		   (idx (annFetchVsetIndex e))
		   (ref-type (annExprFetchType ref)))
	      (allocate-effect-variables-t ref-type)
	      (let ((effs (loop ref)))
		(for-each add-neighbor! effs))
	      (let ((effs (loop arg)))
		(for-each add-neighbor! effs))
	      (let ((effs (loop idx)))
		(for-each add-neighbor! effs))
	      (let ((eref (node-fetch-effect ref-type)))
		(effect-add-neighbor! eref evar)))
	    (list evar))
	   ((annIsVfill? e)
	    (vector-set! *access-vector* (annFetchVfillLabel e) e)
	    (let* ((ref (annFetchVfillVec e))
		   (arg (annFetchVfillArg e))
		   (ref-type (annExprFetchType ref)))
	      (allocate-effect-variables-t ref-type)
	      (let ((effs (loop ref)))
		(for-each add-neighbor! effs))
	      (let ((effs (loop arg)))
	      (for-each add-neighbor! effs))
	      (let ((eref (node-fetch-effect ref-type)))
		(effect-add-neighbor! eref evar)))
	    (list evar))
	   (else
	    (display (list 'allocate-effect-variables "unknown expression tag:"
			   e)) (newline) 
	    '())))))))

(define (allocate-effect-variables-t node)
  (let loop ((node node) (seen '()))
    (if (memq node seen)
	'nothing-to-do
	(let* ((type (node-fetch-type (full-ecr node)))
	       (ctor (type->ctor type))
	       (effect (type->effect type)))
	  ;;(display (list 'allocate-effect-variables-t ctor effect))
	  (if effect
	      'nothing-to-do
	      (let ((seen (cons node seen)))
		(if (or (eq? ctor ctor-function)
			(eq? ctor ctor-reference)
			(eq? ctor ctor-vector)
			(eq? ctor ctor-top))
		    (type->effect! type (make-effect '() empty-labset)))
		(for-each (lambda (node) (loop node seen))
			  (type->args type))))))))


(define (extract-references var)
  (let ((node (annExprFetchType var))
	(seen '()))
    (let loop ((node node))
      (if (memq node seen)
	  '()
      (let* ((type (node-fetch-type (full-ecr node)))
	     (ctor (type->ctor type)))
	(set! seen (cons node seen))
	(cond
	 ((eq? ctor ctor-function)
	  (cons (type->effect type)
		(apply append (map loop (type->args type)))))
	 ((eq? ctor ctor-reference)
	  (list (type->effect type)))
	 (else
	  (apply append (map loop (type->args type))))))))))

(define (effect-singlestep)
  (let loop ((roots *initial-effects*) (change? #f))
    (if (null? roots)
	change?
	(let recur-a ((evar (car roots)))
	  (let recur ((n (effect->neighbors evar)))
	    (if (null? n)
		(loop (cdr roots) change?)
		(let* ((evarb (car n))
		       (constraints (effect->constraints evarb))
		       (labs (effect->labset evar))
		       (labs (if constraints
				 (labset-intersection
				  labs
				  (effect->labset constraints))
				 labs))
		       (labsb (effect->labset evarb)))
		    (if (labset-subset? labs labsb)
			(recur (cdr n))
			(begin (set! change? #t)
			       (debug-level
				2 (display (list (labset->list labs)
						 "|||"
						 (labset->list labsb)))
				(newline))
			       (effect->labset! evarb
						(labset-union labs labsb))
			       (recur-a evarb)
			       (recur (cdr n)))))))))))

(define (effect-fixpoint)
  (let loop ()
    (if (effect-singlestep)
	(loop))))

(define *initial-effects* '())
(define (initial-effects-add! evar)
  (set! *initial-effects* (cons evar *initial-effects*)))

(define (nubq evar*)
  (let loop ((ins evar*) (outs '()))
    (if (null? ins)
	outs
	(let ((in (car ins)))
	(if (memq in outs)
	    (loop (cdr ins) outs)
	    (loop (cdr ins) (cons in outs)))))))