From 64efe3634978a2a7e06d6f21020f381795893403 Mon Sep 17 00:00:00 2001 From: Doug Evans Date: Fri, 25 Sep 2009 19:40:08 +0000 Subject: [PATCH] * operand.scm (/anyof-merge-setter): Handle set-quiet. * rtl-c.scm (estate-make-for-rtl-c): Delete args context, owner, rtl-cover-fns?, macro?. All callers updated. (estate-make-for-normal-rtl-c): Delete, have all callers call estate-make-for-rtl-c directly. (rtl-c-parsed): Pass #:outer-expr to estate-make-for-rtl-c. (rtl-c, rtl-c-expr-parsed, rtl-c-expr, rtl-c++-parsed, rtl-c++): Ditto. * rtl-c.scm (/par-replace-set-dest-expr-fn): New function, replaces /par-replace-set-dests. (/par-replace-set-src-expr-fn): New function, replaces /par-replace-set-srcs. (s-parallel): Rewrite. * rtl.scm (rtx-pretty-strdump): New function. * rtl-traverse.scm (/rtx-canon-error): Use it. (): New member outer-expr. (estate-error): Include outer expression in error message if present. * rtl.scm (rtx-single-set?): Handle set-quiet. --- ChangeLog | 24 +++++ operand.scm | 5 +- rtl-c.scm | 247 +++++++++++++++++++++++++---------------------- rtl-traverse.scm | 22 +++-- rtl.scm | 11 ++- sim.scm | 6 +- 6 files changed, 183 insertions(+), 132 deletions(-) diff --git a/ChangeLog b/ChangeLog index c46419b..8585dbd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,27 @@ +2009-09-25 Doug Evans + + * operand.scm (/anyof-merge-setter): Handle set-quiet. + + * rtl-c.scm (estate-make-for-rtl-c): Delete args context, owner, + rtl-cover-fns?, macro?. All callers updated. + (estate-make-for-normal-rtl-c): Delete, have all callers call + estate-make-for-rtl-c directly. + (rtl-c-parsed): Pass #:outer-expr to estate-make-for-rtl-c. + (rtl-c, rtl-c-expr-parsed, rtl-c-expr, rtl-c++-parsed, rtl-c++): Ditto. + + * rtl-c.scm (/par-replace-set-dest-expr-fn): New function, + replaces /par-replace-set-dests. + (/par-replace-set-src-expr-fn): New function, replaces + /par-replace-set-srcs. + (s-parallel): Rewrite. + + * rtl.scm (rtx-pretty-strdump): New function. + * rtl-traverse.scm (/rtx-canon-error): Use it. + (): New member outer-expr. + (estate-error): Include outer expression in error message if present. + + * rtl.scm (rtx-single-set?): Handle set-quiet. + 2009-09-23 Doug Evans * xc16x.cpu (h-cr): New hardware. diff --git a/operand.scm b/operand.scm index 144afbd..22a90a7 100644 --- a/operand.scm +++ b/operand.scm @@ -1239,7 +1239,8 @@ (let ((src (rtx-set-src setter)) (dest (rtx-set-dest setter)) (mode (rtx-mode setter)) - (options (rtx-options setter))) + (options (rtx-options setter)) + (name (rtx-name setter))) (if (rtx-kind 'mem dest) (set! dest (rtx-change-address dest @@ -1247,7 +1248,7 @@ (rtx-mem-addr dest) value-names values)))) (set! src (/anyof-merge-getter src value-names values)) - (rtx-make 'set options mode dest src))) + (rtx-make name options mode dest src))) (else (error "/anyof-merge-setter: unsupported form" (car setter)))) ) diff --git a/rtl-c.scm b/rtl-c.scm index 83837cf..065b730 100644 --- a/rtl-c.scm +++ b/rtl-c.scm @@ -272,37 +272,24 @@ (loop (cddr args) unrecognized))))) ) -; Build an estate for use in generating C. -; CONTEXT is a object or #f if there is none. -; OWNER is the owner of the expression or #f if there is none. -; EXTRA-VARS-ALIST is an association list of -; (symbol -or-mode-name value) elements to be used during value lookup. -; OVERRIDES is a #:keyword/value list of parameters to apply last. - -(define (estate-make-for-rtl-c context owner extra-vars-alist - rtl-cover-fns? macro? overrides) +;; Build an estate for use in generating C. +;; EXTRA-VARS-ALIST is an association list of +;; (symbol -or-mode-name value) elements to be used during value lookup. +;; OVERRIDES is a #:keyword/value list of parameters to apply last. +;; +;; ??? Move EXTRA-VARS-ALIST into OVERRIDES (caller would have to call +;; rtx-env-init-stack1)? + +(define (estate-make-for-rtl-c extra-vars-alist overrides) (apply vmake (append! (list - #:context context - #:owner owner #:expr-fn (lambda (rtx-obj expr mode estate) (rtl-c-generator rtx-obj)) #:env (rtx-env-init-stack1 extra-vars-alist) - #:rtl-cover-fns? rtl-cover-fns? - #:macro? macro?) - overrides)) -) - -(define (estate-make-for-normal-rtl-c extra-vars-alist overrides) - (estate-make-for-rtl-c - #f ; FIXME: context - #f ; FIXME: owner - extra-vars-alist - /rtl-c-rtl-cover-fns? - #f ; macro? - overrides) + #:rtl-cover-fns? /rtl-c-rtl-cover-fns?) + overrides)) ) ; Translate RTL expression EXPR to C. @@ -323,7 +310,12 @@ ; with. (define (rtl-c-parsed mode x extra-vars-alist . overrides) - (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) + ;; ??? If we're passed insn-compiled-semantics the output of xops is + ;; confusing. Fix by subclassing -> , and + ;; have provide original source expr. + (let ((estate (estate-make-for-rtl-c extra-vars-alist + (cons #:outer-expr + (cons x overrides))))) (rtl-c-with-estate estate mode x)) ) @@ -331,7 +323,11 @@ ; MODE is a object. (define (rtl-c mode x extra-vars-alist . overrides) - (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) + ;; This doesn't pass the canonicalized expr for #outer-expr on purpose, + ;; to keep it closer to what the user wrote. + (let ((estate (estate-make-for-rtl-c extra-vars-alist + (cons #:outer-expr + (cons x overrides))))) (rtl-c-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x extra-vars-alist))) ) @@ -347,7 +343,12 @@ ; MODE is a object. (define (rtl-c-expr-parsed mode x extra-vars-alist . overrides) - (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) + ;; ??? If we're passed insn-compiled-semantics the output of xops is + ;; confusing. Fix by subclassing -> , and + ;; have provide original source expr. + (let ((estate (estate-make-for-rtl-c extra-vars-alist + (cons #:outer-expr + (cons x overrides))))) (rtl-c-expr-with-estate estate mode x)) ) @@ -355,7 +356,11 @@ ; MODE is a object. (define (rtl-c-expr mode x extra-vars-alist . overrides) - (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) + ;; This doesn't pass the canonicalized expr for #outer-expr on purpose, + ;; to keep it closer to what the user wrote. + (let ((estate (estate-make-for-rtl-c extra-vars-alist + (cons #:outer-expr + (cons x overrides))))) (rtl-c-expr-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x extra-vars-alist))) ) @@ -367,14 +372,9 @@ ; elements to be used during value lookup. ; OVERRIDES is a #:keyword/value list of parameters to apply last. -(define (estate-make-for-normal-rtl-c++ extra-vars-alist overrides) - (estate-make-for-rtl-c - #f ; FIXME: context - #f ; FIXME: owner - extra-vars-alist - /rtl-c-rtl-cover-fns? - #f ; macro? - (cons #:output-language (cons "c++" overrides))) +(define (estate-make-for-rtl-c++ extra-vars-alist overrides) + (estate-make-for-rtl-c extra-vars-alist + (cons #:output-language (cons "c++" overrides))) ) ; Translate parsed RTL expression X to a string of C++ code. @@ -387,7 +387,12 @@ ; with. (define (rtl-c++-parsed mode x extra-vars-alist . overrides) - (let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides))) + ;; ??? If we're passed insn-compiled-semantics the output of xops is + ;; confusing. Fix by subclassing -> , and + ;; have provide original source expr. + (let ((estate (estate-make-for-rtl-c++ extra-vars-alist + (cons #:outer-expr + (cons x overrides))))) (rtl-c-with-estate estate mode x)) ) @@ -395,7 +400,11 @@ ; MODE is a object. (define (rtl-c++ mode x extra-vars-alist . overrides) - (let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides))) + ;; This doesn't pass the canonicalized expr for #outer-expr on purpose, + ;; to keep it closer to what the user wrote. + (let ((estate (estate-make-for-rtl-c++ extra-vars-alist + (cons #:outer-expr + (cons x overrides))))) (rtl-c-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x extra-vars-alist))) ) @@ -1162,89 +1171,90 @@ "\n") ) -; Parallels are handled by converting them into two sequences. The first has -; all set destinations replaced with temps, and the second has all set sources -; replaced with those temps. -; ??? Revisit later to see if (if ...) and (set pc ...) is ok. -; How about disallowing if's and jump's inside parallels? -; One can still put a parallel inside an `if' however. - -(define (/par-replace-set-dests estate exprs) - ;(display exprs) (newline) - (let ((sets (list 'set 'set-quiet - (rtx-lookup 'set) (rtx-lookup 'set-quiet)))) - (letrec ((replace - (lambda (expr) - ;(display expr) (newline) - (let ((name (car expr)) - (options (rtx-options expr)) - (mode (rtx-mode expr))) - (if (memq name sets) - (list name - options - mode - (/par-new-temp! ; replace dest with temp - (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore - (rtx-lvalue-mode-name estate (rtx-set-dest expr)) - mode)) - (rtx-set-src expr)) - (cons name - (cons options - (cons mode (replace (rtx-args expr))))))))) - ) - (map replace exprs))) -) - -; This must process expressions in the same order as /par-replace-set-dests! - -(define (/par-replace-set-srcs estate exprs) - (let ((sets (list 'set 'set-quiet - (rtx-lookup 'set) (rtx-lookup 'set-quiet)))) - (letrec ((replace - (lambda (expr) - (let ((name (car expr)) - (options (rtx-options expr)) - (mode (rtx-mode expr))) - (if (memq name sets) - (list name - options - mode - (rtx-set-dest expr) - (/par-next-temp!)) ; the source's temp - (cons name - (cons options - (cons mode (replace (cddr expr))))))))) - ) - (map replace exprs))) -) - -; Return a node for a `parallel'. +;; Parallels are handled by converting them into two sequences. The first has +;; all set destinations replaced with temps, and the second has all set sources +;; replaced with those temps. + +;; rtl-traverse expr-fn to replace the dest of sets with the parallel temp. + +(define (/par-replace-set-dest-expr-fn rtx-obj expr parent-expr op-pos + tstate appstuff) + (case (car expr) + ((set set-quiet) + (let ((name (rtx-name expr)) + (options (rtx-options expr)) + (mode (rtx-mode expr)) + (dest (rtx-set-dest expr)) + (src (rtx-set-src expr))) + (list name options mode (/par-new-temp! mode) src))) + (else #f)) +) + +;; rtl-traverse expr-fn to replace the src of sets with the parallel temp. +;; This must process expressions in the same order as /par-replace-set-dests. + +(define (/par-replace-set-src-expr-fn rtx-obj expr parent-expr op-pos + tstate appstuff) + (case (car expr) + ((set set-quiet) + (let ((name (rtx-name expr)) + (options (rtx-options expr)) + (mode (rtx-mode expr)) + (dest (rtx-set-dest expr)) + (src (rtx-set-src expr))) + (list name options mode dest (/par-next-temp!)))) + (else #f)) +) + +;; Return a node for a `parallel'. (define (s-parallel estate . exprs) (begin - ; Initialize /par-temp-list for /par-replace-set-dests. + + ;; Initialize /par-temp-list for /par-replace-set-dests. (set! /par-temp-list nil) - (let* ((set-dests (string-map (lambda (e) - (rtl-c-with-estate estate VOID e)) - (/par-replace-set-dests estate exprs))) + + (let* ((set-dest-exprs + (map (lambda (expr) + (rtx-traverse (estate-context estate) + (estate-owner estate) + expr + /par-replace-set-dest-expr-fn + #f)) + exprs)) + (set-dests (string-map (lambda (expr) + (rtl-c-with-estate estate VOID expr)) + set-dest-exprs)) (temps (reverse! /par-temp-list))) - ; Initialize /par-temp-list for /par-replace-set-srcs. + + ;; Initialize /par-temp-list for /par-replace-set-srcs. (set! /par-temp-list temps) - (cx:make VOID - (string-append - ; FIXME: do {} while (0); doesn't get "optimized out" - ; internally by gcc, meaning two labels and a loop are - ; created for it to have to process. We can generate pretty - ; big files and can cause gcc to require *lots* of memory. - ; So let's try just {} ... - "{\n" - (/gen-par-temp-defns temps) - set-dests - (string-map (lambda (e) - (rtl-c-with-estate estate VOID e)) - (/par-replace-set-srcs estate exprs)) - "}\n") - ))) + + (let* ((set-src-exprs + (map (lambda (expr) + (rtx-traverse (estate-context estate) + (estate-owner estate) + expr + /par-replace-set-src-expr-fn + #f)) + exprs)) + (set-srcs (string-map (lambda (expr) + (rtl-c-with-estate estate VOID expr)) + set-src-exprs))) + + (cx:make VOID + (string-append + ;; ??? do {} while (0); doesn't get "optimized out" + ;; internally by gcc, meaning two labels and a loop are + ;; created for it to have to process. We can generate pretty + ;; big files and can cause gcc to require *lots* of memory. + ;; So let's try just {} ... + "{\n" + (/gen-par-temp-defns temps) + set-dests + set-srcs + "}\n") + )))) ) ; Return a node for a `sequence'. @@ -1257,7 +1267,7 @@ (mode:eq? 'VOID mode)) (cx:make VOID (string-append - ; FIXME: do {} while (0); doesn't get "optimized out" + ; ??? do {} while (0); doesn't get "optimized out" ; internally by gcc, meaning two labels and a loop are ; created for it to have to process. We can generate pretty ; big files and can cause gcc to require *lots* of memory. @@ -1380,10 +1390,11 @@ ; nil #f #f)) ) -; Operand support +;; Operand support. (define-fn operand (*estate* options mode object-or-name) (cond ((operand? object-or-name) + ;; FIXME: objects is what xop is for ;; mode checking to be done during canonicalization object-or-name) ((symbol? object-or-name) @@ -1396,7 +1407,7 @@ (estate-error *estate* "bad arg to `operand'" object-or-name))) ) -(define-fn xop (*estate* options mode object) +(define-fn xop (*estate* options mode object) (let ((delayed (assoc '#:delay (estate-modifiers *estate*)))) (if (and delayed (equal? APPLICATION 'SID-SIMULATOR) diff --git a/rtl-traverse.scm b/rtl-traverse.scm index 11268ac..958d4fb 100644 --- a/rtl-traverse.scm +++ b/rtl-traverse.scm @@ -27,10 +27,7 @@ ;; Flag an error while canonicalizing rtl. (define (/rtx-canon-error cstate errmsg expr parent-expr op-num) - (let* ((pretty-parent-expr - (with-output-to-string - (lambda () - (pretty-print (rtx-dump (/cstate-outer-expr cstate)))))) + (let* ((pretty-parent-expr (rtx-pretty-strdump (/cstate-outer-expr cstate))) (intro (if parent-expr (string-append "While canonicalizing " (rtx-strdump parent-expr) @@ -1881,6 +1878,10 @@ ; want it to). So we record the value here. (owner . #f) + ;; The outer expr being evaluated, for error messages. + ;; #f if there is none. + (outer-expr . #f) + ; EXPR-FN is a dual-purpose beast. The first purpose is to ; just process the current expression and return the result. ; The second purpose is to lookup the function which will then @@ -1937,6 +1938,8 @@ (elm-set! self 'context (cadr args))) ((#:owner) (elm-set! self 'owner (cadr args))) + ((#:outer-expr) + (elm-set! self 'outer-expr (cadr args))) ((#:expr-fn) (elm-set! self 'expr-fn (cadr args))) ((#:env) @@ -1955,10 +1958,10 @@ ; Accessors. (define-getters estate - (context owner expr-fn env depth modifiers) + (context owner outer-expr expr-fn env depth modifiers) ) (define-setters estate - (context owner expr-fn env depth modifiers) + (env depth modifiers) ) ; Build an estate for use in producing a value from rtl. @@ -2028,7 +2031,12 @@ (apply context-owner-error (cons (estate-context estate) (cons (estate-owner estate) - (cons "During rtx evalution" + (cons (string-append "During rtx evalution" + (if (estate-outer-expr estate) + (string-append " of\n" + (rtx-pretty-strdump (estate-outer-expr estate)) + "\n") + "")) (cons errmsg expr))))) ) diff --git a/rtl.scm b/rtl.scm index bb99ef7..0394378 100644 --- a/rtl.scm +++ b/rtl.scm @@ -760,7 +760,6 @@ (define (rtx-make-xop op) (rtx-make 'xop (op:mode-name op) op) ) - (define rtx-xop-obj rtx-arg1) ;(define (rtx-opspec? rtx) (eq? 'opspec (rtx-name rtx))) @@ -773,7 +772,7 @@ (define (rtx-make-set dest src) (rtx-make 'set dest src)) (define rtx-set-dest rtx-arg1) (define rtx-set-src rtx-arg2) -(define (rtx-single-set? rtx) (eq? (car rtx) 'set)) +(define (rtx-single-set? rtx) (memq (car rtx) '(set set-quiet))) (define rtx-alu-op-mode rtx-mode) (define (rtx-alu-op-arg rtx n) (list-ref rtx (+ n 3))) @@ -856,6 +855,14 @@ (write (rtx-dump rtx)))) ) +;; Return the pretty-printed from of RTX. + +(define (rtx-pretty-strdump rtx) + (with-output-to-string + (lambda () + (pretty-print (rtx-dump rtx)))) +) + ; Return a boolean indicating if EXPR is known to be a compile-time constant. (define (rtx-compile-time-constant? expr) diff --git a/sim.scm b/sim.scm index b1d7f18..958c48b 100644 --- a/sim.scm +++ b/sim.scm @@ -1018,7 +1018,7 @@ ; For operands, the word `read' is only used in this context. (define (op:read op sfmt) - (let ((estate (estate-make-for-normal-rtl-c nil nil))) + (let ((estate (estate-make-for-rtl-c nil nil))) (send op 'gen-read estate sfmt /par-operand-macro)) ) @@ -1029,7 +1029,7 @@ ; For operands, the word `write' is only used in this context. (define (op:write op sfmt) - (let ((estate (estate-make-for-normal-rtl-c nil nil))) + (let ((estate (estate-make-for-rtl-c nil nil))) (send op 'gen-write estate sfmt /par-operand-macro)) ) @@ -1328,7 +1328,7 @@ ; smart enough to know there is no need. (define (op:record-profile op sfmt out?) - (let ((estate (estate-make-for-normal-rtl-c nil nil))) + (let ((estate (estate-make-for-rtl-c nil nil))) (send op 'gen-record-profile sfmt out? estate)) ) -- 2.43.5