c-backend.scm

Scheme跨平台编译器

;;; c-backend.scm - C-generating backend 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 backend))


(private compiler
  compiler-arguments process-command-line find-early-refs
  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 debugging cleanup
  file-io-only
  unit-name insert-timer-checks used-units inlining external-variables
  foreign-declarations emit-trace-info block-compilation line-number-database-size
  target-heap-size target-stack-size target-heap-growth target-heap-shrinkage
  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
  target-initial-heap-size disable-stack-overflow-checking
  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants
  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 
  mutable-constants encode-literal
  broken-constant-nodes inline-substitutions-enabled
  direct-call-ids foreign-type-table first-analysis block-variable-literal?
  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 find-inlining-candidates perform-inlining!
  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub 
  expand-foreign-lambda*
  transform-direct-lambdas! target-include-file emit-unsafe-marker
  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
  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? source-info->string
  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 external-protos-first emit-closure-info
  topological-sort print-version print-usage initialize-analysis-database
  generate-external-variables real-name real-name2 unique-id
  default-declarations units-used-by-default words-per-flonum big-fixnum?
  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 generate-foreign-callback-header generate-foreign-callback-stub-prototypes
  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
  foreign-argument-conversion foreign-result-conversion)

(include "tweaks")


;;; Write atoms to output-port:

(define output #f)

(define (gen . data)
  (for-each
   (lambda (x) 
     (if (eq? #t x)
	 (newline output)
	 (display x output) ) )
   data) )

(define (gen-list lst)
  (for-each
   (lambda (x) (display x output))
   (intersperse lst #\space) ) )


;;; Unique id/prefix:

(define unique-id
  (string->c-identifier
   (sprintf "C_~X_~A_" (random #x1000000) (current-seconds)) ) )


;;; Generate target code:

(define (generate-code literals lliterals lambdas out source-file dynamic db)
  (let ()

    ;; Some helper procedures

    (define (find-lambda id)
      (or (find (lambda (ll) (eq? id (lambda-literal-id ll))) lambdas)
	  (bomb "can't find lambda" id) ) )

    (define (slashify s) (string-translate (->string s) "\\" "/"))
    (define (uncommentify s) (string-translate* (->string s) '(("*/" . "* /"))))
  
    ;; Compile a single expression
    (define (expression node temps ll)

      (define (expr n i)
	(let ((subs (node-subexpressions n))
	      (params (node-parameters n)) )
	  (case (node-class n)

	    ((##core#immediate)
	     (case (first params)
	       ((bool) (gen (if (second params) "C_SCHEME_TRUE" "C_SCHEME_FALSE")))
	       ((char) (gen "C_make_character(" (char->integer (second params)) #\)))
	       ((nil) (gen "C_SCHEME_END_OF_LIST"))
	       ((fix) (gen "C_fix(" (second params) #\)))
	       ((eof) (gen "C_SCHEME_END_OF_FILE"))
	       (else (bomb "bad immediate")) ) )

	    ((##core#literal) 
	     (let ((lit (first params)))
	       (if (vector? lit)
		   (gen "((C_word)li" (vector-ref lit 0) ")") 
		   (gen "lf[" (first params) #\])) ) )

	    ((if)
	     (gen #t "if(C_truep(")
	     (expr (car subs) i)
	     (gen ")){")
	     (expr (cadr subs) i)
	     (gen #\} #t "else{")
	     (expr (caddr subs) i)
	     (gen #\}) )

	    ((##core#proc)
	     (gen "(C_word)" (first params)) )

	    ((##core#bind) 
	     (let loop ((bs subs) (i i) (count (first params)))
	       (cond [(> count 0)
		      (gen #t #\t i #\=)
		      (expr (car bs) i)
		      (gen #\;) 
		      (loop (cdr bs) (add1 i) (sub1 count)) ]
		     [else (expr (car bs) i)] ) ) )

	    ((##core#ref) 
	     (gen "((C_word*)")
	     (expr (car subs) i)
	     (gen ")[" (+ (first params) 1) #\]) )

	    ((##core#unbox) 
	     (gen "((C_word*)")
	     (expr (car subs) i)
	     (gen ")[1]") )

	    ((##core#update_i)
	     (gen "C_set_block_item(")
	     (expr (car subs) i)
	     (gen #\, (first params) #\,)
	     (expr (cadr subs) i) 
	     (gen #\)) )

	    ((##core#update)
	     (gen "C_mutate(((C_word *)")
	     (expr (car subs) i)
	     (gen ")+" (+ (first params) 1) ",")
	     (expr (cadr subs) i) 
	     (gen #\)) )

	    ((##core#updatebox_i)
	     (gen "C_set_block_item(")
	     (expr (car subs) i)
	     (gen ",0,")
	     (expr (cadr subs) i) 
	     (gen #\)) )

	    ((##core#updatebox)
	     (gen "C_mutate(((C_word *)")
	     (expr (car subs) i)
	     (gen ")+1,")
	     (expr (cadr subs) i) 
	     (gen #\)) )

	    ((##core#closure)
	     (let ((n (first params)))
	       (gen "(*a=C_CLOSURE_TYPE|" n #\,)
	       (for-each 
		(lambda (x j)
		  (gen "a[" j "]=")
		  (expr x i)
		  (gen #\,) )
		subs (iota n 1 1) )
	       (gen "tmp=(C_word)a,a+=" (add1 n) ",tmp)") ) )

	    ((##core#box) 
	     (gen "(*a=C_VECTOR_TYPE|1,a[1]=")
	     (expr (car subs) i)
	     (gen ",tmp=(C_word)a,a+=2,tmp)") )

	    ((##core#local) (gen #\t (first params)))

	    ((##core#setlocal) 
	     (gen #\t (first params) #\=)
	     (expr (car subs) i) )

	    ((##core#global)
	     (let ([index (first params)]
		   [safe (second params)] 
		   [block (third params)] )
	       (cond [block
		      (if safe
			  (gen "lf[" index "]")
			  (gen "C_retrieve2(lf[" index "]," (c-ify-string (symbol->string (fourth params))) #\)) ) ]
		     [safe (gen "*((C_word*)lf[" index "]+1)")]
		     [else (gen "C_retrieve(lf[" index "])")] ) ) )

	    ((##core#setglobal)
	     (let ([index (first params)]
		   [block (second params)] )
	       (if block
		   (gen "C_mutate(&lf[" index "],")
		   (gen "C_mutate((C_word*)lf[" index "]+1,") )
	       (expr (car subs) i)
	       (gen #\)) ) )

	    ((##core#setglobal_i)
	     (let ([index (first params)]
		   [block (second params)] )
	       (cond [block
		      (gen "lf[" index "]=")
		      (expr (car subs) i)
		      (gen #\;) ]
		     [else
		      (gen "C_set_block_item(lf[" index "],0,")
		      (expr (car subs) i)
		      (gen #\)) ] ) ) )

	    ((##core#undefined) (gen "C_SCHEME_UNDEFINED"))

	    ((##core#call) 
	     (let* ((args (cdr subs))
		    (n (length args))
		    (nc i)
		    (nf (add1 n)) 
		    (p2 (pair? (cdr params)))
		    (name (and p2 (second params)))
		    (name-str (source-info->string name))
		    (call-id (and p2 (pair? (cddr params)) (third params))) 
		    (customizable (and call-id (fourth params)))
		    (empty-closure (and customizable (zero? (lambda-literal-closure-size (find-lambda call-id)))))
		    (fn (car subs)) )
	       (when name
		 (if emit-trace-info
		     (gen #t "C_trace(\"" (slashify name-str) "\");")
		     (gen #t "/* " (uncommentify name-str) " */") ) )
	       (cond ((eq? '##core#proc (node-class fn))
		      (let ([fpars (node-parameters fn)])
			(gen #t (first fpars) #\( nf ",0,") )
		      (expr-args args i)
		      (gen ");") )
		     (call-id
		      (cond ((and (eq? call-id (lambda-literal-id ll))
				  (lambda-literal-looping ll) )
			     (let* ([temps (lambda-literal-temporaries ll)]
				    [ts (iota n (+ temps nf) 1)] )
			       (for-each
				(lambda (arg tr)
				  (gen #t #\t tr #\=)
				  (expr arg i) 
				  (gen #\;) )
				args ts)
			       (for-each
				(lambda (from to) (gen #t #\t to "=t" from #\;))
				ts (iota n 1 1) )
			       (unless customizable (gen #t "c=" nf #\;))
			       (gen #t "goto loop;") ) )
			    (else
			     (unless empty-closure
			       (gen #t #\t nc #\=)
			       (expr fn i)
			       (gen #\;) )
			     (gen #t call-id #\()
			     (unless customizable (gen nf #\,))
			     (unless empty-closure (gen #\t nc #\,))
			     (expr-args args i)
			     (gen ");") ) ) )
		     (else
		      (gen #t #\t nc #\=)
		      (expr fn i)
		      (gen #\; #t
			   "((C_proc" nf ")")
		      (if (or unsafe no-procedure-checks (first params))
			  (gen "(void*)(*((C_word*)t" nc "+1))")
			  (gen "C_retrieve_proc(t" nc ")") )
		      (gen ")(" nf ",t" nc #\,)
		      (expr-args args i)
		      (gen ");") ) ) ) )
	  
	    ((##core#recurse) 
	     (let* ([n (length subs)]
		    [nf (add1 n)]
		    [tailcall (first params)]
		    [call-id (second params)] 
		    [empty-closure (zero? (lambda-literal-closure-size ll))] )
	       (cond (tailcall
		      (let* ([temps (lambda-literal-temporaries ll)]
			     [ts (iota n (+ temps nf) 1)] )
			(for-each
			 (lambda (arg tr)
			   (gen #t #\t tr #\=)
			   (expr arg i) 
			   (gen #\;) )
			 subs ts)
			(for-each
			 (lambda (from to) (gen #t #\t to "=t" from #\;))
			 ts (iota n 1 1) )
			(gen #t "goto loop;") ) )
		     (else
		      (gen call-id #\()
		      (unless empty-closure (gen "t0,"))
		      (expr-args subs i)
		      (gen #\)) ) ) ) )

	    ((##core#direct_call) 
	     (let* ((args (cdr subs))
		    (n (length args))
		    (nf (add1 n)) 
		    ;;(name (second params))
		    (call-id (third params))
		    (demand (fourth params))
		    (allocating (not (zero? demand)))
		    (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))
		    (fn (car subs)) )