From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
To: guile-devel@gnu.org
Subject: Special variables to relax boxing
Date: Tue, 19 Mar 2013 23:05:52 +0100 [thread overview]
Message-ID: <3101921.Ei70kTLzB2@warperdoze> (raw)
[-- Attachment #1: Type: text/plain, Size: 714 bytes --]
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
[-- Attachment #2: special.scm --]
[-- Type: text/x-scheme, Size: 3908 bytes --]
(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) ;; #<procedure 13bbe80 at /home/stis/src/special.scm:51:10 ()>
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
|#
[-- Attachment #3: special.diff --]
[-- Type: text/x-patch, Size: 10680 bytes --]
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
- ((<application> proc args)
+ ((<application> 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))
((<lambda-case> 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)))))))))
((<letrec> 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))))))
((<fix> 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
+ ((<application> proc args)
+ (record-case proc
+ ((<module-ref> src mod name public?)
+ (if (and (equal? mod '(system vm special-variable))
+ (eq? name 'special)
+ (= (length args) 1))
+ (record-case (car args)
+ ((<lexical-ref> src gensym)
+ (hashq-set! register gensym #t))
+ (else #t))))
+ (else #f))
+ (lp proc)
+ (for-each lp args))
+
+ ((<conditional> test consequent alternate)
+ (lp test)
+ (lp consequent)
+ (lp alternate))
+
+
+ ((<lexical-set> gensym exp)
+ (lp exp))
+
+ ((<module-set> exp)
+ (lp exp))
+
+ ((<toplevel-set> exp)
+ (lp exp))
+
+ ((<toplevel-define> exp)
+ (lp exp))
+
+ ((<sequence> exps)
+ (for-each lp exps))
+
+ ((<lambda> body)
+ (lp body))
+
+ ((<lambda-case> opt kw inits gensyms body alternate)
+ (for-each lp inits)
+ (lp body)
+ (if alternate (lp alternate)))
+
+ ((<let> gensyms vals body)
+ (for-each lp vals)
+ (lp body))
+
+ ((<letrec> gensyms vals body)
+ (for-each lp vals)
+ (lp body))
+
+ ((<fix> gensyms vals body)
+ (for-each lp vals)
+ (lp body))
+
+ ((<let-values> exp body)
+ (lp exp)
+ (lp body))
+
+ ((<dynwind> body winder unwinder)
+ (lp body)
+ (lp winder)
+ (lp unwinder))
+
+ ((<dynlet> fluids vals body)
+ (lp body)
+ (for-each lp (append fluids vals)))
+
+ ((<dynref> fluid)
+ (lp fluid))
+
+ ((<dynset> fluid exp)
+ (lp fluid) (lp exp))
+
+ ((<prompt> tag body handler)
+ (lp tag)
+ (lp body)
+ (lp handler))
+
+ ((<abort> 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)
+ ...))
next reply other threads:[~2013-03-19 22:05 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-03-19 22:05 Stefan Israelsson Tampe [this message]
2013-03-21 6:00 ` Special variables to relax boxing Mark H Weaver
2013-03-21 9:35 ` Stefan Israelsson Tampe
2013-03-21 15:35 ` Noah Lavine
2013-03-21 16:28 ` Stefan Israelsson Tampe
2013-03-21 19:03 ` Mark H Weaver
2013-03-21 20:15 ` Stefan Israelsson Tampe
2013-03-21 21:11 ` Noah Lavine
2013-03-22 22:33 ` Stefan Israelsson Tampe
2013-03-23 0:18 ` Daniel Hartwig
2013-03-23 15:34 ` Stefan Israelsson Tampe
2013-03-23 18:31 ` Stefan Israelsson Tampe
-- strict thread matches above, loose matches on Subject: below --
2013-03-23 10:30 Stefan Israelsson Tampe
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=3101921.Ei70kTLzB2@warperdoze \
--to=stefan.itampe@gmail.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).