c-backend.scm

Scheme跨平台编译器

    (define (gen-string-constant str)
      (let* ([len (##sys#size str)]
	     [ns (fx/ len 80)]
	     [srest (modulo len 80)] )
	(do ([i ns (sub1 i)]
	     [offset 0 (+ offset 80)] )
	    ((zero? i)
	     (when (or (zero? len) (not (zero? srest)))
	       (gen (c-ify-string (string-like-substring str offset len))) ) )
	  (gen (c-ify-string (string-like-substring str offset (+ offset 80))) #t) ) ) )
 
    (define (string-like-substring s start end)
      (let* ([len (- end start)]
	     [s2 (make-string len)] )
	(##sys#copy-bytes s s2 start 0 len)
	s2) )

    (define (procedures)
      (for-each
       (lambda (ll)
	 (let* ([n (lambda-literal-argument-count ll)]
		[id (lambda-literal-id ll)]
		[rname (real-name id db)]
		[demand (lambda-literal-allocated ll)]
		[rest (lambda-literal-rest-argument ll)]
		[customizable (lambda-literal-customizable ll)]
		[empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
		[nec (- n (if empty-closure 1 0))]
		[vlist0 (make-variable-list n "t")]
		[alist0 (make-argument-list n "t")]
		[varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,)]
		[arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,)]
		[external (lambda-literal-external ll)]
		[looping (lambda-literal-looping ll)]
		[direct (lambda-literal-direct ll)]
		[rest-mode (lambda-literal-rest-argument-mode ll)]
		[temps (lambda-literal-temporaries ll)]
		[topname (if unit-name
			     (string-append unit-name "_toplevel")
			     "toplevel") ] )
	   (when empty-closure (debugging 'o "dropping unused closure argument" id))
	   (gen #t #t)
	   (gen "/* " (cleanup rname) " */" #t)
	   (cond [(not (eq? 'toplevel id)) 
		  (gen "static ")
		  (gen (if direct "C_word " "void "))
		  (if customizable
		      (gen "C_fcall ")
		      (gen "C_ccall ") )
		  (gen id) ]
		 [else
		  (gen "static C_TLS int toplevel_initialized=0;")
		  (unless unit-name
		    (gen #t "C_main_entry_point") )
		  (gen #t "C_noret_decl(toplevel_trampoline)"
		       #t "static void C_fcall toplevel_trampoline(void *dummy) C_regparm C_noret;"
		       #t "C_regparm static void C_fcall toplevel_trampoline(void *dummy){"
		       #t "C_" topname "(2,C_SCHEME_UNDEFINED,C_restore);}"
		       #t #t "void C_ccall C_" topname) ] )
	   (gen #\()
	   (unless customizable (gen "C_word c,"))
	   (when (and direct (not (zero? demand))) 
	     (gen "C_word *a")
	     (when (pair? varlist) (gen #\,)) )
	   (apply gen varlist)
	   (when rest (gen ",..."))
	   (gen "){")
	   (when (eq? rest-mode 'none) (set! rest #f))
	   (gen #t "C_word tmp;")
	   (if rest
	       (gen #t "C_word t" n #\;) ; To hold rest-list if demand is met
	       (do ([i n (add1 i)]
		    [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )
		   ((zero? j))
		 (gen #t "C_word t" i #\;) ) )
	   (cond [(eq? 'toplevel id) 
		  (let ([ldemand (fold (lambda (lit n) (+ n (literal-size lit))) 0 literals)]
			[llen (length literals)] )
		    (gen #t "C_word *a;"
			 #t "if(toplevel_initialized) C_kontinue(t1,C_SCHEME_UNDEFINED);"
			 #t "else C_toplevel_entry(C_text(\"" topname "\"));")
		    (when disable-stack-overflow-checking
		      (gen #t "C_disable_overflow_check=1;") )
		    (unless unit-name
		      (cond [target-initial-heap-size
			     (gen #t "C_set_or_change_heap_size(" target-initial-heap-size ",1);") ]
			    [target-heap-size
			     (gen #t "C_set_or_change_heap_size(" target-heap-size ",1);"
				  #t "C_heap_size_is_fixed=1;") ] )
		      (when target-heap-growth
			(gen #t "C_heap_growth=" target-heap-growth #\;) )
		      (when target-heap-shrinkage
			(gen #t "C_heap_shrinkage=" target-heap-shrinkage #\;) )
		      (when target-stack-size
			(gen #t "C_resize_stack(" target-stack-size ");") ) )
		    (gen #t "C_check_nursery_minimum(" demand ");"
			 #t "if(!C_demand(" demand ")){"
			 #t "C_save(t1);"
			 #t "C_reclaim((void*)toplevel_trampoline,NULL);}"
			 #t "toplevel_initialized=1;")
		    (gen #t "if(!C_demand_2(" ldemand ")){"
			 #t "C_save(t1);"
			 #t "C_rereclaim2(" ldemand "*sizeof(C_word), 1);"
			 #t "t1=C_restore;}")
		    (gen #t "a=C_alloc(" demand ");")
		    (when (not (zero? llen))
		      (gen #t "C_initialize_lf(lf," llen ");")
		      (literal-frame)
		      (gen #t "C_register_lf2(lf," llen ",create_ptable());") ) ) ]
		 [rest
		  (gen #t "va_list v;")
		  (gen #t "C_word *a,c2=c;")
		  (gen #t "C_save_rest(")
		  (if (> n 0)
		      (gen #\t (- n 1))
		      (gen "c") )
		  (gen ",c2," n ");")
		  (when (and (not unsafe) (not no-argc-checks) (> n 2) (not empty-closure))
		    (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);") )
		  (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
		  (gen #t "if(!C_demand(c*C_SIZEOF_PAIR+" demand ")){") ]
		 [else
		  (cond [(and (not direct) (> demand 0))
			 (if looping
			     (gen #t "C_word *a;"
				  #t "loop:"
				  #t "a=C_alloc(" demand ");")
			     (gen #t "C_word ab[" demand "],*a=ab;") ) ]
			[else
			 (unless direct (gen #t "C_word *a;"))
			 (when looping (gen #t "loop:")) 
			 (when (and direct (not unsafe) (not disable-stack-overflow-checking))
			   (gen #t "C_stack_check;") ) ] )
		  (when (and external (not unsafe) (not no-argc-checks) (not customizable))
		    ;; (not customizable) implies empty-closure
		    (if (eq? rest-mode 'none)
			(when (> n 2) (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);"))
			(gen #t "if(c!=" n ") C_bad_argc_2(c," n ",t0);") ) )
		  (when (and (not direct) (or external (> demand 0)))
		    (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
		    (if (and looping (> demand 0))
			(gen #t "if(!C_stack_probe(a)){")
			(gen #t "if(!C_stack_probe(&a)){") ) ) ] )
	   (when (and (not (eq? 'toplevel id))
		      (not direct)
		      (or rest external (> demand 0)) )
;; 	     (cond [(> nec 1)
;; 		    (gen #t "C_adjust_stack(" nec ");")
;; 		    (do ([i (if empty-closure 1 0) (+ i 1)])
;; 			((>= i n))
;; 		      (gen #t "C_rescue(t" i #\, (- n i 1) ");") ) ]
;; 		   [(= nec 1) (gen #t "C_save(" (if empty-closure "t1" "t0") ");")] )
	     (cond [rest
		    (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr" n #\r)
		    (when (eq? rest-mode 'vector) (gen #\v))
		    (gen ",(void*)" id "r")
		    (when (> nec 0)
		      (gen #\, nec #\,)
		      (apply gen arglist) )
		    (gen ");}"
			 #t "else{"
			 #t "a=C_alloc((c-" n ")*3);")
		    (case rest-mode
		      [(list #f) (gen #t "t" n "=C_restore_rest(a,C_rest_count(0));")]
		      [(vector) (gen #t "t" n "=C_restore_rest_vector(a,C_rest_count(0));")] )
		    (gen #t id "r(")
		    (apply gen (intersperse (make-argument-list n "t") #\,))
		    (gen ",t" n ");}}")
		    ;; Create secondary routine (no demand-check or argument-count-parameter):
		    (gen #t #t "static void C_ccall " id "r(")
		    (apply gen varlist)
		    (gen ",C_word t" n "){")
		    (gen #t "C_word tmp;")
		    (do ([i (+ n 1) (+ i 1)]
			 [j temps (- j 1)] )
			((zero? j))
		      (gen #t "C_word t" i #\;) )
		    (when (> demand 0) (gen #t "C_word *a=C_alloc(" demand ");")) ]
		   [else 
		    (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr")
		    (if customizable 
			(gen id ",NULL")
			(gen n ",(void*)" id) )
		    (when (> nec 0)
		      (gen #\, nec #\,)
		      (apply gen arglist) )
		    (gen ");}") ] ) )
	   (expression
	    (lambda-literal-body ll)
	    (if rest
		(add1 n) ; One temporary is needed to hold the rest-list
		n)
	    ll)
	   (gen #\}) ) )
       lambdas) )

    (debugging 'p "code generation phase...")
    (set! output out)
    (header)
    (declarations)
    (generate-external-variables external-variables)
    (generate-foreign-stubs foreign-lambda-stubs db)
    (prototypes)
    (generate-foreign-callback-stubs foreign-callback-stubs db)
    (trampolines)
    (procedures)
    (emit-procedure-table-info lambdas source-file)
    (trailer) ) )


;;; Emit procedure table:

(define (emit-procedure-table-info lambdas sf)
  (gen #t #t "#ifdef C_ENABLE_PTABLES"
       #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambdas)) "] = {")
  (do ((ll lambdas (cdr ll)))
      ((null? ll)
       (gen #t "{NULL,NULL}};") )
    (let ((id (lambda-literal-id (car ll))))
      (gen #t "{\"" id sf "\",(void*)")
      (if (eq? 'toplevel id)
	  (if unit-name
	      (gen "C_" unit-name "_toplevel},")
	      (gen "C_toplevel},") )
	  (gen id "},") ) ) )
  (gen #t "#endif")
  (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")
  (gen "{" #t "#ifdef C_ENABLE_PTABLES"
       #t "return ptable;"
       #t "#else"
       #t "return NULL;"
       #t "#endif"
       #t "}") )


;;; Create name that is safe for C comments:

(define (cleanup s)
  (let ([s2 #f] 
	[len (string-length s)] )
    (let loop ([i 0])
      (if (>= i len)
	  (or s2 s)
	  (let ([c (string-ref s i)])
	    (if (or (char<? c #\space)
		    (char>? c #\~)
		    (and (char=? c #\*) (< i (sub1 len)) (char=? #\/ (string-ref s (add1 i)))) )
		(begin
		  (unless s2 (set! s2 (string-copy s)))
		  (string-set! s2 i #\~) )
		(when s2 (string-set! s2 i c)) ) 
	    (loop (add1 i)) ) ) ) ) )


;;; Create list of variables/parameters, interspersed with a special token:

(define (make-variable-list n prefix)
  (list-tabulate
   n
   (lambda (i) (string-append "C_word " prefix (number->string i))) ) )
  
(define (make-argument-list n prefix)
  (list-tabulate
   n
   (lambda (i) (string-append prefix (number->string i))) ) )


;;; Generate external variable declarations:

(define (generate-external-variables vars)
  (gen #t)
  (for-each
   (match-lambda 
     [#(name type exported)
      (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ] )
   vars) )


;;; Generate foreign stubs:

(define (generate-foreign-callback-stub-prototypes stubs)
  (for-each
   (lambda (stub)
     (gen #t)
     (generate-foreign-callback-header "C_externexport " stub)
     (gen #\;) )
   stubs) )

(define (generate-foreign-stubs stubs db)
  (for-each
   (lambda (stub)
     (let* ([id (foreign-stub-id stub)]
	    [rname (real-name2 id db)]
	    [types (foreign-stub-argument-types stub)]
	    [n (length types)]
	    [varlist (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,)]
	    [rtype (foreign-stub-return-type stub)] 
	    [sname (foreign-stub-name stub)] 
	    [body (foreign-stub-body stub)]
	    [names (or (foreign-stub-argument-names stub) (make-list n #f))]
	    [rconv (foreign-result-conversion rtype "C_a")] 
	    [cps (foreign-stub-cps stub)]
	    [callback (foreign-stub-callback stub)] )
       (gen #t)
       (when rname
	 (gen #t "/* from " (cleanup rname) " */") )
       (when body
	 (gen #t "#define return(x) C_cblock C_r = (" rconv 
	      "(x))); goto C_ret; C_cblockend"))
       (if cps
	   (gen #t "C_noret_decl(" id ")"
		#t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
	   (gen #t "static C_word C_fcall " id #\() )
       (apply gen varlist)
       (if cps
	   (gen ") C_noret;" #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
	   (gen ") C_regparm;" #t "C_regparm static C_word C_fcall " id #\() )
       (apply gen varlist)
       (gen "){")
       (gen #t "C_word C_r=C_SCHEME_UNDEFINED,*C_a=(C_word*)C_buf;")
       (for-each
	(lambda (type index name)
	  (gen #t 
	       (foreign-type-declaration 
		type
		(if name (symbol->string name) (sprintf "t~a" index)) )
	       "=(" (foreign-type-declaration type "") #\)
	       (foreign-argument-conversion type) "C_a" index ");") )
	types (iota n) names)
       (when callback (gen #t "int C_level=C_save_callback_continuation(&C_a,C_k);"))
       (cond [body
	      (gen #t body
		   #t "C_ret:")
	      (gen #t "#undef return" #t)
	      (cond [callback
		     (gen #t "C_k=C_restore_callback_continuation2(C_level);"
			  #t "C_kontinue(C_k,C_r);") ]
		    [cps (gen #t "C_kontinue(C_k,C_r);")]
		    [else (gen #t "return C_r;")] ) ]
	     [else
	      (if (not (eq? rtype 'void))
		  (gen #t "C_r=" rconv)
		  (gen #t) )
	      (gen sname #\()
	      (apply gen (intersperse (make-argument-list n "t") #\,))
	      (unless (eq? rtype 'void) (gen #\)))
	      (gen ");")