support.scm

Scheme跨平台编译器

;;;; support.scm - Miscellaneous support code for the CHICKEN compiler
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare (unit support))


(private compiler
  compiler-arguments process-command-line dump-nodes dump-undefined-globals
  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
  installation-home optimization-iterations compiler-cleanup-hook decompose-lambda-list
  file-io-only banner custom-declare-alist disabled-warnings internal-bindings
  unit-name insert-timer-checks used-units source-filename pending-canonicalizations
  foreign-declarations block-compilation line-number-database-size
  target-heap-size target-stack-size check-global-exports check-global-imports
  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
  dependency-list broken-constant-nodes inline-substitutions-enabled emit-syntax-trace-info
  always-bound-to-procedure block-variable-literal? copy-node! valid-c-identifier? tree-copy copy-node-tree-and-rename
  direct-call-ids foreign-type-table first-analysis scan-sharp-greater-string
  make-block-variable-literal block-variable-literal-name
  expand-profile-lambda profile-lambda-list profile-lambda-index profile-info-vector-name
  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments
  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
  reorganize-recursive-bindings substitution-table simplify-named-call
  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
  transform-direct-lambdas! finish-foreign-result csc-control-file
  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
  string->c-identifier c-ify-string words words->bytes check-and-open-input-file close-checked-input-file fold-inner
  constant? basic-literal? source-info->string import-table
  collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
  build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list 
  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
  topological-sort print-version print-usage initialize-analysis-database estimate-foreign-result-location-size
  real-name real-name-table set-real-name! real-name2 display-real-name-table display-line-number-database
  default-declarations units-used-by-default words-per-flonum emit-control-file-item compiler-warning
  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
  default-optimization-iterations chop-separator chop-extension follow-without-loop dump-exported-globals
  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
  foreign-argument-conversion foreign-result-conversion final-foreign-type debugging export-list block-globals
  lookup-exports-file constant-declarations process-lambda-documentation big-fixnum?
  compiler-macro-table register-compiler-macro export-dump-hook export-import-hook
  make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration)


(include "tweaks")
(include "banner")


;;; Debugging and error-handling stuff:

(define (compiler-cleanup-hook) #f)

(define debugging-chicken '())
(define disabled-warnings '())		; usage type load var const syntax redef use call ffi

(define (bomb . msg-and-args)
  (if (pair? msg-and-args)
      (apply error (string-append "[internal compiler screwup] " (car msg-and-args)) (cdr msg-and-args))
      (error "[internal compiler screwup]") ) )

(define (debugging mode msg . args)
  (and (memq mode debugging-chicken)
       (begin
	 (printf "~a" msg)
	 (if (pair? args)
	     (begin
	       (display ": ")
	       (for-each (lambda (x) (printf "~s " (force x))) args) ) )
	 (newline)
	 (flush-output)
	 #t) ) )

(define (compiler-warning class msg . args)	       
  (when (and ##sys#warnings-enabled (not (memq class disabled-warnings)))
    (let ((out (current-error-port)))
      (apply fprintf out (string-append "Warning: " msg) args)
      (newline out) ) ) )

(define (quit msg . args)
  (let ([out (current-error-port)])
    (apply fprintf out (string-append "Error: " msg) args)
    (newline out)
    (exit 1) ) )

(set! ##sys#syntax-error-hook
  (lambda (msg . args)
    (let ([out (current-error-port)])
      (fprintf out "Syntax error: ~a~%~%" msg) 
      (for-each (cut fprintf out "\t~s~%" <>) args)
      (print-call-chain out 0 ##sys#current-thread "\n\tExpansion history:\n")
      (exit 70) ) ) )

(set! syntax-error ##sys#syntax-error-hook)

(define (emit-syntax-trace-info info cntr) 
  (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) )

(define (map-llist proc llist)
  (let loop ([llist llist])
    (cond [(null? llist) '()]
	  [(symbol? llist) (proc llist)]
	  [else (cons (proc (car llist)) (loop (cdr llist)))] ) ) )

(define (check-signature var args llist)
  (define (err)
    (quit "Arguments to inlined call of `~A' do not match parameter-list ~A" 
	  (real-name var)
	  (map-llist real-name (cdr llist)) ) )
  (let loop ([as args] [ll llist])
    (cond [(null? ll) (unless (null? as) (err))]
	  [(symbol? ll)]
	  [(null? as) (err)]
	  [else (loop (cdr as) (cdr ll))] ) ) )


;;; Generic utility routines:

(define (posq x lst)
  (let loop ([lst lst] [i 0])
    (cond [(null? lst) #f]
	  [(eq? x (car lst)) i]
	  [else (loop (cdr lst) (add1 i))] ) ) )

(define (stringify x)
  (cond ((string? x) x)
	((symbol? x) (symbol->string x))
	(else (sprintf "~a" x)) ) )

(define (symbolify x)
  (cond ((symbol? x) x)
	((string? x) (string->symbol x))
	(else (string->symbol (sprintf "~a" x))) ) )

(define (build-lambda-list vars argc rest)
  (let loop ((vars vars) (n argc))
    (cond ((or (zero? n) (null? vars)) (or rest '()))
          (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )

(define string->c-identifier ##sys#string->c-identifier)

(define (c-ify-string str)
  (list->string
   (cons 
    #\"
    (let loop ((chars (string->list str)))
      (if (null? chars)
	  '(#\")
	  (let* ((c (car chars))
		 (code (char->integer c)) )
	    (if (or (< code 32) (>= code 127) (memq c '(#\" #\' #\\ #\?)))
		(append '(#\\)
			(cond ((< code 8) '(#\0 #\0))
			      ((< code 64) '(#\0))
			      (else '()) )
			(string->list (number->string code 8))
			(loop (cdr chars)) )
		(cons c (loop (cdr chars))) ) ) ) ) ) ) )

(define (valid-c-identifier? name)
  (let ([str (string->list (->string name))])
    (and (pair? str)
	 (let ([c0 (car str)])
	   (and (or (char-alphabetic? c0) (char=? #\_ c0))
		(any (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
		     (cdr str) ) ) ) ) ) )

(eval-when (load)
  (define words (foreign-lambda int "C_bytestowords" int)) 
  (define words->bytes (foreign-lambda int "C_wordstobytes" int)) )

(eval-when (eval)
  (define (words n)
    (let ([wordsize (##sys#fudge 7)])
      (+ (quotient n wordsize) (if (zero? (modulo n wordsize)) 0 1)) ) )
  (define (words->bytes n)
    (* n (##sys#fudge 7)) ) )

(define (check-and-open-input-file fname . line)
  (cond [(string=? fname "-") (current-input-port)]
	[(file-exists? fname) (open-input-file fname)]
	[(or (null? line) (not (car line))) (quit "Can not open file ~s" fname)]
	[else (quit "Can not open file ~s in line ~s" fname (car line))] ) )

(define (close-checked-input-file port fname)
  (unless (string=? fname "-") (close-input-port port)) )

(define (fold-inner proc lst)
  (if (null? (cdr lst)) 
      lst
      (let fold ((xs (reverse lst)))
	(apply
	 proc 
	 (if (null? (cddr xs))
	     (list (cadr xs) (car xs))
	     (list (fold (cdr xs)) (car xs)) ) ) ) ) )

(define (follow-without-loop seed proc abort)
  (let loop ([x seed] [done '()])
    (if (member x done)
	(abort)
	(proc x (lambda (x2) (loop x2 (cons x done)))) ) ) )


;;; Predicates on expressions and literals:

(define (constant? x)
  (or (number? x)
      (char? x)
      (string? x)
      (boolean? x)
      (eof-object? x)
      (and (pair? x) (eq? 'quote (car x))) ) )

(define (collapsable-literal? x)
  (or (boolean? x)
      (char? x)
      (eof-object? x)
      (number? x)
      (symbol? x) ) )

(define (immediate? x)
  (or (and (fixnum? x) (not (big-fixnum? x))) ; 64-bit fixnums would result in platform-dependent .c files
      (eq? (##core#undefined) x)
      (null? x)
      (eof-object? x)
      (char? x)
      (boolean? x) ) )

(define (basic-literal? x)
  (or (null? x)
      (symbol? x)
      (constant? x)
      (and (vector? x) (every basic-literal? (vector->list x)))
      (and (pair? x) 
	   (basic-literal? (car x))
	   (basic-literal? (cdr x)) ) ) )


;;; Expression manipulation:

(define (canonicalize-begin-body body)
  (let loop ((xs body))
    (cond ((null? xs) '(##core#undefined))
	  ((null? (cdr xs)) (car xs))
	  ((let ([h (car xs)])
	     (or (equal? h '(##core#undefined))
		 (constant? h) 
		 (equal? h '(##sys#void)) ) )
	   (loop (cdr xs)) )
	  (else `(let ((,(gensym 't) ,(car xs)))
		   ,(loop (cdr xs))) ) ) ) )

(define (extract-mutable-constants exp)
  (let ([mlist '()])
    (define (walk x)
      (match x
	[(? not-pair? x) x]
	[`(quote ,c)
	 (if (not (collapsable-literal? c))
	     (let ([var (make-random-name)])
	       (set! mlist (alist-cons var c mlist))
	       var)
	     x) ]
	[`(let ((,vars ,vals) ...) . ,body)
	 `(let ,(map (lambda (var val) (list var (walk val))) vars vals) ,@(map walk body)) ]
	[(op . args)
	 (case op
	   [(##core#include ##core#declare ##core#immutable ##core#undefined ##core#primitive ##core#inline_ref) x]
	   [(##core#set! set! lambda ##core#inline ##core#inline_allocate ##core#inline_update ##core#inline_loc_ref
			 ##core#inline_loc_update)
	    (cons* op (first args) (map walk (cdr args))) ]
	   [(if ##core#compiletimeonly ##core#compiletimetoo)
	    (cons op (map walk args)) ]
	   [else (map walk x)] ) ]
	[_ x] ) ) 
    (let ([exp2 (walk exp)])
      (values exp2 mlist) ) ) )

(define string->expr
  (let ([exn? (condition-predicate 'exn)]
	[exn-msg (condition-property-accessor 'exn 'message)] )
    (lambda (str)
      (handle-exceptions ex
	  (quit "can not parse expression: ~s [~a]~%" 
		str
		(if (exn? ex) 
		    (exn-msg ex)
		    (->string ex) ) ) 
	(let ([xs (with-input-from-string str (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
	  (cond [(null? xs) '(##core#undefined)]
		[(null? (cdr xs)) (car xs)]
		[else `(begin ,@xs)] ) ) ) ) ) )

(define decompose-lambda-list ##sys#decompose-lambda-list)

(define (process-lambda-documentation id doc proc)
  proc)					; Hook this


;;; Profiling instrumentation:

(define (expand-profile-lambda name llist body)
  (let ([index profile-lambda-index] 
	[args (gensym)] )
    (set! profile-lambda-list (alist-cons index name profile-lambda-list))
    (set! profile-lambda-index (add1 index))
    `(lambda ,args
       (##sys#dynamic-wind
	(lambda () (##sys#profile-entry ',index ,profile-info-vector-name))
	(lambda () (apply (lambda ,llist ,body) ,args))
	(lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )


;;; Database operations:
;
; - 'get' and 'put' shadow the routines in the extras-unit, we use low-level
;   symbol-keyed hash-tables here.

(define (initialize-analysis-database db)
  (for-each
   (lambda (s) 
     (put! db s 'standard-binding #t)
     (when (memq s side-effecting-standard-bindings) (put! db s 'side-effecting #t))
     (when (memq s foldable-standard-bindings) (put! db s 'foldable #t)) )
   standard-bindings)
  (for-each
   (lambda (s)
     (put! db s 'extended-binding #t)
     (when (memq s foldable-extended-bindings) (put! db s 'foldable #t)) )
   extended-bindings)
  (for-each
   (lambda (s) (put! db (car s) 'constant #t))
   mutable-constants) )

(define (get db key prop)
  (let ((plist (##sys#hash-table-ref db key)))
    (and plist
	 (let ([a (assq prop plist)])
	   (and a (##sys#slot a 1)) ) ) ) )

(define (get-all db key . props)
  (let ((plist (##sys#hash-table-ref db key)))
    (if plist
	(filter-map (lambda (prop) (assq prop plist)) props)
	'() ) ) )

(define (put! db key prop val)
  (let ([plist (##sys#hash-table-ref db key)])