c-backend.scm

Scheme跨平台编译器

	       (gen call-id #\()
	       (when allocating 
		 (gen "C_a_i(&a," demand #\))
		 (when (or (not empty-closure) (pair? args)) (gen #\,)) )
	       (unless empty-closure
		 (expr fn i)
		 (when (pair? args) (gen #\,)) )
	       (when (pair? args) (expr-args args i))
	       (gen #\)) ) )

	    ((##core#callunit)
	     ;; The code generated here does not use the extra temporary needed for standard calls, so we have
	     ;;  one unused varable:
	     (let* ((n (length subs))
		    (nf (+ n 1)) )
	       (gen #t "C_" (first params) "_toplevel(" nf ",C_SCHEME_UNDEFINED,")
	       (expr-args subs i)
	       (gen ");") ) )

	    ((##core#return)
	     (gen #t "return(")
	     (expr (first subs) i)
	     (gen ");") )

	    ((##core#inline)
	     (gen "(C_word)" (first params) #\()
	     (expr-args subs i)
	     (gen #\)) )

	    ((##core#inline_allocate)
	     (gen "(C_word)" (first params) "(&a," (length subs))
	     (if (pair? subs)
		 (begin
		   (gen #\,)
		   (expr-args subs i) ) )
	     (gen #\)) )

	    ((##core#inline_ref)
	     (gen (foreign-result-conversion (second params) "a") (first params) #\)) )

	    ((##core#inline_update)
	     (let ([t (second params)])
	       (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t)) 
	       (expr (first subs) i)
	       (gen "),C_SCHEME_UNDEFINED)") ) )

	    ((##core#inline_loc_ref)
	     (let ([t (first params)])
	       (gen (foreign-result-conversion t "a") "*((" (foreign-type-declaration t "") "*)C_data_pointer(")
	       (expr (first subs) i)
	       (gen ")))") ) )

	    ((##core#inline_loc_update)
	     (let ([t (first params)])
	       (gen "((*(" (foreign-type-declaration t "") "*)C_data_pointer(")
	       (expr (first subs) i)
	       (gen "))=" (foreign-argument-conversion t))
	       (expr (second subs) i) 
	       (gen "),C_SCHEME_UNDEFINED)") ) )

	    ((##core#switch)
	     (gen #t "switch(")
	     (expr (first subs) i)
	     (gen "){")
	     (do ([j (first params) (sub1 j)]
		  [ps (cdr subs) (cddr ps)] )
		 ((zero? j)
		  (gen #t "default:")
		  (expr (car ps) i)
		  (gen #\}) )
	       (gen #t "case ")
	       (expr (car ps) i)
	       (gen #\:)
	       (expr (cadr ps) i) ) )

	    ((##core#cond)
	     (gen "(C_truep(")
	     (expr (first subs) i)
	     (gen ")?")
	     (expr (second subs) i)
	     (gen #\:)
	     (expr (third subs) i)
	     (gen #\)) )

	    (else (bomb "bad form")) ) ) )
    
      (define (expr-args args i)
	(pair-for-each
	 (lambda (xs)
	   (if (not (eq? xs args)) (gen #\,))
	   (expr (car xs) i) )
	 args) )

      (expr node temps) )
  
    (define (header)
      (define (pad0 n)
	(if (< n 10)
	    (string-append "0" (number->string n))
	    n) )
      (match (##sys#decode-seconds (current-seconds) #f)
	[#(_ min hour mday mon year _ _ _ _)
	  (gen "/* Generated from " source-file " by the CHICKEN compiler" #t
	       "   http://www.call-with-current-continuation.org" #t
	       "   " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t
	       (string-intersperse
		(map (cut string-append "   " <> "\n") 
		     (string-split (chicken-version #t) "\n") ) 
		"")
	       "   command line: ")
	  (gen-list compiler-arguments)
	  (gen #t)
	  (cond [unit-name (gen "   unit: " unit-name)]
		[else 
		 (gen "   used units: ")
		 (gen-list used-units) ] )
	  (gen #t "*/" #t #t "#include \"" target-include-file "\"")
	  (when external-protos-first
	    (generate-foreign-callback-stub-prototypes foreign-callback-stubs) )
	  (when (pair? foreign-declarations)
	    (gen #t)
	    (for-each (lambda (decl) (gen #t decl)) foreign-declarations) )
	  (unless external-protos-first
	    (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) ] ) )
  
    (define (trailer)
      (gen #t "/* end of file */" #t) )
  
    (define (declarations)
      (let ((n (length literals)))
	(gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")
	(for-each 
	 (lambda (uu) 
	   (gen #t "C_noret_decl(C_" uu "_toplevel)"
		#t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word d,C_word k) C_noret;"))
	 used-units)
	(unless (zero? n)
	  (gen #t #t "static C_TLS C_word lf[" n "];") )
	(gen #t "static double C_possibly_force_alignment;")
	(do ((i 0 (add1 i))
	     (llits lliterals (cdr llits)))
	    ((null? llits))
	  (let* ((ll (##sys#lambda-info->string (car llits)))
		 (llen (string-length ll)))
	    (gen #t "static C_char C_TLS li" i "[] C_aligned={C_lihdr(" 
		 (arithmetic-shift llen -16) #\,
		 (bitwise-and #xff (arithmetic-shift llen -8)) #\,
		 (bitwise-and #xff llen)
		 #\))
	    (do ((n 0 (add1 n)))
		((>= n llen))
	      (gen #\, (char->integer (string-ref ll n))) )
	    (do ((n (- (bitwise-and #xfffff8 (+ llen 7)) llen) (sub1 n))) ; fill up with zeros to align following entry
		((zero? n))
	      (gen ",0") )
	    (gen "};")))))
  
    (define (prototypes)
      (let ([large-signatures '()])
	(gen #t)
	(for-each
	 (lambda (ll)
	   (let* ([n (lambda-literal-argument-count ll)]
		  [customizable (lambda-literal-customizable ll)] 
		  [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
		  [varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,)]
		  [id (lambda-literal-id ll)]
		  [rest (lambda-literal-rest-argument ll)]
		  [rest-mode (lambda-literal-rest-argument-mode ll)]
		  [direct (lambda-literal-direct ll)] 
		  [allocated (lambda-literal-allocated ll)] )
	     (when (>= n small-parameter-limit)
	       (set! large-signatures (lset-adjoin = large-signatures (add1 n))) )
	     (gen #t)
	     (for-each
	      (lambda (s) 
		(when (>= s small-parameter-limit)
		  (set! large-signatures (lset-adjoin = large-signatures (add1 s))) ) )
	      (lambda-literal-callee-signatures ll) )
	     (cond [(not (eq? 'toplevel id))
		    (gen "C_noret_decl(" id ")" #t)
		    (gen "static ")
		    (gen (if direct "C_word " "void "))
		    (if customizable
			(gen "C_fcall ")
			(gen "C_ccall ") )
		    (gen id) ]
		   [else
		    (let ((uname (if unit-name (string-append unit-name "_toplevel") "toplevel")))
		      (gen "C_noret_decl(C_" uname ")" #t)
		      (when emit-unsafe-marker
			(gen "C_externexport void C_dynamic_and_unsafe(void) {}" #t) )
		      (gen "C_externexport void C_ccall ")
		      (gen "C_" uname) ) ] )
	     (gen #\()
	     (unless customizable (gen "C_word c,"))
	     (when (and direct (not (zero? allocated)))
	       (gen "C_word *a")
	       (when (pair? varlist) (gen #\,)) )
	     (apply gen varlist)
	     (cond [rest
		    (gen ",...) C_noret;")
		    (if (not (eq? rest-mode 'none))
			(begin
			  (gen #t "C_noret_decl(" id ")" 
			       #t "static void C_ccall " id "r(")
			  (apply gen varlist)
			  (gen ",C_word t" (+ n 1) ") C_noret;") ) ) ]
		   [else 
		    (gen #\))
		    ;;(when customizable (gen " C_c_regparm"))
		    (unless direct (gen " C_noret"))
		    (gen #\;) ] ) ) )
	 lambdas) 
	(for-each
	 (lambda (s)
	   (gen #t "typedef void (*C_proc" s ")(C_word")
	   (for-each gen (make-list s ",C_word"))
	   (gen ") C_noret;") )
	 large-signatures) ) )
  
    (define (trampolines)
      (let ([ns '()]
	    [nsr '()] 
	    [nsrv '()] )

	(define (restore n)
	  (do ((i (- n 1) (- i 1))
	       (j 0 (+ j 1)) )
	      ((negative? i))
	    (gen #t "C_word t" i "=C_pick(" j ");") ) 
	  (gen #t "C_adjust_stack(-" n ");") )

	(define (emitter vflag)
	  (lambda (n)
	    (gen #t #t "C_noret_decl(tr" n #\r (if vflag #\v "") ")"
		 #t "static void C_fcall tr" n #\r (if vflag #\v ""))
	    (gen "(C_proc" n " k) C_regparm C_noret;")
	    (gen #t "C_regparm static void C_fcall tr" n #\r)
	    (when vflag (gen #\v))
	    (gen "(C_proc" n " k){"
		 #t "int n;"
		 #t "C_word *a,t" n #\;)
	    (restore n)
	    (gen #t "n=C_rest_count(0);")
	    (if vflag
		(gen #t "a=C_alloc(n+1);")
		(gen #t "a=C_alloc(n*3);") )
	    (gen #t #\t n "=C_restore_rest")
	    (when vflag (gen "_vector"))
	    (gen "(a,n);")
	    (gen #t "(k)(")
	    (apply gen (intersperse (make-argument-list (+ n 1) "t") #\,))
	    (gen ");}") ) )

	(for-each
	 (lambda (ll)
	   (let* ([argc (lambda-literal-argument-count ll)]
		  [rest (lambda-literal-rest-argument ll)]
		  [rest-mode (lambda-literal-rest-argument-mode ll)]
		  [id (lambda-literal-id ll)]
		  [customizable (lambda-literal-customizable ll)]
		  [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
	     (when empty-closure (set! argc (sub1 argc)))
	     (unless (lambda-literal-direct ll)
	       (cond [customizable
		      (gen #t #t "C_noret_decl(tr" id ")"
			   #t "static void C_fcall tr" id "(void *dummy) C_regparm C_noret;")
		      (gen #t "C_regparm static void C_fcall tr" id "(void *dummy){")
		      (restore argc)
		      (gen #t id #\()
		      (let ([al (make-argument-list argc "t")])
			(apply gen (intersperse al #\,)) )
		      (gen ");}") ]
		     [(or rest (> (lambda-literal-allocated ll) 0) (lambda-literal-external ll))
		      (if (and rest (not (eq? rest-mode 'none)))
			  (if (eq? rest-mode 'vector)
			      (set! nsrv (lset-adjoin = nsrv argc))
			      (set! nsr (lset-adjoin = nsr argc)) ) 
			  (set! ns (lset-adjoin = ns argc)) ) ] ) ) ) )
	 lambdas)
	(for-each
	 (lambda (n)
	   (gen #t #t "C_noret_decl(tr" n ")"
		#t "static void C_fcall tr" n "(C_proc" n " k) C_regparm C_noret;")
	   (gen #t "C_regparm static void C_fcall tr" n "(C_proc" n " k){")
	   (restore n)
	   (gen #t "(k)(" n #\,)
	   (apply gen (intersperse (make-argument-list n "t") #\,))
	   (gen ");}") )
	 ns)
	(for-each (emitter #f) nsr)
	(for-each (emitter #t) nsrv) ) )
  
    (define (literal-frame)
      (do ([i 0 (add1 i)]
	   [lits literals (cdr lits)] )
	  ((null? lits))
	(gen-lit (car lits) (sprintf "lf[~s]" i)) ) )

    (define (bad-literal lit)
      (bomb "type of literal not supported" lit) )

    (define (literal-size lit)
      (cond [(immediate? lit) 0]
	    [(string? lit) 0]
	    [(number? lit) words-per-flonum]
	    [(symbol? lit) 10]		; size of symbol, and possibly a bucket
	    [(pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit)))]
	    [(vector? lit) (+ 1 (vector-length lit) (reduce + 0 (map literal-size (vector->list lit))))]
	    [(block-variable-literal? lit) 0]
	    [(##sys#immediate? lit) (bad-literal lit)]
	    [(##core#inline "C_lambdainfop" lit) 0]
	    [(##sys#bytevector? lit) (+ 2 (words (##sys#size lit))) ] ; drops "permanent" property!
	    [(##sys#generic-structure? lit)
	     (let ([n (##sys#size lit)])
	       (let loop ([i 0] [s (+ 2 n)])
		 (if (>= i n)
		     s
		     (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) ]
	    [else (bad-literal lit)] ) )

    (define (gen-lit lit to)
      ;; we do simple immediate literals directly to avoid a function call:
      (cond ((and (fixnum? lit) (not (big-fixnum? lit)))
	     (gen #t to "=C_fix(" lit ");") )
	    ((block-variable-literal? lit))
	    ((eq? lit (void))
	     (gen #t to "=C_SCHEME_UNDEFINED;") )
	    ((boolean? lit) 
	     (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )
	    ((char? lit)
	     (gen #t to "=C_make_character(" (char->integer lit) ");") )
	    ((symbol? lit)		; handled slightly specially (see C_h_intern_in)
	     (let* ([str (##sys#slot lit 1)]
		    [cstr (c-ify-string str)]
		    [len (##sys#size str)] )
	       (gen #t to "=")
	       (gen "C_h_intern(&" to #\, len #\, cstr ");") ) )
	    ((null? lit) 
	     (gen #t to "=C_SCHEME_END_OF_LIST;") )
	    ((and (not (##sys#immediate? lit))
		  (##core#inline "C_lambdainfop" lit)))
	    ((or (fixnum? lit) (not (##sys#immediate? lit)))
	     (gen #t to "=C_decode_literal(C_heaptop,")
	     (gen-string-constant (encode-literal lit))
	     (gen ");") )
	    (else (bad-literal lit))))