; -*-scheme-*-

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



;; *** Linker instantiation and factorization ***


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


(define theme-target-compile-instance-predef-fwd '())
(define theme-target-compile-instance-fwd '())
(define compile-factorized-expr-fwd '())
(define tc-tree-il-instance-predef-fwd '())
(define tc-tree-il-instance-fwd '())
(define tc-tree-il-factorized-expr-fwd '())


(define gl-ctr11 0)


(define-hrecord-type <linker-instance-predef> ()
  lst-instance)


(define-hrecord-type <linker-instance> ()
  lst-instance)


(define-hrecord-type <factorized-expr> ()
  address to)


(define (get-binder-for-inst linker)
  (hfield-ref linker 'binder-instantiation))


(define (inst-handle-type-vars linker repr)
  (let ((prev-state (hfield-ref linker 'state))
	(binder (get-binder-for-inst linker)))
    (hfield-set! linker 'state 'binding)
    (if gl-test8 (raise 'inst-test-error))
    (dwl4 (hfield-ref binder 'type-check?))
    (let ((result
	   (inst-bind-type-vars binder '() repr)))
      (hfield-set! linker 'state prev-state)
      result)))


(define (can-be-factorized? repr l-visited)
  (cond
   ;; Objects containing nulls or primitive values can be factorized.
   ((or (is-null-obj? repr) (is-null-class-entity? repr)) #t)
   ((and (is-target-object? repr) (hfield-ref repr 'primitive?)) #t)
   ((memq repr l-visited) #t)
   ((is-normal-variable? repr) #f)
   ((is-t-type-variable? repr) #f)
   ;; Definitions of signatures and parametrized signatures involve
   ;; corresponding objects. Those definitions may not be factorized (?).
   ((is-t-signature? repr) #f)
   ((is-t-param-signature? repr) #f)
   ((not (is-target-object? repr)) #f)
   (else
    ;; Parametrized procedures and parametrized logical types
    ;; may contain expressions in field value-expr.
    ;; OTOH do-tcomp-object seems not to be able to
    ;; compile parametrized procedures or parametrized logical
    ;; types without address.
    (let ((repr-type (get-entity-type repr)))
      (if (or (is-tc-param-proc? repr-type)
	      (is-t-param-logical-type? repr-type))
	  #f
	  (let ((l-subreprs (get-subexpressions repr))
		(l-new-visited (cons repr l-visited)))
	    (and-map? (lambda (ent) (can-be-factorized? ent l-new-visited))
		      l-subreprs)))))))


(define (factorize-pair linker repr fact visited)
  (let* ((new-visited (cons repr visited))
	 (x-head (factorize-subexprs linker (car repr)
				     fact new-visited))
	 (x-tail (factorize-subexprs linker (cdr repr)
				     fact new-visited)))
    (if (or (not (eqv? x-head (car repr)))
	    (not (eqv? x-tail (cdr repr))))
	(cons x-head x-tail)
	repr)))


(define (factorize-object linker repr fact)
  (if (and (null? (hfield-ref repr 'address))
	   (can-be-factorized? repr '()))
      ;; Factorized variables are toplevel.
      (let ((address (linker-alloc-loc linker 'f #t)))
	(hfield-set! fact 'element
		     (append (hfield-ref fact 'element)
			     (list (cons address repr))))
	(let ((to-new (make-object-with-address repr address)))
	  (hashq-set! (hfield-ref linker 'ht-fact) repr to-new)
	  to-new))
      repr))


(define (factorize-normal-entity linker repr fact visited)
  (let* ((new-visited (cons repr visited))
	 (subreprs (get-subexpressions repr))
	 (translated-subreprs
	  (map* (lambda (subrepr)
		  (factorize-subexprs linker subrepr fact new-visited))
		subreprs))
	 ;; There should be no need to do type checking here.
	 (new-repr
	  (let* ((binder (get-binder-for-inst linker))
		 (old-type-check? (hfield-ref binder 'type-check?))
		 (old-preserve-types? (hfield-ref binder 'preserve-types?))
		 (old-instantiation? (hfield-ref binder 'instantiation?))
		 (old-make-instances? (hfield-ref binder 'make-instances?)))
	    (hfield-set! binder 'type-check? #f)
	    (hfield-set! binder 'preserve-types? #t)
	    (hfield-set! binder 'instantiation? #f)
	    (hfield-set! binder 'make-instances? #f)
	    (let ((result
		   (clone-with-branches
		    binder
		    repr
		    translated-subreprs #f)))
	      (hfield-set! binder 'type-check? old-type-check?)
	      (hfield-set! binder 'preserve-types? old-preserve-types?)
	      (hfield-set! binder 'instantiation? old-instantiation?)
	      (hfield-set! binder 'make-instances? old-make-instances?)
	      result))))
    new-repr))


(define (factorize-subexprs linker repr fact visited)
  (assert (is-linker? linker))
  (assert (or (null? repr) (pair? repr) (is-entity? repr)))
  (assert (hrecord-is-instance? fact <singleton>))
  (assert (list? visited))

  ;; (set! gl-counter25 (+ gl-counter25 1))
  ;; (dwli gl-counter25)
  ;; (dwi "fact ")
  ;; (dwc gl-counter25)
  ;; (dwc " ")
  ;; (dwc gl-indent)
  ;; (dwc " ")
  ;; (if (hrecord? repr)
  ;;     (begin
  ;; 	(dwc (hrecord-type-name-of repr))
  ;; 	(dwc " ")))
  ;; (if (is-target-object? repr)
  ;;     (dwc (debug-get-string repr)))
  ;; (dwli-newline)

  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((result
	   (cond
	    ((or (is-null-obj? repr) (is-null-class-entity? repr)) repr)
	    ;; Primitive atomic objects are not factorized but other
	    ;; primitive objects are.
	    ((is-t-atomic-object? repr) repr)
	    ((hashq-ref (hfield-ref linker 'ht-fact) repr)
	     =>
	     (lambda (x) x))
	    ((memv repr visited) repr)
	    ((pair? repr)
	     (factorize-pair linker repr fact visited))
	    ((is-normal-variable? repr) repr)
	    ((is-t-type-variable? repr) repr)
	    ((is-target-object? repr)
	     (factorize-object linker repr fact))
	    (else
	     (factorize-normal-entity linker repr fact visited)))))
      (set! gl-indent old-indent)
      result)))


(define (factorize-instance linker inst fact)
  (assert (list? inst))
  (assert (memv (car inst) '(class ltype proc raw-proc)))
  (if (eq? (car inst) 'proc)
      (let* ((old-expr (caddr inst))
	     (new-expr (factorize-subexprs linker old-expr fact '())))
	(list 'proc (cadr inst) new-expr))
      inst))


(define (make-linker-instance-predef linker lst-instance)
  (make-hrecord <linker-instance-predef> lst-instance))


(define (make-linker-instance-predefs linker lst-instances)
  (map (lambda (lst-inst) (make-linker-instance-predef linker lst-inst))
       lst-instances))


(define (make-linker-instance linker lst-instance)
  (let ((result
	 (make-hrecord <linker-instance> lst-instance)))
    result))


(define (make-linker-instances linker lst-instances)
  (map (lambda (lst-inst) (make-linker-instance linker lst-inst))
       lst-instances))


(define (make-linker-factorized-exprs linker fact)
  (let ((exprs (hfield-ref fact 'element)))
    (map (lambda (expr)
	   (make-hrecord <factorized-expr> (car expr) (cdr expr)))
	 exprs)))


(define (determine-instance-cov linker inst)
  (let ((lst (hfield-ref inst 'lst-instance)))
    ;; Should we do something for parametrized class and type instances, too?
    (if (eq? (car lst) 'proc)
	(determine-coverage linker (list-ref lst 2) '()))))


(define (determine-cov-for-instances linker lst-instances)
  (for-each (lambda (inst) (determine-instance-cov linker inst))
	    lst-instances))


(define (theme-do-target-instantiate linker repr)
  ;; We clear the ht-fact hash table when we start to process a new toplevel
  ;; expression.
  (hash-clear! (hfield-ref linker 'ht-fact))
  (let ((result
	 (if (hfield-ref linker 'factorize?)
	     (let* ((bind-result (inst-handle-type-vars linker repr))
		    (inst (cdr bind-result))
		    (fact (make-hrecord <singleton> '()))
		    (preinst (make-linker-instance-predefs
			      linker
			      inst))
		    (inst2 (map* (lambda (tp-instance)
				   (factorize-instance linker tp-instance fact))
				 inst))
		    (inst3 (make-linker-instances linker inst2))
		    (repr1 (car bind-result))
		    (repr2 (factorize-subexprs linker repr1 fact '()))
		    (lst-fact (make-linker-factorized-exprs linker fact)))
	       (if (hfield-ref linker 'strip?)
		   (begin
		     (determine-cov-for-instances linker inst3)
		     (determine-coverage linker repr2 '())
		     (hashq-set! (hfield-ref linker 'ht-rebound) repr2 #t)))
	       (append preinst lst-fact inst3 (list repr2)))
	     (begin
	       (let* ((bind-result (inst-handle-type-vars linker repr))
		      (preinst (make-linker-instance-predefs
				linker
				(cdr bind-result)))
		      (inst (make-linker-instances linker (cdr bind-result)))
		      (bound-expr (car bind-result)))
		 (if (hfield-ref linker 'strip?)
		     (begin
		       (determine-cov-for-instances linker inst)
		       (determine-coverage linker bound-expr '())
		       (hashq-set! (hfield-ref linker 'ht-rebound) bound-expr
				   #t)))
	       (append preinst inst (list bound-expr)))))))
    result))


(define (theme-target-instantiate linker repr)
  (assert (hrecord-is-instance? linker <linker>))
  (hfield-set! linker 'current-toplevel-repr repr)
  (let ((result
	 (cond
	  ((or 
	    (hrecord-is-instance?
	     repr <param-class-definition>)
	    (hrecord-is-instance?
	     repr <param-logical-type-def>))
	   (list repr))
	  ((and (hrecord-is-instance?
	  	 repr <variable-definition>)
		(or
		 (hrecord-is-instance?
		  (hfield-ref repr 'value-expr)
		  <param-proc-expr>)
		 (hrecord-is-instance?
		  (hfield-ref repr 'value-expr)
		  <prim-proc-ref>)
		 (hrecord-is-instance?
		  (hfield-ref repr 'value-expr)
		  <checked-prim-proc>)))
	   (if (or (not (hfield-ref linker 'strip?))
		   (address-hash-ref
		    (hfield-ref linker 'ht-used)
		    (hfield-ref (hfield-ref repr 'variable) 'address)))
	       (list repr)
	       ;; (if (hfield-ref linker 'factorize?)
	       ;; 	   (let* ((fact (make-hrecord <singleton> '()))
	       ;; 		  (repr-new (factorize-subexprs linker repr fact '()))
	       ;; 		  (lst-fact (make-linker-factorized-exprs linker fact)))
	       ;; 	     (append lst-fact (list repr-new)))
	       ;; 	   (list repr))
	       '()))
	  ((hrecord-is-instance? repr <forward-declaration>)
	   (list repr))
	  ((hrecord-is-instance? repr <variable-definition>)
	   (if (or (not (hfield-ref linker 'strip?))
		   (address-hash-ref
		    (hfield-ref linker 'ht-used)
		    (hfield-ref (hfield-ref repr 'variable) 'address)))
	       (theme-do-target-instantiate linker repr)
	       '()))
	  ((hrecord-is-instance? repr <method-definition>)
	   (if (or (not (hfield-ref linker 'strip?))
		   (hfield-ref repr 'include?))
	       (begin
		 (theme-do-target-instantiate linker repr))
	       '()))
	  ((hrecord-is-instance? repr <prevent-stripping-expr>)
	   '())
	  ((hrecord-is-instance? repr <method-declaration>)
	   (list repr))
	  (else
	   (theme-do-target-instantiate linker repr)))))
    (hfield-set! linker 'current-toplevel-repr '())
    result))


(define (theme-instantiate-program linker lst-reprs)
  (let ((lst-reprs1 (reverse lst-reprs))
	(binder (hfield-ref linker 'binder-instantiation)))
    (let ((result '()))
      (do ((lst-cur lst-reprs1 (cdr lst-cur))
	   (i 0 (+ i 1)))
	  ((null? lst-cur))
	(dw2 "Instantiating expression number ")
	(dwl2 i)
	(let ((expr (car lst-cur)))
	  (if (hrecord-is-instance? expr <variable-definition>)
	      (dwl2 (hfield-ref (hfield-ref (hfield-ref expr 'variable)
					    'address)
				'source-name))))
	;; (let ((expr (car lst-cur)))
	;;   (if (and (hrecord-is-instance? expr <variable-definition>)
	;; 	   (or
	;; 	    (hrecord-is-instance? (hfield-ref expr 'value-expr)
	;; 				  <procedure-expression>)
	;; 	    (hrecord-is-instance? (hfield-ref expr 'value-expr)
	;; 				  <param-proc-expr>)))
	;;       (begin
	;;	(dwl2 "addr HEP")
	(let ((expr (car lst-cur)))
	  (if (hrecord-is-instance? expr <variable-definition>)
	      (hfield-set! binder 's-cur-toplevel
			   (let ((address
				  (hfield-ref (hfield-ref expr 'variable)
					      'address)))
			     (if (not-null? address)
				 (hfield-ref address 'source-name))
				 '()))))
		(set! result
		      (append
		       result
		       (theme-target-instantiate linker (car lst-cur))))
		(hfield-set! binder 's-cur-toplevel '()))
    result)))
