~ chicken-core (chicken-5) b4d056ac344b69dee65a173e4d305276910819ef
commit b4d056ac344b69dee65a173e4d305276910819ef
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Apr 18 00:13:44 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Apr 18 00:13:44 2011 +0200
- added type-check routines for booleans and locatives
- changed all node-constructions in compiler to not use constant parameter lists
(or side-effecting one would create a shared side-effect - not sure if this can be
the case, but who knows...)
- -O5 enables -strict-types
- declared types generate type-checks at procedure entry, unless unsafe or strict-types
- specialization: assigned variables retain computed type if strict-types;
no blist-invalidation anymore; using declared procedure-argument types as initial
type-env entries for formal parameters; incompatible assignment to declared global
removes type marks; blist-entries for assigned vars only if strict-types; no
occurrance typing for assigned vars
diff --git a/c-platform.scm b/c-platform.scm
index 9946b65e..241e010d 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -169,7 +169,7 @@
'(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
- ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol
+ ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol ##sys#check-boolean
##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons
##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range?
##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
@@ -256,12 +256,12 @@
(and (eq? 'quote (node-class x))
(eq? 1 (first (node-parameters x))) ) )
callargs) ] )
- (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode 0)))]
+ (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode 0)))]
[(null? (cdr callargs))
- (make-node '##core#call '(#t) (list cont (first callargs))) ]
+ (make-node '##core#call (list #t) (list cont (first callargs))) ]
[(eq? number-type 'fixnum)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(fold-inner
@@ -284,7 +284,7 @@
(cond [(null? callargs) #f]
[(and (null? (cdr callargs)) (eq? number-type 'fixnum))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node '##core#inline
(if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))
@@ -300,7 +300,7 @@
(and (eq? number-type 'fixnum)
(>= (length callargs) 2)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(fold-inner
@@ -327,7 +327,7 @@
(and (eq? number-type 'fixnum)
(>= (length callargs) 2)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(fold-inner
@@ -346,7 +346,7 @@
(and (= (length callargs) 2)
(if (eq? 'fixnum number-type)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(let ([arg2 (second callargs)])
(list cont
(if (and (eq? 'quote (node-class arg2))
@@ -356,7 +356,7 @@
(list (first callargs) (qnode 1)) )
(make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) )
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) )
(let ()
@@ -369,7 +369,7 @@
(define ((op1 fiop ufiop aiop) db classargs cont callargs)
(and (= (length callargs) 1)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(if (eq? 'fixnum number-type)
@@ -390,13 +390,13 @@
(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))) )
+ (make-node '##core#call (list #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)
+ '##core#call (list #t)
(list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )
(rewrite 'eqv? 8 eqv?-id)
(rewrite '##sys#eqv? 8 eqv?-id))
@@ -413,7 +413,7 @@
(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))) )
+ (make-node '##core#call (list #t) (list cont (qnode #t))) )
(and (or (and (eq? 'quote (node-class arg1))
(let ([f (first (node-parameters arg1))])
(or (immediate? f) (symbol? f)) ) )
@@ -421,10 +421,10 @@
(let ([f (first (node-parameters arg2))])
(or (immediate? f) (symbol? f)) ) ) )
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont (make-node '##core#inline '("C_eqp") callargs)) ) )
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )
(let ()
@@ -438,7 +438,7 @@
[proc (car callargs)] )
(if (eq? 'quote (node-class lastarg))
(make-node
- '##core#call '(#f)
+ '##core#call (list #f)
(cons* (first callargs)
cont
(append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )
@@ -448,12 +448,12 @@
(and (memq name '(values ##sys#values))
(intrinsic? name)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list (make-node '##core#proc '("C_apply_values" #t) '())
cont
(cadr callargs) ) ) ) ) )
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(cons* (make-node '##core#proc '("C_apply" #t) '())
cont callargs) ) ) ) ) ) )
(rewrite 'apply 8 rewrite-apply)
@@ -472,7 +472,7 @@
(lambda (return)
(let ([arg (first callargs)])
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(cond [(and (eq? '##core#variable (node-class arg))
@@ -502,7 +502,7 @@
(lambda (db classargs cont callargs)
;; (values <x>) -> <x>
(and (= (length callargs) 1)
- (make-node '##core#call '(#t) (cons cont callargs) ) ) ) ] )
+ (make-node '##core#call (list #t) (cons cont callargs) ) ) ) ] )
(rewrite 'values 8 rvalues)
(rewrite '##sys#values 8 rvalues) )
@@ -530,10 +530,10 @@
'##core#lambda
(list (gensym 'f_) #f (list tmpk) 0)
(list (make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list arg2 cont (varnode tmpk)) ) ) )
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )
(rewrite 'call-with-values 8 rewrite-c-w-v)
(rewrite '##sys#call-with-values 8 rewrite-c-w-v) )
@@ -738,6 +738,8 @@
(rewrite '##sys#check-number 2 1 "C_i_check_number" #t)
(rewrite '##sys#check-list 2 1 "C_i_check_list" #t)
(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t)
+(rewrite '##sys#check-boolean 2 1 "C_i_check_boolean" #t)
+(rewrite '##sys#check-locative 2 1 "C_i_check_locative" #t)
(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t)
(rewrite '##sys#check-string 2 1 "C_i_check_string" #t)
(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t)
@@ -748,6 +750,8 @@
(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t)
(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t)
(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t)
+(rewrite '##sys#check-boolean 2 2 "C_i_check_boolean_2" #t)
+(rewrite '##sys#check-locative 2 2 "C_i_check_locative_2" #t)
(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t)
(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t)
(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t)
@@ -855,7 +859,7 @@
;; (string->number X Y) -> (##core#inline_allocate ("C_a_i_string_to_number" 4) X Y)
(define (build x y)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline_allocate
@@ -903,7 +907,7 @@
;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)
(and (= (length callargs) 3)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline
@@ -935,7 +939,7 @@
(and (= 2 (length callargs))
(let ([val (second callargs)])
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(or (and-let* ([(eq? 'quote (node-class val))]
[(eq? number-type 'fixnum)]
@@ -1049,7 +1053,7 @@
(list tmp)
(list val
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline_allocate
@@ -1079,7 +1083,7 @@
(not (get db var 'assigned))
(not (get db var 'inline-transient))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
(rewrite 'call-with-current-continuation 8 rewrite-call/cc)
(rewrite 'call/cc 8 rewrite-call/cc) )
@@ -1123,7 +1127,7 @@
(and (intrinsic? sym)
(and-let* ((a (assq sym setter-map)))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) )
(rewrite 'void 3 '##sys#undefined-value 0)
@@ -1139,7 +1143,7 @@
(and (= 1 (length callargs))
(let ((arg (car callargs)))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(if (and (eq? '##core#variable (node-class arg))
(not (get db (car (node-parameters arg)) 'global)) )
@@ -1153,7 +1157,7 @@
(lambda (db classargs cont callargs)
(and (= 2 (length callargs))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline
@@ -1176,7 +1180,7 @@
(lambda (db classargs cont callargs)
(and (= 3 (length callargs))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline_allocate
@@ -1197,7 +1201,7 @@
(list
(first callargs)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline_allocate
diff --git a/chicken.h b/chicken.h
index 00033d14..84bee82f 100644
--- a/chicken.h
+++ b/chicken.h
@@ -552,6 +552,8 @@ void *alloca ();
#define C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR 34
#define C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR 35
#define C_CIRCULAR_DATA_ERROR 36
+#define C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR 37
+#define C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR 38
/* Platform information */
@@ -1249,6 +1251,8 @@ extern double trunc(double);
#define C_i_check_symbol(x) C_i_check_symbol_2(x, C_SCHEME_FALSE)
#define C_i_check_list(x) C_i_check_list_2(x, C_SCHEME_FALSE)
#define C_i_check_pair(x) C_i_check_pair_2(x, C_SCHEME_FALSE)
+#define C_i_check_locative(x) C_i_check_locative_2(x, C_SCHEME_FALSE)
+#define C_i_check_boolean(x) C_i_check_boolean_2(x, C_SCHEME_FALSE)
#define C_i_check_vector(x) C_i_check_vector_2(x, C_SCHEME_FALSE)
#define C_i_check_structure(x, st) C_i_check_structure_2(x, (st), C_SCHEME_FALSE)
#define C_i_check_char(x) C_i_check_char_2(x, C_SCHEME_FALSE)
@@ -1745,6 +1749,8 @@ C_fctexport C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc) C_regpar
C_fctexport C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_list_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_pair_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_locative_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_char_2(C_word x, C_word loc) C_regparm;
diff --git a/chicken.scm b/chicken.scm
index 8c0147f0..27e3739b 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -121,6 +121,7 @@
'inline
'inline-global
'unboxing
+ 'strict-types
options) ) ) ) )
(loop (cdr rest)) ) )
((eq? 'debug-level o)
diff --git a/compiler.scm b/compiler.scm
index 065b58ba..07c50747 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1631,7 +1631,7 @@
'##core#lambda (list id #t (cons t1 llist) 0)
(list (walk (car subs)
(lambda (r)
- (make-node '##core#call '(#t) (list (varnode t1) r)) ) ) ) ) ) ) )
+ (make-node '##core#call (list #t) (list (varnode t1) r)) ) ) ) ) ) ) )
(define (walk n k)
(let ((subs (node-subexpressions n))
@@ -1641,7 +1641,7 @@
((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n))
((if) (let* ((t1 (gensym 'k))
(t2 (gensym 'r))
- (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
+ (k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
(make-node
'let
(list t1)
diff --git a/library.scm b/library.scm
index c764583c..48503eb0 100644
--- a/library.scm
+++ b/library.scm
@@ -304,6 +304,16 @@ EOF
(##core#inline "C_i_check_char_2" x (car loc))
(##core#inline "C_i_check_char" x) ) )
+(define (##sys#check-boolean x . loc)
+ (If (pair? loc)
+ (##core#inline "C_i_check_boolean_2" x (car loc))
+ (##core#inline "C_i_check_boolean" x) ) )
+
+(define (##sys#check-locative x . loc)
+ (If (pair? loc)
+ (##core#inline "C_i_check_locative_2" x (car loc))
+ (##core#inline "C_i_check_locative" x) ) )
+
(define (##sys#check-integer x . loc)
(unless (##core#inline "C_i_integerp" x)
(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
@@ -4041,6 +4051,8 @@ EOF
((34) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))
((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - invalid base" args))
((36) (apply ##sys#signal-hook #:limit-error loc "recursion too deep or circular data encountered" args))
+ ((37) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a boolean" args))
+ ((38) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a locative" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 8009358f..b9c0db45 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -128,7 +128,7 @@ the source text should be read from standard input.
-optimize-level 2 is equivalent to -optimize-leaf-routines -inline -unboxing
-optimize-level 3 is equivalent to -optimize-leaf-routines -local -inline -inline-global -unboxing -specialize
-optimize-level 4 is equivalent to -optimize-leaf-routines -local -inline -inline-global -unboxing -specialize -unsafe
- -optimize-level 5 is equivalent to -optimize-leaf-routines -block -inline -inline-global -unboxing -specialize -unsafe -disable-interrupts -no-trace -no-lambda-info
+ -optimize-level 5 is equivalent to -optimize-leaf-routines -block -inline -inline-global -unboxing -specialize -unsafe -disable-interrupts -no-trace -no-lambda-info -strict-types
; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.
@@ -157,7 +157,7 @@ the source text should be read from standard input.
; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
-; -strict-types : Assume that the type of variables does not change during their lifetime. This gives more type-information during specialization, but violating this assumption will result in unsafe and incorrectly behaving code.
+; -strict-types : Assume that the type of variables does not change because of assignments. This gives more type-information during specialization, but violating this assumption will result in unsafe and incorrectly behaving code.
; -types FILENAME : load additional type database from {{FILENAME}}. Type-definitions in {{FILENAME}} will override previous type-definitions.
diff --git a/optimizer.scm b/optimizer.scm
index dfb50d10..920d4e34 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -199,7 +199,7 @@
(let ((n2 (qnode result)))
(make-node
'##core#call
- '(#t)
+ (list #t)
(list (cadr subs) n2) ) ) ) )))
n1) )
n1) )
@@ -313,7 +313,7 @@
"removed call to pure procedure with unused result"
(or (source-info->string info) var)))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list k (make-node '##core#undefined '() '())) ) )
(walk-generic n class params subs fids)) ) )
((and lval
@@ -857,10 +857,10 @@
(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))) ) ) )
+ (make-node '##core#call (list #t) (list cont (qnode #t))) ) ) )
(and inline-substitutions-enabled
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
;; (<op> ...) -> (##core#inline <iop> ...)
@@ -872,7 +872,7 @@
(or (third classargs) unsafe)
(let ((arg1 (first callargs)))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(make-node '##core#inline (list (second classargs)) callargs) ) ) ) ) )
@@ -886,7 +886,7 @@
(fold-right
(lambda (val body)
(make-node 'let (list (gensym)) (list val body)) )
- (make-node '##core#call '(#t) (list cont (varnode (first classargs))))
+ (make-node '##core#call (list #t) (list cont (varnode (first classargs))))
callargs)))
;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
@@ -910,7 +910,7 @@
(= 1 (length callargs))
(let ((ntype (third classargs)))
(or (not ntype) (eq? ntype number-type)) )
- (make-node '##core#call '(#t)
+ (make-node '##core#call (list #t)
(list cont
(make-node '##core#inline (list (first classargs))
(list (first callargs)
@@ -922,7 +922,7 @@
inline-substitutions-enabled
(= 1 (length callargs))
(intrinsic? name)
- (make-node '##core#call '(#t)
+ (make-node '##core#call (list #t)
(list cont
(make-node '##core#inline (list (first classargs))
(list (make-node '##core#inline (list (second classargs))
@@ -934,7 +934,7 @@
inline-substitutions-enabled
(= (length callargs) (first classargs))
(intrinsic? name)
- (make-node '##core#call '(#t)
+ (make-node '##core#call (list #t)
(list cont
(make-node '##core#inline (list (second classargs))
(append callargs
@@ -952,7 +952,7 @@
(and inline-substitutions-enabled
(intrinsic? name)
(if (< (length callargs) 2)
- (make-node '##core#call '(#t) (list cont (qnode #t)))
+ (make-node '##core#call (list #t) (list cont (qnode #t)))
(and (or (and unsafe (not (eq? number-type 'generic)))
(and (eq? number-type 'fixnum) (third classargs))
(and (eq? number-type 'flonum) (fourth classargs)) )
@@ -961,7 +961,7 @@
(fold-right
(lambda (x n y) (make-node 'let (list n) (list x y)))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(let ([op (list
@@ -1012,7 +1012,7 @@
(let ((n (length callargs)))
(and (<= n (third classargs))
(case n
- ((1) (make-node '##core#call '(#t) (cons cont callargs)))
+ ((1) (make-node '##core#call (list #t) (cons cont callargs)))
(else (make-node '##core#call (list #t (first classargs))
(cons* (varnode (first classargs))
cont callargs) ) ) ) ) ) ) )
@@ -1035,7 +1035,7 @@
(eq? number-type (first classargs))
(or (fourth classargs) unsafe)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline
@@ -1053,7 +1053,7 @@
(make-node '##core#call (list #t (third classargs))
(cons* (varnode (third classargs)) cont callargs) ) )
((eq? number-type (second classargs))
- (make-node '##core#call '(#t) (cons cont callargs)) )
+ (make-node '##core#call (list #t) (cons cont callargs)) )
(else #f) ) ) )
;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
@@ -1080,7 +1080,7 @@
unchecked-specialized-arithmetic
safe))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline_allocate
@@ -1098,7 +1098,7 @@
(= (length callargs) (first classargs))
(intrinsic? name)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node '##core#inline
(list (if (and unsafe (pair? (cddr classargs)))
@@ -1111,7 +1111,7 @@
(and inline-substitutions-enabled
(null? callargs)
(intrinsic? name)
- (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )
+ (make-node '##core#call (list #t) (list cont (qnode (first classargs))) ) ) )
;; (<op>) -> <id>
;; (<op> <x>) -> <x>
@@ -1129,12 +1129,12 @@
(and (eq? 'quote (node-class x))
(eq? id (first (node-parameters x))) ) )
callargs) ] )
- (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
+ (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode id)))]
[(null? (cdr callargs))
- (make-node '##core#call '(#t) (list cont (first callargs))) ]
+ (make-node '##core#call (list #t) (list cont (first callargs))) ]
[(or (fourth classargs) (eq? number-type 'fixnum))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(fold-inner
@@ -1151,7 +1151,7 @@
(= n (first classargs))
(intrinsic? name)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(make-node
'##core#inline (list (second classargs))
@@ -1178,12 +1178,12 @@
(and (eq? 'quote (node-class x))
(eq? id (first (node-parameters x))) ) )
callargs) ] )
- (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
+ (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode id)))]
[(null? (cdr callargs))
- (make-node '##core#call '(#t) (list cont (first callargs))) ]
+ (make-node '##core#call (list #t) (list cont (first callargs))) ]
[else
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list
cont
(fold-inner
@@ -1204,7 +1204,7 @@
(intrinsic? name)
(or (third classargs) unsafe)
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list cont
(if (eq? number-type 'fixnum)
(make-node
diff --git a/runtime.c b/runtime.c
index 880eda19..9ebac8ed 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1515,6 +1515,16 @@ void barf(int code, char *loc, ...)
c = 1;
break;
+ case C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR:
+ msg = C_text("bad argument type - not a boolean");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR:
+ msg = C_text("bad argument type - not a locative");
+ c = 1;
+ break;
+
case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:
msg = C_text("bad argument type - not a list");
c = 1;
@@ -5541,6 +5551,28 @@ C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
}
+C_regparm C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc)
+{
+ if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_locative_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
{
if(C_immediatep(x) || C_block_header(x) != C_SYMBOL_TAG) {
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 12d38aa7..9a42840d 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -28,8 +28,8 @@
(unit scrutinizer)
(hide match-specialization specialize-node! specialization-statistics
procedure-type? named? procedure-result-types procedure-argument-types
- noreturn-type? rest-type procedure-name d-depth
- compatible-types? type<=?))
+ noreturn-type? rest-type procedure-name d-depth generate-type-checks!
+ compatible-types? type<=? initial-argument-types))
(include "compiler-namespace")
@@ -82,9 +82,6 @@
; | INTEGER | SYMBOL | STRING
; | (quote CONSTANT)
; | (TEMPLATE . TEMPLATE)
-;
-; - (not number) succeeds for fixnum and flonum
-; - (not list) succeeds for pair and null
(define-constant +fragment-max-length+ 5)
@@ -154,7 +151,8 @@
(define (variable-result id e loc flow)
(cond ((blist-type id flow) => list)
- ((and (get db id 'assigned)
+ ((and (not strict-variable-types)
+ (get db id 'assigned)
(not (variable-mark id '##compiler#declared-type)))
'(*))
((assq id e) =>
@@ -564,18 +562,6 @@
(set! n (add1 n))
n)))
- (define (invalidate-blist)
- (for-each
- (lambda (b)
- (let ((var (caar b)))
- (when (and (get db var 'assigned)
- ;; if it has a known value, then it only assigned once
- (or (get db var 'unknown)
- (not (get db var 'value))))
- (dd "invalidating: ~a" b)
- (set-cdr! b '*))))
- blist))
-
(define (walk n e loc dest tail flow ctags) ; returns result specifier
(let ((subs (node-subexpressions n))
(params (node-parameters n))
@@ -625,17 +611,26 @@
(first params)
(lambda (vars argc rest)
(let* ((namelst (if dest (list dest) '()))
- (args (append (make-list argc '*) (if rest '(#!rest) '())))
- (e2 (append (map (lambda (v) (cons v '*))
- (if rest (butlast vars) vars))
+ (inits (initial-argument-types dest vars argc))
+ (args (append inits (if rest '(#!rest) '())))
+ (e2 (append (map (lambda (v i) (cons v i))
+ (if rest (butlast vars) vars)
+ inits)
e)))
+ (when dest
+ (d "~a: initial-argument types: ~a" dest inits))
(fluid-let ((blist '()))
(let* ((initial-tag (tag))
(r (walk (first subs)
(if rest (alist-cons rest 'list e2) e2)
(add-loc dest loc)
#f #t (list initial-tag) #f)))
- (list
+ (when (and specialize
+ dest
+ (not strict-variable-types)
+ (not unsafe))
+ (generate-type-checks! n dest vars inits))
+ (list
(append
'(procedure)
namelst
@@ -643,7 +638,7 @@
(let loop ((argc argc) (vars vars) (args args))
(cond ((zero? argc) args)
((and (not (get db (car vars) 'assigned))
- (assoc (cons (car vars) initial-tag) blist))
+ (assoc (cons (car vars) initial-tag) blist))
=>
(lambda (a)
(cons
@@ -674,7 +669,8 @@
(sprintf
"assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
rt var type)
- #t))
+ #t)
+ (mark-variable var '##compiler#type #f))
(when (and (not type)
(not b)
(not (eq? '* rt))
@@ -697,7 +693,8 @@
"variable `~a' of type `~a' was modified to a value of type `~a'"
var ot rt)
#t)))))
- (set! blist (alist-cons (cons var (car flow)) rt blist)))
+ (when strict-variable-types
+ (set! blist (alist-cons (cons var (car flow)) rt blist))))
'(undefined)))
((##core#primitive ##core#inline_ref) '*)
((##core#call)
@@ -719,15 +716,13 @@
(enforces (and pn (variable-mark pn '##compiler#enforce-argument-types)))
(pt (and pn (variable-mark pn '##compiler#predicate))))
(let ((r (call-result n args e loc params)))
- (unless strict-variable-types
- (invalidate-blist))
(for-each
(lambda (arg argr)
(when (eq? '##core#variable (node-class arg))
(let* ((var (first (node-parameters arg)))
(a (assq var e))
(oparg? (eq? arg (first subs)))
- (pred (and pt ctags (not oparg?))))
+ (pred (and pt ctags (not (get db var 'assigned)) (not oparg?))))
(cond (pred
(d " predicate `~a' indicates `~a' is ~a in flow ~a" pn var pt
(car ctags))
@@ -762,7 +757,7 @@
(dd " hardcoded special case: ~a" var)
(set! r (srt n r))))))))
subs
- (cons fn (procedure-argument-types fn (sub1 len))))
+ (cons fn (nth-value 0 (procedure-argument-types fn (sub1 len)))))
r)))
((##core#switch ##core#cond)
(bomb "unexpected node class: ~a" class))
@@ -845,7 +840,7 @@
((symbol? n) n)
(else #f)))))
-(define (procedure-argument-types t n)
+(define (procedure-argument-types t n #!optional norest)
(cond ((or (memq t '(* procedure))
(not-pair? t)
(eq? 'deprecated (car t)))
@@ -859,11 +854,15 @@
(m n)
(opt #f))
(cond ((null? at) '())
- ((eq? '#!optional (car at))
- (loop (cdr at) m #t) )
+ ((eq? '#!optional (car at))
+ (if norest
+ '()
+ (loop (cdr at) m #t) ))
((eq? '#!rest (car at))
- (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))
- (make-list m (rest-type (cdr at))))
+ (cond (norest '())
+ (else
+ (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))
+ (make-list m (rest-type (cdr at))))))
((and opt (<= m 0)) '())
(else (cons (car at) (loop (cdr at) (sub1 m) opt)))))))
(values llist vf)))
@@ -925,7 +924,7 @@
(when (and old (not (equal? old new)))
(##sys#notice
(sprintf
- "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
+ "type-deifnition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
name new old)))
(mark-variable name '##compiler#type new)
(when specs
@@ -1067,14 +1066,79 @@
(else #f)))
(validate type))
+(define (initial-argument-types dest vars argc)
+ (if (and dest (variable-mark dest '##compiler#declared-type))
+ (let ((ptype (variable-mark dest '##compiler#type)))
+ (if (procedure-type? ptype)
+ (nth-value 0 (procedure-argument-types ptype argc #t))
+ (make-list argc '*)))
+ (make-list argc '*)))
+
+
+;;; generate type-checks for formal variables
+
+(define (generate-type-checks! node loc vars inits)
+ (let ((body (first (node-subexpressions node))))
+ (let loop ((vars (reverse vars)) (inits (reverse inits)) (b body))
+ (cond ((null? inits)
+ (if (eq? b body)
+ body
+ (copy-node!
+ (make-node
+ (node-class node) ; lambda
+ (node-parameters node)
+ (list b))
+ node)))
+ ((eq? '* (car inits))
+ (loop (cdr vars) (cdr inits) b))
+ (else
+ (loop
+ (cdr vars)
+ (cdr inits)
+ (make-node
+ 'let (list (gensym))
+ (list
+ (build-node-graph
+ (let ((t (car inits))
+ (v (car vars)))
+ (case t
+ ((null) `(if (not (null? ,v))
+ (##core#app ##sys#error ',loc "bad argument type - not null" v)))
+ ((eof) `(if (not (eof-object? ,v))
+ (##core#app ##sys#error ',loc "bad argument type - not eof" v)))
+ ((string) `(##core#app ##sys#check-string ,v ',loc))
+ ((fixnum) `(##core#app ##sys#check-exact ,v ',loc))
+ ((float) `(##core#app ##sys#check-inexact ,v ',loc))
+ ((char) `(##core#app ##sys#check-char ,v ',loc))
+ ((number) `(##core#app ##sys#check-number ,v ',loc))
+ ((list) `(##core#app ##sys#check-list ,v ',loc))
+ ((symbol) `(##core#app ##sys#check-symbol ,v ',loc))
+ ((pair) `(##core#app ##sys#check-pair ,v ',loc))
+ ((boolean) `(##core#app ##sys#check-boolean ,v ',loc))
+ ((procedure) `(##core#app ##sys#check-closure ,v ',loc))
+ ((vector) `(##core#app ##sys#check-vector ,v ',loc))
+ ((pointer) `(##core#app ##sys#check-pointer ,v ',loc))
+ ((blob) `(##core#app ##sys#check-blob ,v ',loc))
+ ((locative) `(##core#app ##sys#check-locative ,v ',loc))
+ ((port) `(##core#app ##sys#check-port ,v ',loc))
+ ((pointer-vector) `(##core#app ##sys#check-structure ,v 'pointer-vector ',loc))
+ (else
+ (if (pair? t)
+ (case (car t)
+ ((procedure) `(##core#app ##sys#check-closure ,v ',loc))
+ ((struct) `(##core#app ##sys#check-structure ,v ',(cadr t) ',loc))
+ (else (bomb "can not generate type-check for `~a'" t)))
+ (bomb "can not generate type-check for `~a'" t))))))
+ b))))))))
+
+
+;;; hardcoded result types for certain primitives
+
(define-syntax define-special-case
(syntax-rules ()
((_ name handler)
(##sys#put! 'name '##compiler#special-result-type handler))))
-
-;;; hardcoded result types for certain primitives
-
(define-special-case ##sys#make-structure
(lambda (node rtypes)
(or (let ((subs (node-subexpressions node)))
diff --git a/support.scm b/support.scm
index 0d8c01a9..c04e0e6f 100644
--- a/support.scm
+++ b/support.scm
@@ -528,7 +528,7 @@
##core#inline_loc_ref ##core#inline_loc_update)
(make-node (first x) (second x) (map walk (cddr x))) )
((##core#app)
- (make-node '##core#call '(#t) (map walk (cdr x))) )
+ (make-node '##core#call (list #t) (map walk (cdr x))) )
(else
(receive (name ln) (get-line-2 x)
(make-node
@@ -543,7 +543,7 @@
(or rn (##sys#symbol->qualified-string name))) )
(##sys#symbol->qualified-string name) ) )
(map walk x) ) ) ) ) )
- (else (make-node '##core#call '(#f) (map walk x))) ) )
+ (else (make-node '##core#call (list #f) (map walk x))) ) )
(let ([exp2 (walk exp)])
(when (positive? count)
(debugging 'o "eliminated procedure checks" count))
Trap