~ chicken-core (chicken-5) 006bd0e45ef861f52e9846736fa943f439d8a2cd
commit 006bd0e45ef861f52e9846736fa943f439d8a2cd
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Aug 23 22:56:45 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Aug 23 22:56:45 2011 +0200
purity
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 284b6ddb..ec27c9dd 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1110,13 +1110,14 @@
'(##core#undefined)
(let* ((type1 (##sys#strip-syntax (caddr x)))
(name1 (cadr x)))
- (let-values (((type pred)
+ (let-values (((type pred pure)
(##compiler#validate-type type1 (##sys#strip-syntax name1))))
(cond ((not type)
(syntax-error ': "invalid type syntax" name1 type1))
(else
`(##core#declare
(type (,name1 ,type ,@(cdddr x)))
+ ,@(if pure `((pure ,name1)) '())
(enforce-argument-types ,name1)
,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
@@ -1225,7 +1226,7 @@
(if (and rtypes (pair? rtypes))
(list
(map (lambda (rt)
- (let-values (((t _)
+ (let-values (((t pred pure)
(##compiler#validate-type rt #f)))
(or t
(syntax-error
@@ -1250,7 +1251,8 @@
(cond ((symbol? arg)
(loop (cdr args) (cons arg anames) (cons '* atypes)))
((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg)))
- (let-values (((t _) (##compiler#validate-type (cadr arg) #f)))
+ (let-values (((t pred pure)
+ (##compiler#validate-type (cadr arg) #f)))
(if t
(loop
(cdr args)
diff --git a/compiler.scm b/compiler.scm
index 15f17f81..a73202e8 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1503,7 +1503,7 @@
(warning "illegal type declaration" (##sys#strip-syntax spec))
(let ((name (##sys#globalize (car spec) se))
(type (##sys#strip-syntax (cadr spec))))
- (let-values (((type pred) (validate-type type name)))
+ (let-values (((type pred pure) (validate-type type name)))
(cond (type
;; HACK: since `:' doesn't have access to the SE, we
;; fixup the procedure name if type is a named procedure type
@@ -1515,6 +1515,8 @@
(set-car! (cdr type) name))
(mark-variable name '##compiler#type type)
(mark-variable name '##compiler#declared-type)
+ (when pure
+ (mark-variable name '##compiler#pure #t))
(when pred
(mark-variable name '##compiler#predicate pred))
(when (pair? (cddr spec))
@@ -1532,7 +1534,7 @@
(cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
(let ((name (##sys#globalize (car spec) se))
(type (##sys#strip-syntax (cadr spec))))
- (let-values (((type pred) (validate-type type name)))
+ (let-values (((type pred pure) (validate-type type name)))
(if (and type (not pred))
(mark-variable name '##compiler#predicate type)
(warning "illegal `predicate' declaration" spec)))))
diff --git a/defaults.make b/defaults.make
index db4807aa..e37ad02b 100644
--- a/defaults.make
+++ b/defaults.make
@@ -272,7 +272,8 @@ CSI ?= csi$(EXE)
CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR) -inline -ignore-repository -feature chicken-bootstrap
ifdef DEBUGBUILD
-CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db -verbose
+#XXX CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db -verbose
+CHICKEN_OPTIONS += -feature debugbuild -verbose
else
CHICKEN_OPTIONS += -no-warnings
endif
diff --git a/manual/Types b/manual/Types
index 1144184e..2e2729fc 100644
--- a/manual/Types
+++ b/manual/Types
@@ -94,6 +94,7 @@ or {{:}} should follow the syntax given below:
<tr><td>{{(struct STRUCTURENAME)}}</td><td>record structure of given kind</td></tr>
<tr><td>{{(procedure [NAME] (VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]]) . RESULTS)}}</td><td>procedure type, optionally with name</td></tr>
<tr><td>{{(VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]] -> . RESULTS)}}</td><td>alternative procedure type syntax</td></tr>
+<tr><td>{{(VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]] --> . RESULTS)}}</td><td>procedure type that is declared as referentially transparent</td></tr>
<tr><td>{{(VALUETYPE -> VALUETYPE : VALUETYPE)}}</td><td>predicate procedure type</td></tr>
<tr><td>{{(forall (TYPEVAR ...) VALUETYPE)}}</td><td>polymorphic type</td></tr>
<tr><td>COMPLEXTYPE</td><td></td></tr>
@@ -179,6 +180,14 @@ procedure will be a predicate, i.e. it accepts a single argument of type
a true value if the argument is of type {{TYPE}} and false otherwise.
+==== Purity
+
+Procedure types are assumed to be not referentially transparent. Using
+the {{(... --> ...)}} syntax, you can declare a procedure to be referentially
+transparent, i.e. not causing any side-effects. This gives more opportunities
+for optimization but may not be violated or the results are undefined.
+
+
==== Using type information in extensions
Type information of declared toplevel variables can be used in client
diff --git a/scrutinizer.scm b/scrutinizer.scm
index f3fed28b..2bca6c09 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -729,7 +729,7 @@
r
(map (cut resolve <> typeenv) r)))))))
((##core#the)
- (let-values (((t _) (validate-type (first params) #f)))
+ (let-values (((t pred pure) (validate-type (first params) #f)))
(let ((rt (walk (first subs) e loc dest tail flow ctags)))
(cond ((eq? rt '*))
((null? rt)
@@ -1529,6 +1529,9 @@
;;; type-db processing
(define (load-type-database name #!optional (path (repository-path)))
+ (define (pure! name)
+ (when enable-specialization
+ (mark-variable name '##compiler#pure #t)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
(debugging 'p (sprintf "loading type database `~a' ...~%" dbfile))
(fluid-let ((scrutiny-debug #f))
@@ -1540,17 +1543,14 @@
(new
(let adjust ((new (cadr e)))
(if (pair? new)
- (cond ((and (list? (car new))
- (eq? 'procedure (caar new)))
+ (cond ((and (vector? (car new))
+ (eq? 'procedure (vector-ref new 0)))
;;XXX this format is not used yet:
- (let loop ((props (cdar new)))
+ (let loop ((props (cdr (vector->list (car new)))))
(unless (null? props)
(case (car props)
((pure)
- ;;XXX this overwrites a possibly existing 'standard/
- ;; 'extended mark - I don't know if this is
- ;; a problem
- (mark-variable name '##compiler#pure #t)
+ (pure! name)
(loop (cdr props)))
((enforce)
(mark-variable name '##compiler#enforce #t)
@@ -1561,7 +1561,7 @@
(else
(bomb
"load-type-database: invalid procedure-type property"
- (car props))))))
+ (car props) new)))))
`(procedure ,@(cdr new)))
(else ;XXX old style, remove at some stage
(case (car new)
@@ -1581,7 +1581,7 @@
new))))
;; validation is needed, even though .types-files can be considered
;; correct, because type variables have to be renamed:
- (let-values (((t _) (validate-type new name)))
+ (let-values (((t pred pure) (validate-type new name)))
(unless t
(warning "invalid type specification" name new))
(when (and old (not (compatible-types? old t)))
@@ -1607,6 +1607,7 @@
(let ((specs (or (variable-mark sym '##compiler#specializations) '()))
(type (variable-mark sym '##compiler#type))
(pred (variable-mark sym '##compiler#predicate))
+ (pure (variable-mark sym '##compiler#pure))
(enforce (variable-mark sym '##compiler#enforce)))
(pp (cons*
sym
@@ -1614,11 +1615,10 @@
(if (pair? type)
(case (car type)
((procedure)
- `(,(cond ((and enforce pred) 'procedure!?)
- (pred 'procedure?)
- (enforce 'procedure!)
- (else 'procedure))
- ,@(if pred (list pred) '())
+ `(#(procedure
+ ,@(if enforce '(enforce) '())
+ ,@(if pred `(predicate ,pred) '())
+ ,@(if pure '(pure) '()))
,@(cdr type)))
((forall)
`(forall ,(second type) ,(wrap (third type))))
@@ -1668,10 +1668,12 @@
;; - converts some typenames to struct types (u32vector, etc.)
;; - drops "#!key ..." args by converting to #!rest
;; - handles "(T1 -> T2 : T3)" (predicate)
+ ;; - handles "(T1 --> T2 [: T3])" (pure)
;; - simplifies result
;; - coalesces all "forall" forms into one (remove "forall" if typevar-set is empty)
;; - renames type-variables
(let ((ptype #f) ; (T . PT) | #f
+ (pure #f)
(usedvars '())
(typevars '()))
(define (upto lst p)
@@ -1735,22 +1737,26 @@
t))
((eq? 'deprecated (car t))
(and (= 2 (length t)) (symbol? (second t))))
- ((memq '-> t) =>
+ ((or (memq '--> t) (memq '-> t)) =>
(lambda (p)
- (let ((cp (memq ': (cdr p))))
- (cond ((not cp)
- (validate
- `(procedure ,(upto t p) ,@(cdr p))
- rec))
- ((and (= 5 (length t))
- (eq? p (cdr t))
- (eq? cp (cdddr t)))
- (set! t (validate `(procedure (,(first t)) ,(third t)) rec))
- ;; we do it this way to distinguish the "outermost" predicate
- ;; procedure type
- (set! ptype (cons t (validate (cadr cp))))
- t)
- (else #f)))))
+ (let* ((puref (eq? '--> (car p)))
+ (ok (or (not rec) (not puref))))
+ (set! pure puref)
+ (let ((cp (memq ': (cdr p))))
+ (cond ((not cp)
+ (and ok
+ (validate
+ `(procedure ,(upto t p) ,@(cdr p))
+ rec)))
+ ((and (= 5 (length t))
+ (eq? p (cdr t))
+ (eq? cp (cdddr t)))
+ (set! t (validate `(procedure (,(first t)) ,(third t)) rec))
+ ;; we do it this way to distinguish the "outermost" predicate
+ ;; procedure type
+ (set! ptype (cons t (validate (cadr cp))))
+ (and ok t))
+ (else #f))))))
((memq (car t) '(vector list))
(and (= 2 (length t))
(let ((t2 (validate (second t))))
@@ -1792,7 +1798,10 @@
(delete-duplicates typevars eq?))
,type)))
(let ((type (simplify-type type)))
- (values type (and ptype (eq? (car ptype) type) (cdr ptype))))))
+ (values
+ type
+ (and ptype (eq? (car ptype) type) (cdr ptype))
+ pure))))
(else (values #f #f)))))
(define (install-specializations name specs)
@@ -1814,7 +1823,7 @@
(if (and (list? spec) (list? (first spec)))
(let* ((args
(map (lambda (t)
- (let-values (((t2 _) (validate-type t #f)))
+ (let-values (((t2 pred pure) (validate-type t #f)))
(or t2
(error "invalid argument type in specialization"
t spec name))))
@@ -1828,7 +1837,7 @@
(cond ((list? (second spec))
(cons
(map (lambda (t)
- (let-values (((t2 _) (validate-type t #f)))
+ (let-values (((t2 pred pure) (validate-type t #f)))
(or t2
(error "invalid result type in specialization"
t spec name))))
Trap