From 2ae62c5f09f1eb37609a9316a03d52b20d6d3ffd Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Sun, 22 Mar 2015 15:25:49 +1300 Subject: [PATCH] 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. --- c-platform.scm | 53 +++++++++++++++++++++++++++-------------------------- optimizer.scm | 18 ++++++++++++++---- 2 files changed, 41 insertions(+), 30 deletions(-) diff --git a/c-platform.scm b/c-platform.scm index 1d60dcd..98eb99c 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 fb41191..d0d00c4 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) ) ) ) ) ) ) ) ;; ( ...) -> ((##core#proc ) ...) - ((13) ; classargs = ( ) + ((13) ; classargs = ( ) + ;; - 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) ) ) ) ) -- 2.1.4