batch-driver.scm

Scheme跨平台编译器

    ;; Handle `-extension' options:
    (when (memq 'extension options)
      (set! initforms 
	(append 
	 initforms
	 `((define-extension 
	     ,(string->symbol
	       (cond (outfile (pathname-file outfile))
		     (filename (pathname-file filename))
		     (else (quit "no filename available for `-extension' option")) ) ) ) ) ) ) )

    ;; Append required extensions to initforms:
    (let ([ids (lset-difference 
		eq?
		(map string->symbol
		     (append-map
		      (cut string-split <> ",")
		      (collect-options 'require-extension)))
		uses-units)])
      (set! initforms
	(append initforms (map (lambda (r) `(##core#require-extension ',r)) ids)) ) )

    (when (memq 'run-time-macros options)
      (set! ##sys#enable-runtime-macros #t) )
    (set! target-heap-size
      (if hsize
	  (arg-val (option-arg hsize))
	  (and-let* ([hsize default-default-target-heap-size]
		     [(not (zero? hsize))] )
	    hsize) ) )
    (set! target-initial-heap-size (and hisize (arg-val (option-arg hisize))))
    (set! target-heap-growth (and hgrowth (arg-val (option-arg hgrowth))))
    (set! target-heap-shrinkage (and hshrink (arg-val (option-arg hshrink))))
    (set! target-stack-size
      (if ssize
	  (arg-val (option-arg ssize))
	  (and-let* ([ssize default-default-target-stack-size]
		     [(not (zero? ssize))] )
	    ssize) ) )
    (set! emit-trace-info (not (memq 'no-trace options)))
    (set! disable-stack-overflow-checking (memq 'disable-stack-overflow-checks options))
    (when (memq 'm debugging-chicken) (set-gc-report! #t))
    (unless (memq 'no-usual-integrations options)
      (set! standard-bindings default-standard-bindings)
      (set! extended-bindings default-extended-bindings) )
    (when verbose
      (printf "debugging info: ~A~%~!"
	      (if emit-trace-info
		  "stacktrace"
		  "none") ) )
    (when profile
      (let ([acc (eq? 'accumulate-profile (car profile))])
	(set! emit-profile #t)
	(set! profiled-procedures #f)
	(set! initforms
	  (append
	   initforms
	   default-profiling-declarations
	   (if acc
	       '((set! ##sys#profile-append-mode #t))
	       '() ) ) )
	(when verbose
	  (printf "Generating ~aprofile~%~!" (if acc "accumulated " "")) ) ) )

    (cond ((memq 'version options)
	   (print-version #t)
	   (newline) )
	  ((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
	   (print-usage))
	  ((memq 'release options)
	   (display (chicken-version)) 
	   (newline) )
	  ((not filename)
	   (unless quiet
	     (print-version #t)
	     (display "\nEnter \"chicken -help\" for information on how to use it.\n") ) )
	  (else

	   ;; Display header:
	   (unless quiet
	     (printf "compiling `~a' ...~%" filename) )
	   (set! source-filename filename)
	   (debugging 'r "options" options)
	   (debugging 'r "debugging options" debugging-chicken)
	   (debugging 'r "target heap size" target-heap-size)
	   (debugging 'r "target stack size" target-stack-size)
	   (set! start-time (cputime))

	   ;; Read toplevel expressions:
	   (set! ##sys#line-number-database (make-vector line-number-database-size '()))
	   (let ([prelude (collect-options 'prelude)]
		 [postlude (collect-options 'postlude)] 
		 [files (append 
			 (collect-options 'prologue)
			 (list filename)
			 (collect-options 'epilogue) ) ]  )

	     (let ([proc (user-read-pass)])
	       (cond [proc
		      (when verbose (printf "User read pass...~%~!"))
		      (set! forms (proc prelude files postlude)) ]
		     [else
		      (do ([files files (cdr files)])
			  ((null? files)
			   (set! forms
			     (append (map string->expr prelude)
				     (reverse forms)
				     (map string->expr postlude) ) ) )
			(let* ((f (car files))
			       (in (check-and-open-input-file f)) )
			  (fluid-let ((##sys#current-source-filename f))
			    (let ((x1 (read-form in)) )
			      (do ((x x1 (read-form in)))
				  ((eof-object? x) 
				   (close-checked-input-file in f) )
				(set! forms (cons x forms)) ) ) ) ) ) ] ) ) )

	   ;; Start compilation passes:
	   (let ([proc (user-preprocessor-pass)])
	     (when proc
	       (when verbose (printf "User preprocessing pass...~%~!"))
	       (set! forms (map proc forms))))

	   (print-expr "source" '|1| forms)
	   (begin-time)
	   (unless (null? uses-units)
	     (set! ##sys#explicit-library-modules (append ##sys#explicit-library-modules uses-units))
	     (set! forms (cons `(declare (uses ,@uses-units)) forms)) )
	   (let* ([exps0 (map canonicalize-expression (append initforms forms))]
		  [pvec (gensym)]
		  [plen (length profile-lambda-list)]
		  [exps (append
			 (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
			 (map (lambda (n) `(##core#callunit ,n)) used-units)
			 (if emit-profile
			     `((set! ,profile-info-vector-name 
				 (##sys#register-profile-info
				  ',plen
				  ',(if unit-name #f profile-name))))
			     '() )
			 (map (lambda (pl)
				`(##sys#set-profile-info-vector!
				  ,profile-info-vector-name
				  ',(car pl)
				  ',(cdr pl) ) )
			      profile-lambda-list)
			 exps0
			 (if (and (not unit-name) (not dynamic))
			     cleanup-forms
			     '() )
			 '((##core#undefined))) ] )

   	     (when (debugging '|N| "real name table:")
	       (display-real-name-table) )
	     (when (debugging 'n "line number database:")
	       (display-line-number-database) )

	     (when (and block-compilation unit-name)
	       (compiler-warning 
		'usage
		"compilation of library unit `~a' in block-mode - globals may not be accessible outside this unit"
		unit-name) )

	     (when (and unit-name dynamic)
	       (compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )

	     (when (and unsafe (feature? 'compiling-extension))
	       (compiler-warning 
		'style
		"compiling extensions in unsafe mode is bad practice and should be avoided as it may be surprising to an unsuspecting user") )

	     (set! ##sys#line-number-database line-number-database-2)
	     (set! line-number-database-2 #f)

	     (end-time "canonicalization")
	     (print-expr "canonicalized" '|2| exps)

	     (when (memq 'check-syntax options) (exit))

	     (let ([proc (user-pass)])
	       (when proc
		 (when verbose (printf "User pass...~%~!"))
		 (begin-time)
		 (set! exps (map proc exps))
		 (end-time "user pass") ) )

	     (let* ([node0 (make-node
			    'lambda '(())
			    (list (build-node-graph
				   (canonicalize-begin-body exps) ) ) ) ] 
		    [proc (user-pass-2)] )
	       (when (debugging 'M "; requirements:")
		 (pretty-print (##sys#hash-table->alist file-requirements)))
	       (when proc
		 (when verbose (printf "Secondary user pass...~%"))
		 (begin-time)
		 (set! first-analysis #f)
		 (let ([db (analyze 'user node0)])
		   (print-db "analysis (u)" '|0| db 0)
		   (end-time "pre-analysis (u)")
		   (begin-time)
		   (proc node0)
		   (end-time "secondary user pass")
		   (print-node "secondary user pass" '|U| node0) )
		 (set! first-analysis #t) )

	       (when do-lambda-lifting
		 (begin-time)
		 (set! first-analysis #f)
		 (let ([db (analyze 'lift node0)])
		   (print-db "analysis" '|0| db 0)
		   (end-time "pre-analysis")
		   (begin-time)
		   (perform-lambda-lifting! node0 db)
		   (end-time "lambda lifting")
		   (print-node "lambda lifted" '|L| node0) )
		 (set! first-analysis #t) )

	       (set! ##sys#line-number-database #f)
	       (set! constant-table #f)
	       (set! inline-table #f)
	       (unless unsafe
		 (scan-toplevel-assignments (first (node-subexpressions node0))) )

	       (begin-time)
	       (let ([node1 (perform-cps-conversion node0)])
		 (end-time "cps conversion")
		 (print-node "cps" '|3| node1)

		 ;; Optimization loop:
		 (let loop ([i 1] [node2 node1] [progress #t])

		   (begin-time)
		   (let ([db (analyze 'opt node2 i progress)])
		     (when first-analysis
		       (when use-import-table (check-global-imports db))
		       (check-global-exports db)
		       (when (memq 'u debugging-chicken)
			 (dump-undefined-globals db)) )
		     (set! first-analysis #f)
		     (end-time "analysis")
		     (print-db "analysis" '|4| db i)

		     (when (memq 's debugging-chicken) (print-program-statistics db))

		     (cond [progress
			    (debugging 'p "optimization pass" i)

			    (begin-time)
			    (receive (node2 progress-flag) (perform-high-level-optimizations node2 db)
			      (end-time "optimization")
			      (print-node "optimized-iteration" '|5| node2)

			      (cond [progress-flag (loop (add1 i) node2 #t)]
				    [(not inline-substitutions-enabled)
				     (debugging 'p "rewritings enabled...")
				     (set! inline-substitutions-enabled #t)
				     (loop (add1 i) node2 #t) ]
				    [optimize-leaf-routines
				     (begin-time)
				     (let ([db (analyze 'leaf node2)])
				       (end-time "analysis")
				       (begin-time)
				       (let ([progress (transform-direct-lambdas! node2 db)])
					 (end-time "leaf routine optimization")
					 (loop (add1 i) node2 progress) ) ) ]
				    [else (loop (add1 i) node2 #f)] ) ) ]
			   
			   [else
			    (print-node "optimized" '|7| node2)

			    (begin-time)
			    (let ([node3 (perform-closure-conversion node2 db)])
			      (end-time "closure conversion")
			      (print-db "final-analysis" '|8| db i)
			      (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
				(display "(do not worry - still compiling...)\n") )
			      (when export-file-name
				(dump-exported-globals db export-file-name) )
			      (when a-only (exit 0))
			      (print-node "closure-converted" '|9| node3)

			      (begin-time)
			      (receive (node literals lliterals lambdas)
				  (prepare-for-code-generation node3 db)
				(end-time "preparation")

                                (begin-time)
				(let ((out (if outfile (open-output-file outfile) (current-output-port))) )
				  (unless quiet
				    (printf "generating `~A' ...~%" outfile) )
				  (generate-code literals lliterals lambdas out filename dynamic db)
				  (when outfile (close-output-port out)))
                                (end-time "code generation")
                                (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
                                (compiler-cleanup-hook)
                                (when verbose 
                                  (printf "compilation finished.~%~!") ) ) ) ] ) ) ) ) ) ) ) ) ) )