From: Doug Evans Date: Tue, 3 Nov 2009 16:24:02 +0000 (+0000) Subject: Specify isa(s) when doing ifield, operand, insn lookups. X-Git-Url: https://sourceware.org/git/?a=commitdiff_plain;h=05dd8e2dc1fddfe66ec541525fe12794d0f66397;p=cgen.git Specify isa(s) when doing ifield, operand, insn lookups. ACU = all callers updated. * attr.scm (/attr-eval): Call rtx-value instead of rtx-eval-with-estate. * enum.scm (define-full-insn-enum): Pass isa-name-list to current-ifld-lookup. * html.scm (get-insn-properties): Pass isa-name-list to current-op-lookup. * ifield.scm (/ifld-parse-follows): New arg isas, ACU. * insn.scm (/parse-insn-format-symbol): New arg isa-name-list, ACU. (/parse-insn-format-list, /parse-insn-iformat-iflds): Ditto. (/parse-insn-format, syntax-break-out): Ditto. * mach.scm (obj-filter-by-isa): New function. (current-ifld-lookup): New optional arg maybe-isa-name-list. (/ifld-already-defined?, /op-already-defined?): Simplify. (current-op-lookup): New optional arg maybe-isa-name-list. (current-insn-lookup): New arg isa-name-list, ACU. (/insn-already-defined?, /minsn-already-defined?): Simplify. (current-minsn-lookup): New arg isa-name-list, ACU. * minsn.scm (/minsn-compute-iflds): Pass isa-name-list to current-op-lookup. * opc-itab.scm (compute-syntax): New arg isa-name-list, ACU. (gen-syntax-entry): Ditto. * operand.scm (/operand-parse): Pass isa-name-list to current-ifld-lookup. (/derived-parse-encoding): New arg isa-name-list, ACU. (/derived-parse-ifield-assertion): Ditto. (/derived-operand-parse): Pass isa-name-list to current-op-lookup. (/anyof-parse-choice): Ditto. (anyof-satisfies-assertions?): Pass context to rtx-solve. (/anyof-merge-syntax): New arg container, ACU. (operand-builtin!): Add pc to all isas. * rtl-c.scm (estate-make-for-rtl-c): Delete arg extra-vars-alist, ACU. (estate-make-for-rtl-c++, rtl-c-expr-parsed): Ditto. (rtl-c-parsed, rtl-c++-parsed): Ditto. (rtl-c): New arg isa-name-list, ACU. (rtl-c-expr, rtl-c++): Ditto. (closure): New arg isa-name-list, ACU. * rtl-traverse.scm (/make-cstate): New arg isa-name-list, ACU. (/cstate-isas): New function. (/rtx-canon-symbol-list): New function. (/rtx-canon-env-stack): Renamed from /rtx-canon-env, ACU. updated. (/rtx-make-canon-table): Rename ENV to ENVSTACK, new entry SYMBOLLIST. (/rtx-canon-rtx-operand): Pass isa list to current-op-lookup. (/rtx-canon-rtx-ref, /rtx-canon): Ditto. (rtx-canonicalize): New arg isa-name-list, ACU. (rtx-canonicalize-stmt): Delete. (tstate-make): New arg isas, ACU. (tstate-isas, tstate--set-isas!): New functions. (tstate-env-stack): Renamed from tstate-env, ACU. (tstate-set-env-stack!): Renamed from tstate-set-env!, ACU. (tstate-make-closure): Renamed from tstate-new-env, new arg isa-name-list, ACU. (/rtx-traverse-env): Delete. (/rtx-make-traverser-table): Rename ENV to ENVSTACK, new entry SUMBOLLIST. (/rtx-traverse): Include conditional flag in dump output. Update isa,envstack for closures. Pass isa list to current-op-lookup. (): New member isas. Rename env to env-stack. ( vmake!): Handle #:isas. #:env renamed to #:env-stack. (): New getter/setter for isas. Rename env getter/setter to env-stack. (estate-make-for-eval): Provide #:isas. (estate-make-closure): Renamed from estate-new-env. New arg isa-name-list, ACU. * rtl-xform.scm (/rtx-simplify-expr-fn): Handle closures. (/rtx-trim-args): ENV renamed to ENVSTACK. Ad ITERATION, SYMBOLLIST. (/rtx-trim-for-doc): Handle closures. * rtl.scm (/rtx-valid-types): Rename ENV to ENVSTACK. Add ITERATION, SYMBOLLIST. (rtx-env-var-list): Delete. (rtx-env-make): Handle already-compiled environments. (rtx-var-alist-to-env): New function. (rtx-var-alist-to-closure-env-stack, rtx-make-env-stack): New functions. (rtx-env-stack-dump): Renamed from rtx-env-dump, ACU. (rtx-operand-obj): New arg isa-name-list, ACU. (rtx-closure-isas, rtx-closure-env-stack, rtx-closure-expr): New functions. * rtx-funcs.scm (closure): New arg isa-name-list, reorder args, ACU. * sem-frags.scm (): Delete member compiled-semantics. (/frag-compute-desired-frags): Minor simplification. (/frag-pick-best): Ditto. * sid-cpu.scm (gen-semantic-code): Require canonical rtl. (/gen-sfrag-code): Update. * sim-cpu.scm (gen-semantic-code): Require canonical rtl. * utils-cgen.scm (sanitize): New arg isa-name-list, ACU. * utils.scm (non-null-intersection?): New function. --- diff --git a/ChangeLog b/ChangeLog index e3f2689..c3f5b86 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,93 @@ 2009-11-02 Doug Evans + Specify isa(s) when doing ifield, operand, insn lookups. + ACU = all callers updated. + * attr.scm (/attr-eval): Call rtx-value instead of rtx-eval-with-estate. + * enum.scm (define-full-insn-enum): Pass isa-name-list to + current-ifld-lookup. + * html.scm (get-insn-properties): Pass isa-name-list to + current-op-lookup. + * ifield.scm (/ifld-parse-follows): New arg isas, ACU. + * insn.scm (/parse-insn-format-symbol): New arg isa-name-list, ACU. + (/parse-insn-format-list, /parse-insn-iformat-iflds): Ditto. + (/parse-insn-format, syntax-break-out): Ditto. + * mach.scm (obj-filter-by-isa): New function. + (current-ifld-lookup): New optional arg maybe-isa-name-list. + (/ifld-already-defined?, /op-already-defined?): Simplify. + (current-op-lookup): New optional arg maybe-isa-name-list. + (current-insn-lookup): New arg isa-name-list, ACU. + (/insn-already-defined?, /minsn-already-defined?): Simplify. + (current-minsn-lookup): New arg isa-name-list, ACU. + * minsn.scm (/minsn-compute-iflds): Pass isa-name-list to + current-op-lookup. + * opc-itab.scm (compute-syntax): New arg isa-name-list, ACU. + (gen-syntax-entry): Ditto. + * operand.scm (/operand-parse): Pass isa-name-list to + current-ifld-lookup. + (/derived-parse-encoding): New arg isa-name-list, ACU. + (/derived-parse-ifield-assertion): Ditto. + (/derived-operand-parse): Pass isa-name-list to current-op-lookup. + (/anyof-parse-choice): Ditto. + (anyof-satisfies-assertions?): Pass context to rtx-solve. + (/anyof-merge-syntax): New arg container, ACU. + (operand-builtin!): Add pc to all isas. + * rtl-c.scm (estate-make-for-rtl-c): Delete arg extra-vars-alist, ACU. + (estate-make-for-rtl-c++, rtl-c-expr-parsed): Ditto. + (rtl-c-parsed, rtl-c++-parsed): Ditto. + (rtl-c): New arg isa-name-list, ACU. + (rtl-c-expr, rtl-c++): Ditto. + (closure): New arg isa-name-list, ACU. + * rtl-traverse.scm (/make-cstate): New arg isa-name-list, ACU. + (/cstate-isas): New function. + (/rtx-canon-symbol-list): New function. + (/rtx-canon-env-stack): Renamed from /rtx-canon-env, ACU. + updated. + (/rtx-make-canon-table): Rename ENV to ENVSTACK, new entry SYMBOLLIST. + (/rtx-canon-rtx-operand): Pass isa list to current-op-lookup. + (/rtx-canon-rtx-ref, /rtx-canon): Ditto. + (rtx-canonicalize): New arg isa-name-list, ACU. + (rtx-canonicalize-stmt): Delete. + (tstate-make): New arg isas, ACU. + (tstate-isas, tstate--set-isas!): New functions. + (tstate-env-stack): Renamed from tstate-env, ACU. + (tstate-set-env-stack!): Renamed from tstate-set-env!, ACU. + (tstate-make-closure): Renamed from tstate-new-env, new arg + isa-name-list, ACU. + (/rtx-traverse-env): Delete. + (/rtx-make-traverser-table): Rename ENV to ENVSTACK, new entry + SUMBOLLIST. + (/rtx-traverse): Include conditional flag in dump output. + Update isa,envstack for closures. Pass isa list to current-op-lookup. + (): New member isas. Rename env to env-stack. + ( vmake!): Handle #:isas. #:env renamed to #:env-stack. + (): New getter/setter for isas. Rename env getter/setter + to env-stack. + (estate-make-for-eval): Provide #:isas. + (estate-make-closure): Renamed from estate-new-env. New arg + isa-name-list, ACU. + * rtl-xform.scm (/rtx-simplify-expr-fn): Handle closures. + (/rtx-trim-args): ENV renamed to ENVSTACK. Ad ITERATION, SYMBOLLIST. + (/rtx-trim-for-doc): Handle closures. + * rtl.scm (/rtx-valid-types): Rename ENV to ENVSTACK. Add ITERATION, + SYMBOLLIST. + (rtx-env-var-list): Delete. + (rtx-env-make): Handle already-compiled environments. + (rtx-var-alist-to-env): New function. + (rtx-var-alist-to-closure-env-stack, rtx-make-env-stack): New functions. + (rtx-env-stack-dump): Renamed from rtx-env-dump, ACU. + (rtx-operand-obj): New arg isa-name-list, ACU. + (rtx-closure-isas, rtx-closure-env-stack, rtx-closure-expr): New + functions. + * rtx-funcs.scm (closure): New arg isa-name-list, reorder args, ACU. + * sem-frags.scm (): Delete member compiled-semantics. + (/frag-compute-desired-frags): Minor simplification. + (/frag-pick-best): Ditto. + * sid-cpu.scm (gen-semantic-code): Require canonical rtl. + (/gen-sfrag-code): Update. + * sim-cpu.scm (gen-semantic-code): Require canonical rtl. + * utils-cgen.scm (sanitize): New arg isa-name-list, ACU. + * utils.scm (non-null-intersection?): New function. + * gen-all (do_src): Manually run cgen-all for sid. 2009-11-01 Doug Evans diff --git a/attr.scm b/attr.scm index 80c8ca9..baf69c0 100644 --- a/attr.scm +++ b/attr.scm @@ -561,13 +561,18 @@ ; Expand attribute value ATVAL, which is an rtx expression. ; OWNER is the containing object or #f if there is none. ; OWNER is needed if an attribute is defined in terms of other attributes. -; If it's #f obviously ATVAL can't be defined in terms of others. +; OWNER is also needed to get the ISA(s) in which to evaluate the expression. +; If it's #f obviously ATVAL can't be defined in terms of others, +; or refer to operands that require an ISA to disambiguate. (define (/attr-eval atval owner) - (let* ((estate (estate-make-for-eval #f owner)) - (atval-expr (car atval)) - (expr (rtx-simplify #f owner (rtx-canonicalize #f 'DFLT atval-expr nil) nil)) - (value (rtx-eval-with-estate expr DFLT estate))) + (let* ((atval-expr (car atval)) + (expr (rtx-simplify #f owner + (rtx-canonicalize #f 'DFLT + (and owner (obj-isa-list owner)) + nil atval-expr) + nil)) + (value (rtx-value expr owner))) (cond ((symbol? value) value) ((number? value) value) (error "/attr-eval: internal error, unsupported result:" value))) diff --git a/desc-cpu.scm b/desc-cpu.scm index 272f708..5189916 100644 --- a/desc-cpu.scm +++ b/desc-cpu.scm @@ -331,7 +331,8 @@ const CGEN_HW_ENTRY @arch@_cgen_hw_table[] = "#define CGEN_ACTUAL_MAX_SYNTAX_ELEMENTS " ; The +2 account for the leading "MNEM" and trailing 0. (number->string (+ 2 (apply max (map (lambda (insn) - (length (syntax-break-out (insn-syntax insn)))) + (length (syntax-break-out (insn-syntax insn) + (obj-isa-list insn)))) (current-insn-list))))) "\n" "\n" diff --git a/enum.scm b/enum.scm index ec02c06..49cbb07 100644 --- a/enum.scm +++ b/enum.scm @@ -368,10 +368,11 @@ (define (define-full-insn-enum name comment attrs prefix fld vals) (let* ((context (make-current-context "define-full-insn-enum")) - (atlist (atlist-parse context attrs "insn-enum")) - (fld-obj (current-ifld-lookup fld))) + (atlist-obj (atlist-parse context attrs "insn-enum")) + (isa-name-list (atlist-attr-value atlist-obj 'ISA #f)) + (fld-obj (current-ifld-lookup fld isa-name-list))) - (if (keep-isa-atlist? atlist #f) + (if (keep-isa-atlist? atlist-obj #f) (begin (if (not fld-obj) (parse-error context "unknown insn field" fld)) @@ -379,7 +380,7 @@ (let ((e (make (parse-name context name) (parse-comment context comment) - atlist + atlist-obj (/enum-parse-prefix context prefix) fld-obj (parse-enum-vals context prefix vals)))) diff --git a/gas-test.scm b/gas-test.scm index 996436d..b06c588 100644 --- a/gas-test.scm +++ b/gas-test.scm @@ -20,7 +20,8 @@ (define (gas-test-analyze!) (opcodes-analyze!) (map (lambda (insn) - (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn)))) + (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn) + (obj-isa-list insn)))) (non-multi-insns (current-insn-list))) *UNSPECIFIED* ) diff --git a/html.scm b/html.scm index 00d2730..83f3ed0 100644 --- a/html.scm +++ b/html.scm @@ -693,7 +693,8 @@ See the input .cpu file(s) for copyright information. (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) (case (car expr) - ((operand) (if (memory? (op:type (current-op-lookup (rtx-arg1 expr)))) + ((operand) (if (memory? (op:type (current-op-lookup (rtx-arg1 expr) + (obj-isa-list insn)))) ; Don't change to '(MEM), since we use append!. (append! sem-attrs (list 'MEM))) (if (mode-float? (mode:lookup (rtx-mode expr))) diff --git a/ifield.scm b/ifield.scm index 2709e51..f8da65e 100644 --- a/ifield.scm +++ b/ifield.scm @@ -468,7 +468,7 @@ (flength (parse-number context flength '(0 . 127))) (lsb0? (current-arch-insn-lsb0?)) (mode-obj (parse-mode-name context mode)) - (follows-obj (/ifld-parse-follows context follows)) + (follows-obj (/ifld-parse-follows context follows isas)) ) ; Calculate the object. @@ -620,9 +620,9 @@ ; Parse a `follows' spec. -(define (/ifld-parse-follows context follows) +(define (/ifld-parse-follows context follows isas) (if follows - (let ((follows-obj (current-op-lookup follows))) + (let ((follows-obj (current-op-lookup follows isas))) (if (not follows-obj) (parse-error context "unknown operand to follow" follows)) follows-obj) diff --git a/insn.scm b/insn.scm index 459c1a8..0281401 100644 --- a/insn.scm +++ b/insn.scm @@ -310,7 +310,7 @@ (obj:comment insn) (obj-atlist insn) (/anyof-merge-syntax (insn-syntax insn) - value-names new-values) + value-names new-values insn) ifields (insn-ifield-assertion insn) ; FIXME (anyof-merge-semantics (insn-semantics insn) @@ -401,14 +401,20 @@ (let* ((name (parse-name context name)) (context (context-append-name context name)) (atlist-obj (atlist-parse context attrs "cgen_insn")) - (isas (atlist-attr-value atlist-obj 'ISA #f))) + (isa-name-list (atlist-attr-value atlist-obj 'ISA #f))) + + ;; Verify all specified ISAs are valid. + (if (not (all-true? (map current-isa-lookup isa-name-list))) + (parse-error context "unknown isa in isa list" isa-name-list)) (if (keep-atlist? atlist-obj #f) (let ((ifield-assertion (if (and ifield-assertion (not (null? ifield-assertion))) - (rtx-canonicalize context 'DFLT ;; BI? - ifield-assertion nil) + (rtx-canonicalize context + 'DFLT ;; BI? + isa-name-list nil + ifield-assertion) #f)) (semantics (if (not (null? semantics)) semantics @@ -417,11 +423,7 @@ (context-append context " format") (and (not (atlist-has-attr? atlist-obj 'VIRTUAL)) (reader-verify-iformat? CURRENT-READER)) - ;; Just pick the first, the base len - ;; for each should be the same. - ;; If not this is caught by - ;; compute-insn-base-mask-length. - (current-isa-lookup (car isas)) + isa-name-list fmt)) (comment (parse-comment context comment)) ; If there are no semantics, mark this as an alias. @@ -542,9 +544,9 @@ ; Subroutine of /parse-insn-format to parse a symbol ifield spec. -(define (/parse-insn-format-symbol context sym) +(define (/parse-insn-format-symbol context isa-name-list sym) ;(debug-repl-env sym) - (let ((op (current-op-lookup sym))) + (let ((op (current-op-lookup sym isa-name-list))) (if op (cond ((derived-operand? op) ; There is a one-to-one relationship b/w derived operands and @@ -600,8 +602,8 @@ ; ??? There is room for growth in the specification syntax here. ; Possibilities are (ifield-name|operand-name [options] [value]). -(define (/parse-insn-format-list context spec) - (let ((ifld (current-ifld-lookup (car spec)))) +(define (/parse-insn-format-list context isa-name-list spec) + (let ((ifld (current-ifld-lookup (car spec) isa-name-list))) (if ifld (/parse-insn-format-ifield-spec context ifld spec) (parse-error context "unknown ifield" spec))) @@ -609,8 +611,9 @@ ; Subroutine of /parse-insn-format to simplify it. ; Parse the provided iformat spec and return the list of ifields. +; ISA-NAME-lIST is the ISA attribute of the containing insn. -(define (/parse-insn-iformat-iflds context fld-list) +(define (/parse-insn-iformat-iflds context isa-name-list fld-list) (if (null? fld-list) nil ; field list unspecified (case (car fld-list) @@ -619,12 +622,12 @@ (string->symbol fld) fld))) (cond ((symbol? f) - (/parse-insn-format-symbol context f)) + (/parse-insn-format-symbol context isa-name-list f)) ((and (list? f) ; ??? This use to allow objects ; in the `car' position. Checked for below. (symbol? (car f))) - (/parse-insn-format-list context f)) + (/parse-insn-format-list context isa-name-list f)) (else (if (and (list? f) (ifield? (car f))) @@ -637,7 +640,7 @@ (parse-error context "bad `=' format spec, should be `(= insn-name)'" fld-list)) - (let ((insn (current-insn-lookup (cadr fld-list)))) + (let ((insn (current-insn-lookup (cadr fld-list) isa-name-list))) (if (not insn) (parse-error context "unknown insn" (cadr fld-list))) (insn-iflds insn)))) @@ -648,9 +651,8 @@ ; Given an insn format field from a .cpu file, replace it with a list of ; ifield objects with the values assigned. -; ISA is an object or #f. -; If VERIFY? is non-#f, perform various checks on the format -; (ISA must be an object). +; ISA-NAME-LIST is the ISA attribute of the containing insn. +; If VERIFY? is non-#f, perform various checks on the format. ; ; An insn format field is a list of ifields that make up the instruction. ; All bits must be specified, including reserved bits @@ -679,8 +681,9 @@ ; It's called for each instruction, and is one of the more expensive routines ; in insn parsing. -(define (/parse-insn-format context verify? isa ifld-list) - (let* ((parsed-ifld-list (/parse-insn-iformat-iflds context ifld-list))) +(define (/parse-insn-format context verify? isa-name-list ifld-list) + (let* ((parsed-ifld-list + (/parse-insn-iformat-iflds context isa-name-list ifld-list))) ;; NOTE: We could sort the fields here, but it introduces differences ;; in the generated opcodes files. Later it might be a good thing to do @@ -693,14 +696,17 @@ (if verify? - (let ((base-len (isa-base-insn-bitsize isa)) - (pretty-print-iflds (lambda (iflds) - (if (null? iflds) - " none provided" - (string-map (lambda (f) - (string-append " " - (ifld-pretty-print f))) - iflds))))) + ;; Just pick the first ISA, the base len for each should be the same. + ;; If not this is caught by compute-insn-base-mask-length. + (let* ((isa (current-isa-lookup (car isa-name-list))) + (base-len (isa-base-insn-bitsize isa)) + (pretty-print-iflds (lambda (iflds) + (if (null? iflds) + " none provided" + (string-map (lambda (f) + (string-append " " + (ifld-pretty-print f))) + iflds))))) ;; Perform some error checking. ;; Look for overlapping ifields and missing bits. @@ -989,7 +995,7 @@ ; Create a list of syntax strings broken up into a list of characters and ; operand objects. -(define (syntax-break-out syntax) +(define (syntax-break-out syntax isa-name-list) (let ((result nil)) ; ??? The style of the following could be more Scheme-like. Later. (let loop () @@ -1011,13 +1017,15 @@ (let ((n (string-index syntax #\}))) (set! result (cons (current-op-lookup (string->symbol - (substring syntax 2 n))) + (substring syntax 2 n)) + isa-name-list) result)) (set! syntax (string-drop (+ 1 n) syntax))) (let ((n (id-len (string-drop1 syntax)))) (set! result (cons (current-op-lookup (string->symbol - (substring syntax 1 (+ 1 n)))) + (substring syntax 1 (+ 1 n))) + isa-name-list) result)) (set! syntax (string-drop (+ 1 n) syntax))))) ; Handle everything else. diff --git a/intrinsics.scm b/intrinsics.scm index f59b602..ee25a95 100644 --- a/intrinsics.scm +++ b/intrinsics.scm @@ -956,7 +956,8 @@ ;; each cgen operand is replaced by an md-operand. (syntax (map (lambda (x) (if (operand? x) (make-operand x) x)) - (syntax-break-out (insn-syntax insn)))) + (syntax-break-out (insn-syntax insn) + (obj-isa-list insn)))) ;; All relevant outputs. (outputs (find (lambda (op) diff --git a/mach.scm b/mach.scm index 732e5c2..8750239 100644 --- a/mach.scm +++ b/mach.scm @@ -341,6 +341,20 @@ (object-assq isa-name (current-isa-list)) ) +;; Given a list of objects OBJ-LIST, return those objects that are from the +;; ISA(s) in ISA-NAME-LIST. +;; ISA-NAME-LIST may be (all) or #f (which also means (all)). + +(define (obj-filter-by-isa obj-list isa-name-list) + (if (or (eq? isa-name-list #f) + (memq 'all isa-name-list)) + obj-list + (find (lambda (obj) + (let ((obj-isas (obj-attr-value obj 'ISA))) + (non-null-intersection? obj-isas isa-name-list))) + obj-list)) +) + ; Cpu families. (define (current-cpu-list) (arch-cpu-list CURRENT-ARCH)) @@ -431,26 +445,28 @@ ) ;; Look up ifield X in the current architecture. +;; Returns the object or #f if not found. +;; If there is an ambiguity (i.e. the ifield is in multiple ISAs and +;; MAYBE-ISA-NAME-LIST doesn't disambiguate the choice) an error is signalled. ;; ;; If X is an object, just return it. ;; This is to handle ??? ;; Otherwise X is the name of the ifield to look up. -;; -;; ??? This doesn't work if there are multiple operands with the same name -;; for different isas. +;; If MAYBE-ISA-NAME-LIST is provided, the car is a list of ISAs to look in. +;; If the specified isa list is #f, look in all ISAs. -(define (current-ifld-lookup x) +(define (current-ifld-lookup x . maybe-isa-name-list) (if (ifield? x) x (let ((f-list (/ident-object-table-lookup (car (arch-ifld-table CURRENT-ARCH)) x))) (if f-list - (if (= (length f-list) 1) - (car f-list) - ;; FIXME: For now just return the first one, - ;; same behaviour as before. - ;; Here "first one" means "first defined". - (/get-lowest-ordinal f-list)) + (let* ((isas (if (not (null? maybe-isa-name-list)) (car maybe-isa-name-list) #f)) + (filtered-f-list (obj-filter-by-isa f-list isas))) + (case (length filtered-f-list) + ((0) (error "Ifield not in specified ISA:" x)) + ((1) (car filtered-f-list)) + (else (error "Ambiguous ifield lookup:" x)))) #f))) ) @@ -467,7 +483,7 @@ (let ((result #f) (f-isas (obj-isa-list f))) (for-each (lambda (ff) - (if (not (null? (intersection f-isas (obj-isa-list ff)))) + (if (non-null-intersection? f-isas (obj-isa-list ff)) (set! result #t))) iflds) result) @@ -492,18 +508,24 @@ *UNSPECIFIED* ) -; ??? This doesn't work if there are multiple operands with the same name -; for different isas. +;; Look up operand NAME in the current architecture. +;; Returns the object or #f if not found. +;; If there is an ambiguity (i.e. the operand is in multiple ISAs and +;; MAYBE-ISA-NAME-LIST doesn't disambiguate the choice) an error is signalled. +;; +;; If MAYBE-ISA-NAME-LIST is provided, the car is a list of ISAs to look in. +;; If the specified isa list is #f, look in all ISAs. -(define (current-op-lookup name) +(define (current-op-lookup name . maybe-isa-name-list) (let ((op-list (/ident-object-table-lookup (car (arch-op-table CURRENT-ARCH)) name))) (if op-list - (if (= (length op-list) 1) - (car op-list) - ;; FIXME: For now just return the first one, same behaviour as before. - ;; Here "first one" means "first defined". - (/get-lowest-ordinal op-list)) + (let* ((isas (if (not (null? maybe-isa-name-list)) (car maybe-isa-name-list) #f)) + (filtered-o-list (obj-filter-by-isa op-list isas))) + (case (length filtered-o-list) + ((0) (error "Operand not in specified ISA:" name)) + ((1) (car filtered-o-list)) + (else (error "Ambiguous operand lookup:" name)))) #f)) ) @@ -520,7 +542,7 @@ (let ((result #f) (op-isas (obj-isa-list op))) (for-each (lambda (o) - (if (not (null? (intersection op-isas (obj-isa-list o)))) + (if (non-null-intersection? op-isas (obj-isa-list o)) (set! result #t))) ops) result) @@ -554,19 +576,21 @@ *UNSPECIFIED* ) -; ??? This doesn't work if there are multiple insns with the same name -; for different isas. - -(define (current-insn-lookup name) - (let ((i (/ident-object-table-lookup (car (arch-insn-table CURRENT-ARCH)) - name))) - (if i - (begin - (if (= (length i) 1) - (car i) - ;; FIXME: For now just flag an error. - ;; Later add an isa-list arg to distinguish. - (error "multiple insns with name:" name))) +;; Look up insn NAME in the current architecture. +;; Returns the object or #f if not found. +;; If there is an ambiguity (i.e. the insn is in multiple ISAs and +;; ISA-NAME-LIST doesn't disambiguate the choice) an error is signalled. +;; If the specified isa list is #f, look in all ISAs. + +(define (current-insn-lookup name isa-name-list) + (let ((i-list (/ident-object-table-lookup (car (arch-insn-table CURRENT-ARCH)) + name))) + (if i-list + (let ((filtered-i-list (obj-filter-by-isa i-list isa-name-list))) + (case (length filtered-i-list) + ((0) (error "Insn not in specified ISA:" name)) + ((1) (car filtered-i-list)) + (else (error "Ambiguous insn lookup:" name)))) #f)) ) @@ -583,7 +607,7 @@ (let ((result #f) (insn-isas (obj-isa-list insn))) (for-each (lambda (i) - (if (not (null? (intersection insn-isas (obj-isa-list i)))) + (if (non-null-intersection? insn-isas (obj-isa-list i)) (set! result #t))) insns) result) @@ -608,19 +632,21 @@ *UNSPECIFIED* ) -; ??? This doesn't work if there are multiple minsns with the same name -; for different isas. - -(define (current-minsn-lookup name) - (let ((m (/ident-object-table-lookup (car (arch-minsn-table CURRENT-ARCH)) - name))) - (if m - (begin - (if (= (length m) 1) - (car m) - ;; FIXME: For now just flag an error. - ;; Later add an isa-list arg to distinguish. - (error "multiple macro-insns with name:" name))) +;; Look up minsn NAME in the current architecture. +;; Returns the object or #f if not found. +;; If there is an ambiguity (i.e. the minsn is in multiple ISAs and +;; ISA-NAME-LIST doesn't disambiguate the choice) an error is signalled. +;; If the specified isa list is #f, look in all ISAs. + +(define (current-minsn-lookup name isa-name-list) + (let ((m-list (/ident-object-table-lookup (car (arch-minsn-table CURRENT-ARCH)) + name))) + (if m-list + (let ((filtered-m-list (obj-filter-by-isa m-list isa-name-list))) + (case (length filtered-m-list) + ((0) (error "Macro-insn not in specified ISA:" name)) + ((1) (car filtered-m-list)) + (else (error "Ambiguous macro-insn lookup:" name)))) #f)) ) @@ -637,7 +663,7 @@ (let ((result #f) (m-isas (obj-isa-list m))) (for-each (lambda (mm) - (if (not (null? (intersection m-isas (obj-isa-list mm)))) + (if (non-null-intersection? m-isas (obj-isa-list mm)) (set! result #t))) minsns) result) @@ -841,10 +867,6 @@ nil)))) isas) '((max))))) - ; Using a bitset attribute here implies something could be used by two - ; separate isas. This seems highly unlikely but we don't [as yet] - ; preclude it. The other thing to consider is whether the cpu table - ; would ever want to be opened for multiple isas. (define-attr '(type bitset) '(name ISA) '(comment "instruction set selection") ; If there's only one isa, don't (yet) pollute the tables with a value @@ -1880,7 +1902,8 @@ (make-obj-context insn (string-append "canonicalizing semantics of " (obj:str-name insn))) - 'VOID (insn-semantics insn) nil))) + 'VOID (obj-isa-list insn) nil + (insn-semantics insn)))) (insn-set-canonical-semantics! insn canon-sem))) (else (logit 2 "Skipping instruction " (obj:name insn) ", no semantics ...\n")))) diff --git a/minsn.scm b/minsn.scm index 96e0408..3a22906 100644 --- a/minsn.scm +++ b/minsn.scm @@ -180,7 +180,8 @@ ; parsed the associated element in ifld-names is deleted. At the ; end ifld-names must be empty. delq! can't delete the first ; element in a list, so we insert a fencepost. - (ifld-names (cons #f (map obj:name ifld-ops)))) + (ifld-names (cons #f (map obj:name ifld-ops))) + (isa-name-list (obj-isa-list real-insn))) ;(logit 3 "Computing ifld list, operand field names: " ifld-names "\n") ; For each macro-insn ifield expression, look it up in the real insn's ; ifield list. If an operand without a prespecified value, leave @@ -188,7 +189,7 @@ ; the ifield entry. (for-each (lambda (f) (let* ((op-name (if (pair? f) (car f) f)) - (op-obj (current-op-lookup op-name)) + (op-obj (current-op-lookup op-name isa-name-list)) ; If `op-name' is an operand, use its ifield. ; Otherwise `op-name' must be an ifield name. (f-name (if op-obj @@ -219,7 +220,7 @@ (parse-error context "not an alias macro-insn" minsn)) (let* ((expn (car (minsn-expansions minsn))) - (alias-of (current-insn-lookup (cadr expn)))) + (alias-of (current-insn-lookup (cadr expn) (obj-isa-list minsn)))) (if (not alias-of) (parse-error context "unknown real insn in expansion" minsn)) diff --git a/opc-itab.scm b/opc-itab.scm index 52a8509..bb0697a 100644 --- a/opc-itab.scm +++ b/opc-itab.scm @@ -122,7 +122,8 @@ ; Values < 128 are characters that must be matched. ; Values >= 128 are 128 + the index into the operand table. -(define (compute-syntax strip-mnemonic? strip-mnem-operands? syntax op-macro) +(define (compute-syntax strip-mnemonic? strip-mnem-operands? syntax op-macro + isa-name-list) (let ((context (make-prefix-context "syntax computation")) (syntax (if strip-mnemonic? (strip-mnemonic strip-mnem-operands? syntax) @@ -165,7 +166,7 @@ (if (= n 0) (parse-error context "empty or invalid operand name" syntax)) (let ((operand (string->symbol (substring syn 1 (1+ n))))) - (if (not (current-op-lookup operand)) + (if (not (current-op-lookup operand isa-name-list)) (parse-error context "undefined operand " operand syntax))) (loop (string-drop (1+ n) syn) (string-append result op-macro " (" @@ -183,14 +184,15 @@ ; Return C code to define the syntax string for SYNTAX ; MNEM is the C value to use to represent the instruction's mnemonic. ; OP is the C macro to use to compute an operand's syntax value. +; ISA-NAME-LIST is the list of ISA names in which the owning insn lives. -(define (gen-syntax-entry mnem op syntax) +(define (gen-syntax-entry mnem op syntax isa-name-list) (string-append "{ { " mnem ", " ; `mnem' is used to represent the mnemonic, so we always want to strip it ; from the syntax string, regardless of the setting of `strip-mnemonic?'. - (compute-syntax #t #f syntax op) + (compute-syntax #t #f syntax op isa-name-list) " } }") ) @@ -341,7 +343,9 @@ "/* " (insn-syntax insn) " */\n" " {\n" " " (gen-insn-handlers insn) ",\n" - " " (gen-syntax-entry "MNEM" "OP" (insn-syntax insn)) ",\n" + " " + (gen-syntax-entry "MNEM" "OP" (insn-syntax insn) (obj-isa-list insn)) + ",\n" ; ??? 'twould save space to put a pointer here and record format separately " " (gen-ifmt-entry insn) ", " ;"0x" (number->string (insn-value insn) 16) ",\n" @@ -506,7 +510,9 @@ static unsigned int dis_hash_insn (const char *, CGEN_INSN_INT); "-1, " ; macro-insns are not currently enumerated, no current need to "\"" (obj:str-name minsn) "\", " "\"" (minsn-mnemonic minsn) "\",\n" - " " (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn)) ",\n" + " " + (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn) (obj-isa-list minsn)) + ",\n" " (PTR) & macro_" (gen-sym minsn) "_expansions[0],\n" " " (gen-obj-attr-defn 'minsn minsn all-attrs num-non-bools gen-insn-attr-mask) @@ -527,7 +533,9 @@ static unsigned int dis_hash_insn (const char *, CGEN_INSN_INT); "-1, " ; macro-insns are not currently enumerated, no current need to "\"" (obj:str-name minsn) "\", " "\"" (minsn-mnemonic minsn) "\",\n" - " " (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn)) ",\n" + " " + (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn) (obj-isa-list minsn)) + ",\n" " (PTR) & macro_" (gen-sym minsn) "_expansions[0],\n" " " (gen-obj-attr-defn 'minsn minsn all-attrs num-non-bools gen-insn-attr-mask) diff --git a/opcodes.scm b/opcodes.scm index c3bb859..6637b73 100644 --- a/opcodes.scm +++ b/opcodes.scm @@ -125,9 +125,11 @@ (let ((expr (cadr encode)) (value (if (symbol? (caar encode)) (caar encode) (cadr (caar encode)))) (pc (if (symbol? (cadar encode)) (cadar encode) (cadr (cadar encode))))) - (rtl-c DFLT expr + (rtl-c DFLT + (obj-isa-list self) (list (list value (obj:name (ifld-decode-mode self)) "value") - (list pc 'IAI "pc")))) + (list pc 'IAI "pc")) + expr)) ";\n") "") (if need-extra? @@ -208,9 +210,11 @@ (let ((expr (cadr decode)) (value (if (symbol? (caar decode)) (caar decode) (cadr (caar decode)))) (pc (if (symbol? (cadar decode)) (cadar decode) (cadr (cadar decode))))) - (rtl-c DFLT expr + (rtl-c DFLT + (obj-isa-list self) (list (list value (obj:name (ifld-decode-mode self)) "value") - (list pc 'IAI "pc")))) + (list pc 'IAI "pc")) + expr)) ";\n") "") (if need-extra? @@ -235,13 +239,15 @@ (let ((expr (cadr encode)) (value (caar encode)) (pc (cadar encode))) - (rtl-c DFLT expr + (rtl-c DFLT + (obj-isa-list self) (list (list value (obj:name (ifld-decode-mode self)) varname) - (list pc 'IAI "pc")))) + (list pc 'IAI "pc")) + expr)) ";\n") "") (let ((expr (elm-get self 'insert))) - (rtl-c VOID expr nil)) + (rtl-c VOID (obj-isa-list self) nil expr)) (string-list-map (lambda (subfld) (string-list " " @@ -279,15 +285,17 @@ )) (elm-get self 'subfields)) (let ((expr (elm-get self 'extract))) - (rtl-c VOID expr nil)) + (rtl-c VOID (obj-isa-list self) nil expr)) (if need-extra? (string-append " " varname " = " (let ((expr (cadr decode)) (value (caar decode)) (pc (cadar decode))) - (rtl-c DFLT expr + (rtl-c DFLT + (obj-isa-list self) (list (list value (obj:name (ifld-decode-mode self)) varname) - (list pc 'IAI "pc")))) + (list pc 'IAI "pc")) + expr)) ";\n") "") " }\n" diff --git a/operand.scm b/operand.scm index 3467dd0..6a8713a 100644 --- a/operand.scm +++ b/operand.scm @@ -561,7 +561,12 @@ ;; Pick out name first to augment the error context. (let* ((name (parse-name context name)) (context (context-append-name context name)) - (atlist-obj (atlist-parse context attrs "cgen_operand"))) + (atlist-obj (atlist-parse context attrs "cgen_operand")) + (isa-name-list (atlist-attr-value atlist-obj 'ISA #f))) + + ;; Verify all specified ISAs are valid. + (if (not (all-true? (map current-isa-lookup isa-name-list))) + (parse-error context "unknown isa in isa list" isa-name-list)) (if (keep-atlist? atlist-obj #f) @@ -569,7 +574,7 @@ (mode-obj (parse-mode-name context mode)) (ifld-val (if (integer? ifld) ifld - (current-ifld-lookup ifld)))) + (current-ifld-lookup ifld isa-name-list)))) (if (not mode-obj) (parse-error context "unknown mode" mode)) @@ -816,7 +821,7 @@ ; The result is a object. ; The {owner} member still needs to be set! -(define (/derived-parse-encoding context operand-name encoding) +(define (/derived-parse-encoding context isa-name-list operand-name encoding) (if (or (null? encoding) (not (list? encoding))) (parse-error context "encoding not a list" encoding)) @@ -825,7 +830,7 @@ ; ??? Calling /parse-insn-format is a quick hack. ; It's an internal routine of some other file. - (let ((iflds (/parse-insn-format context #f #f encoding))) + (let ((iflds (/parse-insn-format context #f isa-name-list encoding))) (make operand-name 'derived-ifield ; (string-append " for " operand-name) @@ -840,10 +845,10 @@ ;; asserting something about the ifield values of the containing insn. ;; The result is #f if the assertion is (), or the canonical rtl. -(define (/derived-parse-ifield-assertion context ifield-assertion) +(define (/derived-parse-ifield-assertion context isa-name-list ifield-assertion) (if (null? ifield-assertion) #f - (rtx-canonicalize context 'INT ifield-assertion nil)) + (rtx-canonicalize context 'INT isa-name-list nil ifield-assertion)) ) ; Parse a derived operand definition. @@ -864,12 +869,18 @@ ;; Pick out name first to augment the error context. (let* ((name (parse-name context name)) (context (context-append-name context name)) - (atlist-obj (atlist-parse context attrs "cgen_operand"))) + (atlist-obj (atlist-parse context attrs "cgen_operand")) + (isa-name-list (atlist-attr-value atlist-obj 'ISA #f))) + + ;; Verify all specified ISAs are valid. + (if (not (all-true? (map current-isa-lookup isa-name-list))) + (parse-error context "unknown isa in isa list" isa-name-list)) (if (keep-atlist? atlist-obj #f) - (let ((mode-obj (parse-mode-name context mode)) - (parsed-encoding (/derived-parse-encoding context name encoding))) + (let* ((mode-obj (parse-mode-name context mode)) + (parsed-encoding (/derived-parse-encoding context isa-name-list + name encoding))) (if (not mode-obj) (parse-error context "unknown mode" mode)) @@ -883,7 +894,7 @@ (map (lambda (a) (if (not (symbol? a)) (parse-error context "arg not a symbol" a)) - (let ((op (current-op-lookup a))) + (let ((op (current-op-lookup a isa-name-list))) (if (not op) (parse-error context "not an operand" a)) op)) @@ -891,20 +902,27 @@ syntax base-ifield ; FIXME: validate parsed-encoding - (/derived-parse-ifield-assertion context ifield-assertion) + (/derived-parse-ifield-assertion context isa-name-list + ifield-assertion) (if (null? getter) #f - (/operand-parse-getter context - (list args - (rtx-canonicalize context mode getter nil)) - (length args))) + (/operand-parse-getter + context + (list args + (rtx-canonicalize context mode + isa-name-list nil + getter)) + (length args))) (if (null? setter) #f - (/operand-parse-setter context - (list (append args '(newval)) - (rtx-canonicalize context 'VOID setter - (list (list 'newval mode #f)))) - (length args))) + (/operand-parse-setter + context + (list (append args '(newval)) + (rtx-canonicalize context 'VOID + isa-name-list + (list (list 'newval mode #f)) + setter)) + (length args))) ))) (elm-set! result 'hw-name (obj:name (hardware-for-mode mode-obj))) ;(elm-set! result 'hw-name (obj:name parsed-encoding)) @@ -996,10 +1014,10 @@ ; Parse an "anyof" choice, which is a derived-operand name. ; The result is {choice} unchanged. -(define (/anyof-parse-choice context choice) +(define (/anyof-parse-choice context choice isa-name-list) (if (not (symbol? choice)) (parse-error context "anyof choice not a symbol" choice)) - (let ((op (current-op-lookup choice))) + (let ((op (current-op-lookup choice isa-name-list))) (if (not (derived-operand? op)) (parse-error context "anyof choice not a derived-operand" choice)) op) @@ -1025,7 +1043,8 @@ (if (keep-atlist? atlist-obj #f) - (let ((mode-obj (parse-mode-name context mode))) + (let ((mode-obj (parse-mode-name context mode)) + (isa-name-list (atlist-attr-value atlist-obj 'ISA #f))) (if (not mode-obj) (parse-error context "unknown mode" mode)) @@ -1036,7 +1055,7 @@ mode base-ifield (map (lambda (c) - (/anyof-parse-choice context c)) + (/anyof-parse-choice context c isa-name-list)) choices))) (begin @@ -1133,7 +1152,7 @@ (assert (derived-operand? anyof-instance)) (let ((assertion (derived-ifield-assertion anyof-instance))) (if assertion - (rtx-solve #f ; FIXME: context + (rtx-solve (make-obj-context anyof-instance #f) anyof-instance ; owner assertion known-values) @@ -1155,8 +1174,11 @@ (elm-get anyof-instance 'name) ) -(define (/anyof-merge-syntax syntax value-names values) - (let ((syntax-elements (syntax-break-out syntax))) +; CONTAINER is the containing SYNTAX. + +(define (/anyof-merge-syntax syntax value-names values container) + (let* ((isa-name-list (obj-isa-list container)) + (syntax-elements (syntax-break-out syntax isa-name-list))) (syntax-make (map (lambda (e) (if (anyof-operand? e) (let* ((name (obj:name e)) @@ -1333,7 +1355,8 @@ (op:mode choice) (derived-args choice) (/anyof-merge-syntax (derived-syntax choice) - arg-names new-args) + arg-names new-args + container) (derived-base-ifield choice) encoding (/anyof-merge-ifield-assertion (derived-ifield-assertion choice) @@ -1616,6 +1639,7 @@ Define an anyof operand, name/value pair list version. ; Also (defined elsewhere): PCREL-ADDR ABS-ADDR. (set! pc (make )) + (obj-cons-attr! pc (all-isas-attr)) (current-op-add! pc) *UNSPECIFIED* diff --git a/read.scm b/read.scm index f54ea62..25369c6 100644 --- a/read.scm +++ b/read.scm @@ -736,8 +736,10 @@ ; isa. (define (keep-isa? isa-list) + ;; If unspecified, the default is the first one in the list. (if (null? isa-list) (set! isa-list (list (car (current-arch-isa-name-list))))) + (let* ((keep (reader-keep-isa CURRENT-READER)) (keep? (map (lambda (i) (or (memq i keep) diff --git a/rtl-c.scm b/rtl-c.scm index 264fc4f..878f27a 100644 --- a/rtl-c.scm +++ b/rtl-c.scm @@ -7,15 +7,16 @@ ; --------------------- ; The main way to generate C code from an RTL expression is: ; -; (rtl-c mode '(func mode ...) nil) +; (rtl-c-parsed mode isa-name-list nil '(func mode ...)) ; ; E.g. -; (rtl-c SI '(add () SI (const () SI 1) (const () SI 2)) nil) +; (rtl-c-parsed SI (all) nil '(add () SI (const () SI 1) (const () SI 2))) ; --> ; "ADDSI (1, 2)" ; ; The expression is in source form and must be already canonicalized (with -; rtx-canonicalize). +; rtx-canonicalize). There is also rtl-c for the occasions where the rtl +; isn't already canonicalized. ; ; The `set' rtx needs to be handled a little carefully. ; Both the dest and src are processed first, and then code to perform the @@ -274,21 +275,15 @@ ) ;; 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) +(define (estate-make-for-rtl-c overrides) (apply vmake (append! (list #: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-c-rtl-cover-fns?) overrides)) ) @@ -302,35 +297,33 @@ ) ; Translate parsed RTL expression X to a string of C code. -; X must have already been fed through rtx-canonicalize. +; EXPR must have already been fed through rtx-canonicalize. ; MODE is the desired mode of the value or DFLT for "natural mode". ; MODE is a object. -; EXTRA-VARS-ALIST is an association list of extra -; (symbol -or-mode-name value) elements to be used during value lookup. ; OVERRIDES is a #:keyword/value list of arguments to build the eval state ; with. -(define (rtl-c-parsed mode x extra-vars-alist . overrides) +(define (rtl-c-parsed mode expr . 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)) + (let ((estate (estate-make-for-rtl-c (cons #:outer-expr + (cons expr overrides))))) + (rtl-c-with-estate estate mode expr)) ) -; Same as rtl-c-parsed but X is unparsed. +; Same as rtl-c-parsed but EXPR is unparsed. +; ISA-NAME-LIST is the list of ISA(s) in which to evaluate EXPR. +; EXTRA-VARS-ALIST is an association list of extra (symbol value) +; elements to be used during value lookup. ; MODE is a object. -(define (rtl-c mode x 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))) +(define (rtl-c mode isa-name-list extra-vars-alist expr . overrides) + (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode) + isa-name-list extra-vars-alist expr)) + (estate (estate-make-for-rtl-c (cons #:outer-expr + (cons canonical-rtl overrides))))) + (rtl-c-with-estate estate mode canonical-rtl)) ) ; Same as rtl-c-with-estate except return a object. @@ -343,71 +336,60 @@ ; Same as rtl-c-parsed except return a object. ; MODE is a object. -(define (rtl-c-expr-parsed mode x extra-vars-alist . overrides) +(define (rtl-c-expr-parsed mode expr . 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)) + (let ((estate (estate-make-for-rtl-c (cons #:outer-expr + (cons expr overrides))))) + (rtl-c-expr-with-estate estate mode expr)) ) -; Same as rtl-c-expr-parsed but X is unparsed. +; Same as rtl-c-expr-parsed but EXPR is unparsed. ; MODE is a object. -(define (rtl-c-expr mode x 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))) +(define (rtl-c-expr mode isa-name-list extra-vars-alist expr . overrides) + (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode) + isa-name-list extra-vars-alist expr)) + (estate (estate-make-for-rtl-c (cons #:outer-expr + (cons canonical-rtl overrides))))) + (rtl-c-expr-with-estate estate mode canonical-rtl)) ) ; C++ versions of rtl-c routines. ; Build an estate for use in generating C++. -; EXTRA-VARS-ALIST is an association list of (symbol 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++ extra-vars-alist overrides) - (estate-make-for-rtl-c extra-vars-alist - (cons #:output-language (cons "c++" overrides))) +(define (estate-make-for-rtl-c++ overrides) + (estate-make-for-rtl-c (cons #:output-language (cons "c++" overrides))) ) ; Translate parsed RTL expression X to a string of C++ code. -; X must have already been fed through rtx-canonicalize. +; EXPR must have already been fed through rtx-canonicalize. ; MODE is the desired mode of the value or DFLT for "natural mode". ; MODE is a object. -; EXTRA-VARS-ALIST is an association list of extra (symbol value) -; elements to be used during value lookup. ; OVERRIDES is a #:keyword/value list of arguments to build the eval state ; with. -(define (rtl-c++-parsed mode x extra-vars-alist . overrides) +(define (rtl-c++-parsed mode expr . 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)) + (let ((estate (estate-make-for-rtl-c++ (cons #:outer-expr + (cons expr overrides))))) + (rtl-c-with-estate estate mode expr)) ) -; Same as rtl-c++-parsed but X is unparsed. +; Same as rtl-c++-parsed but EXPR is unparsed. ; MODE is a object. -(define (rtl-c++ mode x 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))) +(define (rtl-c++ mode isa-name-list extra-vars-alist expr . overrides) + (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode) + isa-name-list extra-vars-alist expr)) + (estate (estate-make-for-rtl-c++ (cons #:outer-expr + (cons canonical-rtl overrides))))) + (rtl-c-with-estate estate mode canonical-rtl)) ) ; Top level routines for getting/setting values. @@ -481,11 +463,11 @@ (obj:name mode)))))) ;; FIXME: Can we ever get a symbol here? - ((or (and (symbol? src) (rtx-temp-lookup (estate-env estate) src)) + ((or (and (symbol? src) (rtx-temp-lookup (estate-env-stack estate) src)) (rtx-temp? src)) (begin (if (symbol? src) - (set! src (rtx-temp-lookup (estate-env estate) src))) + (set! src (rtx-temp-lookup (estate-env-stack estate) src))) (cond ((mode:eq? 'DFLT mode) (send src 'cxmake-get estate (rtx-temp-mode src) #f #f)) ((rtx-mode-compatible? mode (rtx-temp-mode src)) @@ -1307,8 +1289,8 @@ (let* ((limit-var (rtx-make-iteration-limit-var iter-var)) (env (rtx-env-make-iteration-locals iter-var)) (estate (estate-push-env estate env)) - (temp-iter (rtx-temp-lookup (estate-env estate) iter-var)) - (temp-limit (rtx-temp-lookup (estate-env estate) limit-var)) + (temp-iter (rtx-temp-lookup (estate-env-stack estate) iter-var)) + (temp-limit (rtx-temp-lookup (estate-env-stack estate) limit-var)) (c-iter-var (rtx-temp-value temp-iter)) (c-limit-var (rtx-temp-value temp-limit))) (cx:make VOID @@ -1430,7 +1412,7 @@ (cond ((rtx-temp? object-or-name) object-or-name) ((symbol? object-or-name) - (let ((object (rtx-temp-lookup (estate-env *estate*) object-or-name))) + (let ((object (rtx-temp-lookup (estate-env-stack *estate*) object-or-name))) (if (not object) (estate-error *estate* "undefined local" object-or-name)) object)) @@ -1873,9 +1855,10 @@ (cons *estate* (cons iter-var (cons nr-times (cons expr exprs))))) ) -(define-fn closure (*estate* options mode expr env) - ; ??? estate-push-env? - (rtl-c-with-estate (estate-new-env *estate* env) (mode:lookup mode) expr) +(define-fn closure (*estate* options mode isa-name-list env-stack expr) + (rtl-c-with-estate (estate-make-closure *estate* isa-name-list + (rtx-make-env-stack env-stack)) + (mode:lookup mode) expr) ) ;; The result is the rtl->c generator table. diff --git a/rtl-traverse.scm b/rtl-traverse.scm index 807d295..89c502f 100644 --- a/rtl-traverse.scm +++ b/rtl-traverse.scm @@ -17,12 +17,13 @@ ;; This carries the immutable elements only! ;; OUTER-EXPR is the EXPR argument to rtx-canonicalize. -(define (/make-cstate context outer-expr) - (vector context outer-expr) +(define (/make-cstate context isa-name-list outer-expr) + (vector context isa-name-list outer-expr) ) (define (/cstate-context cstate) (vector-ref cstate 0)) -(define (/cstate-outer-expr cstate) (vector-ref cstate 1)) +(define (/cstate-isas cstate) (vector-ref cstate 1)) +(define (/cstate-outer-expr cstate) (vector-ref cstate 2)) ;; Flag an error while canonicalizing rtl. @@ -475,7 +476,15 @@ (cons val (cons new-env env))) ) -(define (/rtx-canon-env val mode parent-expr op-num cstate env depth) +(define (/rtx-canon-symbol-list val mode parent-expr op-num cstate env depth) + (if (or (not (list? val)) + (not (all-true? (map symbol? val)))) + (/rtx-canon-error cstate "bad symbol list" + val parent-expr op-num)) + #f +) + +(define (/rtx-canon-env-stack val mode parent-expr op-num cstate env depth) ;; VAL is an environment stack. (if (not (list? val)) (/rtx-canon-error cstate "environment not a list" @@ -558,7 +567,8 @@ (cons 'CASERTX /rtx-canon-casertx) (cons 'LOCALS /rtx-canon-locals) (cons 'ITERATION /rtx-canon-iteration) - (cons 'ENV /rtx-canon-env) + (cons 'SYMBOLLIST /rtx-canon-symbol-list) + (cons 'ENVSTACK /rtx-canon-env-stack) (cons 'ATTRS /rtx-canon-attrs) (cons 'SYMBOL /rtx-canon-symbol) (cons 'STRING /rtx-canon-string) @@ -805,7 +815,7 @@ (let ((expr-mode-name (cadr args)) (op-name (caddr args))) - (let ((op-obj (current-op-lookup op-name))) + (let ((op-obj (current-op-lookup op-name (/cstate-isas cstate)))) (if op-obj @@ -876,7 +886,7 @@ (let ((expr-mode-name (cadr args)) (ref-name (caddr args))) ;; FIXME: Will current-op-lookup find named operands? - (let ((op-obj (current-op-lookup env ref-name))) + (let ((op-obj (current-op-lookup ref-name (/cstate-isas cstate)))) (if op-obj @@ -1147,7 +1157,7 @@ (display requested-mode-name) (newline) (display (spaces (* 4 depth))) - (rtx-env-dump env) + (rtx-env-stack-dump env) (force-output))) (let* ((canoner (vector-ref /rtx-operand-canoners (rtx-num rtx-obj))) @@ -1175,7 +1185,7 @@ (display (rtx-dump expr)) (newline) (display (spaces (* 4 depth))) - (rtx-env-dump env) + (rtx-env-stack-dump env) (force-output) )) @@ -1202,7 +1212,7 @@ (if (memq expected '(RTX SETRTX)) (cond ((symbol? expr) - (cond ((current-op-lookup expr) + (cond ((current-op-lookup expr (/cstate-isas cstate)) => (lambda (op) ;; NOTE: We can't simply call ;; op:mode-name here, we need the real @@ -1254,36 +1264,37 @@ ;; - ifield-name -> (ifield ifield-name) ;; Plus an absent option list is replaced with (). ;; Plus DFLT mode is converted to a useful mode. +;; Plus the specified isa-name-list is recorded in the RTL. ;; ;; The result is EXPR in canonical form. ;; ;; CONTEXT is a object or #f if there is none. ;; It is used in error messages. ;; +;; ISA-NAME-LIST is a list of ISAs in which to evaluate the expression, +;; e.g. to do operand lookups. +;; The ISAs must be compatible, e.g. operand lookups must be unambiguous. +;; ;; MODE-NAME is the requested mode of the result, or DFLT. ;; ;; EXTRA-VARS-ALIST is an association list of extra (symbol value) ;; elements to be used during value lookup. -;; VALUE can be #f which means "unknown". -;; -;; ??? If EXTRA-VARS-ALIST is non-null, it might be nice to return a closure. -;; It might simplify subsequent uses of the canonicalized code. - -(define (rtx-canonicalize context mode-name expr extra-vars-alist) +;; VALUE can be #f which means the value is assumed to be known, but is +;; currently unrepresentable. This is used, for example, when representing +;; ifield setters: we don't know the new value, but it will be known when the +;; rtx is evaluated (??? Sigh, this is a bit of a cheat, closures have no +;; such thing, but it's useful here because we don't necessarily know what +;; the value will be in the application side of things). + +(define (rtx-canonicalize context mode-name isa-name-list extra-vars-alist expr) (let ((result (/rtx-canon expr 'RTX mode-name #f 0 - (/make-cstate context expr) + (/make-cstate context isa-name-list expr) (rtx-env-init-stack1 extra-vars-alist) 0))) (rtx-verify-no-dflt-modes context result) - result) -) - -;; Utility for a common case. -;; Canonicalize rtl expression STMT which has a VOID result, -;; and no external environment. - -(define (rtx-canonicalize-stmt context stmt) - (rtx-canonicalize context 'VOID stmt nil) + (rtx-make 'closure mode-name isa-name-list + (rtx-var-alist-to-closure-env-stack extra-vars-alist) + result)) ) ;; RTL expression traversal support. @@ -1325,6 +1336,8 @@ ; computing the insn format) EXPR-FN processes the expression itself, and ; when evaluating EXPR it's the result of EXPR-FN that computes the value. ; +; ISAS is a list of ISA name(s) in which to evaluate the expression. +; ; ENV is the current environment. This is a stack of sequence locals. ; ; COND? is a boolean indicating if the current expression is on a conditional @@ -1349,24 +1362,26 @@ ; ; DEPTH is the current traversal depth. -(define (tstate-make context owner expr-fn env cond? known depth) - (vector context owner expr-fn env cond? known depth) -) - -(define (tstate-context state) (vector-ref state 0)) -(define (tstate-set-context! state newval) (vector-set! state 0 newval)) -(define (tstate-owner state) (vector-ref state 1)) -(define (tstate-set-owner! state newval) (vector-set! state 1 newval)) -(define (tstate-expr-fn state) (vector-ref state 2)) -(define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval)) -(define (tstate-env state) (vector-ref state 3)) -(define (tstate-set-env! state newval) (vector-set! state 3 newval)) -(define (tstate-cond? state) (vector-ref state 4)) -(define (tstate-set-cond?! state newval) (vector-set! state 4 newval)) -(define (tstate-known state) (vector-ref state 5)) -(define (tstate-set-known! state newval) (vector-set! state 5 newval)) -(define (tstate-depth state) (vector-ref state 6)) -(define (tstate-set-depth! state newval) (vector-set! state 6 newval)) +(define (tstate-make context owner expr-fn isas env cond? known depth) + (vector context owner expr-fn isas env cond? known depth) +) + +(define (tstate-context state) (vector-ref state 0)) +(define (tstate-set-context! state newval) (vector-set! state 0 newval)) +(define (tstate-owner state) (vector-ref state 1)) +(define (tstate-set-owner! state newval) (vector-set! state 1 newval)) +(define (tstate-expr-fn state) (vector-ref state 2)) +(define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval)) +(define (tstate-isas state) (vector-ref state 3)) +(define (tstate-set-isas! state newval) (vector-set! state 3 newval)) +(define (tstate-env-stack state) (vector-ref state 4)) +(define (tstate-set-env-stack! state newval) (vector-set! state 4 newval)) +(define (tstate-cond? state) (vector-ref state 5)) +(define (tstate-set-cond?! state newval) (vector-set! state 5 newval)) +(define (tstate-known state) (vector-ref state 6)) +(define (tstate-set-known! state newval) (vector-set! state 6 newval)) +(define (tstate-depth state) (vector-ref state 7)) +(define (tstate-set-depth! state newval) (vector-set! state 7 newval)) ; Create a copy of STATE. @@ -1375,11 +1390,13 @@ (list->vector (vector->list state)) ) -; Create a copy of STATE with a new environment ENV. +;; Create a copy of STATE with environment stack ENV-STACK added, +;; and the ISA(s) set to ISA-NAME-LIST. -(define (tstate-new-env state env) +(define (tstate-make-closure state isa-name-list env-stack) (let ((result (tstate-copy state))) - (tstate-set-env! result env) + (tstate-set-isas! result isa-name-list) + (tstate-set-env-stack! result (append env-stack (tstate-env-stack result))) result) ) @@ -1390,7 +1407,7 @@ (define (tstate-push-env state env) (let ((result (tstate-copy state))) - (tstate-set-env! result (cons env (tstate-env result))) + (tstate-set-env-stack! result (cons env (tstate-env-stack result))) result) ) @@ -1531,11 +1548,6 @@ (cons val (tstate-push-env tstate env))) ) -(define (/rtx-traverse-env val expr op-num tstate appstuff) - ;; VAL is an environment stack. - (cons val (tstate-new-env tstate val)) -) - (define (/rtx-traverse-attrs val expr op-num tstate appstuff) ; (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val "")) ; tstate) @@ -1578,7 +1590,9 @@ (cons 'CASERTX /rtx-traverse-casertx) (cons 'LOCALS /rtx-traverse-locals) (cons 'ITERATION /rtx-traverse-iteration) - (cons 'ENV /rtx-traverse-env) + ;; NOTE: Closure isas and env are handled in /rtx-traverse. + (cons 'SYMBOLLIST /rtx-traverse-normal-operand) + (cons 'ENVSTACK /rtx-traverse-normal-operand) (cons 'ATTRS /rtx-traverse-attrs) (cons 'SYMBOL /rtx-traverse-normal-operand) (cons 'STRING /rtx-traverse-normal-operand) @@ -1605,7 +1619,7 @@ (display "Traversing operands of: ") (display (rtx-dump expr)) (newline) - (rtx-env-dump (tstate-env tstate)) + (rtx-env-stack-dump (tstate-env-stack tstate)) (force-output))) (let loop ((operands (cdr expr)) @@ -1733,12 +1747,6 @@ ; TSTATE is the current traversal state. ; ; APPSTUFF is for application specific use. -; -; All macros are expanded here. User code never sees them. -; All operand shortcuts are also expand here. User code never sees them. -; These are: -; - operands, ifields, and numbers appearing where an rtx is expected are -; converted to use `operand', `ifield', or `const'. (define (/rtx-traverse expr expected parent-expr op-pos tstate appstuff) (if /rtx-traverse-debug? @@ -1751,6 +1759,10 @@ (display "-expected: ") (display expected) (newline) + (display (spaces (* 4 (tstate-depth tstate)))) + (display "-conditional: ") + (display (tstate-cond? tstate)) + (newline) (force-output) )) @@ -1758,12 +1770,21 @@ (if (pair? expr) ; pair? -> cheap non-null-list? - (let ((rtx-obj (rtx-lookup (car expr)))) + (let* ((rtx-name (car expr)) + (rtx-obj (rtx-lookup rtx-name)) + ;; If this is a closure, update tstate. + ;; ??? This is a bit of a wart. All other rtxes handle their + ;; special args/needs via rtx-arg-types. Left as is to simmer. + (tstate (if (eq? rtx-name 'closure) + (tstate-make-closure tstate + (rtx-closure-isas expr) + (rtx-make-env-stack (rtx-closure-env-stack expr))) + tstate))) (tstate-incr-depth! tstate) (let ((result (if rtx-obj (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff) - (let ((rtx-obj (/rtx-macro-lookup (car expr)))) + (let ((rtx-obj (/rtx-macro-lookup rtx-name))) (if rtx-obj (/rtx-traverse (/rtx-macro-expand expr rtx-evaluator) expected parent-expr op-pos tstate appstuff) @@ -1773,17 +1794,18 @@ ; EXPR is not a list. ; See if it's an operand shortcut. + ; FIXME: Can we get here any more? [now that EXPR is already canonical] (if (memq expected '(RTX SETRTX)) (cond ((symbol? expr) - (cond ((current-op-lookup expr) + (cond ((current-op-lookup expr (tstate-isas tstate)) => (lambda (op) (/rtx-traverse ;; NOTE: Can't call op:mode-name here, we need ;; the real mode, not (potentially) DFLT. (rtx-make-operand (obj:name (op:mode op)) expr) expected parent-expr op-pos tstate appstuff))) - ((rtx-temp-lookup (tstate-env tstate) expr) + ((rtx-temp-lookup (tstate-env-stack tstate) expr) => (lambda (tmp) (/rtx-traverse (rtx-make-local (rtx-temp-mode tmp) expr) @@ -1812,7 +1834,7 @@ ) ; User visible procedures to traverse an rtl expression. -; EXPR must be fully canonical (i.e. compiled). +; EXPR must be fully canonical. ; These calls /rtx-traverse to do most of the work. ; See tstate-make for explanations of OWNER, EXPR-FN. ; CONTEXT is a object or #f if there is none. @@ -1821,7 +1843,9 @@ (define (rtx-traverse context owner expr expr-fn appstuff) (/rtx-traverse expr #f #f 0 - (tstate-make context owner expr-fn (rtx-env-empty-stack) + (tstate-make context owner expr-fn + #f ;; ok since EXPR is fully canonical + (rtx-env-empty-stack) #f nil 0) appstuff) ) @@ -1829,6 +1853,7 @@ (define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff) (/rtx-traverse expr #f #f 0 (tstate-make context owner expr-fn + #f ;; ok since EXPR is fully canonical (rtx-env-push (rtx-env-empty-stack) (rtx-env-make-locals locals)) #f nil 0) @@ -1909,8 +1934,16 @@ ; In time things should be simplified. (expr-fn . #f) - ; Current environment. This is a stack of sequence locals. - (env . ()) + ; List of ISA name(s) in which to evaluate the expression. + ; This is used for example during operand lookups. + ; All specified ISAs must be compatible, + ; e.g. operand lookups must be unambiguous. + ; A value of #f means "all ISAs". + (isas . #f) + + ; Current environment. This is a stack of sequence locals, + ; e.g. made with rtx-env-init-stack1. + (env-stack . ()) ; Current evaluation depth. This is used, for example, to ; control indentation in generated output. @@ -1946,8 +1979,10 @@ (elm-set! self 'outer-expr (cadr args))) ((#:expr-fn) (elm-set! self 'expr-fn (cadr args))) - ((#:env) - (elm-set! self 'env (cadr args))) + ((#:env-stack) + (elm-set! self 'env-stack (cadr args))) + ((#:isas) + (elm-set! self 'isas (cadr args))) ((#:depth) (elm-set! self 'depth (cadr args))) ((#:modifiers) @@ -1962,10 +1997,10 @@ ; Accessors. (define-getters estate - (context owner outer-expr expr-fn env depth modifiers) + (context owner outer-expr expr-fn isas env-stack depth modifiers) ) (define-setters estate - (env depth modifiers) + (isas env-stack depth modifiers) ) ; Build an estate for use in producing a value from rtl. @@ -1977,7 +2012,8 @@ #:context context #:owner owner #:expr-fn (lambda (rtx-obj expr mode estate) - (rtx-evaluator rtx-obj))) + (rtx-evaluator rtx-obj)) + #:isas (and owner (obj-isa-list owner))) ) ; Create a copy of ESTATE. @@ -1986,11 +2022,13 @@ (object-copy-top estate) ) -; Create a copy of ESTATE with a new environment ENV. +;; Create a copy of ESTATE with environment stack ENV-STACK added, +;; and the ISA(s) set to ISA-NAME-LIST. -(define (estate-new-env estate env) +(define (estate-make-closure estate isa-name-list env-stack) (let ((result (estate-copy estate))) - (estate-set-env! result env) + (estate-set-isas! result isa-name-list) + (estate-set-env-stack! result (append env-stack (estate-env-stack result))) result) ) @@ -2001,7 +2039,7 @@ (define (estate-push-env estate env) (let ((result (estate-copy estate))) - (estate-set-env! result (cons env (estate-env result))) + (estate-set-env-stack! result (cons env (estate-env-stack result))) result) ) @@ -2026,7 +2064,7 @@ (define (tstate->estate t) (vmake #:context (tstate-context t) - #:env (tstate-env t)) + #:env-stack (tstate-env-stack t)) ) ; Issue an error given an estate. @@ -2070,7 +2108,7 @@ (newline) (display (rtx-dump expr)) (newline) - (rtx-env-dump (estate-env estate)) + (rtx-env-stack-dump (estate-env-stack estate)) )) (if (pair? expr) ; pair? -> cheap non-null-list? @@ -2099,8 +2137,9 @@ ; Evaluate rtx expression EXPR and return the computed value. ; EXPR must already be in canonical form (the result of rtx-canonicalize). -; OWNER is the owner of the value, used for attribute computation, -; or #f if there isn't one. +; OWNER is the owner of the value, used for attribute computation +; and to get the ISA name list. +; OWNER is #f if there isn't one. ; FIXME: context? (define (rtx-value expr owner) diff --git a/rtl-xform.scm b/rtl-xform.scm index 1f7d939..1ff896e 100644 --- a/rtl-xform.scm +++ b/rtl-xform.scm @@ -285,6 +285,11 @@ known-val ; (rtx-make 'const 'INT known-val) #f))) + ((closure) + (let ((simplified-expr (/rtx-traverse (rtx-closure-expr expr) + 'RTX expr 2 tstate appstuff))) + simplified-expr)) + ; Leave EXPR unchanged and continue. (else #f)) ) @@ -315,6 +320,7 @@ (/rtx-traverse expr #f #f 0 (tstate-make context owner /rtx-simplify-expr-fn + #f ;; ok since EXPR is fully canonical (rtx-env-empty-stack) #f known 0) #f) @@ -368,7 +374,7 @@ ; (/rtx-traverse simplified-expr #f #f 0 ; (tstate-make context owner ; /solve-expr-fn -; (rtx-env-empty-stack) +; #f (rtx-env-empty-stack) ; #f known 0) ; #f)) ) @@ -438,7 +444,7 @@ ((LOCALS) #f) ; leave arg untouched - ((ENV) + ((ITERATION SYMBOLLIST ENVSTACK) #f) ; leave arg untouched for now ((ATTRS) @@ -471,6 +477,7 @@ (define (/rtx-trim-for-doc rtx) (if (pair? rtx) ; ??? cheap rtx? + (let ((name (car rtx)) (options (cadr rtx)) (mode (caddr rtx)) @@ -513,6 +520,19 @@ (cons name (cons mode (reverse result)))) (cons name (cons options (cons mode (reverse result))))))) + ((closure) + ;; Remove outer closures, they are artificially added, and are + ;; basically noise to the human trying to understand the semantics. + ;; ??? Since we currently can't distinguish outer closures, + ;; just remove them all. + (let ((trimmed-expr (/rtx-trim-for-doc (rtx-closure-expr rtx)))) + (if (and (null? options) (null? (rtx-closure-env-stack rtx))) + trimmed-expr + (rtx-make 'closure options mode + (rtx-closure-isas rtx) + (rtx-closure-env-stack rtx) + trimmed-expr)))) + (else (let ((trimmed-args (/rtx-trim-args name rest))) (if (null? options) diff --git a/rtl.scm b/rtl.scm index 9f3a178..6173456 100644 --- a/rtl.scm +++ b/rtl.scm @@ -66,7 +66,8 @@ ; CASERTX - a case expression ((symbol .. symbol) rtx ... rtx) ; LOCALS - the locals list of a sequence ; ITERATION - the iteration - ; ENV - environment stack + ; SYMBOLLIST - used for ISA name lists + ; ENVSTACK - environment stack ; ATTRS - attribute list ; SYMBOL - arg must be a symbol ; STRING - arg must be a string @@ -165,7 +166,8 @@ '(OPTIONS) /rtx-valid-mode-types '(RTX SETRTX TESTRTX CONDRTX CASERTX) - '(LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT) + '(LOCALS ITERATION SYMBOLLIST ENVSTACK ATTRS) + '(SYMBOL STRING NUMBER SYMORNUM OBJECT) ) ) @@ -436,7 +438,7 @@ (define (rtx-lvalue-mode-name estate x) (assert (rtx? x)) (case (car x) -; ((operand) (obj:name (op:mode (current-op-lookup (cadr x))))) +; ((operand) (obj:name (op:mode (current-op-lookup (cadr x) (obj-isa-list (estate-owner estate)))))) ((xop) (obj:name (send (rtx-xop-obj x) 'get-mode))) ; ((opspec) ; (if (eq? (rtx-opspec-mode x) 'VOID) @@ -445,7 +447,7 @@ ; ((reg mem) (cadr x)) ((local) ;; (local options mode name) (let* ((name (cadddr x)) - (temp (rtx-temp-lookup (estate-env estate) name))) + (temp (rtx-temp-lookup (estate-env-stack estate) name))) (if (not temp) (estate-error estate "unknown local" name)) (obj:name (rtx-temp-mode temp)))) @@ -530,7 +532,6 @@ (define (rtx-env-stack-empty? env-stack) (null? env-stack)) (define (rtx-env-stack-head env-stack) (car env-stack)) -(define (rtx-env-var-list env) env) (define (rtx-env-empty-stack) nil) (define (rtx-env-init-stack1 vars-alist) (if (null? vars-alist) @@ -539,18 +540,23 @@ ) (define (rtx-env-empty? env) (null? env)) -; Create an initial environment. -; VAR-LIST is a list of (name -or-mode-name value) elements. - -(define (rtx-env-make var-list) - ; Convert VAR-LIST to an associative list of objects. - (map (lambda (var-spec) - (cons (car var-spec) - (make - (car var-spec) - (mode-maybe-lookup (cadr var-spec)) - (caddr var-spec)))) - var-list) +;; Create an environment from VAR-ALIST, +;; an alist of (name -or-mode-name value) elements, +;; or, in the case of /rtx-closure-make, a list of (name . ). + +(define (rtx-env-make var-alist) + ;; Check for an already-compiled environment, for /rtx-closure-make's sake. + (if (and (pair? var-alist) + (rtx-temp? (cdar var-alist))) + var-alist + ;; Convert VAR-ALIST to an associative list of objects. + (map (lambda (var-spec) + (cons (car var-spec) + (make + (car var-spec) + (mode-maybe-lookup (cadr var-spec)) + (caddr var-spec)))) + var-alist)) ) ; Create an initial environment with local variables. @@ -581,6 +587,28 @@ (list 'INT (rtx-make-iteration-limit-var iter-var)))) ) +;; Convert an alist of (name -object-or-name value) to +;; an environment. + +(define (rtx-var-alist-to-env var-alist) var-alist) + +;; Convert an alist of (name -object-or-name value) to +;; an environment stack. + +(define (rtx-var-alist-to-closure-env-stack var-alist) + ;; Preserve emptiness so (null? env-stack) works. + (if (null? var-alist) + nil + (list var-alist)) +) + +;; Convert the source form of an env-stack, e.g. as used in a closure, +;; to the internal form, which is (name -object). + +(define (rtx-make-env-stack closure-env-stack) + (map rtx-env-make closure-env-stack) +) + ; Push environment ENV onto the front of environment stack ENV-STACK, ; returning a new object. ENV-STACK is not modified. @@ -588,12 +616,11 @@ (cons env env-stack) ) -; Lookup variable NAME in environment ENV. +; Lookup variable NAME in environment stack ENV-STACK. ; The result is the object. -; ??? Should environments only have rtx-temps? -(define (rtx-temp-lookup env name) - (let loop ((stack (rtx-env-var-list env))) +(define (rtx-temp-lookup env-stack name) + (let loop ((stack env-stack)) (if (null? stack) #f (let ((temp (assq-ref (car stack) name))) @@ -602,14 +629,17 @@ (loop (cdr stack)))))) ) -; Create a "closure" of EXPR using the current temp stack. +; Create a "closure" of EXPR using the current ISA list and temp stack. +; MODE is the mode name. (define (/rtx-closure-make estate mode expr) - (rtx-make 'closure mode expr (estate-env estate)) + ;; NOTE: This records the "compiled" environment stack in the closure. + (rtx-make 'closure mode (estate-isas estate) (estate-env-stack estate) + expr) ) -(define (rtx-env-dump env) - (let ((stack env)) +(define (rtx-env-stack-dump env-stack) + (let ((stack env-stack)) (if (rtx-env-stack-empty? stack) (display "rtx-env stack (empty):\n") (let loop ((stack stack) (level 0)) @@ -709,7 +739,7 @@ (define (rtx-ifield-obj rtx) (let ((ifield (rtx-arg1 rtx))) (if (symbol? ifield) - (current-ifield-lookup ifield) + (current-ifld-lookup ifield) ifield)) ) @@ -726,19 +756,22 @@ (obj:name operand))) ) -;; Given an operand rtx, construct the object. +;; Given an operand rtx, return the object. ;; RTX must be canonical rtl. - -(define (rtx-operand-obj rtx) - (let ((op (current-op-lookup (rtx-arg1 rtx))) - (mode (rtx-mode rtx))) +;; ISA-NAME-LIST is the list of ISAs to look the operand up in. +;; +;; NOTE: op:mode-name can be DFLT, which means use the mode of the type. +;; It is up to the caller to deal with it. + +(define (rtx-operand-obj rtx isa-name-list) + (let ((op (current-op-lookup (rtx-arg1 rtx) isa-name-list)) + (mode-name (rtx-mode rtx))) (assert op) - (assert (not (eq? mode 'DFLT))) - ;; NOTE: op:mode-name can be DFLT, which means use the mode of the type. - ;; But we can't propagate DFLT here, in canonical rtl DFLT is not allowed. - (if (mode:eq? (op:mode-name op) mode) - op - (op:new-mode op mode))) + (assert (not (eq? mode-name 'DFLT))) + ;; Ensure requested mode is supported by the hardware. + ;; rtx-canonicalize should have verified this already (I think). + (assert (hw-mode-ok? (op:type op) mode-name (op:index op))) + op) ) (define (rtx-make-local mode-name local-name) @@ -802,7 +835,7 @@ (define (rtx-sequence-exprs rtx) (cddddr rtx)) ; Same as rtx-sequence-locals except return in assq'able form. -; ??? Sometimes I should it should have been (sequence ((name MODE)) ...) +; ??? Sometimes I think it should have been (sequence ((name MODE)) ...) ; instead of (sequence ((MODE name)) ...) from the beginning, sigh. (define (rtx-sequence-assq-locals rtx) @@ -812,6 +845,10 @@ locals)) ) +(define (rtx-closure-isas rtx) (list-ref rtx 3)) +(define (rtx-closure-env-stack rtx) (list-ref rtx 4)) +(define (rtx-closure-expr rtx) (list-ref rtx 5)) + ; Return a semi-pretty string describing RTX. ; This is used by hw to include the index in the element's name. @@ -986,20 +1023,16 @@ ; HW-NAME/MODE-NAME/SELECTOR/INDEX-ARG. ; ; HW-NAME is the name of the hardware element. +; MODE-NAME is the name of the mode. ; INDEX-ARG is an rtx or number of the index. ; In the case of scalar hardware elements, pass 0 for INDEX-ARG. -; MODE-NAME is the name of the mode. ; In the case of a vector of registers, INDEX-ARG is the vector index. -; In the case of a scalar register, the value is ignored, but pass 0 (??? #f?). ; SELECTOR is an rtx or number and is passed to HW-NAME to allow selection of a ; particular variant of the hardware. It's kind of like an INDEX, but along ; an atypical axis. An example is memory ASI's on Sparc. Pass ; hw-selector-default if there is no selector. ; ESTATE is the current rtx evaluation state. ; -; e.g. (hw estate WI h-gr #f (const INT 14)) -; selects register 14 of the h-gr set of registers. -; ; *** The index is passed unevaluated because for parallel execution support ; *** a variable is created with a name based on the hardware element and ; *** index, and we want a reasonably simple and stable name. We get this by @@ -1043,13 +1076,6 @@ (cond ((number? index-arg) (make 'anonymous 'constant UINT index-arg)) ((rtx? index-arg) - ; For the simulator the following could be done which - ; would save having to create a closure. - ; ??? Old code, left in for now. - ; (rtx-get estate DFLT - ; (rtx-eval (estate-context estate) - ; (estate-econfig estate) - ; index-arg rtx-evaluator)) ; Make sure constant indices are recorded as such. (if (rtx-constant? index-arg) (make 'anonymous 'constant UINT diff --git a/rtx-funcs.scm b/rtx-funcs.scm index b4608e2..cbd0bcd 100644 --- a/rtx-funcs.scm +++ b/rtx-funcs.scm @@ -1125,7 +1125,6 @@ ; This has to be a syntax node to handle locals properly: they're not defined ; yet and thus pre-evaluating the expressions doesn't work. -; ??? This should create a closure. (drsn (sequence &options &mode locals expr . exprs) #f @@ -1145,11 +1144,13 @@ ) ; Internal rtx to create a closure. -; Internal, so it does not appear in rtl.texi. +; Internal, so it does not appear in rtl.texi (at least not yet). +; ??? Maybe closures shouldn't be separate from sequences, +; but I'm less convinced these days. -(drsn (closure &options &mode expr env) +(drsn (closure &options &mode isa-name-list env-stack expr) #f - (OPTIONS VOIDORNUMMODE RTX ENV) (NA NA MATCHEXPR NA) + (OPTIONS VOIDORNUMMODE SYMBOLLIST ENVSTACK RTX) (NA NA NA NA MATCHEXPR) MISC #f ) diff --git a/sem-frags.scm b/sem-frags.scm index bd03cd2..0fb26f4 100644 --- a/sem-frags.scm +++ b/sem-frags.scm @@ -196,7 +196,7 @@ (define (/frag-hash-stmt stmt locals size) (set! /frag-hash-value-tmp 0) - (rtx-traverse-with-locals #f #f stmt /frag-hash-compute! locals #f) ; FIXME: (/fastcall-make /frag-hash-compute!)) + (rtx-traverse-with-locals #f #f stmt /frag-hash-compute! locals #f) (modulo /frag-hash-value-tmp size) ) @@ -241,7 +241,7 @@ (define (/frag-stmt-cost stmt locals) (set! /frag-speed-cost-tmp 0) (set! /frag-size-cost-tmp 0) - (rtx-traverse-with-locals #f #f stmt /frag-cost-compute! locals #f) ; FIXME: (/fastcall-make /frag-cost-compute!)) + (rtx-traverse-with-locals #f #f stmt /frag-cost-compute! locals #f) (cons /frag-speed-cost-tmp /frag-size-cost-tmp) ) @@ -433,12 +433,9 @@ ; statements. stmt-numbers - ; Raw rtl source of fragment. + ; rtl source of fragment. semantics - ; Compiled source. - compiled-semantics - ; Boolean indicating if this frag is for parallel exec support. parallel? @@ -454,7 +451,7 @@ ) (define-getters sfrag - (users user-nums sfmt stmt-numbers semantics compiled-semantics + (users user-nums sfmt stmt-numbers semantics parallel? header? trailer?) ) @@ -686,6 +683,17 @@ (for-each (lambda (users) (let* ((first-owner (cdar users)) + (context (make-obj-context first-owner "While building sfrags")) + (rtl (apply + rtx-make + (cons 'sequence + (cons 'VOID + (cons nil + (map (lambda (stmt-num) + (-stmt-expr + (vector-ref stmt-table + stmt-num))) + stmt-list)))))) (sfrag (make (symbol-append (obj:name first-owner) @@ -698,17 +706,7 @@ (map car users) (insn-sfmt first-owner) stmt-list - (apply - rtx-make - (cons 'sequence - (cons 'VOID - (cons nil - (map (lambda (stmt-num) - (-stmt-expr - (vector-ref stmt-table - stmt-num))) - stmt-list))))) - #f ; compiled-semantics + rtl #f ; parallel? (eq? kind 'header) (eq? kind 'trailer) @@ -856,7 +854,17 @@ (+ expr-num 1) (cdr expr-middle-stmts)) ; Yep. - (let ((owner (vector-ref owner-table expr-num))) + (let* ((owner (vector-ref owner-table expr-num)) + (context (make-obj-context owner "While building sfrags")) + (rtl (apply + rtx-make + (cons 'sequence + (cons 'VOID + (cons nil + (map (lambda (stmt-num) + (-stmt-expr + (vector-ref stmt-table stmt-num))) + (car expr-middle-stmts)))))))) (vector-set! (vector-ref expr-sfrags expr-num) 1 next-middle-frag-num) (loop (cons (make @@ -868,16 +876,7 @@ (list expr-num) (insn-sfmt owner) (car expr-middle-stmts) - (apply - rtx-make - (cons 'sequence - (cons 'VOID - (cons nil - (map (lambda (stmt-num) - (-stmt-expr - (vector-ref stmt-table stmt-num))) - (car expr-middle-stmts)))))) - #f ; compiled-semantics + rtl #f ; parallel? #f ; header? #f ; trailer? @@ -1105,10 +1104,9 @@ '(VIRTUAL) "") nil ; users nil ; user ordinals - (insn-sfmt (current-insn-lookup 'x-before)) + (insn-sfmt (current-insn-lookup 'x-before #f)) #f ; stmt-numbers (rtx-make 'nop) - #f ; compiled-semantics #f ; parallel? #t ; header? #f ; trailer? @@ -1123,10 +1121,9 @@ '(VIRTUAL) "") nil ; users nil ; user ordinals - (insn-sfmt (current-insn-lookup 'x-before)) + (insn-sfmt (current-insn-lookup 'x-before #f)) #f ; stmt-numbers (rtx-make 'nop) - #f ; compiled-semantics #f ; parallel? #f ; header? #t ; trailer? diff --git a/semantics.scm b/semantics.scm index 306c431..7307467 100644 --- a/semantics.scm +++ b/semantics.scm @@ -75,8 +75,10 @@ ; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc. (define (/build-operand! op-expr tstate ref-type op-list sem-attrs) - (let* ((op (rtx-operand-obj op-expr)) + (let* ((orig-op (rtx-operand-obj op-expr (obj-isa-list (tstate-owner tstate)))) (mode (rtx-mode op-expr)) + ;; We need a copy as we'll be modifying it. + (op (op:new-mode orig-op mode)) ;; The first #f is a placeholder for the object. (try (list '-op- #f mode (rtx-arg1 op-expr) #f)) (existing-op (/rtx-find-op try op-list))) @@ -208,7 +210,8 @@ "only `(index-of operand)' is currently supported" expr)) - (let ((op (rtx-operand-obj (rtx-index-of-value expr)))) + (let ((op (rtx-operand-obj (rtx-index-of-value expr) + (obj-isa-list (tstate-owner tstate))))) (let ((indx (op:index op))) (if (not (eq? (hw-index:type indx) 'ifield)) (parse-error (tstate-context tstate) @@ -278,8 +281,7 @@ (define (csem-outputs csem) (vector-ref csem 2)) (define (csem-attrs csem) (vector-ref csem 3)) -; Traverse each element in SEM-CODE, converting them to canonical form, -; and computing the input and output operands. +; Traverse SEM-CODE, computing the input and output operands. ; The result is an object of four elements (built with csem-make). ; The first is a list of the canonical form of each element in SEM-CODE: ; operand and ifield elements specified without `operand' or `ifield' have it @@ -298,6 +300,7 @@ ; ; CONTEXT is a object or #f if there is none. ; INSN is the object. +; SEM-CODE must be canonicalized rtl. ; ; ??? Specifying operand ordinals in the source would simplify this and speed ; it up. On the other hand that makes the source form more complex. Maybe the diff --git a/sid-cpu.scm b/sid-cpu.scm index 69b30d9..0b178b1 100644 --- a/sid-cpu.scm +++ b/sid-cpu.scm @@ -111,7 +111,6 @@ namespace @arch@ { (name (obj:name hw)) (getter (hw-getter hw)) (setter (hw-setter hw)) - (isas (obj-attr-value hw 'ISA)) (type (gen-type hw))) (let ((get-code (if getter (let ((mode (hw-mode hw)) @@ -119,10 +118,12 @@ namespace @arch@ { (expr (cadr getter))) (string-append "return " - (rtl-c++ mode expr + (rtl-c++ mode + #f ;; h/w is not ISA-specific (if scalar? nil (list (list (car args) 'UINT "regno"))) + expr #:rtl-cover-fns? #t) ";")) (string-append @@ -135,11 +136,12 @@ namespace @arch@ { (expr (cadr setter))) (rtl-c++ VOID ; not `mode', sets have mode VOID - expr + #f ;; h/w is not ISA-specific (if scalar? (list (list (car args) (hw-mode hw) "newval")) (list (list (car args) 'UINT "regno") (list (cadr args) (hw-mode hw) "newval"))) + expr #:rtl-cover-fns? #t)) (string-append "this->hardware." @@ -704,26 +706,22 @@ using namespace cgen; ; Return C code to perform the semantics of INSN. (define (gen-semantic-code insn) - ; Indicate generating code for INSN. - ; Use the canonical form if available. - ; The case when they're not available is for virtual insns. (??? Still true?) (cond ((insn-compiled-semantics insn) => (lambda (sem) - (rtl-c++-parsed VOID sem nil + (rtl-c++-parsed VOID sem #:for-insn? #t #:rtl-cover-fns? #t #:owner insn))) ((insn-canonical-semantics insn) => (lambda (sem) - (rtl-c++-parsed VOID sem nil + (rtl-c++-parsed VOID sem #:for-insn? #t #:rtl-cover-fns? #t #:owner insn))) (else - (rtl-c++ VOID (insn-semantics insn) nil - #:for-insn? #t - #:rtl-cover-fns? #t - #:owner insn))) + (context-error (make-obj-context insn #f) + "While generating semantic code" + "semantics of insn are not canonicalized"))) ) ; Return definition of C function to perform INSN. @@ -894,7 +892,8 @@ using namespace @prefix@; // FIXME: namespace organization still wip\n")) (isa-setup-semantics (current-isa))) (string-append " " - (rtl-c++ VOID (isa-setup-semantics (current-isa)) nil + (rtl-c++ VOID (obj-isa-list insn) nil + (isa-setup-semantics (current-isa)) #:for-insn? #t #:rtl-cover-fns? #t #:owner insn)) @@ -1115,27 +1114,20 @@ struct @prefix@_pbb_label { ; Each element is (symbol "c-var-name"). (define (/gen-sfrag-code frag locals) - ; Indicate generating code for FRAG. - ; Use the compiled form if available. - ; The case when they're not available is for virtual insns. - (let ((sem (sfrag-compiled-semantics frag)) + (let ((sem (sfrag-semantics frag)) ; If the frag has one owner, use it. Otherwise indicate the owner is ; unknown. In cases where the owner is needed by the semantics, the ; frag should have only one owner. In practice this means that frags ; with the ref,current-insn rtx cannot be used by multiple insns. (owner (if (= (length (sfrag-users frag)) 1) (car (sfrag-users frag)) - #f)) - ) - (if sem - (rtl-c++-parsed VOID sem locals - #:for-insn? #t - #:rtl-cover-fns? #t - #:owner owner) - (rtl-c++ VOID (sfrag-semantics frag) locals - #:for-insn? #t - #:rtl-cover-fns? #t - #:owner owner))) + #f))) + ;; NOTE: (sfrag-users frag) is nil for the x-header and x-trailer frags. + ;; They are just nops. + (rtl-c++ VOID (and owner (obj-isa-list owner)) locals sem + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner owner)) ) ; Generate a switch case to perform FRAG. @@ -1189,7 +1181,8 @@ struct @prefix@_pbb_label { (isa-setup-semantics (current-isa))) (string-append " " - (rtl-c++ VOID (isa-setup-semantics (current-isa)) nil + (rtl-c++ VOID (list (obj:name (current-isa))) nil + (isa-setup-semantics (current-isa)) #:rtl-cover-fns? #t #:owner #f)) "") diff --git a/sid-decode.scm b/sid-decode.scm index d58adbc..999f47c 100644 --- a/sid-decode.scm +++ b/sid-decode.scm @@ -609,7 +609,7 @@ static void (let ((decode-code (gen-decoder insn-list initial-bitnums decode-bitsize " " lsb0? - (current-insn-lookup 'x-invalid) + (current-insn-lookup 'x-invalid #f) #t))) (string-write diff --git a/sid.scm b/sid.scm index 113a958..72ecae9 100644 --- a/sid.scm +++ b/sid.scm @@ -876,7 +876,7 @@ ; Generate C code for SEL. (define (/gen-hw-selector sel) - (rtl-c++ 'INT sel nil) + (rtl-c++ INT #f nil sel) ) ; Instruction operand support code. @@ -925,7 +925,7 @@ 'cxmake-skip (lambda (self estate yes?) (send (op:type self) 'cxmake-skip estate - (rtl-c++ INT yes? nil #:rtl-cover-fns? #t))) + (rtl-c++ INT (obj-isa-list self) nil yes? #:rtl-cover-fns? #t))) ) ; Default gen-read method. @@ -997,9 +997,11 @@ (getter (let ((args (car getter)) (expr (cadr getter))) - (rtl-c-expr mode expr + (rtl-c-expr mode + (obj-isa-list self) (if (= (length args) 0) nil (list (list (car args) 'UINT index))) + expr #:rtl-cover-fns? #t #:output-language (estate-output-language estate)))) (else @@ -1078,11 +1080,13 @@ (if (op:setter op) (let ((args (car (op:setter op))) (expr (cadr (op:setter op)))) - (rtl-c 'VOID expr + (rtl-c 'VOID + (obj-isa-list op) (if (= (length args) 0) (list (list 'newval mode "opval")) (list (list (car args) 'UINT index) (list 'newval mode "opval"))) + expr #:rtl-cover-fns? #t #:output-language (estate-output-language estate))) ;else @@ -1805,7 +1809,10 @@ pbb_br_status = BRANCH_UNTAKEN; UINT cond_code = abuf->cond; BI exec_p = " - (rtl-c++ DFLT (cadr (isa-condition isa)) '((cond-code UINT "cond_code")) + (rtl-c++ DFLT + (list (obj:name isa)) + '((cond-code UINT "cond_code")) + (cadr (isa-condition isa)) #:rtl-cover-fns? #t) "; if (! exec_p) @@ -2007,7 +2014,7 @@ )) ; Do our own error checking. - (assert (current-insn-lookup 'x-invalid)) + (assert (current-insn-lookup 'x-invalid #f)) *UNSPECIFIED* ) diff --git a/sim-cpu.scm b/sim-cpu.scm index e083c63..3b85498 100644 --- a/sim-cpu.scm +++ b/sim-cpu.scm @@ -534,7 +534,8 @@ SEM_FN_NAME (@prefix@,init_idesc_table) (SIM_CPU *current_cpu) (isa-setup-semantics (current-isa))) (string-append " " - (rtl-c VOID (isa-setup-semantics (current-isa)) nil + (rtl-c VOID (obj-isa-list insn) nil + (isa-setup-semantics (current-isa)) #:for-insn? #t #:rtl-cover-fns? #t #:owner insn) @@ -543,24 +544,23 @@ SEM_FN_NAME (@prefix@,init_idesc_table) (SIM_CPU *current_cpu) ; Indicate generating code for INSN. ; Use the compiled form if available. - ; The case when they're not available is for virtual insns. (??? Still true?) + ; The case when they're not available is for virtual insns. xxx Still true? (cond ((insn-compiled-semantics insn) => (lambda (sem) - (rtl-c-parsed VOID sem nil + (rtl-c-parsed VOID sem #:for-insn? #t #:rtl-cover-fns? #t #:owner insn))) ((insn-canonical-semantics insn) => (lambda (sem) - (rtl-c-parsed VOID sem nil + (rtl-c-parsed VOID sem #:for-insn? #t #:rtl-cover-fns? #t #:owner insn))) (else - (rtl-c VOID (insn-semantics insn) nil - #:for-insn? #t - #:rtl-cover-fns? #t - #:owner insn)))) + (context-error (make-obj-context insn #f) + "While generating semantic code" + "semantics of insn are not canonicalized")))) ) ; Return definition of C function to perform INSN. @@ -1272,7 +1272,7 @@ xfull-extract-* | xfast-extract-*) cat < 'cxmake-skip (lambda (self estate yes?) (send (op:type self) 'cxmake-skip estate - (rtl-c INT yes? nil #:rtl-cover-fns? #t))) + (rtl-c INT (obj-isa-list self) nil yes? #:rtl-cover-fns? #t))) ) ; For parallel write post-processing, we don't want to defer setting the pc. @@ -1028,7 +1031,7 @@ ; For operands, the word `read' is only used in this context. (define (op:read op sfmt) - (let ((estate (estate-make-for-rtl-c nil nil))) + (let ((estate (estate-make-for-rtl-c nil))) (send op 'gen-read estate sfmt /par-operand-macro)) ) @@ -1039,7 +1042,7 @@ ; For operands, the word `write' is only used in this context. (define (op:write op sfmt) - (let ((estate (estate-make-for-rtl-c nil nil))) + (let ((estate (estate-make-for-rtl-c nil))) (send op 'gen-write estate sfmt /par-operand-macro)) ) @@ -1111,10 +1114,12 @@ ((op:getter self) (let ((args (car (op:getter self))) (expr (cadr (op:getter self)))) - (rtl-c-expr mode expr + (rtl-c-expr mode + (obj-isa-list self) (if (= (length args) 0) nil (list (list (car args) 'UINT index))) + expr #:rtl-cover-fns? #t))) (else (send (op:type self) 'cxmake-get estate mode index selector))))) @@ -1198,11 +1203,13 @@ (if (op:setter op) (let ((args (car (op:setter op))) (expr (cadr (op:setter op)))) - (rtl-c 'VOID expr + (rtl-c VOID + (obj-isa-list op) (if (= (length args) 0) (list (list 'newval mode "opval")) (list (list (car args) 'UINT index) (list 'newval mode "opval"))) + expr #:rtl-cover-fns? #t)) ;else (send (op:type op) 'gen-set-quiet estate mode index selector @@ -1338,7 +1345,7 @@ ; smart enough to know there is no need. (define (op:record-profile op sfmt out?) - (let ((estate (estate-make-for-rtl-c nil nil))) + (let ((estate (estate-make-for-rtl-c nil))) (send op 'gen-record-profile sfmt out? estate)) ) @@ -2089,7 +2096,7 @@ struct scache { (set! /sim-insns-analyzed? #t))) ; Do our own error checking. - (assert (current-insn-lookup 'x-invalid)) + (assert (current-insn-lookup 'x-invalid #f)) *UNSPECIFIED* ) diff --git a/utils-cgen.scm b/utils-cgen.scm index daeef6e..e98ecca 100644 --- a/utils-cgen.scm +++ b/utils-cgen.scm @@ -578,11 +578,10 @@ ; Ideally most, if not all, of the guts of the generated sanitization is here. ; Utility to simplify expression in .cpu file. -; Usage: (sanitize keyword entry-type entry-name1 [entry-name2 ...]) +; Usage: (sanitize isa-name-list keyword entry-type entry-name1 [entry-name2 ...]) ; Enum attribute `(sanitize keyword)' is added to the entry. -; It's written this way so Hobbit can handle it. -(define (sanitize keyword entry-type . entry-names) +(define (sanitize isa-name-list keyword entry-type . entry-names) (for-each (lambda (entry-name) (let ((entry #f)) (case entry-type @@ -592,11 +591,11 @@ ((cpu) (set! entry (current-cpu-lookup entry-name))) ((mach) (set! entry (current-mach-lookup entry-name))) ((model) (set! entry (current-model-lookup entry-name))) - ((ifield) (set! entry (current-ifld-lookup entry-name))) + ((ifield) (set! entry (current-ifld-lookup entry-name isa-name-list))) ((hardware) (set! entry (current-hw-lookup entry-name))) - ((operand) (set! entry (current-op-lookup entry-name))) - ((insn) (set! entry (current-insn-lookup entry-name))) - ((macro-insn) (set! entry (current-minsn-lookup entry-name))) + ((operand) (set! entry (current-op-lookup entry-name isa-name-list))) + ((insn) (set! entry (current-insn-lookup entry-name isa-name-list))) + ((macro-insn) (set! entry (current-minsn-lookup entry-name isa-name-list))) (else (parse-error (make-prefix-context "sanitize") "unknown entry type" entry-type))) diff --git a/utils-gen.scm b/utils-gen.scm index 0ae3006..ec83686 100644 --- a/utils-gen.scm +++ b/utils-gen.scm @@ -107,9 +107,11 @@ ; cadr: fetches expression to be evaluated ; caar: fetches symbol in arglist ; cadar: fetches `pc' symbol in arglist - (rtl-c DFLT (cadr decode) + (rtl-c DFLT + (obj-isa-list f) (list (list (caar decode) 'UINT extraction) (list (cadar decode) 'IAI "pc")) + (cadr decode) #:rtl-cover-fns? #f #:ifield-var? #t))) ) @@ -223,9 +225,11 @@ ; cadr: fetches expression to be evaluated ; caar: fetches symbol in arglist ; cadar: fetches `pc' symbol in arglist - (rtl-c DFLT (cadr decode) + (rtl-c DFLT + (obj-isa-list f) (list (list (caar decode) 'UINT extraction) (list (cadar decode) 'IAI "pc")) + (cadr decode) #:rtl-cover-fns? #f #:ifield-var? #t))) ) @@ -256,15 +260,18 @@ (varname (gen-sym f)) (decode (string-list ;; First, the block that extract the multi-ifield into the ifld variable. - (rtl-c VOID (multi-ifld-extract f) nil + (rtl-c VOID (obj-isa-list f) nil + (multi-ifld-extract f) #:rtl-cover-fns? #f #:ifield-var? #t) ;; Next, the decode routine that modifies it. (if decode-proc (string-append " " varname " = " - (rtl-c DFLT (cadr decode-proc) + (rtl-c DFLT + (obj-isa-list f) (list (list (caar decode-proc) 'UINT varname) (list (cadar decode-proc) 'IAI "pc")) + (cadr decode-proc) #:rtl-cover-fns? #f #:ifield-var? #t) ";\n") "") diff --git a/utils.scm b/utils.scm index 5ba87fe..22e8a23 100644 --- a/utils.scm +++ b/utils.scm @@ -663,6 +663,18 @@ (define (intersection a b) (foldl (lambda (l e) (if (memq e a) (cons e l) l)) '() b)) +; Return #t if the intersection of A and B is non-null. + +(define (non-null-intersection? a b) + (let loop ((todo a)) + (cond ((null? todo) + #f) + ((memq (car todo) b) + #t) + (else + (loop (cdr todo))))) +) + ; Return union of two lists. (define (union a b)