; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; The static linker.

; link-simple-system:
; resumer-exp should evaluate to a procedure
;   (lambda (arg i-port i-port-encoding o-port o-port-encoding ...) ...)

(define (link-simple-system filename resumer-exp . structs)
  (link-system structs
	       (lambda () resumer-exp)
	       (lambda (alist) ; zap everything in phases other than 0
		 (map (lambda (p)
			(case (car p)
			  ((0) p)
			  (else (list (car p)))))
		      alist))
	       (lambda (struct phase) #f)
	       filename))


; resumer-exp should evaluate to a procedure
;   (lambda (structs-thunk) ... (lambda (arg i-port i-port-encoding o-port o-port-encoding ...) ...))

; `update-macro-opens' is a procedure accepting and producing an alist phase |-> (list structure)

; `follow-macro-open?' takes a struct and a phase (!= 0), and returns
; #t if this open should be followed in the dependency analysis,
; i.e. if this structure should be compiled before those that open it
; at expand time.

(define (link-reified-system some filename make-resumer-exp update-macro-opens follow-macro-open? . structs)
  (link-system (append structs (map cdr some))
	       (lambda ()
		 `(,make-resumer-exp
		   (lambda ()
		     ,(call-with-values
			  (lambda () (reify-structures some update-macro-opens))
			(lambda (exp locs least-uid)
			  `(,exp (lambda (i)
				   (vector-ref ,(strange-quotation locs)
					       (- i ,least-uid)))))))))
	       update-macro-opens
	       follow-macro-open?
	       filename))

; The compiler doesn't like to see unusual objects quoted, but this will
; fake it out.

(define strange-quotation
  (let ((operator/quote (get-operator 'quote)))
    (lambda (thing)
      (make-node operator/quote `',thing))))


; `(,make-resumer-exp ',vector) should evaluate to a procedure
;   (lambda (locs) ... (lambda (arg i-port i-port-encoding o-port o-port-encoding ...) ...))

(define (link-semireified-system some filename
				 make-resumer-exp update-macro-opens follow-macro-open? . structs)
  (let ((loser #f))
    (link-system (append structs (map cdr some))
		 (lambda ()
		   (call-with-values (lambda ()
				       (reify-structures some update-macro-opens))
		     (lambda (exp locs least)
		       (set! loser exp)
		       `(,make-resumer-exp ,(strange-quotation locs)
					   ,least))))
		 update-macro-opens
		 follow-macro-open?
		 filename)
    (let ((f (namestring filename #f 'env)))
      (call-with-output-file f
	(lambda (port)
	  (display "Writing environment structure to ")
	  (display f)
	  (newline)
	  ;; loser evaluates to a procedure
	  ;;  (lambda (uid->location) struct-alist)
	  (write `(define make-the-structures
		    (,loser location-from-id))
		 port))))))


; (link-system structs make-resumer update-macro-opens filename)
;    structs is a list of structures to be compiled (which should
;    include packages-internal, if there are update-macro-opens),
;    make-resumer is a thunk which should return an expression, to be
;      evaluated in a package that opens the given structures, that
;      evaluates to the procedure to be called after all
;      initializations are run, and
;    filename is the name of the file to which the image should be written.

(define (link-system structs make-resumer update-macro-opens follow-macro-open? filename)
  (with-fresh-compiler-state
   (if *debug-linker?* 100000 0)    ;Location uid
   (lambda ()
     (set! *loser* #f)
     (let* ((location-info (make-table))
	    (generator (make-location-generator location-info
						(if *debug-linker?* 10000 0)))
	    (templates (compile-structures structs
					   update-macro-opens
					   follow-macro-open?
					   generator
					   package->environment))
	    (package (make-simple-package structs #f #f))
	    (startup-template (begin
				(set-package-get-location! package generator)
				(expand&compile-form (make-resumer) package))))
       (let ((startup (make-closure 
		       (make-startup-procedure templates startup-template)
		       0)))
	 (if *debug-linker?* (set! *loser* startup))
	 (write-image-file startup
			   (namestring filename #f 'image)))
       (write-debug-info location-info
			 (namestring filename #f 'debug))))))

 
(define (expand&compile-form form package)
  (receive (expanded for-syntax)
      (expand-forms (package->environment package)
		    (list (cons #f (list form))))
    (let ((template (compile-forms expanded
				   #f	;filename
				   (package-uid package))))
      (link! template package 0 #t)
      template)))

(define *loser* #f)
(define *debug-linker?* #f)

(define (compile-structures structs update-macro-opens follow-macro-open? generator package->env)
  (let ((packages 
	 (map car ; collect-packages returns (list (pair package phase))
	      (collect-packages structs 0 (lambda (package phase) #t) follow-macro-open?)))
	(out (current-noise-port)))
    (for-each (lambda (package)
		(set-package-get-location! package generator))
	      packages)
    (for-each (lambda (package)
		(display #\[ out)
		(display (package-name package) out)
		(compile-package package)
		(display #\] out)
		(newline out))
	      packages)
    (append (map (lambda (package)
		   ;; make template amenable to transportation, but link before we do that to
		   ;; avoid problems with generated names
		   (let* ((template (package-invoke-template package))
			  (linked (link template package 0 #t)))
		     (freeze-template! template package)
		     linked))
		 packages)
	    (map (lambda (package)
		   (let ((template (package-visit-template package))
			 (macro-opens-alist (package-macro-opens->alist package)))
		     ;; we don't want to link against the phony link-time package
		     (package-zap-macro-opens! package)
		     (for-each (lambda (p)
				 (package-add-opens! package (car p)
						     (lambda () (cdr p))))
			       (update-macro-opens macro-opens-alist))
		     ;; ditto, also make sure the syntax definitions
		     ;; are re-linked against the new macro opens
		     (let ((env (comp-env-next-phase (package->environment package))))
		       (freeze-template! template env)
		       (link template env 0 #t))))
		 packages))))

; Locations in new image will have their own sequence of unique id's.
	    
(define (make-location-generator location-info start)

  (let ((*location-uid* start))

    (define (make-new-location p name)
      (let ((uid *location-uid*))
	(set! *location-uid* (+ *location-uid* 1))
	(table-set! location-info uid
		    (cons (name->symbol name) (package-uid p))) ;?
	(make-undefined-location uid)))

    make-new-location))


(define (write-image-file start filename)
  (write-image filename
	       start
	       "This heap image was made by the Scheme 48 linker."))



; Handy utility for making arguments to link-reified-system

(define-syntax struct-list
  (syntax-rules ()
    ((struct-list name ...) (list (cons 'name name) ...))))
