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: Re: Special variables to relax boxing Date: Fri, 22 Mar 2013 23:33:06 +0100 Message-ID: <2174121.eLPOcnxQL8@warperdoze> References: <3101921.Ei70kTLzB2@warperdoze> <12515493.61rmnodEK6@warperdoze> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="nextPart2635348.iFAPnrpzHt" Content-Transfer-Encoding: 7Bit X-Trace: ger.gmane.org 1363991605 24305 80.91.229.3 (22 Mar 2013 22:33:25 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Fri, 22 Mar 2013 22:33:25 +0000 (UTC) Cc: Mark H Weaver , guile-devel To: Noah Lavine Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Fri Mar 22 23:33:51 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 1UJAWy-0007yW-5b for guile-devel@m.gmane.org; Fri, 22 Mar 2013 23:33:48 +0100 Original-Received: from localhost ([::1]:58954 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UJAWa-0006V8-6V for guile-devel@m.gmane.org; Fri, 22 Mar 2013 18:33:24 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:43393) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UJAWU-0006Ur-In for guile-devel@gnu.org; Fri, 22 Mar 2013 18:33:21 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UJAWR-0005S0-3F for guile-devel@gnu.org; Fri, 22 Mar 2013 18:33:18 -0400 Original-Received: from mail-la0-x22b.google.com ([2a00:1450:4010:c03::22b]:54983) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UJAWQ-0005Rt-Hs for guile-devel@gnu.org; Fri, 22 Mar 2013 18:33:15 -0400 Original-Received: by mail-la0-f43.google.com with SMTP id ek20so8278739lab.30 for ; Fri, 22 Mar 2013 15:33:12 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=x-received:from:to:cc:subject:date:message-id:user-agent :in-reply-to:references:mime-version:content-type :content-transfer-encoding; bh=FBTw1cJTKrQUQljXv4h1bTrE5G0rsx52DEIImtHn938=; b=vui/OSxDePObJoBZSym3005gK8B2LsvHYTRx/fPPbJXBhhkE7Mv2a8l4QulpQ9BWhn NcRAccuwTR8rZyebsz9cosqC5NDRaVW4cynCO5o4OF9R+5pNdAWSQ4/anpZh9jJFgs3k q3mi0cHn7I/0XqxtzDM2uzf3KIFye47XTrxHrVB/9VHIvNtxFqe+QglsbLAwpAc4sW/R eMFRTydZ1auS39ltJsh9yHaoC1RLQO2V+XFjULMHdSvDWlxPeE8UyD+C18BKAxz2a9rD grtLED3tO52DhhxiaDgW8O62GmAxd+i6nnOd+8WvNuggDlvdZnpci/FGZrSpvFlFdw9V 1yRw== X-Received: by 10.112.79.1 with SMTP id f1mr2010480lbx.114.1363991592127; Fri, 22 Mar 2013 15:33:12 -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 fl9sm1565443lbb.9.2013.03.22.15.33.09 (version=TLSv1.1 cipher=ECDHE-RSA-RC4-SHA bits=128/128); Fri, 22 Mar 2013 15:33:10 -0700 (PDT) User-Agent: KMail/4.9.5 (Linux/3.5.0-26-generic; KDE/4.9.5; x86_64; ; ) In-Reply-To: X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2a00:1450:4010:c03::22b 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:15971 Archived-At: This is a multi-part message in MIME format. --nextPart2635348.iFAPnrpzHt Content-Transfer-Encoding: 7Bit Content-Type: text/plain; charset="us-ascii" Hi list, Mark and Noah, Yesterday I noticed that the sematics for special variables are quite close to fluids and decied to see if I could model special variables ontop of that with-fluids semantics. That was pretty easy. The basic difference between fluid and special variables is that with fluids one swaps between the storages at the with-fluids point, both backwards and forwards. in the case of special variables one bascially takes on half of the swap at the wind and the other half at the unwind. So it become quite easy to just copy the fluid logic and then slightly modify that source. The scheme compilation part is a little hacky but it was not that hard to plumb an acceptable solution for testing. I did verify that it manages the value as said and noticed a 10x increase of speed when it comes to code passing into a with-fluids without any prompts compared to any possible setup using dynamic-wind and fluids. The system is still pretty rough though but there are some significant optimization implemented. a preliminary git diff is attached for you to play with. I did try to implement special variables in current guile. I found that it is pretty difficult to get the correct semantics working anyone able to spot it. I use, (define guards (make-vector 10)) (let lp ((i 0)) (when (< i 10) (vector-set! guards i (make-fluid)))) (define-syntax with-special-soft (lambda (x) (syntax-case x () ((_ (x ...) code ...) (with-syntax (((((a k) ...) (y ...)) (let loop ((i 0) (l #'(x ...)) (r '())) (if (or (= i 10) (null? l)) (list (reverse r) l) (loop (+ i 1) (cdr l) (cons (car l) r)))))) (with-syntax (((i ...) (iota (length #'(a ...))))) (if (null? #'(y ...)) #'(with-fluids (((vector-ref guards i) a) ...) (with-special* ((i a k) ...) code ...)) #'(with-fluids (((vector-ref guards i) a) ...) (with-special* ((i a k) ...) (with-special-soft (y ...) code ...)))))))))) (define special-wind-guard (make-fluid (lambda (x) #t))) (define-syntax-rule (with-special* ((i a k) ...) code ...) (dynamic-wind (lambda () (set! a (fluid-ref (vector-ref guards i))) ...) (lambda () code ...) (lambda y (fluid-set! (vector-ref guards i) a) ...))) (define (f x) (let ((s 0)) (with-special-soft ((s 0)) (let lp ((i 0)) (cond ((>= i 100) s) ((= i 50) (abort-to-prompt 'tag) (lp (+ i 1))) (else (set! s (+ s i)) (lp (+ i 1)))))))) (define k (call-with-prompt 'tag (lambda () (f 1)) (lambda (k . l) k))) scheme@(guile-user)> (k) $1 = 4900 scheme@(guile-user)> (k) $2 = 8575 Can you spot the bug? The example works very well with my hardcoded version code and is as fast as this logic can get, much better than 10x faster because this case can be very well optimized. To note here also is that with this code we might get into stack issues due to the with-special can spoil tail call stack features just as with-fluids. WDYT? /Stefan --nextPart2635348.iFAPnrpzHt Content-Disposition: attachment; filename="special.diff" Content-Transfer-Encoding: 7Bit Content-Type: text/x-patch; charset="UTF-8"; name="special.diff" diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 14dd861..76c4889 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -244,6 +244,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) scm_i_swap_with_fluids (wind_elt, SCM_I_CURRENT_THREAD->dynamic_state); } + else if (SCM_WITH_SPECIAL_P (wind_elt)) + { + scm_i_with_special_from_guard (wind_elt, + SCM_I_CURRENT_THREAD->dynamic_state); + } else if (SCM_PROMPT_P (wind_elt)) ; /* pass -- see vm_reinstate_partial_continuation */ else if (scm_is_pair (wind_elt)) @@ -277,6 +282,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) scm_i_swap_with_fluids (wind_elt, SCM_I_CURRENT_THREAD->dynamic_state); } + else if (SCM_WITH_SPECIAL_P (wind_elt)) + { + scm_i_with_special_to_guard (wind_elt, + SCM_I_CURRENT_THREAD->dynamic_state); + } else if (SCM_PROMPT_P (wind_elt)) ; /* pass -- though we could invalidate the prompt */ else if (scm_is_pair (wind_elt)) diff --git a/libguile/fluids.c b/libguile/fluids.c index 327d12f..c43011d 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -346,6 +346,47 @@ scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals) return ret; } + +const int nguards = 10; +SCM guards[10]; +SCM scm_i_make_with_special (size_t n, SCM *fluids, SCM *vals) +{ + SCM ret; + if(n > nguards) + scm_misc_error ("with-special", + "VM with-special can maximally be called with 10 slots", + SCM_EOL); + + /* Ensure that there are no duplicates in the fluids set -- an N^2 operation, + but N will usually be small, so perhaps that's OK. */ + { + size_t i, j; + + for (j = n; j--;) + for (i = j; i--;) + if (scm_is_eq (fluids[i], fluids[j])) + { + vals[i] = vals[j]; /* later bindings win */ + n--; + fluids[j] = fluids[n]; + vals[j] = vals[n]; + break; + } + } + + ret = scm_words (scm_tc7_with_special | (n << 8), 1 + n*2); + SCM_SET_CELL_WORD_1 (ret, n); + + while (n--) + { + if (SCM_UNLIKELY ( !SCM_VARIABLEP (fluids[n]))) + scm_wrong_type_arg ("with-special need a box as input", 0, fluids[n]); + SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]); + SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]); + } + + return ret; +} void scm_i_swap_with_fluids (SCM wf, SCM dynstate) @@ -385,6 +426,80 @@ scm_i_swap_with_fluids (SCM wf, SCM dynstate) SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x); } } + +void +scm_i_with_special_to_guard (SCM wf, SCM dynstate) +{ + SCM fluids; + size_t i, max = 0; + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + + /* We could cache the max in the with-fluids, but that would take more mem, + and we're touching all the fluids anyway, so this per-swap traversal should + be OK. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t num = FLUID_NUM (guards[i]); + max = (max > num) ? max : num; + } + + if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Lazily grow the current thread's dynamic state. */ + grow_dynamic_state (dynstate); + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + } + + /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t fluid_num; + + fluid_num = FLUID_NUM (guards[i]); + SCM_SIMPLE_VECTOR_SET + (fluids, fluid_num, + SCM_VARIABLE_REF (SCM_WITH_SPECIAL_NTH_VAR (wf, i))); + } +} + +void +scm_i_with_special_from_guard (SCM wf, SCM dynstate) +{ + SCM fluids; + size_t i, max = 0; + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + + /* We could cache the max in the with-fluids, but that would take more mem, + and we're touching all the fluids anyway, so this per-swap traversal should + be OK. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t num = FLUID_NUM ( guards[i]); + max = (max > num) ? max : num; + } + + if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Lazily grow the current thread's dynamic state. */ + grow_dynamic_state (dynstate); + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + } + + /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t fluid_num; + SCM x; + + fluid_num = FLUID_NUM (guards[i]); + x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num); + SCM_VARIABLE_SET (SCM_WITH_SPECIAL_NTH_VAR (wf, i), x); + } +} SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, (SCM fluids, SCM values, SCM thunk), @@ -592,6 +707,12 @@ SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0, void scm_init_fluids () { + int i; + for(i = 0; i < nguards; i++) + { + guards[i] = scm_make_fluid(); + } + #include "libguile/fluids.x" } diff --git a/libguile/fluids.h b/libguile/fluids.h index 2b91ff3..6a593a7 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -38,6 +38,12 @@ #define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2)) #define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v))) +#define SCM_WITH_SPECIAL_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_special) +#define SCM_WITH_SPECIAL_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8) +#define SCM_WITH_SPECIAL_NTH_VAR(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2)) +#define SCM_WITH_SPECIAL_NTH_KIND(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2)) + + /* Fluids. @@ -73,6 +79,12 @@ SCM_API SCM scm_fluid_bound_p (SCM fluid); SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals); SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state); +SCM_INTERNAL SCM scm_i_make_with_special (size_t n, SCM *fluids, SCM *vals); +SCM_INTERNAL void scm_i_with_special_from_guard +(SCM with_fluids, SCM dynamic_state); +SCM_INTERNAL void scm_i_with_special_to_guard +(SCM with_fluids, SCM dynamic_state); + SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *cdata); SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val, diff --git a/libguile/tags.h b/libguile/tags.h index a3032bf..869a9d4 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -426,7 +426,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_program 79 #define scm_tc7_array 85 #define scm_tc7_bitvector 87 -#define scm_tc7_unused_20 93 +#define scm_tc7_with_special 93 #define scm_tc7_unused_11 95 #define scm_tc7_unused_12 101 #define scm_tc7_unused_18 103 diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 34545dd..f9e8151 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1556,6 +1556,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0) NEXT; } + VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) { SCM wf; @@ -1565,6 +1566,30 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) NEXT; } + +VM_DEFINE_INSTRUCTION (99, wind_special, "wind-special", 1, -1, 0) +{ + unsigned n = FETCH (); + SCM wf; + + SYNC_REGISTER (); + sp -= 2 * n; + CHECK_UNDERFLOW (); + wf = scm_i_make_with_special (n, sp + 1, sp + 1 + n); + NULLSTACK (2 * n); + + //This is not nessesary + //scm_i_swap_with_special (wf, current_thread->dynamic_state); + scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (100, unwind_special, "unwind-special", 0, 0, 0) +{ + scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ())); + NEXT; +} + VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) { size_t num; 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..b4d3836 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) @@ -199,6 +201,19 @@ (proc emit-code) (reverse out))) +(define (with-special? x) + (record-case x + (( src proc args) + (record-case proc + (( src mod name public?) + (and (equal? mod '(system vm special-variable)) + (eq? name 'w-special) + (= (length args) 1) + (car args))) + (else #f))) + (else #f))) + + (define (flatten-lambda x self-label allocation) (record-case x (( src meta body) @@ -229,6 +244,7 @@ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) (define (comp-fix tree RA) (comp tree context RA MVRA)) + ;; Use this helper to guard some syms ;; A couple of helpers. Note that if we are in tail context, we ;; won't have an RA. (define (maybe-emit-return) @@ -236,6 +252,15 @@ (emit-branch #f 'br RA) (if (eq? context 'tail) (emit-code #f (make-glil-call 'return 1))))) + + (define (is-boxed? x) + (record-case x + (( src gensym) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + boxed?) + (_ #f))) + (else #f))) ;; After lexical binding forms in non-tail context, call this ;; function to clear stack slots, allowing their previous values to @@ -255,7 +280,25 @@ (,loc (error "bad let var allocation" x loc)))))) syms)))) - (record-case x + (if (pair? x) + (case (car x) + ((raw-ref) + (record-case (cdr x) + (( src gensym) + (case context + ((push) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + (emit-code src + (make-glil-lexical local? #f 'ref index))) + (,loc + (error "bad lexical allocation" x loc)))) + (else + (error "Bad raw-ref")))))) + (else + (error "Bad pair tree-il"))) + + (record-case x (() (case context ((push vals tail) @@ -277,7 +320,7 @@ (comp-drop (car exps)) (lp (cdr exps)))))) - (( src proc args) + (( src proc args) ;; FIXME: need a better pattern-matcher here (cond ((and (primitive-ref? proc) @@ -1037,11 +1080,38 @@ (if RA (emit-branch #f 'br RA))))) - (( src fluids vals body) - (for-each comp-push fluids) - (for-each comp-push vals) - (emit-code #f (make-glil-call 'wind-fluids (length fluids))) - + (( src fluids vals body) + (define spc (let lp ((l (map (lambda (sym val) + (let ((sp (with-special? val))) + (and (is-boxed? sym) + sp))) + fluids vals))) + (if (pair? l) + (if (car l) + (cons (car l) (lp (cdr l))) + (lp (cdr l))) + '()))) + (define id (lambda (x) x)) + (define spc? (or-map with-special? vals)) + (if (and spc? (null? spc)) + (comp-tail body) + (begin + (if spc? + (for-each (lambda (ref) + (when (is-boxed? ref) + (comp-push (cons 'raw-ref ref)))) + fluids) + (for-each comp-push fluids)) + + (if spc? + (for-each comp-push spc) + (for-each comp-push vals)) + + (if spc? + (emit-code #f (make-glil-call 'wind-special (length spc))) + (emit-code #f (make-glil-call 'wind-fluids (length fluids)))) + + (begin (case context ((tail) (let ((MV (make-label))) @@ -1052,17 +1122,23 @@ ;; ourselves). (comp-vals body MV) ;; one value: unwind and return - (emit-code #f (make-glil-call 'unwind-fluids 0)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (emit-code #f (make-glil-call 'unwind-fluids 0))) (emit-code #f (make-glil-call 'return 1)) (emit-label MV) ;; multiple values: unwind and return values - (emit-code #f (make-glil-call 'unwind-fluids 0)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (emit-code #f (make-glil-call 'unwind-fluids 0))) (emit-code #f (make-glil-call 'return/nvalues 1)))) ((push) (comp-push body) - (emit-code #f (make-glil-call 'unwind-fluids 0))) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (emit-code #f (make-glil-call 'unwind-fluids 0)))) ((vals) (let ((MV (make-label))) @@ -1072,16 +1148,20 @@ (emit-label MV) ;; multiple values: unwind and goto MVRA - (emit-code #f (make-glil-call 'unwind-fluids 0)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (emit-code #f (make-glil-call 'unwind-fluids 0))) (emit-branch #f 'br MVRA))) ((drop) ;; compile body, discarding values. then unwind... (comp-drop body) - (emit-code #f (make-glil-call 'unwind-fluids 0)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (emit-code #f (make-glil-call 'unwind-fluids 0))) ;; and fall through, or goto RA if there is one. (if RA - (emit-branch #f 'br RA))))) + (emit-branch #f 'br RA)))))))) (( src fluid) (case context @@ -1202,4 +1282,4 @@ (emit-code #f (make-glil-mv-bind 1 #f))) ((vals) ;; Go to MVRA. - (emit-branch #f 'br MVRA))))))) + (emit-branch #f 'br MVRA)))))))) 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..99cc497 --- /dev/null +++ b/module/system/vm/special-variable.scm @@ -0,0 +1,85 @@ +(define-module (system vm special-variable) + #:export (with-special with-special-soft special-wind-guard)) + +(define special (lambda (x) x)) +(define w-special (lambda (x) x)) + +(define-syntax-rule (mark-as-special v ...) + (begin + (special v) + ... + (if #f #f))) + +;; This will allocate guard on the stack as a boxed value +(define (make-winder l) + (lambda () + (let loop ((l l)) + (if (pair? l) + (let ((c (car l))) + (variable-set! (cdr c) (car c)) + (loop (cdr l))) + (if #f #f))))) + +(define (make-unwinder l) + (lambda () + (let loop ((l l)) + (if (pair? l) + (let ((c (car l))) + (set-car! c (variable-ref (cdr c))) + (loop (cdr l))) + (if #f #f))))) + +(define-syntax with-special + (lambda (x) + (syntax-case x () + ((_ (x ...) code ...) + (with-syntax (((((a k) ...) (y ...)) + (let loop ((i 0) (l #'(x ...)) (r '())) + (if (or (= i 10) (null? l)) + (list (reverse r) l) + (loop (+ i 1) (cdr l) (cons (car l) r)))))) + (if (null? #'(y ...)) + #'(with-fluids ((a (w-special k)) ...) + (mark-as-special a) ... + code ...) + #'(with-fluids ((a (w-special k)) ...) + (mark-as-special a) ... + (with-special (y ...) code ...)))))))) + +(define guards (make-vector 10)) +(let lp ((i 0)) + (when (< i 10) (vector-set! guards i (make-fluid)))) + +(define-syntax with-special-soft + (lambda (x) + (syntax-case x () + ((_ (x ...) code ...) + (with-syntax (((((a k) ...) (y ...)) + (let loop ((i 0) (l #'(x ...)) (r '())) + (if (or (= i 10) (null? l)) + (list (reverse r) l) + (loop (+ i 1) (cdr l) (cons (car l) r)))))) + (with-syntax (((i ...) (iota (length #'(a ...))))) + (if (null? #'(y ...)) + #'(with-fluids (((vector-ref guards i) a) ...) + (with-special* ((i a k) ...) + code ...)) + #'(with-fluids (((vector-ref guards i) a) ...) + (with-special* ((i a k) ...) + (with-special-soft (y ...) code ...)))))))))) + +(define special-wind-guard (make-fluid (lambda (x) #t))) +(define-syntax-rule (with-special* ((i a k) ...) code ...) + (dynamic-wind + (lambda () + (when ((fluid-ref special-wind-guard) k) + (set! a (fluid-ref (vector-ref guards i)))) + ...) + (lambda () + code ...) + (lambda y + (fluid-set! (vector-ref guards i) a) + ...))) + + + --nextPart2635348.iFAPnrpzHt--