From d4b77af68389580594a437f9b6fe7c2b74be1adb Mon Sep 17 00:00:00 2001 From: devans Date: Thu, 27 Aug 2009 05:47:12 +0000 Subject: [PATCH] * read.scm (parse-error): Change error message output format to match context-owner-error. * rtl-c.scm (-rtl-c-get): Call estate-error instead of error. (rtl-c-set-quiet, rtl-c-set-trace): Ditto. (s-if, s-cond, -gen-non-vm-case-test): Ditto. (operand): Call estate-error instead of context-error. (local, delay): Ditto. (ref, attr): Call estate-error instead of error. * rtl-traverse.scm (tstate-error): New function. (-rtx-traverse-error): Call tstate-error instead of context-error. (-rtx-traverse-operands, -rtx-traverse): Ditto. (estate-error): New function. * rtl.scm (rtx-lvalue-mode-name): Handle locals. Call estate-error instead of error. (e-if): Call estate-error instead of error. * rtx-funcs.scm (error): Call estate-error instead of context-error. (member): Ditto. * utils-cgen.scm (context-error): New arg `intro', all callers updated. Rewrite to call context-owner-error. (context-owner-error): New function. --- cgen/ChangeLog | 21 ++++++++++++ cgen/read.scm | 13 +++++--- cgen/rtl-c.scm | 91 +++++++++++++++++++++++++++++---------------------- cgen/rtl-traverse.scm | 56 ++++++++++++++++++------------- cgen/rtl-xform.scm | 15 +++++++-- cgen/rtl.scm | 21 +++++++++--- cgen/rtx-funcs.scm | 10 +++--- cgen/utils-cgen.scm | 81 ++++++++++++++++++++++++++++++++++++--------- 8 files changed, 212 insertions(+), 96 deletions(-) diff --git a/cgen/ChangeLog b/cgen/ChangeLog index 4e4f6914fa..f903490b7f 100644 --- a/cgen/ChangeLog +++ b/cgen/ChangeLog @@ -1,5 +1,26 @@ 2009-08-26 Doug Evans + * read.scm (parse-error): Change error message output format + to match context-owner-error. + * rtl-c.scm (-rtl-c-get): Call estate-error instead of error. + (rtl-c-set-quiet, rtl-c-set-trace): Ditto. + (s-if, s-cond, -gen-non-vm-case-test): Ditto. + (operand): Call estate-error instead of context-error. + (local, delay): Ditto. + (ref, attr): Call estate-error instead of error. + * rtl-traverse.scm (tstate-error): New function. + (-rtx-traverse-error): Call tstate-error instead of context-error. + (-rtx-traverse-operands, -rtx-traverse): Ditto. + (estate-error): New function. + * rtl.scm (rtx-lvalue-mode-name): Handle locals. Call estate-error + instead of error. + (e-if): Call estate-error instead of error. + * rtx-funcs.scm (error): Call estate-error instead of context-error. + (member): Ditto. + * utils-cgen.scm (context-error): New arg `intro', all callers updated. + Rewrite to call context-owner-error. + (context-owner-error): New function. + * ifield.scm ( constructor): New arg `location', all callers updated. * insn.scm ( constructor): Ditto. diff --git a/cgen/read.scm b/cgen/read.scm index f541986641..b7246859f9 100644 --- a/cgen/read.scm +++ b/cgen/read.scm @@ -333,15 +333,18 @@ (set! context (make (current-reader-location) #f))) (let* ((loc (or (context-location context) (unspecified-location))) (top-sloc (location-top loc)) - (prefix (context-prefix context))) + (intro "While reading description") + (prefix (context-prefix context)) + (text (if prefix + (string-append prefix ": " message) + message))) (error (simple-format #f - "While reading description:\n~A: ~A:\n ~S\nReference chain:\n~A~A" + "\n~A:\n~A: ~A: ~S\n\nReference chain:\n~A~A" + intro (single-location->simple-string top-sloc) - (if prefix - (string-append prefix ": " message) - message) + text expr (location->string loc) (if (null? maybe-help-text) diff --git a/cgen/rtl-c.scm b/cgen/rtl-c.scm index 11a7a4a479..e63e1b51f9 100644 --- a/cgen/rtl-c.scm +++ b/cgen/rtl-c.scm @@ -422,11 +422,14 @@ ((-rtx-mode-compatible? mode (cx:mode src)) (cx-new-mode mode src)) (else - (error (string-append "incompatible mode for " - "(" (obj:name (cx:mode src)) " vs " (obj:name mode) ") in " - "\"" (cx:c src) "\"" - ": ") - (obj:name mode))))) + (estate-error + estate + (string-append "incompatible mode for " + "(" (obj:name (cx:mode src)) " vs " + (obj:name mode) ") in " + "\"" (cx:c src) "\"" + ": ") + (obj:name mode))))) ; The recursive call to -rtl-c-get is in case the result of rtx-eval ; is a hardware object, rtx-func object, or another rtl expression. @@ -449,9 +452,11 @@ (let ((mode (-rtx-lazy-sem-mode mode))) (send src 'cxmake-get estate mode #f #f))) (else - (error (string-append "operand " (obj:str-name src) - " referenced in incompatible mode: ") - (obj:name mode)))))) + (estate-error + estate + (string-append "operand " (obj:str-name src) + " referenced in incompatible mode: ") + (obj:name mode)))))) ((or (and (symbol? src) (rtx-temp-lookup (estate-env estate) src)) (rtx-temp? src)) @@ -463,9 +468,11 @@ ((-rtx-mode-compatible? mode (rtx-temp-mode src)) (let ((mode (-rtx-lazy-sem-mode mode))) (send src 'cxmake-get estate mode #f #f))) - (else (error (string-append "sequence temp " (rtx-temp-name src) - " referenced in incompatible mode: ") - (obj:name mode)))))) + (else (estate-error + estate + (string-append "sequence temp " (rtx-temp-name src) + " referenced in incompatible mode: ") + (obj:name mode)))))) ((integer? src) ; Default mode of string argument is INT. @@ -479,7 +486,7 @@ (cx:make INT src) (cx:make mode src))) - (else (error "-rtl-c-get: invalid argument:" src)))) + (else (estate-error estate "-rtl-c-get: invalid argument:" src)))) ) (define (rtl-c-get estate mode src) @@ -507,9 +514,11 @@ ((rtx? dest) (rtx-eval-with-estate dest mode estate)) (else - (error "rtl-c-set-quiet: invalid dest:" dest))))) + (estate-error estate + "rtl-c-set-quiet: invalid dest:" + dest))))) (if (not (object? xdest)) - (error "rtl-c-set-quiet: invalid dest:" dest)) + (estate-error estate "rtl-c-set-quiet: invalid dest:" dest)) (let ((mode (if (mode:eq? 'DFLT mode) (-rtx-obj-mode xdest) (-rtx-lazy-sem-mode mode)))) @@ -532,9 +541,11 @@ ((rtx? dest) (rtx-eval-with-estate dest mode estate)) (else - (error "rtl-c-set-trace: invalid dest:" dest))))) + (estate-error estate + "rtl-c-set-trace: invalid dest:" + dest))))) (if (not (object? xdest)) - (error "rtl-c-set-trace: invalid dest:" dest)) + (estate-error estate "rtl-c-set-trace: invalid dest:" dest)) (let ((mode (if (mode:eq? 'DFLT mode) (-rtx-obj-mode xdest) ; FIXME: internal routines (-rtx-lazy-sem-mode mode)))) @@ -861,7 +872,7 @@ (define (s-if estate mode cond then . else) (if (> (length else) 1) - (error "if: too many elements in `else' part" else)) + (estate-error estate "if: too many elements in `else' part" else)) (let () (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode)) @@ -883,7 +894,7 @@ ") : (" (cx:c (rtl-c-get estate mode (car else))) "))")) - (error "non-VoidMode `if' must have `else' part")))) + (estate-error estate "non-void-mode `if' must have `else' part")))) ) ; A multiway `if'. @@ -900,7 +911,7 @@ (define (s-cond estate mode . cond-code-list) (let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode)))) (if (null? cond-code-list) - (error "empty `cond'")) + (estate-error estate "empty `cond'")) (let ((if-part (if vm? "if (" "(")) (then-part (if vm? ") " ") ? ")) (elseif-part (if vm? " else if (" " : (")) @@ -995,10 +1006,11 @@ ((symbol? (car cases)) (if (enum-lookup-val (car cases)) (rtx-make 'enum mode (car cases)) - (context-error (estate-context estate) - "symbol not an enum" - (car cases)))) - (else (error "invalid case" (car cases)))))) + (estate-error estate + "symbol not an enum" + (car cases)))) + (else + (estate-error estate "invalid case" (car cases)))))) (loop (string-append result (if (= (string-length result) 0) @@ -1298,12 +1310,10 @@ ((symbol? object-or-name) (let ((object (current-op-lookup object-or-name))) (if (not object) - (context-error (estate-context estate) - "undefined operand" object-or-name)) + (estate-error estate "undefined operand" object-or-name)) object)) (else - (context-error (estate-context estate) - "bad arg to `operand'" object-or-name))) + (estate-error estate "bad arg to `operand'" object-or-name))) ) (define-fn xop (estate options mode object) @@ -1330,12 +1340,10 @@ ((symbol? object-or-name) (let ((object (rtx-temp-lookup (estate-env estate) object-or-name))) (if (not object) - (context-error (estate-context estate) - "undefined local" object-or-name)) + (estate-error estate "undefined local" object-or-name)) object)) (else - (context-error (estate-context estate) - "bad arg to `local'" object-or-name))) + (estate-error estate "bad arg to `local'" object-or-name))) ) (define-fn reg (estate options mode hw-elm . indx-sel) @@ -1363,7 +1371,8 @@ (define-fn ref (estate options mode name) (if (not (insn? (estate-owner estate))) - (error "ref: not processing an insn")) + (estate-error estate "ref: not processing an insn" + (obj:name (estate-owner estate)))) (cx:make 'UINT (string-append "(referenced & (1 << " @@ -1396,15 +1405,14 @@ ((xop) (op:type (rtx-xop-obj rtx))) (else #f)))) (not (and hw (or (pc? hw) (memory? hw) (register? hw))))) - (context-error - (estate-context estate) - (string-append - "(delay ...) rtx applied to wrong type of operand '" (car rtx) "'. should be pc, register or memory"))) + (estate-error + estate + "(delay ...) rtx applied to wrong type of operand, should be pc, register or memory" + (car rtx))) ;; signal an error if we're delayed and not in a "parallel-insns" CPU (if (not (with-parallel?)) - (context-error - (estate-context estate) - "delayed operand in a non-parallel cpu")) + (estate-error estate "delayed operand in a non-parallel cpu" + (car rtx))) ;; update cpu-global pipeline bound (cpu-set-max-delay! (current-cpu) (max (cpu-max-delay (current-cpu)) new-delay)) ;; pass along new delay to embedded rtx @@ -1437,7 +1445,8 @@ (cond ((equal? owner '(current-insn () DFLT)) (s-c-raw-call estate 'INT "GET_ATTR" (string-upcase (gen-c-symbol attr-name)))) - (else (error "attr: unsupported object type:" owner))) + (else + (estate-error estate "attr: unsupported object type:" owner))) ) (define-fn const (estate options mode c) @@ -1768,5 +1777,7 @@ ) ; The result is the rtl->c generator table. + table + )) ; End of rtl-c-build-table diff --git a/cgen/rtl-traverse.scm b/cgen/rtl-traverse.scm index ae8fb1b098..648c4373de 100644 --- a/cgen/rtl-traverse.scm +++ b/cgen/rtl-traverse.scm @@ -148,6 +148,16 @@ (define (tstate-decr-depth! tstate) (tstate-set-depth! tstate (1- (tstate-depth tstate))) ) + +; Issue an error given a tstate. + +(define (tstate-error tstate errmsg . expr) + (apply context-owner-error + (cons (tstate-context tstate) + (cons (tstate-owner tstate) + (cons "During rtx traversal" + (cons errmsg expr))))) +) ; Traversal/compilation support. @@ -172,16 +182,14 @@ rtx-list) ) -; Cover-fn to context-error for signalling an error during rtx traversal. +; Cover-fn to tstate-error for signalling an error during rtx traversal +; of operand OP-NUM. +; RTL-EXPR must be an rtl expression. -(define (-rtx-traverse-error tstate errmsg expr op-num) -; (parse-error (tstate-context context) -; (string-append errmsg ", operand number " -; (number->string op-num)) -; (rtx-dump expr)) - (context-error (tstate-context tstate) - (string-append errmsg ", operand #" (number->string op-num)) - (rtx-strdump expr)) +(define (-rtx-traverse-error tstate errmsg rtl-expr op-num) + (tstate-error tstate + (string-append errmsg ", operand #" (number->string op-num)) + (rtx-strdump rtl-expr)) ) ; Rtx traversers. @@ -513,12 +521,10 @@ (if (or (null? arg-types) varargs?) (reverse! result) - (context-error (tstate-context tstate) - "missing operands" (rtx-strdump expr)))) + (tstate-error tstate "missing operands" (rtx-strdump expr)))) ((null? arg-types) - (context-error (tstate-context tstate) - "too many operands" (rtx-strdump expr))) + (tstate-error tstate "too many operands" (rtx-strdump expr))) (else (let ((type (if varargs? arg-types (car arg-types))) @@ -726,8 +732,7 @@ (if rtx-obj (-rtx-traverse (-rtx-macro-expand expr rtx-evaluator) expected mode parent-expr op-pos tstate appstuff) - (context-error (tstate-context tstate) "unknown rtx function" - expr)))))) + (tstate-error tstate "unknown rtx function" expr)))))) (tstate-decr-depth! tstate) result)) @@ -755,20 +760,15 @@ (rtx-make-enum 'INT expr) expected mode parent-expr op-pos tstate appstuff)) (else - (context-error (tstate-context tstate) - "unknown operand" expr)))) + (tstate-error tstate "unknown operand" expr)))) ((integer? expr) (-rtx-traverse (rtx-make-const 'INT expr) expected mode parent-expr op-pos tstate appstuff)) (else - (context-error (tstate-context tstate) - "unexpected operand" - expr))) + (tstate-error tstate "unexpected operand" expr))) ; Not expecting RTX or SETRTX. - (context-error (tstate-context tstate) - "unexpected operand" - expr))) + (tstate-error tstate "unexpected operand" expr))) ) ; User visible procedures to traverse an rtl expression. @@ -982,6 +982,16 @@ #:context (tstate-context t) #:env (tstate-env t)) ) + +; Issue an error given an estate. + +(define (estate-error estate errmsg . expr) + (apply context-owner-error + (cons (estate-context estate) + (cons (estate-owner estate) + (cons "During rtx evalution" + (cons errmsg expr))))) +) ; RTL expression evaluation. ; diff --git a/cgen/rtl-xform.scm b/cgen/rtl-xform.scm index 707a48dfce..3b220378dd 100644 --- a/cgen/rtl-xform.scm +++ b/cgen/rtl-xform.scm @@ -76,7 +76,9 @@ (current-mach-list)))) ; Ensure at least one mach is selected. (if (null? values) - (context-error context "rtx simplification, no machs selected" + (context-error context + "While simplifying rtl" + "no machs selected" (rtx-strdump rtx))) ; All values equal to the first one? (if (all-true? (map (lambda (val) @@ -103,6 +105,7 @@ (value (rtx-eq-attr-value rtx))) (if (not (insn? insn)) (context-error context + "While simplifying rtl" "No current insn for `(current-insn)'" (rtx-strdump rtx))) (let ((attr-value (obj-attr-value insn attr))) @@ -395,11 +398,17 @@ (let ((op (current-op-lookup expr))) (if op (rtx-make-operand expr) - (context-error context "can't canonicalize" expr)))) + (context-error context + "While canonicalizing rtl" + "can't canonicalize" + expr)))) ((pair? expr) expr) (else - (context-error context "can't canonicalize" expr))) + (context-error context + "While canonicalizing rtl" + "can't canonicalize" + expr))) ) ;; rtx-compile (and supporting cast) diff --git a/cgen/rtl.scm b/cgen/rtl.scm index 302d5d1d7b..69f743a068 100644 --- a/cgen/rtl.scm +++ b/cgen/rtl.scm @@ -397,10 +397,16 @@ ; (rtx-lvalue-mode-name estate (rtx-opspec-hw-ref x)) ; (rtx-opspec-mode x))) ; ((reg mem) (cadr x)) -; ((local) (obj:name (rtx-temp-mode (rtx-temp-lookup (estate-env estate) -; (cadr x))))) + ((local) ;; (local options mode name) + (let* ((name (cadddr x)) + (temp (rtx-temp-lookup (estate-env estate) name))) + (if (not temp) + (estate-error estate "unknown local" name)) + (obj:name (rtx-temp-mode temp)))) (else - (error "rtx-lvalue-mode-name: not an operand or hardware reference:" x))) + (estate-error error + "rtx-lvalue-mode-name: not an operand or hardware reference:" + x))) ) ; Lookup the mode to use for semantic operations (unsigned modes aren't @@ -498,7 +504,8 @@ ) ; Create an initial environment with local variables. -; VAR-LIST is a list of (mode-name name) elements (the argument to `sequence'). +; VAR-LIST is a list of (mode-name name) elements, i.e. the locals argument to +; `sequence' or equivalent thereof. (define (rtx-env-make-locals var-list) ; Convert VAR-LIST to an associative list of objects. @@ -516,6 +523,10 @@ (cons env env-stack) ) +; Lookup variable NAME in environment ENV. +; The result is the object. +; ??? Should environments only have rtx-temps? + (define (rtx-temp-lookup env name) ;(display "looking up:") (display name) (newline) (let loop ((stack (rtx-env-var-list env))) @@ -1027,7 +1038,7 @@ (define (e-if estate mode cond then . else) (if (> (length else) 1) - (error "if: too many elements in `else' part" else)) + (estate-error estate "if: too many elements in `else' part" else)) (if (null? else) (if cond then) (if cond then (car else))) diff --git a/cgen/rtx-funcs.scm b/cgen/rtx-funcs.scm index 1600a8c7fe..55863f91cb 100644 --- a/cgen/rtx-funcs.scm +++ b/cgen/rtx-funcs.scm @@ -36,7 +36,7 @@ (drn (error &options &mode message) (OPTIONS ANYMODE STRING) (NA NA NA) MISC - (context-error (estate-context *estate*) message) + (estate-error *estate* "error in rtl" message) ) ; Enums @@ -955,9 +955,11 @@ MISC (begin (if (not (rtx-constant? value)) - (context-error (estate-context *estate*) "value is not a constant" value)) + (estate-error *estate* "`member rtx'" + "value is not a constant" value)) (if (not (rtx-kind? 'number-list set)) - (context-error (estate-context *estate*) "set is not a `number-list' rtx" set)) + (estate-error *estate* "`member' rtx" + "set is not a `number-list' rtx" set)) (if (memq (rtx-constant-value value) (rtx-number-list-values set)) (rtx-true) (rtx-false))) @@ -1001,7 +1003,7 @@ ; This has to be a syntax node as we don't want EXPRS to be pre-evaluated. ; All semantic ops must have a mode, though here it must be VOID. ; IGNORE is for consistency with sequence. ??? Delete some day. -; ??? There's no real need for mode either. +; ??? There's no real need for mode either, but convention requires it. (drsn (parallel &options &mode ignore expr . exprs) (OPTIONS VOIDMODE LOCALS RTX . RTX) (NA NA NA VOID . VOID) diff --git a/cgen/utils-cgen.scm b/cgen/utils-cgen.scm index f72b62f998..1f087167b2 100644 --- a/cgen/utils-cgen.scm +++ b/cgen/utils-cgen.scm @@ -328,23 +328,72 @@ (context-append context (stringsym-append ":" name)) ) -; Call this to issue an error message. +; Call this to issue an error message when all you have is a context. ; CONTEXT is a object or #f if there is none. -; ARG is the value that had the error if there is one. - -(define (context-error context errmsg . arg) - (cond ((and context (context-location context)) - (let ((msg (string-append - "@ " - (location->string (context-location context)) - ": " - (context-prefix context) ": " - errmsg ": "))) - (apply error (cons msg arg)))) - (context (let ((msg (string-append (context-prefix context) ": " - errmsg ": "))) - (apply error (cons msg arg)))) - (else (apply error (cons (string-append errmsg ": ") arg)))) +; INTRO is a general introduction to what cgen was doing. +; ERRMSG is, yes, you guessed it, the error message. +; EXPR is the value that had the error if there is one. + +(define (context-error context intro errmsg . expr) + (apply context-owner-error + (cons context + (cons #f + (cons intro + (cons errmsg expr))))) +) + +; Call this to issue an error message when you have a context and an +; or object (we call the "owner"). +; CONTEXT is a object or #f if there is none. +; OWNER is an or object or #f if there is none. +; INTRO is a general introduction to what cgen was doing. +; If OWNER is non-#f, the text " of " is appended. +; ERRMSG is, yes, you guessed it, the error message. +; EXPR is the value that had the error if there is one. + +(define (context-owner-error context owner intro errmsg . expr) + ;; If we don't have a context, look at the owner to try to find one. + ;; We want to include the source location in the error if we can. + (if (and (not context) + owner + (source-ident? owner)) + (set! context (make-obj-context owner #f))) + (if (not context) + (set! context (make-prefix-context #f))) + + (let* ((loc (context-location context)) + (top-sloc (and loc (location-top loc))) + (intro (string-append intro + (if owner + (string-append " of " + (obj:str-name owner)) + ""))) + (prefix (or (context-prefix context) "Error")) + (text (if prefix + (string-append prefix ": " errmsg) + errmsg))) + + (if loc + + (apply error + (cons + (simple-format + #f + "\n~A:\n@ ~A:\n\n~A: ~A:" + intro + (location->string loc) + (single-location->simple-string top-sloc) + text) + expr)) + + (apply error + (cons + (simple-format + #f + "\n~A:\n~A:" + intro + text) + expr)))) ) ; Parse an object name. -- 2.11.0