c-platform.scm

Scheme跨平台编译器

	       (lambda (x y)
		 (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y))))
		     (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))
		     (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )
	       callargs) ) ) ]
	   [else #f] ) ) ) )

(rewrite 
 '- 8 
 (lambda (db classargs cont callargs)
   ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>)  [fixnum-mode]
   ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>)  [fixnum-mode + unsafe]
   ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]
   ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...)) 
   ;;    [fixnum-mode + unsafe]
   ;; - Remove "0" from arguments, if more than 1.
   (cond [(null? callargs) #f]
	 [(and (null? (cdr callargs)) (eq? number-type 'fixnum))
	  (make-node
	   '##core#call '(#t)
	   (list cont
		 (make-node '##core#inline
			    (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))
			    callargs)) ) ]
	 [else
	  (let ([callargs
		 (cons (car callargs)
		       (remove
			(lambda (x)
			  (and (eq? 'quote (node-class x))
			       (zero? (first (node-parameters x))) ) ) 
			(cdr callargs) ) ) ] )
	    (and (eq? number-type 'fixnum)
		 (>= (length callargs) 2)
		 (make-node
		  '##core#call '(#t)
		  (list 
		   cont
		   (fold-inner
		    (lambda (x y)
		      (make-node '##core#inline 
				 (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))
				 (list x y) ) )
		    callargs) ) ) ) ) ] ) ) )

(rewrite 
 '/ 8 
 (lambda (db classargs cont callargs)
   ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]
   ;; - Remove "1" from arguments, if more than 1.
   ;; - Replace divisions by 2 with shift right. [fixnum-mode]
   (and (>= (length callargs) 2)
	(let ([callargs
	       (cons (car callargs)
		     (remove
		      (lambda (x)
			(and (eq? 'quote (node-class x))
			     (= 1 (first (node-parameters x))) ) ) 
		      (cdr callargs) ) ) ] )
	  (and (eq? number-type 'fixnum)
	       (>= (length callargs) 2)
	       (make-node
		'##core#call '(#t)
		(list
		 cont
		 (fold-inner
		  (lambda (x y)
		    (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y))))
			(make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))
			(make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )
		  callargs) ) ) ) ) ) ) )

(rewrite
 'quotient 8
 (lambda (db classargs cont callargs)
   ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]
   ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]
   ;; (quotient <x> <y>) -> ((##core#proc "C_quotient") <x> <y>)
   (and (= (length callargs) 2)
	(if (eq? 'fixnum number-type)
	    (make-node
	     '##core#call '(#t)
	     (let ([arg2 (second callargs)])
	       (list cont 
		     (if (and (eq? 'quote (node-class arg2)) 
			      (= 2 (first (node-parameters arg2))) )
			 (make-node 
			  '##core#inline '("C_fixnum_shift_right") 
			  (list (first callargs) (qnode 1)) )
			 (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) )
	    (make-node
	     '##core#call '(#t)
	     (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) )

(rewrite
 'eqv? 8
 (lambda (db classargs cont callargs)
   ;; (eqv? <var> <var>) -> (quote #t)
   ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum]
   (and (= (length callargs) 2)
	(let ([arg1 (first callargs)]
	      [arg2 (second callargs)] )
	  (or (and (eq? '##core#variable (node-class arg1))
		   (eq? '##core#variable (node-class arg2))
		   (equal? (node-parameters arg1) (node-parameters arg2))
		   (make-node '##core#call '(#t) (list cont (qnode #t))) )
	      (and (or (and (eq? 'quote (node-class arg1))
			    (not (flonum? (first (node-parameters arg1)))) )
		       (and (eq? 'quote (node-class arg2))
			    (not (flonum? (first (node-parameters arg2)))) ) )
		   (make-node
		    '##core#call '(#t) 
		    (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) ) )

(rewrite
 'equal? 8
 (lambda (db classargs cont callargs)
   ;; (equal? <var> <var>) -> (quote #t)
   ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol]
   ;; (equal? ...) -> (##core#inline "C_i_equalp" ...)
   (and (= (length callargs) 2)
	(let ([arg1 (first callargs)]
	      [arg2 (second callargs)] )
	  (or (and (eq? '##core#variable (node-class arg1))
		   (eq? '##core#variable (node-class arg2))
		   (equal? (node-parameters arg1) (node-parameters arg2))
		   (make-node '##core#call '(#t) (list cont (qnode #t))) )
	      (and (or (and (eq? 'quote (node-class arg1))
			    (let ([f (first (node-parameters arg1))])
			      (or (immediate? f) (symbol? f)) ) )
		       (and (eq? 'quote (node-class arg2))
			    (let ([f (first (node-parameters arg2))])
			      (or (immediate? f) (symbol? f)) ) ) )
		   (make-node
		    '##core#call '(#t) 
		    (list cont (make-node '##core#inline '("C_eqp") callargs)) ) )
	      (make-node
	       '##core#call '(#t) 
	       (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )

(let ()
  (define (rewrite-apply db classargs cont callargs)
    ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...)
    ;; (apply ...) -> ((##core#proc "C_apply") ...)
    ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst)
    ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst)
    (and (pair? callargs)
	 (let ([lastarg (last callargs)]
	       [proc (car callargs)] )
	   (if (eq? 'quote (node-class lastarg))
	       (make-node
		'##core#call '(#f)
		(cons* (first callargs)
		       cont 
		       (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )
	       (or (and (eq? '##core#variable (node-class proc))
			(= 2 (length callargs))
			(let ([name (car (node-parameters proc))])
			  (and (memq name '(values ##sys#values))
			       (or (get db name 'standard-binding)
				   (get db name 'extended-binding) )
			       (make-node
				'##core#call '(#t)
				(list (make-node '##core#proc '("C_apply_values" #t) '())
				      cont
				      (cadr callargs) ) ) ) ) ) 
		   (make-node
		    '##core#call '(#t)
		    (cons* (make-node '##core#proc '("C_apply" #t) '())
			   cont callargs) ) ) ) ) ) )
  (rewrite 'apply 8 rewrite-apply)
  (rewrite '##sys#apply 8 rewrite-apply) )

(let ()
  (define (rewrite-c..r op iop1 iop2 index)
    (rewrite
     op 8
     (lambda (db classargs cont callargs)
       ;; (<op> <rest-vector>) -> (##core#inline "C_i_vector_ref"/"C_slot" <rest-vector> (quote <index>))
       ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe]
       ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe]
       (and (= (length callargs) 1)
	    (call-with-current-continuation
	     (lambda (return)
	       (let ([arg (first callargs)])
		 (make-node
		  '##core#call '(#t)
		  (list
		   cont
		   (cond [(and (eq? '##core#variable (node-class arg))
			       (eq? 'vector (get db (first (node-parameters arg)) 'rest-parameter)) )
			  (make-node
			   '##core#inline 
			   (if unsafe
			       '("C_slot")
			       '("C_i_vector_ref") )
			   (list arg (qnode index)) ) ]
			 [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]
			 [iop1 (make-node '##core#inline (list iop1) callargs)]
			 [else (return #f)] ) ) ) ) ) ) ) ) ) )

  (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0)
  (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr" 1)
  (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr" 2)
  (rewrite-c..r 'cadddr "C_i_cadddr" "C_u_i_cadddr" 3)
  (rewrite-c..r 'first "C_i_car" "C_u_i_car" 0)
  (rewrite-c..r 'second "C_i_cadr" "C_u_i_cadr" 1)
  (rewrite-c..r 'third "C_i_caddr" "C_u_i_caddr" 2)
  (rewrite-c..r 'fourth "C_i_cadddr" "C_u_i_cadddr" 3) )

(let ([rvalues
       (lambda (db classargs cont callargs)
	 ;; (values <x>) -> <x>
	 (and (= (length callargs) 1)
	      (make-node '##core#call '(#t) (cons cont callargs) ) ) ) ] )
  (rewrite 'values 8 rvalues)
  (rewrite '##sys#values 8 rvalues) )

(let ()
  (define (rewrite-c-w-v db classargs cont callargs)
   ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) (<var2> <k0> r)))) (<var1> k))
   ;; - if <var2> is a known lambda of a single argument
   (and (= 2 (length callargs))
	(let ((arg1 (car callargs))
	      (arg2 (cadr callargs)) )
	  (and (eq? '##core#variable (node-class arg1))	; probably not needed
	       (eq? '##core#variable (node-class arg2))
	       (and-let* ((sym (car (node-parameters arg2)))
			  (val (get db sym 'value)) )
		 (and (eq? '##core#lambda (node-class val))
		      (let ((llist (third (node-parameters val))))
			(and (proper-list? llist)
			     (= 2 (length (third (node-parameters val))))
			     (let ((tmp (gensym))
				   (tmpk (gensym 'r)) )
			       (debugging 'o "removing single-valued `call-with-values'" (node-parameters val))
			       (make-node
				'let (list tmp)
				(list (make-node
				       '##core#lambda
				       (list (gensym 'f_) #f (list tmpk) 0)
				       (list (make-node
					      '##core#call '(#t)
					      (list arg2 cont (varnode tmpk)) ) ) ) 
				      (make-node
				       '##core#call '(#t)
				       (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )
  (rewrite 'call-with-values 8 rewrite-c-w-v)
  (rewrite '##sys#call-with-values 8 rewrite-c-w-v) )

(rewrite 'values 13 "C_values" #t)
(rewrite '##sys#values 13 "C_values" #t)
(rewrite 'call-with-values 13 "C_u_call_with_values" #f)
(rewrite 'call-with-values 13 "C_call_with_values" #t)
(rewrite '##sys#call-with-values 13 "C_u_call_with_values" #f)
(rewrite '##sys#call-with-values 13 "C_call_with_values" #t)
(rewrite 'cpu-time 13 "C_cpu_time" #t)
(rewrite 'locative-ref 13 "C_locative_ref" #t)
(rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t)

(rewrite 'caar 2 1 "C_u_i_caar" #f #f)
(rewrite 'cdar 2 1 "C_u_i_cdar" #f #f)
(rewrite 'cddr 2 1 "C_u_i_cddr" #f #f)
(rewrite 'caaar 2 1 "C_u_i_caaar" #f #f)
(rewrite 'cadar 2 1 "C_u_i_cadar" #f #f)
(rewrite 'caddr 2 1 "C_u_i_caddr" #f #f)
(rewrite 'cdaar 2 1 "C_u_i_cdaar" #f #f)
(rewrite 'cdadr 2 1 "C_u_i_cdadr" #f #f)
(rewrite 'cddar 2 1 "C_u_i_cddar" #f #f)
(rewrite 'cdddr 2 1 "C_u_i_cdddr" #f #f)
(rewrite 'caaaar 2 1 "C_u_i_caaaar" #f #f)
(rewrite 'caadar 2 1 "C_u_i_caadar" #f #f)
(rewrite 'caaddr 2 1 "C_u_i_caaddr" #f #f)
(rewrite 'cadaar 2 1 "C_u_i_cadaar" #f #f)