compiler.scm

来自「Scheme跨平台编译器」· SCM 代码 · 共 1,734 行 · 第 1/5 页

(define optimize-leaf-routines #f)
(define emit-profile #f)
(define no-bound-checks #f)
(define no-argc-checks #f)
(define no-procedure-checks #f)
(define block-globals '())
(define source-filename #f)
(define export-list #f)
(define safe-globals-flag #f)
(define explicit-use-flag #f)
(define disable-stack-overflow-checking #f)
(define require-imports-flag #f)
(define emit-unsafe-marker #f)
(define external-protos-first #f)
(define do-lambda-lifting #f)
(define inline-max-size -1)
(define emit-closure-info #t)
(define export-file-name #f)
(define import-table #f)
(define use-import-table #f)
(define undefine-shadowed-macros #t)
(define constant-declarations '())
(define profiled-procedures #f)


;;; These are here so that the backend can access them:

(define default-default-target-heap-size default-target-heap-size)
(define default-default-target-stack-size default-target-stack-size)


;;; Other global variables:

(define verbose-mode #f)
(define original-program-size #f)
(define current-program-size 0)
(define line-number-database-2 #f)
(define immutable-constants '())
(define rest-parameters-promoted-to-vector '())
(define inline-table #f)
(define inline-table-used #f)
(define constant-table #f)
(define constants-used #f)
(define mutable-constants '())
(define broken-constant-nodes '())
(define inline-substitutions-enabled #f)
(define direct-call-ids '())
(define first-analysis #t)
(define foreign-type-table #f)
(define foreign-variables '())
(define foreign-lambda-stubs '())
(define foreign-callback-stubs '())
(define external-variables '())
(define loop-lambda-names '())
(define profile-lambda-list '())
(define profile-lambda-index 0)
(define profile-info-vector-name #f)
(define external-to-pointer '())
(define error-is-extended-binding #f)
(define real-name-table #f)
(define location-pointer-map '())
(define pending-canonicalizations '())
(define defconstant-bindings '())
(define callback-names '())
(define toplevel-scope #t)
(define toplevel-lambda-id #f)
(define custom-declare-alist '())
(define csc-control-file #f)
(define data-declarations '())
(define inline-list '())
(define not-inline-list '())
(define file-requirements #f)
(define postponed-initforms '())
(define unused-variables '())
(define compiler-macro-table #f)
(define compiler-macros-enabled #t)
(define literal-rewrite-hook #f)


;;; Initialize globals:

(define (initialize-compiler)
  (if line-number-database-2
      (vector-fill! line-number-database-2 '())
      (set! line-number-database-2 (make-vector line-number-database-size '())) )
  (if inline-table
      (vector-fill! inline-table '())
      (set! inline-table (make-vector inline-table-size '())) )
  (if constant-table
      (vector-fill! constant-table '())
      (set! constant-table (make-vector constant-table-size '())) )
  (set! profile-info-vector-name (make-random-name 'profile-info))
  (set! real-name-table (make-vector real-name-table-size '()))
  (if file-requirements
      (vector-fill! file-requirements '())
      (set! file-requirements (make-vector file-requirements-size '())) )
  (if import-table
      (vector-fill! import-table '())
      (set! import-table (make-vector import-table-size '())) )
  (if foreign-type-table
      (vector-fill! foreign-type-table '())
      (set! foreign-type-table (make-vector foreign-type-table-size '())) ) )


;;; Expand macros and canonicalize expressions:

(define (canonicalize-expression exp)

  (define (resolve v ae)
    (cond [(assq v ae) => cdr]
	  [else v] ) )

  (define (set-real-names! as ns)
    (for-each (lambda (a n) (set-real-name! a n)) as ns) )

  (define (write-to-string x)
    (let ([out (open-output-string)])
      (write x out)
      (get-output-string out) ) )

  (define unquotify 
    (match-lambda 
      [('quote x) x]
      [x x] ) )

  (define (resolve-atom x ae me dest)
    (cond [(and constants-used (##sys#hash-table-ref constant-table x)) 
	   => (lambda (val) (walk (car val) ae me dest)) ]
	  [(and inline-table-used (##sys#hash-table-ref inline-table x))
	   => (lambda (val)
		(walk val ae me dest)) ]
	  [(assq x foreign-variables)
	   => (lambda (fv) 
		(let* ([t (second fv)]
		       [ft (final-foreign-type t)] 
		       [body `(##core#inline_ref (,(third fv) ,t))] )
		  (foreign-type-convert-result
		   (finish-foreign-result ft body)
		   t) ) ) ]
	  [(assq x location-pointer-map)
	   => (lambda (a)
		(let* ([t (third a)]
		       [ft (final-foreign-type t)] 
		       [body `(##core#inline_loc_ref (,t) ,(second a))] )
		  (foreign-type-convert-result
		   (finish-foreign-result ft body)
		   t) ) ) ]
	  [else #f] ) )

  (define (walk-literal x ae me dest)
    (if literal-rewrite-hook
	(literal-rewrite-hook x (cut walk <> ae me dest))
	`(quote ,x) ) )

  (define (walk x ae me dest)
    (cond ((symbol? x)
	   (cond ((keyword? x) (walk-literal x ae me dest))
		 ((assq x ae) => 
		  (lambda (a)
		    (let ((alias (cdr a)))
		      (or (resolve-atom alias ae me dest)
			  alias) ) ) )
		 ((resolve-atom x ae me dest))
		 (else (##sys#alias-global-hook x))) )
	  ((and (not-pair? x) (constant? x)) 
	   (walk-literal x ae me dest) )
	  ((not-pair? x) (syntax-error "illegal atomic form" x))
	  ((symbol? (car x))
	   (let* ([head (car x)]
		  [rest (cdr x)]
		  [ln (get-line x)]
		  [name (resolve head ae)] )
	     (emit-syntax-trace-info x #f)
	     (unless (proper-list? x)
	       (if ln
		   (syntax-error (sprintf "(in line ~s) - malformed expression" ln) x)
		   (syntax-error "malformed expression" x)))
	     (set! ##sys#syntax-error-culprit x)
	     (let* ([x2 (cons name rest)]
		    [xexpanded (##sys#macroexpand-1-local x2 me)] )
	       (cond [(not (eq? x2 xexpanded))
		      (when ln (update-line-number-database! xexpanded ln))
		      (walk xexpanded ae me dest) ]
		     [(and inline-table-used (##sys#hash-table-ref inline-table name))
		      => (lambda (val)
			   (walk (cons val (cdr x)) ae me dest)) ]
		     [else
		      (case name

			((if)
			 (##sys#check-syntax 'if x '(if _ _ . #(_)))
			 `(if ,(walk (cadr x) ae me #f)
			      ,(walk (caddr x) ae me #f)
			      ,(if (null? (cdddr x)) 
				   '(##core#undefined)
				   (walk (cadddr x) ae me #f) ) ) )

			((quote)
			 (##sys#check-syntax 'quote x '(quote _))
			 (walk-literal (cadr x) ae me dest) )

			((##core#check)
			 (if unsafe
			     ''#t
			     (walk (cadr x) ae me dest) ) )

			((##core#immutable)
			 (let ((c (cadadr x)))
			   (cond [(assoc c immutable-constants) => cdr]
				 [else
				  (let ([var (gensym 'c)])
				    (set! immutable-constants (alist-cons c var immutable-constants))
				    (set! always-bound (cons var always-bound))
				    (set! block-globals (cons var block-globals))
				    var) ] ) ) )

			((##core#undefined ##core#callunit ##core#primitive ##core#inline_ref 
					   ##core#inline_loc_ref) x)

			((##core#require-for-syntax)
			 (let ([ids (map eval (cdr x))])
			   (apply ##sys#require ids)
			   (##sys#hash-table-update! 
			    file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
			    (lambda () ids) )
			   '(##core#undefined) ) )

			((##core#require-extension)
			 (walk
			  (let loop ([ids (cdr x)])
			    (if (null? ids)
				'(##core#undefined)
				(let ([id (cadar ids)])
				  (let-values ([(exp f) (##sys#do-the-right-thing id #t)])
				    (if (not (or f 
						 (and (symbol? id)
						     (or (feature? id)
							 (##sys#find-extension
							  (##sys#canonicalize-extension-path 
							   id 'require-extension) #f)) ) ) )
					(compiler-warning 
					 'ext "extension `~A' is currently not installed" id)
					(unless (and-let* (use-import-table
							   ((symbol? id))
							   (info (##sys#extension-information id #f)) 
							   (exps (assq 'exports info)) )
						  (for-each
						   (cut ##sys#hash-table-set! import-table <> id)
						   (cdr exps) )
						  #t)
					  (lookup-exports-file id) ) )
				    `(begin ,exp ,(loop (cdr ids))) ) ) ) )
			  ae me dest) )

			((let)
			 (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)))
			 (let* ([bindings (cadr x)]
				[vars (unzip1 bindings)]
				[aliases (map gensym vars)] 
				(ae2 (append (map cons vars aliases) ae)) )
			   (set-real-names! aliases vars)
			   `(let ,(map (lambda (alias b)
					 (list alias (walk (cadr b) ae me (car b))) )
				       aliases bindings)
			      ,(walk (##sys#canonicalize-body (cddr x) (cut assq <> ae2) me dest)
				     ae2
				     me dest) ) ) )

			((lambda ##core#internal-lambda)
			 (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)))
			 (let ([llist (cadr x)]
			       [obody (cddr x)] )
			   (when (##sys#extended-lambda-list? llist)
			     (set!-values 
			      (llist obody) 
			      (##sys#expand-extended-lambda-list 
			       llist obody
			       ##sys#error) ) )
			   (decompose-lambda-list
			    llist
			    (lambda (vars argc rest)
			      (let* ((aliases (map gensym vars))
				     (ae2 (append (map cons vars aliases) ae))
				     (body0 (##sys#canonicalize-body obody (cut assq <> ae2) me dest))
				     (body (walk body0 ae2 me #f))
				     (llist2 
				      (build-lambda-list
				       aliases argc
				       (and rest (list-ref aliases (posq rest vars))) ) )
				     (l `(lambda ,llist2 ,body)) )
				(set-real-names! aliases vars)
				(cond ((or (not dest) 
					   (not (eq? dest (resolve dest ae)))) ; global?
				       l)
				      ((and (eq? 'lambda name)
					    emit-profile 
					    (or (not profiled-procedures)
						(memq dest profiled-procedures)))
				       (expand-profile-lambda dest llist2 body) )
				      (else
				       (match body0
					 (('begin (or (? string? doc) ('quote doc)) _ . more)
					  (process-lambda-documentation
					   dest doc l) )
					 (_ l) ) ) ) ) ) ) ) )

			((##core#named-lambda)
			 (walk `(lambda ,@(cddr x)) ae me (cadr x)) )

			((##core#loop-lambda)
			 (let* ([vars (cadr x)]
				[obody (cddr x)]
				[aliases (map gensym vars)]
				(ae2 (append (map cons vars aliases) ae))
				[body 
				 (walk 
				  (##sys#canonicalize-body obody (cut assq <> ae2) me dest)
				  ae2
				  me #f) ] )
			   (set-real-names! aliases vars)
			   `(lambda ,aliases ,body) ) )

			((set! ##core#set!) 
			 (##sys#check-syntax 'set! x '(_ variable _))
			 (let* ([var0 (cadr x)]
				[var (resolve var0 ae)]
				[ln (get-line x)]
				[val (walk (caddr x) ae me var0)] )
			   (when (eq? var var0) ; global?
			     (set! var (##sys#alias-global-hook var))
			     (when safe-globals-flag
			       (set! always-bound-to-procedure
				 (lset-adjoin eq? always-bound-to-procedure var))
			       (set! always-bound (lset-adjoin eq? always-bound var)) )
			     (when (macro? var)
			       (compiler-warning 
				'var "assigned global variable `~S' is a macro ~A"
				var
				(if ln (sprintf "in line ~S" ln) "") )
			       (when undefine-shadowed-macros (undefine-macro! var) ) ) )
			   (when (keyword? var)
			     (compiler-warning 'syntax "assignment to keyword `~S'" var) )
			   (cond [(assq var foreign-variables)
				  => (lambda (fv)
				       (let ([type (second fv)]
					     [tmp (gensym)] )
					 `(let ([,tmp ,(foreign-type-convert-argument val type)])