;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; *** Stripping unused code in the linker output ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-i-var-def-table-size 20000)


(define gl-debug4 '())


(define (var-ref-addr var-ref)
  (hfield-ref (hfield-ref var-ref 'variable) 'address))


(define (mark-repr-used! repr)
  (hfield-set! repr 'include? #t))


(define (determine-address-coverage linker address lst-new-visited)
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((ht-var-defs (hfield-ref linker 'ht-var-defs))
	  (ht-method-decls (hfield-ref linker 'ht-method-decls))
	  (ht-used-decls (hfield-ref linker 'ht-used-decls))
	  (ht-used (hfield-ref linker 'ht-used)))
      ;; There is no need to check a variable
      ;; that has already been checked.
      (if (not (address-hash-ref ht-used address))
	  (let ((var-def (address-hash-ref ht-var-defs address)))
	    (if (not (eq? var-def #f))
		(determine-coverage linker var-def lst-new-visited))
	    (let ((method-def (address-hash-ref ht-method-decls
						address)))
	      (if method-def
		  (begin
		    (address-hash-set! ht-used-decls address
				       method-def)
		    (determine-coverage 
		     linker
		     (hfield-ref method-def 'procexpr)
		     lst-new-visited)))))))
    (set! gl-indent old-indent)))


;; (define (address-to-string address)
;;   (let ((source-name (hfield-ref address 'source-name)))
;;     (string-append
;;      (if (not-null? source-name)
;; 	 (symbol->string (hfield-ref address 'source-name))
;; 	 "()")
;;      "["
;;      (number->string (hfield-ref address 'number))
;;      "]")))


(define (determine-coverage linker repr lst-visited)
  (let ((ht-var-defs (hfield-ref linker 'ht-var-defs))
	(ht-method-decls (hfield-ref linker 'ht-method-decls))
	(ht-used-decls (hfield-ref linker 'ht-used-decls))
	(ht-used (hfield-ref linker 'ht-used)))
    (let ((old-indent gl-indent))
      (set! gl-indent (+ gl-indent 1))
      (cond
       ((null? repr)
	'())
       ((memq repr lst-visited)
	'())
       ;; The following test is an optimization.
       ((and (hrecord-is-instance? repr <variable-definition>)
	     (or (hfield-ref repr 'include?)
		 (address-hash-ref (hfield-ref linker 'ht-used)
				   (hfield-ref (hfield-ref repr 'variable)
					       'address))))
	'())
       ((pair? repr)
	(let ((lst-new-visited (cons repr lst-visited)))
	  (determine-coverage linker (car repr) lst-new-visited)
	  (determine-coverage linker (cdr repr) lst-new-visited)))
       ;; We have to check subclasses of <variable-definition> before that.
       ((hrecord-is-instance? repr <generic-procedure-definition>)
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address)))
	  (if (not (address-hash-ref ht-used address))
	      (begin
		(mark-repr-used! repr)
		(address-hash-set! ht-used address repr)
		(let ((lst-new-visited (cons repr lst-visited)))
		  (mark-methods-for-coverage linker lst-new-visited))))))
       ((or (hrecord-is-instance? repr <class-definition>)
	    (hrecord-is-instance? repr <param-class-definition>)
	    (hrecord-is-instance? repr <param-logical-type-def>)
	    (hrecord-is-instance? repr <param-class-definition>)
	    (hrecord-is-instance? repr <generic-procedure-definition>))
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address)))
	  (mark-repr-used! repr)
	  (address-hash-set! ht-used address repr)
	  (let ((lst-subreprs (get-subexpressions repr))
		(lst-new-visited (cons repr lst-visited)))
	    (for-each (lambda (repr1)
			(determine-coverage linker repr1 lst-new-visited))
		      lst-subreprs))))
       ((hrecord-is-instance? repr <prim-class-def>)
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address)))
	  (address-hash-set! ht-used address repr))
	(mark-repr-used! repr)
	(let ((var-superclass (hfield-ref repr 'superclass))
	      (lst-new-visited (cons repr lst-visited)))
	  (determine-coverage linker var-superclass lst-new-visited)))
       ((hrecord-is-instance? repr <variable-definition>)
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address))
	      (lst-new-visited (cons repr lst-visited)))
	  (mark-repr-used! repr)
	  (address-hash-set! ht-used address repr)
	  (determine-coverage linker (hfield-ref repr 'value-expr)
			      lst-new-visited)))
       ((hrecord-is-instance? repr <variable-reference>)
	(let ((var (hfield-ref repr 'variable)))
	  ;; Variables without a toplevel definition
	  ;; need not be checked for coverage.
	  ;; Builtin variables and local variable don't
	  ;; have a variable definition.
	  (if (is-normal-variable? var)
	      (let ((lst-new-visited (cons repr lst-visited)))
		(determine-coverage linker var lst-new-visited)))))
       ((hrecord-is-instance? repr <normal-variable>)
	(let ((address (hfield-ref repr 'address))
	      (lst-new-visited (cons repr lst-visited)))
	  (determine-address-coverage linker address lst-new-visited)))
       ((is-entity? repr)
	(let ((lst-subreprs (get-subexpressions repr))
	      (lst-new-visited (cons repr lst-visited))
	      (address (hfield-ref repr 'address)))
	  (if (not-null? address)
	      (determine-address-coverage linker address lst-new-visited))
	  (for-each (lambda (repr1)
		      (determine-coverage linker repr1 lst-new-visited))
		    lst-subreprs)))
       (else
	(dvar1-set! repr)
	(raise 'determine-coverage:invalid-object)))
      (set! gl-indent old-indent))))


(define (mark-method-for-coverage linker repr def? lst-visited)
  (let ((gen-proc (hfield-ref repr 'gen-proc)))
    (assert (is-target-object? gen-proc))
    ;; We may have to check globals-by-address here.
    (let ((address (hfield-ref gen-proc 'address))
	  (ht-used (hfield-ref linker 'ht-used)))
      (assert (is-address? address))
      (if (address-hash-ref ht-used address)
	  (begin
	    (mark-repr-used! repr)
	    (if def?
		(determine-coverage
		 linker (hfield-ref repr 'procexpr) lst-visited)))))))


(define (mark-methods-for-coverage linker lst-visited)
  (for-each
   (lambda (repr)
     (cond
      ((hrecord-is-instance? repr <method-definition>)
       (mark-method-for-coverage linker repr #t lst-visited))
      ((hrecord-is-instance? repr <method-declaration>)
       (mark-method-for-coverage linker repr #f lst-visited))
      (else '())))
   (hfield-ref linker 'repr-list)))


(define (do-prevent-stripping linker)
  (let ((lst-reprs (hfield-ref linker 'repr-list)))
    (for-each
     (lambda (repr)
       (if (hrecord-is-instance? repr <prevent-stripping-expr>)
	   (let ((address (hfield-ref repr 'target-address)))
	     (if (null? address)
		 (begin
		   ;; This is an error situation.
		   (raise 'error-with-prevent-stripping-expr)))
	     (determine-address-coverage linker address '()))))
     lst-reprs)))


(define (make-var-def-hash-table lst-reprs)
  (let ((ht (make-hash-table gl-i-var-def-table-size)))
    (for-each (lambda (repr)
		(if (hrecord-is-instance? repr <variable-definition>)
		    (address-hash-set!
		     ht
		     (hfield-ref (hfield-ref repr 'variable) 'address)
		     repr)))
	      lst-reprs)
    ht))


(define (decl-is-used? linker repr)
  (assert (is-linker? linker))
  (assert (hrecord-is-instance? repr <forward-declaration>))
  (let ((address (hfield-ref (hfield-ref repr 'variable) 'address))
	(ht-used (hfield-ref linker 'ht-used)))
    (if (address-hash-ref ht-used address) #t #f)))


(define (var-def-is-used? linker repr)
  (or (not (hfield-ref linker 'strip?))
      (hfield-ref repr 'include?)
      (hashq-ref (hfield-ref linker 'ht-rebound) repr)))


(define (is-my-main-address? address)
  (and
   (eqv? (hfield-ref address 'number) address-number-target)
   (eqv? (hfield-ref address 'source-name) '_main)))


(define (include-in-stripping? expr)
  (not (or
	(and (hrecord-is-instance? expr <variable-definition>)
	     (let ((expr-value (hfield-ref expr 'value-expr)))
	       (or (null? expr-value)
		   (is-target-object? expr-value)
		   (hrecord-is-instance? expr-value <procedure-expression>)
		   (hrecord-is-instance? expr-value <param-proc-expr>)
		   (hrecord-is-instance? expr-value <prim-proc-ref>)
		   (hrecord-is-instance? expr-value <checked-prim-proc>)))
	     (not (is-my-main-address? (hfield-ref (hfield-ref expr 'variable)
						   'address))))
	(hrecord-is-instance? expr <forward-declaration>)
	(hrecord-is-instance? expr <method-definition>)
	(hrecord-is-instance? expr <method-declaration>)
	(hrecord-is-instance? expr <zero-setting-expr>)
	(hrecord-is-instance? expr <prevent-stripping-expr>)
	(hrecord-is-instance? expr <expr-define-syntax>)
	(hrecord-is-instance? expr <debug-output-expr>))))


(define (determine-total-coverage linker)
  (assert (is-linker? linker))
  ;; Reversion is not necessary here.
  (let ((l-reprs (reverse (hfield-ref linker 'repr-list))))
    (for-each (lambda (repr)
		(if (include-in-stripping? repr)
		    (determine-coverage linker repr '())))
	      l-reprs)))
