diff options
Diffstat (limited to 'top/phases.scm')
| -rw-r--r-- | top/phases.scm | 226 |
1 files changed, 226 insertions, 0 deletions
diff --git a/top/phases.scm b/top/phases.scm new file mode 100644 index 0000000..706c541 --- /dev/null +++ b/top/phases.scm @@ -0,0 +1,226 @@ + +;;; This is the top-level phase structure of the compiler. + +;;; Compilation phase support + +(define *phase* '#f) +(define *abort-phase* '#f) ; abort when this phase completes +(define *abort-compilation* + (lambda () + (error "No error continuation defined here!"))) + +(define *module-asts* '()) ; a global only for debugging purposes + +;;; Later add the printing and timing stuff here + +(define-local-syntax (phase-body phase-name body printer) + `(dynamic-let ((*phase* ',phase-name)) + (when (memq ',phase-name (dynamic *printers*)) + (format '#t "~%Phase ~a:~%" ',phase-name) + (force-output)) + (let* ((phase-start-time (get-run-time)) + (result ,body) + (current-time (get-run-time))) + (when (eq? (dynamic *abort-phase*) ',phase-name) + (abort-compilation)) + ,@(if (eq? printer '#f) + '() + `((when (memq ',phase-name (dynamic *printers*)) + (funcall ,printer result) + (force-output)))) + (when (memq 'phase-time *printers*) + (let ((elapsed-time (- current-time phase-start-time))) + (format '#t "~&~A complete: ~A seconds~%" + ',phase-name elapsed-time) + (force-output))) + result))) + + + +;;; Returns 2 values: module ast's and lisp code. + +(define (compile-haskell-files files) + (dynamic-let ((*abort-phase* '#f)) + (let ((all-mods (haskell-parse-files files)) + (interface-mods '()) + (regular-mods '())) + (dolist (m all-mods) + (if (eq? (module-type m) 'interface) + (push m interface-mods) + (push m regular-mods))) + (dynamic-let ((*unit* (module-name (car all-mods)))) + (values + all-mods + `(begin + ,(if interface-mods + (compile-interface-modules (nreverse interface-mods)) + '#f) + ,(if regular-mods + (compile-modules (nreverse regular-mods)) + '#f)) + ))))) + + + +(define (compile-modules mods) + (dynamic-let ((*context* '#f) + (*recoverable-error-handler* '#f) + (*abort-phase* '#f) + (*unique-name-counter* 1) + (*suffix-table* (make-table))) + (haskell-import-export mods '#f) + (haskell-process-type-declarations mods) + (haskell-scope mods) + (let ((big-let (haskell-dependency-analysis mods))) + (cond ((not (void? big-let)) + (haskell-type-check big-let mods) + (setf big-let (haskell-cfn big-let)) + (setf big-let (haskell-dependency-reanalysis big-let)) + (setf big-let (haskell-ast-to-flic big-let)) + (setf big-let (haskell-optimize big-let)) + (setf big-let (haskell-strictness big-let)) + (haskell-codegen big-let mods)) + (else + ''#f) + )))) + + +(define (modules->lisp-code modules) + (dynamic-let ((*unit* (module-name (car modules)))) + (compile-modules modules))) + + +(predefine (notify-error)) ; in command-interface/command-utils.scm + +(define (abort-compilation) + (notify-error) + (funcall (dynamic *abort-compilation*))) + +(define (halt-compilation) + (setf (dynamic *abort-phase*) (dynamic *phase*))) + + +;;; Here are the actual phase bodies + +(predefine (parse-files files)) + +(define (haskell-parse-files filenames) + (phase-body parse + (let ((mods (parse-files filenames))) + mods) + #f)) + +(predefine (import-export modules)) ; in import-export/import-export.scm +(predefine (import-export/interface modules)) + +(define (haskell-import-export modules interface?) + (phase-body import + (if interface? + (import-export/interface modules) + (import-export modules)) + #f)) + + +(predefine (process-type-declarations modules)) + ; in tdecl/type-declaration-analysis.scm + +(define (haskell-process-type-declarations modules) + (phase-body type-decl + (begin + (process-type-declarations modules)) + #f)) + + +(predefine (scope-modules x)) ; in prec/scope.scm +(predefine (print-full-module x . maybe-stream)) ; in the printers + +(define (haskell-scope modules) + (phase-body scope + (scope-modules modules) + (lambda (result) + (declare (ignore result)) + (dolist (m modules) (print-full-module m))) + )) + + +(predefine (do-dependency-analysis x)) ; in depend/dependency-analysis.scm + +(define (haskell-dependency-analysis modules) + (phase-body depend + (do-dependency-analysis modules) + (function pprint*))) + + +(predefine (do-haskell-type-check big-let mods)) + +(define (haskell-type-check big-let modules) + (phase-body type + (do-haskell-type-check big-let modules) + #f)) + +(predefine (cfn-ast x)) ; in cfn/main.scm + +(define (haskell-cfn big-let) + (phase-body cfn + (cfn-ast big-let) + (function pprint*))) + + +(predefine (analyze-dependency-top x)) ; in depend/dependency-analysis.scm + +(define (haskell-dependency-reanalysis big-let) + (phase-body depend2 + (begin + (analyze-dependency-top big-let) + big-let) + (function pprint*))) + + +(predefine (ast-to-flic x)) ; in flic/ast-to-flic.scm + +(define (haskell-ast-to-flic big-let) + (phase-body flic + (ast-to-flic big-let) + (function pprint*))) + + +(predefine (optimize-top x)) ; in backend/optimize.scm + +(define (haskell-optimize big-let) + (phase-body optimize + (optimize-top big-let) + (function pprint*))) + +(predefine (strictness-analysis-top x)) ; in backend/strictness.scm +(predefine (strictness-analysis-printer x)) + +(define (haskell-strictness big-let) + (phase-body strictness + (strictness-analysis-top big-let) + (function strictness-analysis-printer))) + + +(predefine (codegen-top x)) ; in backend/codegen.scm +(predefine (codegen-exported-types x)) ; " +(predefine (codegen-prim-entries x)) ; ditto + +(define (haskell-codegen big-let mods) + (phase-body codegen + `(begin + ,(codegen-exported-types mods) + ,(codegen-top big-let)) + #f)) + + +;;; This is for interface modules. + +(predefine (haskell-codegen/interface mods)) + +(define (compile-interface-modules mods) + (dynamic-let ((*context* '#f) + (*recoverable-error-handler* '#f) + (*abort-phase* '#f)) + (haskell-import-export mods '#t) + (haskell-process-type-declarations mods) + (haskell-scope mods) + (haskell-codegen/interface mods))) |