From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Stefan Israelsson Tampe Newsgroups: gmane.lisp.guile.devel Subject: Special variables to relax boxing Date: Tue, 19 Mar 2013 23:05:52 +0100 Message-ID: <3101921.Ei70kTLzB2@warperdoze> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="nextPart3910070.69VcXdEC65" Content-Transfer-Encoding: 7Bit X-Trace: ger.gmane.org 1363730767 18156 80.91.229.3 (19 Mar 2013 22:06:07 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 19 Mar 2013 22:06:07 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Mar 19 23:06:33 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UI4fw-0001fE-P1 for guile-devel@m.gmane.org; Tue, 19 Mar 2013 23:06:33 +0100 Original-Received: from localhost ([::1]:51609 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UI4fZ-0001Bw-Kh for guile-devel@m.gmane.org; Tue, 19 Mar 2013 18:06:09 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:36327) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UI4fR-0001Bo-T4 for guile-devel@gnu.org; Tue, 19 Mar 2013 18:06:07 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UI4fP-0006ny-Fg for guile-devel@gnu.org; Tue, 19 Mar 2013 18:06:01 -0400 Original-Received: from mail-la0-x230.google.com ([2a00:1450:4010:c03::230]:60467) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UI4fO-0006nb-KL for guile-devel@gnu.org; Tue, 19 Mar 2013 18:05:59 -0400 Original-Received: by mail-la0-f48.google.com with SMTP id fq13so1899811lab.7 for ; Tue, 19 Mar 2013 15:05:57 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=x-received:from:to:subject:date:message-id:user-agent:mime-version :content-type:content-transfer-encoding; bh=9H/gIJuDviR88DLCDq/vFi5OP1pATWswvlMlmxXCE7A=; b=hwGdYzFDci2OAmOunJ1Nu+7rGo3ZczNs9B8OW8fIrjZi/gLhUSp4xf4gtaQBqkzwRB qwBXHiOpqOPSCxNetAZAVmRMMDSz3RK8Zj/GtJmC6QabZDxpc7wtlHwjZyFevsom86xM UQQpz0TfjKom6ZPNde6rJ5Mjicxx/JW4DbnkDsCIEGzTAoEW0+/LkA39PNGH4F0C3J19 eEWvPbLL8HVAdI+jw2nwYoXEFJxjhfmC7R/3LS33NJtnhV8xoB6pqGbo5XpYWWKhRLK9 5+BHgLLwmrqK1QH30Id5DjhaJvSMfX0wKz+0IMV0bUFgkfdgdzGTTLcy8ndRMALpR1dm fdeg== X-Received: by 10.152.110.6 with SMTP id hw6mr3453381lab.43.1363730757643; Tue, 19 Mar 2013 15:05:57 -0700 (PDT) Original-Received: from warperdoze.localnet (1-1-1-39a.veo.vs.bostream.se. [82.182.254.46]) by mx.google.com with ESMTPS id hk10sm11739680lab.4.2013.03.19.15.05.55 (version=TLSv1.1 cipher=ECDHE-RSA-RC4-SHA bits=128/128); Tue, 19 Mar 2013 15:05:56 -0700 (PDT) User-Agent: KMail/4.9.5 (Linux/3.5.0-25-generic; KDE/4.9.5; x86_64; ; ) X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2a00:1450:4010:c03::230 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:15934 Archived-At: This is a multi-part message in MIME format. --nextPart3910070.69VcXdEC65 Content-Transfer-Encoding: 7Bit Content-Type: text/plain; charset="us-ascii" Hi, I wouldl like to start a discussion of introducing a way to mark variables as special, and by that mean that set! variables does not nessesary get boxed. This is a deviation from the scheme standard but it's pretty useful if one want to set! local variables but make sure that the state of the function can be stored in a continuation and later restart at the same state. This patch introduces a macro (mark-as-special var), this will mark var as a special variable in the above meaning, please look at the example in special.scm for more info. There is a preleminary patch following the document against stable-2.0 that we can use as a discussion point for know about this feature. Best Greetings Stefan --nextPart3910070.69VcXdEC65 Content-Disposition: attachment; filename="special.scm" Content-Transfer-Encoding: 7Bit Content-Type: text/x-scheme; charset="UTF-8"; name="special.scm" (use-modules (system vm special-variable)) ;; This makes sure to treat s special and not box it (define (g x) (let ((s 0)) (mark-as-special s) (let lp ((i 0)) (if (< i 10000000) (begin (set! s (+ i s)) (lp (+ i 1))) s)))) #| ,x g 0 (assert-nargs-ee/locals 17) ;; 1 arg, 2 locals 2 (make-int8:0) ;; 0 3 (local-set 1) ;; `s' 5 (new-frame) 6 (toplevel-ref 1) ;; `((system vm special-variable) special #f)' 8 (local-ref 1) ;; `s' 10 (mv-call 1 :L583) ;; MV -> 20 15 (drop) 16 (br :L584) ;; -> 23 20 (truncate-values 0 0) 23 (br :L585) ;; -> 56 27 (local-ref 2) ;; `i' 29 (make-int16 3 232) ;; 1000 32 (lt?) 33 (br-if-not :L586) ;; -> 53 37 (local-ref 2) ;; `i' 39 (local-ref 1) ;; `s' 41 (add) 42 (local-set 1) ;; `s' 44 (local-ref 2) ;; `i' 46 (add1) 47 (local-set 2) ;; `i' 49 (br :L587) ;; -> 27 53 (local-ref 1) ;; `s' 55 (return) 56 (make-int8:0) ;; 0 57 (local-set 2) 59 (br :L587) ;; -> 27 |# ;; This makes sure to treat s as special but we cannot box it because it's ;; referenced in closure, set! + closure = boxed (define (g2 x) (let ((s 0)) (mark-as-special s) (let lp ((i 0)) (if (< i 10000000) (begin (set! s (+ i s)) (lp (+ i 1))) (lambda () s))))) #| 0 (assert-nargs-ee/locals 17) ;; 1 arg, 2 locals 2 (make-int8:0) ;; 0 at /home/stis/src/special.scm:45:2 3 (box 1) 5 (new-frame) at /home/stis/src/special.scm:46:4 6 (toplevel-ref 1) ;; `((system vm special-variable) special #f)' 8 (local-boxed-ref 1) ;; `s' 10 (mv-call 1 :L824) ;; MV -> 20 15 (drop) 16 (br :L825) ;; -> 23 20 (truncate-values 0 0) 23 (br :L826) ;; -> 67 at /home/stis/src/special.scm:47:4 27 (local-ref 2) ;; `i' 29 (make-uint64 0 0 0 0 0 152 150 128);; 10000000 38 (lt?) at /home/stis/src/special.scm:48:10 39 (br-if-not :L827) ;; -> 59 at /home/stis/src/special.scm:48:6 43 (local-ref 2) ;; `i' 45 (local-boxed-ref 1) ;; `s' 47 (add) at /home/stis/src/special.scm:49:25 48 (local-boxed-set 1) ;; `s' at /home/stis/src/special.scm:49:17 50 (local-ref 2) ;; `i' 52 (add1) at /home/stis/src/special.scm:50:21 53 (local-set 2) ;; `i' 55 (br :L828) ;; -> 27 at /home/stis/src/special.scm:50:17 59 (object-ref 2) ;; # 61 (local-ref 1) ;; `s' 63 (make-closure 0 1) 66 (return) at /home/stis/src/special.scm:47:4 67 (make-int8:0) ;; 0 68 (local-set 2) 70 (br :L828) ;; -> 27 |# --nextPart3910070.69VcXdEC65 Content-Disposition: attachment; filename="special.diff" Content-Transfer-Encoding: 7Bit Content-Type: text/x-patch; charset="UTF-8"; name="special.diff" diff --git a/module/Makefile.am b/module/Makefile.am index c47d0b4..b07c342 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -101,6 +101,7 @@ SCHEME_LANG_SOURCES = \ language/scheme/decompile-tree-il.scm TREE_IL_LANG_SOURCES = \ + language/tree-il/special.scm \ language/tree-il/primitives.scm \ language/tree-il/effects.scm \ language/tree-il/fix-letrec.scm \ @@ -337,6 +338,7 @@ OOP_SOURCES = \ oop/goops/simple.scm SYSTEM_SOURCES = \ + system/vm/special-variable.scm \ system/vm/inspect.scm \ system/vm/coverage.scm \ system/vm/frame.scm \ diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index badce9f..50d64b8 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -151,7 +151,7 @@ (hashq-set! res k v) res)) -(define (analyze-lexicals x) +(define* (analyze-lexicals x #:optional (special-vars #f)) ;; bound-vars: lambda -> (sym ...) ;; all identifiers bound within a lambda (define bound-vars (make-hash-table)) @@ -159,6 +159,9 @@ ;; all identifiers referenced in a lambda, but not bound ;; NB, this includes identifiers referenced by contained lambdas (define free-vars (make-hash-table)) + ;; free-syms: sym -> #t + ;; All variables that is free with respect to a lambda. + (define free-syms (make-hash-table)) ;; assigned: sym -> #t ;; variables that are assigned (define assigned (make-hash-table)) @@ -180,7 +183,7 @@ (analyze! x new-proc (append labels labels-in-proc) #t #f)) (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) (record-case x - (( proc args) + (( proc args) (apply lset-union eq? (step-tail-call proc args) (map step args))) @@ -236,6 +239,9 @@ (let ((free (recur body x))) (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) + (for-each (lambda (var) + (hashq-set! free-syms var #t)) + free) free)) (( opt kw inits gensyms body alternate) @@ -286,7 +292,8 @@ ;; recur/labels instead of recur (hashq-set! bound-vars x '()) (let ((free (recur/labels body x gensyms))) - (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) + (hashq-set! bound-vars x + (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) free)))) vals)) @@ -330,7 +337,11 @@ (append (hashq-ref bound-vars val) (hashq-ref bound-vars proc))) (hashq-remove! bound-vars val) - (hashq-remove! free-vars val)))) + (hashq-remove! free-vars val)) + ;; Else we will allocate a closure; register the free-syms + (for-each (lambda (sym) + (hashq-set! free-syms sym #t)) + (hashq-ref free-vars val)))) gensyms vals) (lset-difference eq? (apply lset-union eq? body-refs var-refs) @@ -395,7 +406,12 @@ (begin (hashq-set! (hashq-ref allocation (car c)) x - `(#f ,(hashq-ref assigned (car c)) . ,n)) + `(#f ,(and (hashq-ref assigned (car c)) + (not (and special-vars + (hashq-ref special-vars (car c)) + (not (hashq-ref free-syms + (car c)))))) + . ,n)) (lp (cdr c) (1+ n))))) (let ((nlocs (allocate! body x 0)) @@ -427,7 +443,15 @@ (begin (hashq-set! allocation (car gensyms) (make-hashq - proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n))) + proc `(#t + ,(and (hashq-ref assigned (car gensyms)) + (not (and special-vars + (hashq-ref special-vars + (car gensyms)) + (not (hashq-ref + free-syms + (car gensyms)))))) + . ,n))) (lp (cdr gensyms) (1+ n))))) (if alternate (allocate! alternate proc n) n))) @@ -456,7 +480,12 @@ (hashq-set! allocation v (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) + `(#t ,(and (hashq-ref assigned v) + (not (and special-vars + (hashq-ref special-vars v) + (not (hashq-ref free-syms + v))))) + . ,n))) (lp (cdr gensyms) (1+ n))))))))) (( gensyms vals body) @@ -471,7 +500,12 @@ (hashq-set! allocation v (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) + `(#t ,(and (hashq-ref assigned v) + (not (and special-vars + (hashq-ref special-vars v) + (not (hashq-ref free-syms + v))))) + . ,n))) (lp (cdr gensyms) (1+ n)))))) (( gensyms vals body) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e4df6e1..7321fb1 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -29,6 +29,7 @@ #:use-module (language tree-il optimize) #:use-module (language tree-il canonicalize) #:use-module (language tree-il analyze) + #:use-module (language tree-il special) #:use-module ((srfi srfi-1) #:select (filter-map)) #:export (compile-glil)) @@ -64,9 +65,10 @@ (let* ((x (make-lambda (tree-il-src x) '() (make-lambda-case #f '() #f #f #f '() '() x #f))) - (x (optimize! x e opts)) + (x (optimize! (optimize! x e opts) e opts)) (x (canonicalize! x)) - (allocation (analyze-lexicals x))) + (special-vars (register-special-vars x)) + (allocation (analyze-lexicals x special-vars))) (with-fluids ((*comp-module* e)) (values (flatten-lambda x #f allocation) diff --git a/module/language/tree-il/special.scm b/module/language/tree-il/special.scm new file mode 100644 index 0000000..0e38084 --- /dev/null +++ b/module/language/tree-il/special.scm @@ -0,0 +1,104 @@ +(define-module (language tree-il special) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (system base syntax) + #:use-module (system base message) + #:use-module (system vm program) + #:use-module (language tree-il) + #:use-module (system base pmatch) + #:export (register-special-vars)) + + +(define (register-special-vars x) + (define register (make-hash-table)) + (let lp ((x x)) + (record-case x + (( proc args) + (record-case proc + (( src mod name public?) + (if (and (equal? mod '(system vm special-variable)) + (eq? name 'special) + (= (length args) 1)) + (record-case (car args) + (( src gensym) + (hashq-set! register gensym #t)) + (else #t)))) + (else #f)) + (lp proc) + (for-each lp args)) + + (( test consequent alternate) + (lp test) + (lp consequent) + (lp alternate)) + + + (( gensym exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exps) + (for-each lp exps)) + + (( body) + (lp body)) + + (( opt kw inits gensyms body alternate) + (for-each lp inits) + (lp body) + (if alternate (lp alternate))) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( exp body) + (lp exp) + (lp body)) + + (( body winder unwinder) + (lp body) + (lp winder) + (lp unwinder)) + + (( fluids vals body) + (lp body) + (for-each lp (append fluids vals))) + + (( fluid) + (lp fluid)) + + (( fluid exp) + (lp fluid) (lp exp)) + + (( tag body handler) + (lp tag) + (lp body) + (lp handler)) + + (( tag args tail) + (lp tag) (lp tail) (for-each lp args)) + + (else #t))) + register) + diff --git a/module/system/vm/special-variable.scm b/module/system/vm/special-variable.scm new file mode 100644 index 0000000..2068b84 --- /dev/null +++ b/module/system/vm/special-variable.scm @@ -0,0 +1,9 @@ +(define-module (system vm special-variable) + #:export (mark-as-special)) + +(define special (lambda (x) #f)) + +(define-syntax-rule (mark-as-special v ...) + (begin + (special v) + ...)) --nextPart3910070.69VcXdEC65--