c-backend.scm

Scheme跨平台编译器

	      (cond [callback
		     (gen #t "C_k=C_restore_callback_continuation2(C_level);"
			  #t "C_kontinue(C_k,C_r);") ]
		    [cps (gen "C_kontinue(C_k,C_r);")]
		    [else (gen #t "return C_r;")] ) ] )
       (gen #\}) ) )
   stubs) )

(define (generate-foreign-callback-stubs stubs db)
  (for-each
   (lambda (stub)
     (let* ([id (foreign-callback-stub-id stub)]
	    [rname (real-name2 id db)]
	    [rtype (foreign-callback-stub-return-type stub)]
	    [argtypes (foreign-callback-stub-argument-types stub)]
	    [n (length argtypes)]
	    [vlist (make-argument-list n "t")] )

       (define (compute-size type var ns)
	 (case type
	   [(char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
		  byte unsigned-byte)
	    ns]
	   [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 unsigned-long 
		   nonnull-c-pointer number integer64 c-string-list c-string-list*)
	    (string-append ns "+3") ]
	   [(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
	    (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ]
	   [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
	    (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ]
	   [else
	    (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) 
		   => (lambda (t)
			(compute-size (if (vector? t) (vector-ref t 0) t) var ns) ) ]
		  [(pair? type)
		   (case (car type)
		     [(ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance 
			   nonnull-instance instance-ref)
		      (string-append ns "+3") ]
		     [(const) (compute-size (cadr type) var ns)]
		     [else ns] ) ]
		  [else ns] ) ] ) )

       (let ([sizestr (fold compute-size "0" argtypes vlist)])
	 (gen #t)
	 (when rname
	   (gen #t "/* from " (cleanup rname) " */") )
	 (generate-foreign-callback-header "" stub)
	 (gen #\{ #t "C_word x,s=" sizestr ",*a=C_alloc(s);")
	 (gen #t "C_callback_adjust_stack(a,s);") ; make sure content is below stack_bottom as well
	 (for-each
	  (lambda (v t)
	    (gen #t "x=" (foreign-result-conversion t "a") v ");"
		 #t "C_save(x);") )
	  vlist 
	  argtypes)
	 (unless (eq? 'void rtype)
	   (gen #t "return " (foreign-argument-conversion rtype)) )
	 (gen "C_callback_wrapper((void *)" id #\, n #\))
	 (unless (eq? 'void rtype) (gen #\)))
	 (gen ";}") ) ) )
   stubs) )

(define (generate-foreign-callback-header cls stub)
  (let* ([name (foreign-callback-stub-name stub)]
	 [quals (foreign-callback-stub-qualifiers stub)]
	 [rtype (foreign-callback-stub-return-type stub)]
	 [argtypes (foreign-callback-stub-argument-types stub)]
	 [n (length argtypes)]
	 [vlist (make-argument-list n "t")] )
    (gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()
    (pair-for-each
     (lambda (vs ts)
       (gen (foreign-type-declaration (car ts) (car vs)))
       (when (pair? (cdr vs)) (gen #\,)) )
     vlist argtypes)
    (gen #\)) ) )


;; Create type declarations

(define (foreign-type-declaration type target)
  (let ([err (lambda () (quit "illegal foreign type `~A'" type))]
	[str (lambda (ts) (string-append ts " " target))] )
    (case type
      [(scheme-object) (str "C_word")]
      [(char byte) (str "C_char")]
      [(unsigned-char unsigned-byte) (str "unsigned C_char")]
      [(unsigned-int unsigned-integer) (str "unsigned int")]
      [(unsigned-int32 unsigned-integer32) (str "C_u32")]
      [(int integer bool) (str "int")]
      [(int32 integer32) (str "C_s32")]
      [(integer64) (str "C_s64")]
      [(short) (str "short")]
      [(long) (str "long")]
      [(unsigned-short) (str "unsigned short")]
      [(unsigned-long) (str "unsigned long")]
      [(float) (str "float")]
      [(double number) (str "double")]
      ;; pointer and nonnull-pointer are DEPRECATED
      [(pointer nonnull-pointer) (str "void *")]
      [(c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *")]
      [(c-string-list c-string-list*) "C_char **"]
      ;; byte-vector and nonnull-byte-vector are DEPRECATED
      [(byte-vector nonnull-byte-vector) (str "unsigned char *")]
      [(blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *")]
      [(u16vector nonnull-u16vector) (str "unsigned short *")]
      [(s8vector nonnull-s8vector) (str "char *")]
      [(u32vector nonnull-u32vector) (str "unsigned int *")]
      [(s16vector nonnull-s16vector) (str "short *")]
      [(s32vector nonnull-s32vector) (str "int *")]
      [(f32vector nonnull-f32vector) (str "float *")]
      [(f64vector nonnull-f64vector) (str "double *")]
      [(nonnull-c-string c-string nonnull-c-string* c-string* 
			 nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string*
			 symbol) (str "char *")]
      [(void) (str "void")]
      [else
       (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
	      => (lambda (t)
		   (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ]
	     [(string? type) (str type)]
	     [(pair? type)
	      (match type
		[((or 'pointer 'nonnull-pointer 'c-pointer 'nonnull-c-pointer) ptype)
		 (foreign-type-declaration ptype (string-append "*" target)) ]
		[('ref rtype)
		 (foreign-type-declaration rtype (string-append "&" target)) ]
		[`(template ,t0 ,ts ...)
		 (str
		  (string-append 
		   (foreign-type-declaration t0 "")
		   "<"
		   (string-intersperse (map (cut foreign-type-declaration <> "") ts) ",")
		   "> ") ) ]
		[`(const ,t) (string-append "const " (foreign-type-declaration t target))]
		[`(struct ,sname) (string-append "struct " (->string sname) " " target)]
		[`(union ,uname) (string-append "union " (->string uname) " " target)]
		[`(enum ,ename) (string-append "enum " (->string ename) " " target)]
		[((or 'instance 'nonnull-instance) cname sname) (string-append (->string cname) "*" target)]
		[('instance-ref cname sname) (string-append (->string cname) "&" target)]
		[`(function ,rtype ,argtypes . ,callconv)
		 (string-append
		  (foreign-type-declaration rtype "")
		  (or (and-let* ([(pair? callconv)]
				 [cc (car callconv)]
				 [(string? cc)] )
			cc)
		      "")
		  " (*" target ")("
		  (string-intersperse
		   (map (lambda (at)
			  (if (eq? '... at) 
			      "..."
			      (foreign-type-declaration at "") ) )
			argtypes) 
		   ",")
		  ")" ) ]
		[_ (err)] ) ]
	     [else (err)] ) ] ) ) )


;; Generate expression to convert argument from Scheme data

(define (foreign-argument-conversion type)
  (let ([err (lambda () (quit "illegal foreign argument type `~A'" type))])
    (case type
      ((scheme-object) "(")
      ((char unsigned-char) "C_character_code((C_word)")
      ((byte int unsigned-int unsigned-int32 unsigned-byte) "C_unfix(")
      ((short) "C_unfix(")
      ((unsigned-short) "(unsigned short)C_unfix(")
      ((unsigned-long) "C_num_to_unsigned_long(")
      ((double number float) "C_c_double(")
      ((integer integer32) "C_num_to_int(")
      ((integer64) "C_num_to_int64(")
      ((long) "C_num_to_long(")
      ((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")
      ;; pointer and nonnull-pointer are DEPRECATED
      ((pointer) "C_data_pointer_or_null(")
      ((nonnull-pointer) "C_data_pointer(")
      ((scheme-pointer) "C_data_pointer_or_null(")
      ((nonnull-scheme-pointer) "C_data_pointer(")
      ((c-pointer) "C_c_pointer_or_null(")
      ((nonnull-c-pointer) "C_c_pointer_nn(")
      ((blob) "C_c_bytevector_or_null(")
      ((nonnull-blob) "C_c_bytevector(")
      ;; byte-vector and nonnull-byte-vector are DEPRECATED
      ((byte-vector) "C_c_bytevector_or_null(")
      ((nonnull-byte-vector) "C_c_bytevector(")
      ((u8vector) "C_c_u8vector_or_null(")
      ((nonnull-u8vector) "C_c_u8vector(")
      ((u16vector) "C_c_u16vector_or_null(")
      ((nonnull-u16vector) "C_c_u16vector(")
      ((u32vector) "C_c_u32vector_or_null(")
      ((nonnull-u32vector) "C_c_u32vector(")
      ((s8vector) "C_c_s8vector_or_null(")
      ((nonnull-s8vector) "C_c_s8vector(")
      ((s16vector) "C_c_s16vector_or_null(")
      ((nonnull-s16vector) "C_c_s16vector(")
      ((s32vector) "C_c_s32vector_or_null(")
      ((nonnull-s32vector) "C_c_s32vector(")
      ((f32vector) "C_c_f32vector_or_null(")
      ((nonnull-f32vector) "C_c_f32vector(")
      ((f64vector) "C_c_f64vector_or_null(")
      ((nonnull-f64vector) "C_c_f64vector(")
      ((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")
      ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string 
			 nonnull-unsigned-c-string* symbol) "C_c_string(")
      ((bool) "C_truep(")
      (else
       (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
	      => (lambda (t)
		   (foreign-argument-conversion (if (vector? t) (vector-ref t 0) t)) ) ]
	     [(pair? type)
	      (match type
                ;; pointer and nonnull-pointer are DEPRECATED
		[('pointer ptype) "C_c_pointer_or_null("]
		[('nonnull-pointer ptype) "C_c_pointer_nn("]
		[('c-pointer ptype) "C_c_pointer_or_null("]
		[('nonnull-c-pointer ptype) "C_c_pointer_nn("]
		[`(instance ,cname ,sname) "C_c_pointer_or_null("]
		[`(nonnull-instance ,cname ,sname) "C_c_pointer_nn("]
		[`(function ,rtype ,@argtypes) "C_c_pointer_or_null("]
		[`(const ,ctype) (foreign-argument-conversion ctype)]
		[`(enum ,etype) "C_num_to_int("]
		[`(ref ,rtype) (string-append "*(" (foreign-type-declaration rtype "*") ")C_c_pointer_nn(")]
		[`(instance-ref ,cname ,sname) (string-append "*(" cname "*)C_c_pointer_nn(")]
		[else (err)] ) ]
	     [else (err)] ) ) ) ) )


;; Generate suitable conversion of a result value into Scheme data
	    
(define (foreign-result-conversion type dest)
  (let ([err (lambda () (quit "illegal foreign return type `~A'" type))])
    (case type
      ((char unsigned-char) "C_make_character((C_word)")
      ((int int32) "C_fix((C_word)")
      ((unsigned-int unsigned-int32) "C_fix(C_MOST_POSITIVE_FIXNUM&(C_word)")
      ((short) "C_fix((short)")
      ((unsigned-short) "C_fix(0xffff&(C_word)")
      ((byte) "C_fix((char)")
      ((unsigned-byte) "C_fix(0xff&(C_word)")
      ((float double) (sprintf "C_flonum(&~a," dest))	;*** suboptimal for int64
      ((number) (sprintf "C_number(&~a," dest))
      ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string* 
			 unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string
			 nonnull-unsigned-c-string* symbol c-string-list c-string-list*) 
       (sprintf "C_mpointer(&~a,(void*)" dest) )
      ((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))
      ((integer integer32) (sprintf "C_int_to_num(&~a," dest))
      ((integer64) (sprintf "C_a_double_to_num(&~a," dest))
      ((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))
      ((long) (sprintf "C_long_to_num(&~a," dest))
      ((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))
      ((bool) "C_mk_bool(")
      ((void scheme-object) "((C_word)")
      (else
       (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
	      => (lambda (x)
		   (foreign-result-conversion (if (vector? x) (vector-ref x 0) x) dest)) ]
	     [(pair? type)
	      (match type
		[((or 'nonnull-pointer 'nonnull-c-pointer) ptype) 
		 (sprintf "C_mpointer(&~A,(void*)" dest) ]
		[('ref rtype) 
		 (sprintf "C_mpointer(&~A,(void*)&" dest) ]
		[('instance cname sname)
		 (sprintf "C_mpointer_or_false(&~A,(void*)" dest) ]
		[('nonnull-instance cname sname)
		 (sprintf "C_mpointer(&~A,(void*)" dest) ]
		[('instance-ref cname sname)
		 (sprintf "C_mpointer(&~A,(void*)&" dest) ]
		[('const ctype) (foreign-result-conversion ctype dest)]
		[((or 'pointer 'c-pointer) ptype) 
		 (sprintf "C_mpointer_or_false(&~a,(void*)" dest) ]
		[`(function ,rtype ,@argtypes) (sprintf "C_mpointer(&~a,(void*)" dest)]
		[`(enum ,etype) (sprintf "C_int_to_num(&~a," dest)]
		[else (err)] ) ]
	     [else (err)] ) ) ) ) )


;;; Encoded literals as strings, to be decoded by "C_decode_literal()"
;; 
;; - everything hardcoded, using the FFI would be the ugly, but safer method.

(define (encode-literal lit)
  (define getbits
    (foreign-lambda* int ((scheme-object lit))
      "
#ifdef C_SIXTY_FOUR
return((C_header_bits(lit) >> (24 + 32)) & 0xff);
#else
return((C_header_bits(lit) >> 24) & 0xff);
#endif
") )
  (define getsize
    (foreign-lambda* int ((scheme-object lit))
      "return(C_header_size(lit));"))
  (define (encode-size n)
    ;; only handles sizes in the 24-bit range!
    (string (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
	    (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
	    (integer->char (bitwise-and #xff n))))
  (define (finish str)		   ; can be taken out at a later stage
    (string-append (string #\xfe) str))
  (finish
   (cond ((eq? #t lit) "\xff\x06\x01")
	 ((eq? #f lit) "\xff\x06\x00")
	 ((char? lit) (string-append "\xff\x0a" (encode-size (char->integer lit))))
	 ((null? lit) "\xff\x0e")
	 ((eof-object? lit) "\xff\x3e")
	 ((eq? (void) lit) "\xff\x1e")
	 ((fixnum? lit)
	  (if (not (big-fixnum? lit))
	      (string-append
	       "\xff\x01"
	       (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))
		       (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))
		       (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))
		       (integer->char (bitwise-and #xff lit)) ) )
	      (string-append "\xff\x55" (number->string lit) "\x00") ) )
	 ((number? lit)
	  (string-append "\x55" (number->string lit) "\x00") )
	 ((symbol? lit)
	  (let ((str (##sys#slot lit 1)))
	    (string-append 
	     "\x01" 
	     (encode-size (string-length str))
	     str) ) )
	 ((##sys#immediate? lit)
	  (bomb "invalid literal - can not encode" lit))
	 ((##core#inline "C_byteblockp" lit)
	  (##sys#string-append ; relies on the fact that ##sys#string-append doesn't check
	   (string-append
	    (string (integer->char (getbits lit)))
	    (encode-size (getsize lit)) )
	   lit) )
	 (else
	  (let ((len (getsize lit)))
	    (string-intersperse
	     (cons*
	      (string (integer->char (getbits lit)))
	      (encode-size len)
	      (list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
	     ""))))) )