home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / phases.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  8.4 KB  |  265 lines  |  [TEXT/CCL2]
  1. memq ',phase-name (dynamic *printers*))
  2.        (format '#t "~%Phase ~a:~%" ',phase-name)
  3.        (force-output))
  4.      (let* ((phase-start-time (get-run-time))
  5.         (result ,body)
  6.         (current-time  (get-run-time)))
  7.        (when (eq? (dynamic *abort-phase*) ',phase-name)
  8.      (abort-compilation))
  9.        ,@(if (eq? printer '#f)
  10.          '()
  11.          `((when (memq ',phase-name (dynamic *printers*))
  12.          (funcall ,printer result)
  13.          (force-output))))
  14.        (when (memq 'phase-time *printers*)
  15.      (let ((elapsed-time (- current-time phase-start-time)))
  16.        (format '#t "~&~A complete: ~A seconds~%"
  17.            ',phase-name elapsed-time)
  18.        (force-output)))
  19.        result)))
  20.  
  21. ;;; This function compiles a set of files in a compilation environment.
  22. ;;; The compilation environment consists of a set of previously compiled
  23. ;;; implementations and interfaces.  This environment is not passed explicitly
  24. ;;; as a parameter here; instead it lives in the background within some
  25. ;;; global variables.
  26.  
  27. ;;; Interface files are handled specially.  Since interfaces are completely
  28. ;;; standalone, they are compiled in a null environment one source file at
  29. ;;; a time.
  30.  
  31. ;;; Returns 2 values: module ast's and lisp code.
  32.  
  33. ;;; %%% This is set up to allow interfaces and implementations to be
  34. ;;;     mixed in a program but this can't happen; the compilation system
  35. ;;;     separates .hi and .hs source files into different units.
  36.  
  37. (define (compile-haskell-files files)
  38.   (dynamic-let ((*abort-phase*                '#f))
  39.      (let ((all-mods       (haskell-parse-files files))
  40.        (interface-mods '())
  41.        (regular-mods   '()))
  42.        (if (null? all-mods)
  43.        (values '() '(begin))
  44.        (dolist (m all-mods)
  45.          (if (interface-module? m)
  46.          (push m interface-mods)
  47.          (push m regular-mods))))
  48.        (dynamic-let ((*unit*  (get-compilation-unit-name (car all-mods))))
  49.      (values
  50.        all-mods
  51.        `(begin
  52.           ,@(if interface-mods
  53.             (list (compile-interface-modules (nreverse interface-mods)))
  54.             '())
  55.           ,@(if regular-mods
  56.             (list (compile-modules (nreverse regular-mods)))
  57.             '()))
  58.        )))))
  59.  
  60. ;;; Some module from the list supplies the unit name.  The name is
  61. ;;; different for interfaces so that there is no chance that an interface
  62. ;;; and implementation of a module will share the same unit name.
  63.  
  64. (define (get-compilation-unit-name mod)
  65.   (if (interface-module? mod)
  66.       (symbol-append (module-name mod) '|-interface|)
  67.       (module-name mod)))
  68.  
  69. (define (compile-modules mods)
  70.   (dynamic-let ((*context*                    '#f)
  71.         (*recoverable-error-handler*  '#f)
  72.         (*abort-phase*                '#f)
  73.         (*unique-name-counter*        1))
  74.         (haskell-import-export mods '#f)
  75.       (haskell-process-type-declarations mods)
  76.       (haskell-scope mods)
  77.       (let ((big-let (haskell-dependency-analysis mods)))
  78.         (haskell-type-check big-let mods)
  79.         (setf big-let (haskell-cfn big-let))
  80.         (setf big-let (haskell-dependency-reanalysis big-let))
  81.         (setf big-let (haskell-ast-to-flic big-let))
  82.         (setf big-let (haskell-optimize big-let))
  83.         (setf big-let (haskell-strictness big-let))
  84.         (let ((res (haskell-codegen big-let mods)))
  85.           (haskell-check-interfaces mods)
  86.           (dolist (m mods)
  87.         (zap-module-slots m))
  88.           res))))
  89.  
  90. (define (modules->lisp-code modules)
  91.   (dynamic-let ((*unit* (module-name (car modules))))
  92.     (compile-modules modules)))
  93.  
  94. (define (abort-compilation)
  95.   (format *error-output-port* "Compilation aborted.~%")
  96.   (funcall (dynamic *abort-compilation*)))
  97.  
  98. (define (halt-compilation)
  99.   (setf (dynamic *abort-phase*) (dynamic *phase*)))
  100.  
  101. ;;; Zap slots of module data structures that contain pointers to things
  102. ;;; that are no longer needed once compilation has finished.  This
  103. ;;; frees up lots of memory.
  104. ;;; The slots that are saved are the ones that are also saved by
  105. ;;; dump-interface, namely things like the symbol table and export table,
  106. ;;; and stuff like the module name and type.
  107.  
  108. (define (zap-module-slots m)
  109.   ;; Throw out all the AST structure built by the parser
  110.   (setf (module-exports m) '())
  111.   (setf (module-imports m) '())
  112.   (setf (module-fixities m) '())
  113.   (setf (module-synonyms m) '())
  114.   (setf (module-algdatas m) '())
  115.   (setf (module-classes m) '())
  116.   (setf (module-instances m) '())
  117.   (setf (module-derivings m) '())
  118.   (setf (module-annotations m) '())
  119.   (setf (module-decls m) '())
  120.   ;; Throw out other slots that are used internally by the compiler
  121.   (setf (module-synonym-defs m) '())
  122.   (setf (module-alg-defs m) '())
  123.   (setf (module-class-defs m) '())
  124.   (setf (module-fresh-exports m) '())
  125.   (setf (module-exported-modules m) '())
  126.   (setf (module-interface-imports m) '())
  127.   ;; FLIC associated with top-level variables in the symbol table that
  128.   ;; isn't needed later for inlining is zapped elsewhere -- see
  129.   ;; csys/structure-save.scm.
  130.   )
  131.  
  132.  
  133. ;;; Here are the actual phase bodies
  134.  
  135. (predefine (parse-files files))
  136.  
  137. (define (haskell-parse-files filenames)
  138.   (phase-body parse
  139.     (let ((mods (parse-files filenames)))
  140.       mods)
  141.     #f))
  142.  
  143. (predefine (import-export modules))  ; in import-export/import-export.scm
  144. (predefine (import-export/interface modules))
  145.  
  146. (define (haskell-import-export modules interface?)
  147.   (phase-body import
  148.     (if interface?
  149.     (import-export/interface modules)
  150.     (import-export modules))
  151.     #f))
  152.  
  153.  
  154. (predefine (process-type-declarations modules)) 
  155.     ; in tdecl/type-declaration-analysis.scm
  156.  
  157. (define (haskell-process-type-declarations modules)
  158.   (phase-body type-decl
  159.     (begin
  160.       (process-type-declarations modules))
  161.     #f))
  162.  
  163.  
  164. (predefine (scope-modules x))  ; in prec/scope.scm
  165. (predefine (print-full-module x . maybe-stream)) ; in the printers
  166.  
  167. (define (haskell-scope modules)
  168.   (phase-body scope
  169.     (scope-modules modules)
  170.     (lambda (result)
  171.       (declare (ignore result))
  172.       (dolist (m modules) (print-full-module m)))
  173.     ))
  174.  
  175.  
  176. (predefine (do-dependency-analysis x))  ; in depend/dependency-analysis.scm
  177.  
  178. (define (haskell-dependency-analysis modules)
  179.   (phase-body depend
  180.     (do-dependency-analysis modules)
  181.     (function pprint*)))
  182.  
  183.  
  184. (predefine (do-haskell-type-check big-let mods))
  185.  
  186. (define (haskell-type-check big-let modules)
  187.   (phase-body type
  188.     (do-haskell-type-check big-let modules)
  189.     #f))
  190.  
  191. (predefine (cfn-ast x))  ; in cfn/main.scm
  192.  
  193. (define (haskell-cfn big-let)
  194.   (phase-body cfn
  195.     (cfn-ast big-let)
  196.     (function pprint*)))
  197.  
  198.  
  199. (predefine (analyze-dependency-top x))  ; in depend/dependency-analysis.scm
  200.  
  201. (define (haskell-dependency-reanalysis big-let)
  202.   (phase-body depend2
  203.     (begin
  204.       (analyze-dependency-top big-let)
  205.       big-let)
  206.     (function pprint*)))
  207.  
  208.  
  209. (predefine (ast-to-flic x))        ; in flic/ast-to-flic.scm
  210.  
  211. (define (haskell-ast-to-flic big-let)
  212.   (phase-body flic
  213.     (ast-to-flic big-let)
  214.     (function pprint*)))
  215.  
  216.  
  217. (predefine (optimize-top x))  ; in backend/optimize.scm
  218.  
  219. (define (haskell-optimize big-let)
  220.   (phase-body optimize
  221.     (optimize-top big-let)
  222.     (function pprint*)))
  223.  
  224. (predefine (strictness-analysis-top x)) ; in backend/strictness.scm
  225. (predefine (strictness-analysis-printer x))
  226.  
  227. (define (haskell-strictness big-let)
  228.   (phase-body strictness
  229.     (strictness-analysis-top big-let)
  230.     (function strictness-analysis-printer)))
  231.  
  232.  
  233. (predefine (codegen-top x))  ; in backend/codegen.scm
  234. (predefine (codegen-exported-types x)) ; "
  235. (predefine (codegen-prim-entries x))  ; ditto
  236.  
  237. (define (haskell-codegen big-let mods)
  238.   (phase-body codegen
  239.     `(begin
  240.        ,(codegen-exported-types mods)
  241.        ,(codegen-top big-let))
  242.     #f))
  243.  
  244. (predefine (check-interfaces mods))
  245.  
  246. (define (haskell-check-interfaces mods)
  247.   (phase-body interface-check
  248.       (check-interfaces mods)
  249.   #f))
  250.            
  251. ;;; This is for interface modules.
  252.  
  253. (predefine (haskell-codegen/interface mods))
  254.  
  255. (define (compile-interface-modules mods)
  256.  (dynamic-let ((*context*                    '#f)
  257.            (*recoverable-error-handler*  '#f)
  258.            (*abort-phase*                '#f))
  259.      (haskell-import-export mods '#t)
  260.      (haskell-process-type-declarations mods)
  261.      (haskell-scope mods)
  262.      (let ((res (haskell-codegen/interface mods)))
  263.        res)))
  264.  
  265.