;;; -*- Mode: Scheme; scheme48-package: package-fasloader -*-

;;;; Compiled Code Storage for Scheme48
;;;; Package Fasloader

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (maybe-fasload-package-bindings package)
  (call-with-package-fasload-file-port package
      package-bindings-file-name
    (lambda (port)
      (*fasload-package-bindings package port)
      #t)))

(define (fasload-package-bindings package port)
  (call-with-package-fasload-port package port
    (lambda (port)
      (*fasload-package-bindings package port))))

(define (*fasload-package-bindings package port)
  (create-package-location-map package)
  (let loop ()
    (cond ((fasload port)
           => (lambda (name)
                (let* ((type (fasload port))
                       (static (fasload port)))
                  (package-define! package name type #f static)
                  (loop))))))
  (set-package-early-bound?! package #t))

(define (maybe-fasload-package-template package)
  (call-with-package-fasload-file-port package
      package-template-file-name
    (lambda (port)
      (*fasload-package-template package port))))

(define (fasload-package-template package port)
  (call-with-package-fasload-port package port
    (lambda (port)
      (*fasload-package-template package port))))

(define (*fasload-package-template package port)
  (let ((template (fasload port)))
    (set-package-template! package template)
    template))

(define (maybe-fasload-package-debug-data package)
  (call-with-package-template package
    (lambda (template)
      (call-with-package-fasload-file-port package
          package-debug-data-file-name
        (lambda (port)
          (fasload-template-debug-data template port))))))

(define (fasload-package-debug-data package port)
  (call-with-package-template package
    (lambda (template)
      (call-with-package-fasload-port package port
        (lambda (port)
          (fasload-template-debug-data template port))))))

(define (call-with-package-template package receiver)
  (cond ((package-template package) => receiver)
        (else (error "package has no template to load debug data into"
                     package))))

(define (call-with-package-fasload-file-port package compute-file-name
          receiver)
  (let ((file-name (compute-file-name package)))
    (and file-name
         (file-exists? file-name)
         (call-with-input-file file-name
           (lambda (input-port)
             (with-fasloading-package package
               (lambda ()
                 (receiver (open-block-fasload-port
                            input-port
                            package-fasl-decoder)))))))))

(define (call-with-package-fasload-port package port receiver)
  (with-fasload-port-decoder-selector port package-fasl-decoder
    (lambda ()
      (with-fasloading-package package
        (lambda ()
          (receiver port))))))

(define (with-fasloading-package package thunk)
  (if (not (package-qualified->generated-table package))
      (create-package-qualified->generated-table package))
  (let-fluid $package package
    thunk))

(define (file-exists? file-name)         ;** HACK
  (call-with-current-continuation
    (lambda (abort)
      (with-handler (lambda (condition propagate)
                      (if (error? condition)
                          (abort #f)
                          (propagate)))
        (lambda ()
          (close-input-port (open-input-file file-name))
          #t)))))

(define $package (make-fluid #f))

(define (package-fasl-decoder key)
  (case key
    ((CLOSURE)     closure-fasl-decoder)
    ((LOCATION)   location-fasl-decoder)
    ((TEMPLATE)   template-fasl-decoder)
    ((GENERATED) generated-fasl-decoder)
    ((TRANSFORM) transform-fasl-decoder)
    ((NODE)           node-fasl-decoder)
    ((OPERATOR)   operator-fasl-decoder)
    ((PRIMOP)       primop-fasl-decoder)
    ((TYPE)           type-fasl-decoder)
    ((DEBUG-DATA) debug-data-fasl-decoder)
    (else (usual-fasl-decoder key))))

(define closure-fasl-decoder
  (lambda (port register)
    (let ((closure (make-closure #f #f)))
      (register closure)
      (set-closure-template! closure (fasload port))
      (set-closure-env!      closure (fasload port))
      closure)))

;;; This is used for defining setters for fields that don't have them
;;; built-in, namely closures & weak pointers.  This uses explicit
;;; renaming macros, not SYNTAX-RULES, because the LAP transducer can't
;;; handle the generated names in the output of SYNTAX-RULES macros.
;;; This is used locally to this module anyway, so it doesn't need to
;;; be hygienic.
;;;
;;; This is kind of gross, and it might be better placed in the object
;;; dumper itself.

(define-syntax define-stob-setter
  (lambda (form rename compare)
    (let ((name      (cadr   form))
          (stob-type (caddr  form))
          (index     (cadddr form)))
      `(DEFINE ,name
         (LAP ,name ()
           (PROTOCOL 2)                 ; Two arguments.
           (POP)
           (STORED-OBJECT-SET! ,stob-type ,index
                               0)       ; The 0 tells it not to log in
           (RETURN))))))                ;   the current proposal.

(define-stob-setter set-closure-template! closure 0)
(define-stob-setter set-closure-env!      closure 1)

(define location-fasl-decoder
  (lambda (port register)
    (let* ((id (fasload port))
           (qname (fasload port))
           (type (fasload port))
           (package (fluid $package))
           (location (find-location qname type package)))
      (register location)
      (table-set! (package-location-map package)
                  location
                  ;; Translate the dumped qualified name to this image.
                  (cons (name->qualified
                         (qualified->name qname)
                         (package->environment package))
                        type))
      location)))

(define template-fasl-decoder
  (lambda (port)
    (let* ((len (fasload port))
           (template (make-template len #f)))
      (let ((code (fasload port)))
        (set-template-code! template code)
        (set-template-byte-code! template code))
      (set-template-info! template (fasload port))
      (set-template-package-id! template
                                (package-uid (fluid $package)))
      (do ((i template-overhead (+ i 1)))
          ((= i len))
        (template-set! template i (fasload port)))
      template)))

(define debug-data-fasl-decoder
  (lambda (port register)
    (let ((ddata (%make-debug-data)))
      (register ddata)
      (set-debug-data-name! ddata (fasload port))
      (set-debug-data-parent! ddata (fasload port))
      (set-debug-data-env-maps! ddata (fasload port))
      (set-debug-data-source! ddata (fasload port))
      ddata)))

(define (fasload-template-debug-data template port)
  (let ((ddata (fasload port)))
    (if (debug-data? ddata)
        (begin
          (set-debug-data-uid! ddata (template-id template))
          (set-template-info! template ddata)))
    (do ((i template-overhead (+ i 1)))
        ((= i (template-length template)))
      (let ((element (template-ref template i)))
        (if (template? element)
            (fasload-template-debug-data element port))))))

;;; This is a total crock.

(define (%make-debug-data)
  (make-debug-data #f #f #f #f #f))

(define (set-debug-data-uid! ddata uid)
  (record-set! ddata 1 uid))

(define (set-debug-data-name! ddata name)
  (record-set! ddata 2 name))

(define (set-debug-data-parent! ddata parent)
  (record-set! ddata 3 parent))

;;; These two happen to be provided already.

;; (define (set-debug-data-env-maps! ddata env-maps)
;;   (record-set! ddata 4 env-maps))
;;
;; (define (set-debug-data-source! ddata source)
;;   (record-set! ddata 5 source))

(define generated-fasl-decoder
  (lambda (port register)
    (let* ((qname (fasload port))
           (generated (qualified->name qname)))
      (register generated)
      generated)))

(define transform-fasl-decoder
  (lambda (port)
    (let* ((id        (fasload port))
           (type      (fasload port))
           (proc      (fasload port))
           (aux-names (fasload port))
           (source    (fasload port)))
      (receive (proc.aux-names source)
               (if (eq? proc 'INLINE-TRANSFORM)
                   (values (inline-transform source aux-names)
                           `(INLINE-TRANSFORM ',source ',aux-names))
                   (values (cons proc aux-names)
                           source))
        (make-transform proc.aux-names
                        (fluid $package)
                        type
                        source
                        id)))))

(define node-fasl-decoder
  (lambda (port register)
    (let* ((operator (fasload port))
           (form     (fasload port))
           (node (make-node operator form)))
      (register node)
      (node-set! node 'BINDING (fasload port))
      node)))

(define operator-fasl-decoder
  (lambda (port register)
    (let* ((name (fasload port))
           (type (fasload port))
           (operator (get-operator name type)))
      (register operator)
      operator)))

(define primop-fasl-decoder
  (lambda (port)
    (get-primop (fasload port))))

(define type-fasl-decoder
  (lambda (port)
    (sexp->type (fasload port) #t)))

;;;; Location Resolution

(define (find-location qname want-type package)
  (let ((name (qualified->name qname)))
    (cond ((package-lookup package name)
           => (lambda (binding)
                (check-binding-type binding want-type package qname)
                (binding-place binding)))
          (else
           (error "unable to retrieve location for name"
                  qname name want-type package)))))

(define (check-binding-type binding want-type package qname)
  (let ((real-type (binding-type binding)))
    (if (not (or (equal? want-type usual-variable-type)
                 (if (pair? want-type)
                     (and (pair? real-type)
                          (eq? (car want-type) 'VARIABLE)
                          (eq? (car real-type) 'VARIABLE)
                          (same-type? (cadr want-type)
                                      (cadr real-type)))
                     (and (not (pair? real-type))
                          (same-type? want-type real-type)))))
        (warn "type inconsistency in dumped binding"
              package qname
              `(compile-time type was ,want-type)
              `(load-time type is ,real-type)))))

(define (qualified->name name)
  (if (not (qualified? name))
      name
      (let* ((package (fluid $package))
             (table (package-qualified->generated-table package)))
        (or (table-ref table name)
            ((lambda (generated)
               (table-set! table name generated)
               generated)
             (let ((parent
                    (qualified->name (qualified-parent-name name))))
               (generate-name
                (qualified-symbol name)
                (if (generated? parent)
                    (get-qualified-env (generated-env parent)
                                       (generated-name parent))
                    (get-qualified-env (package->environment package)
                                       parent))
                parent)))))))

(define (get-qualified-env env name)
  (let ((probe (generic-lookup env name)))
    (if (and (binding? probe)
             (transform? (binding-static probe)))
        (transform-env (binding-static probe))
        (error "invalid qualified reference"
               env name probe))))