~ chicken-core (chicken-5) 2b89724d5654b3a729b06c8a3fb95f16cf304101
commit 2b89724d5654b3a729b06c8a3fb95f16cf304101
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Mar 22 15:25:49 2015 +1300
Commit: Moritz Heidkamp <moritz.heidkamp@bevuta.com>
CommitDate: Tue Mar 31 17:33:15 2015 +0200
Add arity checks for ##core#proc-class platform rewrites
This prevents the c-backend from producing code containing invalid C
procedure calls when a Scheme procedure with a ##core#proc (class 13)
rewrite is invoked with the wrong number of arguments.
Signed-off-by: Moritz Heidkamp <moritz.heidkamp@bevuta.com>
diff --git a/c-platform.scm b/c-platform.scm
index 1d60dcd1..98eb99cf 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -538,14 +538,14 @@
(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 'locative-ref 13 "C_locative_ref" #t)
-(rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t)
+(rewrite 'values 13 #f "C_values" #t)
+(rewrite '##sys#values 13 #f "C_values" #t)
+(rewrite 'call-with-values 13 2 "C_u_call_with_values" #f)
+(rewrite 'call-with-values 13 2 "C_call_with_values" #t)
+(rewrite '##sys#call-with-values 13 2 "C_u_call_with_values" #f)
+(rewrite '##sys#call-with-values 13 2 "C_call_with_values" #t)
+(rewrite 'locative-ref 13 1 "C_locative_ref" #t)
+(rewrite '##sys#continuation-graft 13 2 "C_continuation_graft" #t)
(rewrite 'caar 2 1 "C_u_i_caar" #f)
(rewrite 'cdar 2 1 "C_u_i_cdar" #f)
@@ -800,24 +800,25 @@
(rewrite '>= 17 2 "C_i_greater_or_equalp")
(rewrite '<= 17 2 "C_i_less_or_equalp")
-(rewrite '* 13 "C_times" #t)
-(rewrite '- 13 "C_minus" #t)
-(rewrite '+ 13 "C_plus" #t)
-(rewrite '/ 13 "C_divide" #t)
-(rewrite '= 13 "C_nequalp" #t)
-(rewrite '> 13 "C_greaterp" #t)
-(rewrite '< 13 "C_lessp" #t)
-(rewrite '>= 13 "C_greater_or_equal_p" #t)
-(rewrite '<= 13 "C_less_or_equal_p" #t)
-
-(rewrite 'number->string 13 "C_number_to_string" #t)
-(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t)
-(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t)
-(rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t)
-(rewrite 'return-to-host 13 "C_return_to_host" #t)
-(rewrite '##sys#context-switch 13 "C_context_switch" #t)
-(rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t)
-(rewrite '##sys#make-symbol 13 "C_make_symbol" #t)
+(rewrite '= 13 #f "C_nequalp" #t)
+(rewrite '> 13 #f "C_greaterp" #t)
+(rewrite '< 13 #f "C_lessp" #t)
+(rewrite '>= 13 #f "C_greater_or_equal_p" #t)
+(rewrite '<= 13 #f "C_less_or_equal_p" #t)
+
+(rewrite '* 13 #f "C_times" #t)
+(rewrite '+ 13 #f "C_plus" #t)
+(rewrite '/ 13 '(1 . #f) "C_divide" #t)
+(rewrite '- 13 '(1 . #f) "C_minus" #t)
+
+(rewrite 'number->string 13 '(1 . 2) "C_number_to_string" #t)
+(rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t)
+(rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t)
+(rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t)
+(rewrite 'return-to-host 13 0 "C_return_to_host" #t)
+(rewrite '##sys#context-switch 13 1 "C_context_switch" #t)
+(rewrite '##sys#intern-symbol 13 1 "C_string_to_symbol" #t)
+(rewrite '##sys#make-symbol 13 1 "C_make_symbol" #t)
(rewrite 'even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")
(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
diff --git a/optimizer.scm b/optimizer.scm
index fb411914..d0d00c4b 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -917,7 +917,15 @@
(##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
(define (simplify-named-call db params name cont class classargs callargs)
- (define (test sym prop) (get db sym prop))
+
+ (define (argc-ok? argc)
+ (or (not argc)
+ (and (fixnum? argc)
+ (fx= argc (length callargs)))
+ (and (pair? argc)
+ (argc-ok? (car argc))
+ (argc-ok? (cdr argc)))))
+
(define (defarg x)
(cond ((symbol? x) (varnode x))
((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
@@ -1096,11 +1104,13 @@
cont callargs) ) ) ) ) ) ) )
;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
- ((13) ; classargs = (<primitiveop> <safe>)
+ ((13) ; classargs = (<argc> <primitiveop> <safe>)
+ ;; - <argc> may be #f for any number of args, or a pair specifying a range
(and inline-substitutions-enabled
(intrinsic? name)
- (or (second classargs) unsafe)
- (let ((pname (first classargs)))
+ (or (third classargs) unsafe)
+ (argc-ok? (first classargs))
+ (let ((pname (second classargs)))
(make-node '##core#call (if (pair? params) (cons #t (cdr params)) params)
(cons* (make-node '##core#proc (list pname #t) '())
cont callargs) ) ) ) )
Trap