home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / hci-files.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.2 KB  |  191 lines  |  [TEXT/CCL2]
  1. ;;; hci-files.scm -- interface file writer/loader
  2. ;;;
  3. ;;; author :  John & Sandra
  4. ;;; date   :  8 Jul 1992
  5. ;;;
  6. ;;; This writes binary interface files.  A binary interface file is just
  7. ;;; a lisp (mumble) source file which directly builds the ast structure
  8. ;;; created by a compilation.  These files could be stored in either
  9. ;;; source or binary (compiled lisp) form.
  10.  
  11. ;;; An interface may reference entities defined in other interfaces.
  12. ;;; To ensure consistancy between when an interface is written and
  13. ;;; when it is read back in, a stamp is assigned to all interface files
  14. ;;; which serves as a unique id.  The stamps of all imported units are
  15. ;;; saved and examined at load time.
  16.  
  17.  
  18.  
  19. ;;;==================================================================
  20. ;;; Interface to compilation system
  21. ;;;==================================================================
  22.  
  23.  
  24. ;;; For compiled code, don't actually write out all the source code.
  25. ;;; Use a magic macro to memoize the form to be compiled.
  26.  
  27. (define *form-to-compile* '#f)
  28. (define *magic-file-to-compile* "$HASKELL/bin/magic.scm")
  29.  
  30.  
  31. ;;; The output from compiling the prelude can completely overwhelm
  32. ;;; the Lisp compiler.  If this variable is a number, it specifies
  33. ;;; a "reasonable" number of top-level forms which can be compiled
  34. ;;; and write-compiled-code-file will try to break up the input
  35. ;;; code automagically.
  36.  
  37. (define *magic-chunk-size* '#f)
  38.  
  39.  
  40. ;;; This is called to write both the code file and the interface file.
  41.  
  42. (define (write-compiled-code-file filename code code-quality chunk-size)
  43.   (let ((phase-start-time (get-run-time))
  44.         (forms            (flatten-forms code)))
  45.     (dynamic-let ((*magic-chunk-size*
  46.            (or chunk-size (dynamic *magic-chunk-size*)))
  47.           (*code-quality*
  48.            (or code-quality (dynamic *code-quality*))))
  49.       (if (or (not (dynamic *magic-chunk-size*))
  50.           (<= (the fixnum (length forms))
  51.           (the fixnum (dynamic *magic-chunk-size*))))
  52.       (write-compiled-code-file-aux filename `(begin ,@forms))
  53.       (with-compilation-unit ()
  54.         (write-compiled-code-file-aux
  55.           filename
  56.           `(begin
  57.          ,@(map (lambda (f) `(load ,f))
  58.             (write-compiled-code-file-split filename forms)))
  59.           ))))
  60.     (when (memq 'phase-time *printers*)
  61.       (let* ((current-time (get-run-time))
  62.          (elapsed-time (- current-time phase-start-time)))
  63.     (format '#t "Lisp compilation complete: ~A seconds~%" elapsed-time)))
  64.     ))
  65.  
  66. (define (write-compiled-code-file-split filename forms)
  67.   (let ((place     (filename-place filename))
  68.     (name      (filename-name filename))
  69.     (type      (filename-type filename))
  70.     (result    '()))
  71.     (do ((i 0 (1+ i)))
  72.     ((null? forms))
  73.     (multiple-value-bind (head tail)
  74.         (split-list forms (dynamic *magic-chunk-size*))
  75.       (let ((fname
  76.           (assemble-filename
  77.             place (format '#f "~a-part~a" name i) type)))
  78.         (push fname result)
  79.         (write-compiled-code-file-aux fname `(begin ,@head))
  80.         (setf forms tail))))
  81.     (nreverse result)))
  82.  
  83. (define (flatten-forms code)
  84.   (if (and (pair? code) (eq? (car code) 'begin))
  85.       (nreverse (flatten-forms-aux (cdr code) '()))
  86.       (list code)))
  87.  
  88. (define (flatten-forms-aux forms result)
  89.   (dolist (f forms)
  90.     (if (and (pair? f) (eq? (car f) 'begin))
  91.     (setf result (flatten-forms-aux (cdr f) result))
  92.     (push f result)))
  93.   result)
  94.     
  95.  
  96. (define (write-compiled-code-file-aux filename code)
  97.   (dynamic-let ((*form-to-compile*  code))
  98.     (compile-file (dynamic *magic-file-to-compile*) filename)))
  99.  
  100. (define-syntax (magic-form-to-compile)
  101.   (dynamic *form-to-compile*))
  102.  
  103.  
  104. ;;; Writing source code is good for debugging purposes, but slow.
  105. ;;; The *print-circle* and *print-shared* flags have to be set because
  106. ;;; the code printed out may contain gensyms, and this will ensure
  107. ;;; that the code can be read in again.
  108.  
  109. (define (write-interpreted-code-file filename code hairy?)
  110.   (dynamic-let ((*print-circle*   '#t)
  111.         (*print-shared*   '#t))
  112.     (call-with-output-file
  113.       filename
  114.       (lambda (port)
  115.     (if hairy?
  116.         (pprint-flatten code port)
  117.         (print-flatten code port))))))
  118.  
  119.  
  120. ;;; This attempts to read a compiled interface for a unit.  This is
  121. ;;; done whenever the unit file is newer than the source file.  If
  122. ;;; imported units have changed, the load will fail and recompilation
  123. ;;; will be attempted.  
  124. ;;; The caller is responsible for making sure that the interface file exists
  125. ;;; and for making sure that the interface file is up-to-date with
  126. ;;; respect to imported modules and that all the imported modules are
  127. ;;; known.
  128.  
  129. ;;; These variables are assigned by the code in the dump file.
  130.  
  131. (define *modules-imported* '())
  132. (define *defs-referenced* '())
  133. (define *types-referenced* '())
  134. (define *writer-version* '())
  135.  
  136. (define (read-binary-interface unit)
  137.   (dynamic-let ((*modules-loaded*     '())
  138.         (*modules-imported*   '())
  139.         (*defs-referenced*    '())
  140.         (*types-referenced*   '())
  141.         (*writer-version*     '()))
  142.       (load-more-recent-file (ucache-cifile unit) (ucache-sifile unit))
  143.       (setup-ucache-modules unit (vector->list *modules-loaded*))
  144.       (cond ((string=? *writer-version* *haskell-compiler-version*)
  145.          (add-modules-to-environment (vector->list *modules-loaded*))
  146.          '#t)
  147.         (else
  148.          (signal-incompatible-interface-file (ucache-cifile unit))
  149.          '#f))))
  150.  
  151. (define (setup-ucache-modules unit mods)
  152.   (setf (ucache-modules-defined unit) '())
  153.   (setf (ucache-interfaces-defined unit) '())
  154.   (dolist (m mods)
  155.     (if (and (interface-module? m)
  156.          (not (module-stand-alone? m)))
  157.     (push (module-name m)
  158.           (ucache-interfaces-defined unit))
  159.     (push (module-name m)
  160.           (ucache-modules-defined unit)))))
  161.  
  162. (define (signal-incompatible-interface-file filename)
  163.   (fatal-error 'incompatible-interface-file
  164.     "File ~A~%~
  165.      was written by a different version of the Haskell system.~%~
  166.      You must remove it and recompile."
  167.     filename))
  168.  
  169.  
  170. (define (load-more-recent-file cfile sfile)
  171.   (cond ((file-exists? cfile)
  172.      (if (or (not (file-exists? sfile))
  173.          (> (file-write-date cfile)
  174.             (file-write-date sfile)))
  175.          (load-compiled-interface-file cfile)
  176.          (load-interpreted-interface-file sfile)))
  177.     ((file-exists? sfile)
  178.      (load-interpreted-interface-file sfile))
  179.     (else
  180.      (signal-file-not-found cfile))))
  181.  
  182. (define (load-interpreted-interface-file file)
  183.   (load file)
  184.   (file-write-date file))
  185.  
  186. (define (load-compiled-interface-file file)
  187.   (load file)
  188.   (file-write-date file))
  189.  
  190.  
  191.