;;; 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)))