[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-180-g0d08

From: Noah Lavine
Subject: [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-180-g0d0808a
Date: Mon, 18 Feb 2013 19:13:00 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

The branch, wip-rtl-cps has been updated
       via  0d0808ae3f7390ffb250b9deb6706ad4158cce0e (commit)
       via  eebd889baa1d7f762e144ad7f9af005946d75273 (commit)
       via  c6540722c35720d664dd3c294440700746bb6eb1 (commit)
      from  9be266c32e468e81c72b0affc88da81e6cb9ee1c (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 0d0808ae3f7390ffb250b9deb6706ad4158cce0e
Author: Noah Lavine <address@hidden>
Date:   Mon Feb 18 14:10:58 2013 -0500

    Make Lambda Arguments Mutable
    * module/language/cps.scm: let variable objects come with an
      initialization value.
    * module/language/tree-il/compile-cps.scm: put all lambda arguments in
      variable boxes, so they are mutable.

commit eebd889baa1d7f762e144ad7f9af005946d75273
Author: Noah Lavine <address@hidden>
Date:   Mon Feb 18 14:09:33 2013 -0500

    Allocate Call Frames Explicitly
    * module/language/cps/compile-rtl.scm: have the allocator explicitly say
      where to put the frame for a procedure call, instead of inferring it
      from the argument destinations.

commit c6540722c35720d664dd3c294440700746bb6eb1
Author: Noah Lavine <address@hidden>
Date:   Sat Feb 16 12:08:45 2013 -0500

    Support N-ary Primitive Outputs
    * module/language/cps/primitives.scm: add new data table for output
    * module/language/cps/compile-rtl.scm: adjust.


Summary of changes:
 module/language/cps.scm                 |    7 ++-
 module/language/cps/compile-rtl.scm     |   75 ++++++++++++++++++++++---------
 module/language/cps/primitives.scm      |   25 +++++++---
 module/language/tree-il/compile-cps.scm |   50 +++++++++++++-------
 4 files changed, 107 insertions(+), 50 deletions(-)

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 9802451..7b056fb 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -3,7 +3,7 @@
   #:use-module (ice-9 match)
   #:export (<letval> letval? make-letval letval-names letval-vals letval-body
             <const> const? make-const const-value
-            <var> var? make-var
+            <var> var? make-var var-value
             <toplevel-var> toplevel-var? make-toplevel-var toplevel-var-name
             <letrec> letrec? make-letrec letrec-names letrec-funcs letrec-body
             <letcont> letcont? make-letcont letcont-names
@@ -136,8 +136,9 @@
   ;; const represents constants.
   (<const> value)
   ;; var is for lexical variables. these things just map to variable
-  ;; objects in the VM.
-  (<var>)
+  ;; objects in the VM. value is the value it is initialized to. it
+  ;; should be a CPS variable (which is a symbol).
+  (<var> value)
   ;; toplevel vars are like pseudo-vars. instead of actually creating a
   ;; variable object, we'll just remember that there *is* a variable
   ;; object already in existence and look it up when we need it. we
diff --git a/module/language/cps/compile-rtl.scm 
index eb3afed..5cac8da 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -17,6 +17,10 @@
 ;; always be a symbol)
 (define register (make-object-property))
+;; when we make a call, we need to know where to put the new stack
+;; frame. this holds that information.
+(define call-frame-start (make-object-property))
 ;; and every contination gets a label, so we can jump to it. this is
 ;; indexed by the names of the continuations, not the actual lambda objects.
 (define label (make-object-property))
@@ -53,7 +57,12 @@
   (define (visit cps counter)
     ;; counter is the number of local variables we've already allocated.
     (record-case cps
-      ((<call>) counter)
+      ;; call is kind of a weird case, because although it doesn't need
+      ;; any extra registers, the new frame needs to be on top of the
+      ;; stack. so we save that information in its own property.
+      ((<call>)
+       (set! (call-frame-start cps) (+ counter))
+       counter)
       ((<lambda> names body)
        ;; TO DO: record which variables will be closure variables.
@@ -176,7 +185,9 @@
          (record-case cps
            ((<call> proc cont args)
-            (cons* (with-alloc proc)
+            (cons* 'call
+                   (call-frame-start cps)
+                   (with-alloc proc)
                    (with-alloc cont)
                    (map with-alloc args)))
            ((<lambda> names body)
@@ -205,6 +216,12 @@
   (set-cdr! q (cdr r))
+;; and this is some sort of general utility
+(define (int-range start end)
+  (if (< start end)
+      (cons start (int-range (+ start 1) end))
+      '()))
 ;; this function returns a list of `mov' instructions that accomplish a
 ;; shuffle in the stack. each tail argument is a pair (from . to) that
 ;; indicates how a value should move. the first argument is the number
@@ -288,7 +305,7 @@
   ;; given args, placing the result in register(s) dsts. This is its own
   ;; function because it is called twice in visit - once in the tail
   ;; case and once in the non-tail case.
-  (define (generate-primitive-call dst prim args)
+  (define (generate-primitive-call dsts prim args)
     ;; the primitives 'ref and 'set are handled differently than the
     ;; others because they need to know whether they're setting a
     ;; toplevel variable or not. I think there's some bad abstraction
@@ -300,7 +317,8 @@
     (case prim
       ((ref) (let* ((var-value (car args))
-                    (var (name-defn var-value)))
+                    (var (name-defn var-value))
+                    (dst (car dsts)))
                (if (toplevel-var? var)
                    (let ((var-name (toplevel-var-name var)))
                      ;; the scope is 'foo because we don't meaningfully
@@ -310,19 +328,25 @@
                        (cached-toplevel-ref ,dst foo ,var-name)))
                    `((box-ref ,dst ,(register var-value))))))
       ((set) (let* ((var-value (car args))
-                    (var (name-defn var-value)))
+                    (var (name-defn var-value))
+                    (dst (car dsts)))
                (if (toplevel-var? var)
                    (let ((var-name (toplevel-var-name var)))
                      `((cache-current-module! ,dst foo)
                        (cached-toplevel-set! ,(register (cadr args))
-                                             foo ,var-name)))
+                                             foo ,var-name)
+                       (mov ,dst ,(register (cadr args)))))
                       ,(register (car args))
                       ,(register (cadr args)))))))
        (let ((insn (hashq-ref *primitive-insn-table* prim))
-             (arity (hashq-ref *primitive-arity-table* prim)))
-         (if (and insn (= arity (length args)))
+             (in-arity (hashq-ref *primitive-in-arity-table* prim))
+             (out-arity (hashq-ref *primitive-out-arity-table* prim))
+             (dst (car dsts)))
+         (if (and insn
+                  (= in-arity (length args))
+                  (= out-arity 1)) ;; we don't support n-ary outputs yet
              `((,insn ,dst ,@(map register args)))
              (error "malformed primitive call" (cons prim args)))))))
@@ -345,10 +369,13 @@
             ;; then return. this seems like it might have to change in
             ;; the future. it's fine to take the maximum register and
             ;; add one, because the allocator reserved us one extra.
+            ;; note: this only handles primitives that return exactly
+            ;; one value.
             (let ((return-reg
                    (+ 1 (apply max (map register args)))))
-                   return-reg (primitive-name proc) args)
+                   (list return-reg) (primitive-name proc) args)
                 (return ,return-reg)))
             (let ((num-args (length args)))
@@ -376,24 +403,30 @@
        (($ <call> proc cont args)
         (if (label cont) ;; a call whose continuation is bound in a
                          ;; letcont form
-            (let ((return-base (register
-                                (car (lambda-names (name-defn cont))))))
-              ;; return-base is the stack offset where we want to put
-              ;; the return values of this function. there can't be
-              ;; anything important on the stack past return-base,
-              ;; because anything in scope would already have a reserved
-              ;; spot on the stack before return-base, because the
-              ;; allocator works that way.
+            (let* ((dsts (map register (lambda-names (name-defn cont))))
+                   (return-start (call-frame-start cps))
+                   ;; perm is the permutation we have to execute to put
+                   ;; the results of the call in their destinations
+                   (perm (map cons (int-range return-start
+                                              (+ return-start (length dsts)))
+                              dsts))
+                   (perm-label (next-label!)))
               (if (primitive? proc)
-                       return-base (primitive-name proc) args)
+                       dsts (primitive-name proc) args)
                     (br ,(label cont)))
-                  `((call ,return-base ,(register proc)
+                  `((call ,(call-frame-start cps) ,(register proc)
                           ,(map register args))
+                    ;; shuffle the return values into their place. we
+                    ;; pass #f as our swap point because this
+                    ;; permutation should never need swap space.
+                    (br ,perm-label) ;; MVRA
+                    (br ,perm-label) ;; RA
+                    (label ,perm-label)
+                    ,@(apply generate-shuffle #f perm)
                     ;; the RA and MVRA both branch to the continuation. we
                     ;; don't do error checking yet.
-                    (br ,(label cont))    ;; MVRA
-                    (br ,(label cont))))) ;; RA
+                    (br ,(label cont)))))
             (error "We don't know how to compile" cps)))
        ;; consequent and alternate should both be continuations with no
        ;; arguments, so we call them by just jumping to them.
diff --git a/module/language/cps/primitives.scm 
index b2f23ae..7a93138 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -1,6 +1,7 @@
 (define-module (language cps primitives)
   #:export (*primitive-insn-table*
-            *primitive-arity-table*))
+            *primitive-in-arity-table*
+            *primitive-out-arity-table*))
 ;; the "primitives" in this file are the operations which are supported
 ;; by VM opcodes. Each primitive has more than one name - there is its
@@ -9,7 +10,7 @@
 ;; name as a VM instruction, which may be different from the first two.
 ;; this list holds information about the primitive VM operations. The
-;; current fields are (Scheme name, VM name, arity). We don't handle
+;; current fields are (Scheme name, VM name, in-arity). We don't handle
 ;; folds, reductions, or variable-arity instructions yet.
 (define *primitive-insn-data*
   '((string-length string-length 1)
@@ -46,19 +47,27 @@
 (define *primitive-insn-table* (make-hash-table))
-;; this table maps our names to the instruction arities. We assume that
-;; each instruction takes its destination first and the remaining
-;; arguments in order. We don't handle folds or reductions right now.
+;; We assume that each instruction takes its destination first and the
+;; remaining arguments in order. We don't handle folds or reductions
+;; right now.
-(define *primitive-arity-table* (make-hash-table))
+;; this table holds the number of inputs each primitive function takes
+(define *primitive-in-arity-table* (make-hash-table))
+;; and this one holds the number of outputs. this will always be 1 right
+;; now, but there are cases where that won't be true - for instance,
+;; divmod.
+(define *primitive-out-arity-table* (make-hash-table))
 (define (fill-insn-tables!)
    (lambda (entry)
      (hashq-set! *primitive-insn-table*
                  (car entry) (cadr entry))
-     (hashq-set! *primitive-arity-table*
-                 (car entry) (caddr entry)))
+     (hashq-set! *primitive-in-arity-table*
+                 (car entry) (caddr entry))
+     (hashq-set! *primitive-out-arity-table*
+                 (car entry) 1))
diff --git a/module/language/tree-il/compile-cps.scm 
index 796800b..150bbc0 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -4,8 +4,16 @@
                 #:renamer (symbol-prefix-proc 'cps-))
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
+  #:use-module (srfi srfi-1)
   #:export (tree-il->cps))
+;; this should probably be a general utility. it simply executes a
+;; function n times and returns a list of the results
+(define (sample f n)
+  (if (< n 1)
+      '()
+      (cons (f)
+            (sample f (- n 1)))))
 ;; k is the continuation
 (define (tree-il->cps tree)
@@ -13,13 +21,11 @@
   ;; tree, and then calls 'gen-k' to generate more CPS code - but
   ;; 'gen-k' is called with a name which can reference the value of
   ;; tree. the real point is to abstract out the idea of *not*
-  ;; generating extra continuations for lexical variable references and
-  ;; constants. we could always optimize them out later, but it seems
-  ;; easier to just not make them in the first place.
+  ;; generating extra continuations for constants. we could always
+  ;; optimize them out later, but it seems easier to just not make them
+  ;; in the first place.
   (define (with-value-name gen-k tree env)
-    (cond ((lexical-ref? tree)
-           (gen-k (lexical-ref-gensym tree)))
-          ((const? tree)
+    (cond ((const? tree)
            (let ((val-name (gensym "val-")))
               (list val-name)
@@ -50,16 +56,17 @@
   ;; the given variables and then calls 'gen-k' with a new environment
   ;; in which the given names are mapped to the names of their boxes.
   (define (with-variable-boxes gen-k vars env)
-    (let iter ((vars vars)
-               (env env))
-      (if (null? vars)
-          (gen-k env)
-          (let ((var-name (gensym "var-")))
-            (cps-make-letval
-             (list var-name)
-             (list (cps-make-var (car vars)))
-             (iter (car vars)
-                   (vhash-consq (car vars) var-name env)))))))
+    (let ((var-names (sample (lambda () (gensym "var-"))
+                             (length vars))))
+      (cps-make-letval
+       var-names
+       (map (lambda (var-name val)
+              (cps-make-var val))
+            var-names vars)
+       (gen-k
+        (fold vhash-consq
+              env
+              vars var-names)))))
   ;; visit returns a CPS version of tree which ends by calling
   ;; continuation k. 'env' is a vhash that maps Tree-IL variable gensyms
@@ -72,7 +79,11 @@
       (($ <lambda> src meta
           ($ <lambda-case> src req opt rest kw inits gensyms body alternate))
        (cps-make-lambda gensyms
-         (visit 'return body env)))
+                   (with-variable-boxes
+                    (lambda (env)
+                      (visit 'return body env))
+                    gensyms
+                    env)))
       (($ <call> src proc args)
         (lambda (proc . args)
@@ -96,7 +107,10 @@
       (($ <lexical-ref> src name gensym)
-       (cps-make-call k #f (list gensym)))
+       (cps-make-call
+        (cps-make-primitive 'ref)
+        k
+        (list (cdr (vhash-assq gensym env)))))
       (($ <toplevel-ref> src name)
        (let ((var-name (gensym "var-")))

GNU Guile

reply via email to

[Prev in Thread] Current Thread [Next in Thread]