From 5a44ec4c40a6bb6fa781cf4ab98526129fcfe0c0 Mon Sep 17 00:00:00 2001 From: Noah Lavine Date: Sat, 3 Aug 2013 17:14:38 -0400 Subject: Test cps->rtl * module/language/cps/compile-rtl.scm: bugfixes. * module/language/cps/primitives: a new table for primitive properties, used to represent variable arities. * module/language/cps/util.scm: add `maybe-append'. * test-suite/tests/compile-rtl.test: tests for compile-rtl. --- module/language/cps/compile-rtl.scm | 226 +++++++++++++++++++----------------- module/language/cps/primitives.scm | 78 +++++++------ module/language/cps/util.scm | 11 +- test-suite/tests/compile-rtl.test | 29 +++++ 4 files changed, 197 insertions(+), 147 deletions(-) create mode 100644 test-suite/tests/compile-rtl.test diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index a9d8192bb..be0edb0f2 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -12,7 +12,8 @@ #:use-module (language tree-il compile-cps) #:use-module (system vm assembler) #:export (cps->rtl generate-rtl cps-compile - calculate-free-values cps-eval)) + calculate-free-values cps-eval + generate-primitive-call)) ;; currently, the only way we have to run RTL code is to package it up ;; into a program and call that program. Therefore, all code that we @@ -139,119 +140,124 @@ free-vals) -;; generate-rtl compiles a CPS form to RTL. -(define (generate-rtl cps name-defn register call-frame-start - rest-args-start nlocals label next-label!) - ;; generate-primitive-call: generate a call to primitive prim with the - ;; given args, placing the result in register(s) dsts. rest is either - ;; #f or the location of the rest arguments of the destination - ;; continuation (if it has rest arguments). 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 dsts rest prim args) - ;; some of the primitives have special handling. this probably - ;; points to a bad abstraction, but I don't know where yet. the - ;; distinction is whether the primitives require information that is - ;; part of the CPS or not. A "regular" primitive takes Scheme values - ;; from registers and returns Scheme values to registers. These - ;; primitives are handled in the primitive instruction tables in - ;; (language cps primitives). However, other primitives are - ;; different, in different ways: +;; the next few functions define special cases for certain VM +;; instructions. it's usually because they need special arguments. - ;; ref and set need to know if they're handling a module variable or - ;; not. The most elegant thing from the CPS point of view is to - ;; forget about the module-ref and module-set VM instructions and - ;; just use resolve for everything, but that might be slow until we - ;; have a tiling code generator. +;; ref and set need to know if they're handling a module variable or +;; not. The most elegant thing from the CPS point of view is to forget +;; about the module-ref and module-set VM instructions and just use +;; resolve for everything, but that might be slow until we have a tiling +;; code generator. +(define (generate-ref dst args name-defn register) + (let* ((var-value (car args)) + ;; var-value is the value holding the variable object, var is + ;; the actual variable object + (var (name-defn var-value))) + (if (module-var? var) + ;; the scope is 'foo because we don't meaningfully + ;; distinguish scopes yet. + (if (eq? (module-var-module var) 'toplevel) + ;; we should really just cache the current module + ;; once per procedure. + `((cache-current-module! ,dst foo) + (cached-toplevel-ref ,dst foo + ,(module-var-name var))) + `((cached-module-ref ,dst + ,(module-var-module var) + ,(module-var-public? var) + ,(module-var-name var)))) + `((box-ref ,dst ,(register var-value)))))) - ;; closure-ref needs to know the value of its argument at compile - ;; time, so it has to look that up in the name-defn table. +(define (generate-set dst args name-defn register) + (let* ((var-value (car args)) + (new-value (cadr args)) + (var (name-defn var-value))) + (if (module-var? var) + (if (eq? (module-var-module var) 'toplevel) + `((cache-current-module! ,dst foo) + (cached-toplevel-set! ,(register new-value) foo + ,(module-var-name var)) + (mov ,dst ,(register new-value))) + `((cached-module-set! ,(register new-value) + ,(module-var-module var) + ,(module-var-public? var) + ,(module-var-name var)) + (mov ,dst ,(register new-value)))) + `((box-set! + ,(register var-value) + ,(register new-value)) + (mov ,dst ,(register new-value)))))) - ;; make-closure's first argument is a label, not a register. +;; closure-ref needs to know the value of its argument at compile time, +;; so it has to look that up in the name-defn table. +(define (generate-closure-ref dst args name-defn) + (let ((defn (name-defn (car args)))) + (when (not (const? defn)) + (error + "closure-ref must be called with a constant argument")) + `((free-ref + ,dst + ,(const-value defn))))) - ;; in the future, things like prompt and dynwind will take arguments - ;; that are lambdas in Scheme, but are actually continuations in CPS - ;; world, so they'll have to know how to turn them into - ;; continuations. +;; make-closure's first argument is a label, not a register. +(define (generate-make-closure dst args label register) + (let ((func (car args)) + (vals (cdr args))) + `((make-closure + ,dst + ,(label func) + ,(map register vals))))) - (case prim - ((ref) (let* ((var-value (car args)) - ;; var-value is the value holding the variable - ;; object - (var (name-defn var-value)) - ;; var is the actual variable object - (dst (if (pair? dsts) - (car dsts) - rest))) - (if (module-var? var) - ;; the scope is 'foo because we don't meaningfully - ;; distinguish scopes yet. - (if (eq? (module-var-module var) 'toplevel) - ;; we should really just cache the current module - ;; once per procedure. - `((cache-current-module! ,dst foo) - (cached-toplevel-ref ,dst foo - ,(module-var-name var))) - `((cached-module-ref ,dst - ,(module-var-module var) - ,(module-var-public? var) - ,(module-var-name var)))) - `((box-ref ,dst ,(register var-value)))))) - ((set) (let* ((var-value (car args)) - (new-value (cadr args)) - (var (name-defn var-value)) - (dst (if (pair? dsts) - (car dsts) - rest))) - (if (module-var? var) - (if (eq? (module-var-module var) 'toplevel) - `((cache-current-module! ,dst foo) - (cached-toplevel-set! ,(register new-value) foo - ,(module-var-name var)) - (mov ,dst ,(register new-value))) - `((cached-module-set! ,(register new-value) - ,(module-var-module var) - ,(module-var-public? var) - ,(module-var-name var)) - (mov ,dst ,(register new-value)))) - `((box-set! - ,(register var-value) - ,(register new-value)) - (mov ,dst ,(register new-value)))))) +;; generate-primitive-call: generate a call to primitive prim with the +;; given args, placing the result in register(s) dsts. rest is either +;; #f or the location of the rest arguments of the destination +;; continuation (if it has rest arguments). +(define (generate-primitive-call dsts rest prim args + name-defn label register) + (define (has-prop? primitive prop) + (memq prop (hashq-ref *primitive-props-table* primitive))) - ((closure-ref) (let* ((dst (if (pair? dsts) - (car dsts) - rest)) - (defn (name-defn (car args)))) - (when (not (const? defn)) - (error - "closure-ref must be called with a constant argument")) - `((free-ref - ,dst - ,(const-value defn))))) + ;; TO DO: let primitives indicate the type of their arguments, with + ;; options 'register and 'label, and maybe more. That would let us + ;; remove the special handling for some of them, and implement things + ;; like prompt and dynwind. - ((make-closure) (let ((dst (if (pair? dsts) - (car dsts) - rest)) - (func (car args)) - (vals (cdr args))) - `((make-closure - ,dst - ,(label func) - ,(map register vals))))) - (else - (let ((insn (hashq-ref *primitive-insn-table* prim)) - (in-arity (hashq-ref *primitive-in-arity-table* prim)) - (out-arity (hashq-ref *primitive-out-arity-table* prim)) - (dst (if (pair? dsts) - (car dsts) - rest))) - (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))))))) - + (catch 'bad-primitive + (lambda () + (let ((dst (if (pair? dsts) (car dsts) rest))) + ;; if out-arity is 0, dst will be junk, but it shouldn't error. + (case prim + ((ref) (generate-ref dst args name-defn register)) + ((set) (generate-set dst args name-defn register)) + ((closure-ref) (generate-closure-ref dst args name-defn)) + ((make-closure) (generate-make-closure dst args label register)) + (else + (let ((insn (hashq-ref *primitive-insn-table* prim)) + (in-arity (hashq-ref *primitive-in-arity-table* prim)) + (out-arity (hashq-ref *primitive-out-arity-table* prim))) + (unless insn + (throw 'bad-primitive)) + (unless (or (has-prop? prim 'variable) + (= in-arity (length args))) + (throw 'bad-primitive)) + + (let ((fix-args (list-head args in-arity)) + (var-args (list-tail args in-arity))) + (list + (maybe-append + (list insn) + (and (= out-arity 1) + (list dst)) + (map register fix-args) + (and (has-prop? prim 'variable) + (list (map register var-args))))))))))) + (lambda (key) + (error "malformed primitive call" (cons prim args))))) + + +;; generate-rtl compiles a CPS form to RTL. +(define (generate-rtl cps name-defn register call-frame-start + rest-args-start nlocals label next-label!) (define (visit cps) ;; cps is either a let expression or a call (match cps @@ -276,7 +282,8 @@ (let ((return-reg (+ 1 (apply max (map register args))))) `(,@(generate-primitive-call - (list return-reg) #f (primitive-name proc) args) + (list return-reg) #f (primitive-name proc) args + name-defn label register) (return ,return-reg)))) (($ proc 'return args) @@ -317,7 +324,8 @@ (perm-label (next-label!))) (if (primitive? proc) `(,@(generate-primitive-call - dsts rest (primitive-name proc) args) + dsts rest (primitive-name proc) args + name-defn label register) (br ,(label cont))) `((call ,(call-frame-start cps) ,(register proc) ,(map register args)) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 7a93138c8..5a1176e5f 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -1,43 +1,44 @@ (define-module (language cps primitives) #:export (*primitive-insn-table* *primitive-in-arity-table* - *primitive-out-arity-table*)) + *primitive-out-arity-table* + *primitive-props-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 -;; name in the (guile) module, its name in a record (which -;; is always the same as its name in (guile), for simplicity) and its -;; 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, in-arity). We don't handle -;; folds, reductions, or variable-arity instructions yet. (define *primitive-insn-data* - '((string-length string-length 1) - (string-ref string-ref 2) - (string->number string->number 1) - (string->symbol string->symbol 1) - (symbol->keyword symbol->keyword 1) - (cons cons 2) - (car car 1) - (cdr cdr 1) - (+ add 2) - (1+ add1 1) - (- sub 2) - (1- sub1 1) - (* mul 2) - (/ div 2) + ;; fields: + ;; (Scheme name, VM name, in arity, out arity, props ...) + + ;; "Scheme name" is what will appear in CPS records, and + ;; also the corresponding procedure's name in the (guile) module if it + ;; has one. "out arity" must be 0 or 1. "in arity" is the minimum in + ;; arity. if the primitive accepts more than that, it should have the + ;; "variable" property. + '((string-length string-length 1 1) + (string-ref string-ref 2 1) + (string->number string->number 1 1) + (string->symbol string->symbol 1 1) + (symbol->keyword symbol->keyword 1 1) + (cons cons 2 1) + (car car 1 1) + (cdr cdr 1 1) + (+ add 2 1) + (1+ add1 1 1) + (- sub 2 1) + (1- sub1 1 1) + (* mul 2 1) + (/ div 2 1) ;; quo isn't here because I don't know which of our many types of ;; division it's supposed to be. same for rem and mod. - (ash ash 2) - (logand logand 2) - (logior logior 2) - (logxor logxor 2) - (vector-length vector-length 1) - (vector-ref vector-ref 2) - (struct-vtable struct-vtable 1) - (struct-ref struct-ref 2) - (class-of class-of 1))) + (ash ash 2 1) + (logand logand 2 1) + (logior logior 2 1) + (logxor logxor 2 1) + (vector-length vector-length 1 1) + (vector-ref vector-ref 2 1) + (struct-vtable struct-vtable 1 1) + (struct-ref struct-ref 2 1) + (class-of class-of 1 1) + (fix-closure fix-closure 1 0 variable))) ;; this table maps our names for primitives (which are the Scheme names) ;; to the corresponding VM instructions. It also does double duty as the @@ -54,11 +55,12 @@ ;; 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. +;; and this one holds the number of outputs. (define *primitive-out-arity-table* (make-hash-table)) +;; this is for miscellaneous properties +(define *primitive-props-table* (make-hash-table)) + (define (fill-insn-tables!) (for-each (lambda (entry) @@ -67,7 +69,9 @@ (hashq-set! *primitive-in-arity-table* (car entry) (caddr entry)) (hashq-set! *primitive-out-arity-table* - (car entry) 1)) + (car entry) (cadddr entry)) + (hashq-set! *primitive-props-table* + (car entry) (cddddr entry))) *primitive-insn-data*)) (fill-insn-tables!) diff --git a/module/language/cps/util.scm b/module/language/cps/util.scm index 8fa6591b3..a5de59341 100644 --- a/module/language/cps/util.scm +++ b/module/language/cps/util.scm @@ -1,7 +1,7 @@ (define-module (language cps util) #:use-module (ice-9 q) #:use-module (srfi srfi-1) - #:export (append-qs! int-range generate-shuffle)) + #:export (append-qs! int-range maybe-append generate-shuffle)) ;; The functions in this file are not directly related to CPS or ;; compilation; they're here because the CPS compiler needs them and @@ -19,6 +19,15 @@ (cons start (int-range (+ start 1) end)) '())) +;; this is a totally generic utility +(define (maybe-append . args) + (cond ((null? args) '()) + ((eq? (car args) #f) + (apply maybe-append (cdr args))) + (else + (append (car args) + (apply maybe-append (cdr args)))))) + ;; 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 diff --git a/test-suite/tests/compile-rtl.test b/test-suite/tests/compile-rtl.test new file mode 100644 index 000000000..51fda7d64 --- /dev/null +++ b/test-suite/tests/compile-rtl.test @@ -0,0 +1,29 @@ +(use-modules + (test-suite lib) + (language cps) + (language cps compile-rtl)) + +(with-test-prefix "generate-primitive-call" + (pass-if-equal "arity: 1 -> 1" + '((string-length 1 0)) + (let ((regs (make-object-property))) + (set! (regs 'a) 0) + (generate-primitive-call '(1) #f 'string-length '(a) + #f #f regs))) + + (pass-if-equal "arity: 2 -> 1" + '((cons 2 0 1)) + (let ((regs (make-object-property))) + (set! (regs 'a) 0) + (set! (regs 'b) 1) + (generate-primitive-call '(2) #f 'cons '(a b) + #f #f regs))) + + (pass-if-equal "arity: variable -> 0" + '((fix-closure 0 (1 2))) + (let ((regs (make-object-property))) + (set! (regs 'a) 0) + (set! (regs 'b) 1) + (set! (regs 'c) 2) + (generate-primitive-call '() #f 'fix-closure '(a b c) + #f #f regs)))) -- cgit v1.2.1