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.
(<eval-state>): New member isas. Rename env to env-stack.
(<eval-state> vmake!): Handle #:isas. #:env renamed to #:env-stack.
(<eval-state>): 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 (<sfrag>): 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.
2009-11-02 Doug Evans <dje@sebabeach.org>
+ 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.
+ (<eval-state>): New member isas. Rename env to env-stack.
+ (<eval-state> vmake!): Handle #:isas. #:env renamed to #:env-stack.
+ (<eval-state>): 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 (<sfrag>): 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 <dje@sebabeach.org>
; 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)))
"#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"
(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))
(let ((e (make <insn-enum>
(parse-name context name)
(parse-comment context comment)
- atlist
+ atlist-obj
(/enum-parse-prefix context prefix)
fld-obj
(parse-enum-vals context prefix vals))))
(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*
)
(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)))
(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 <bitrange> object.
; 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)
(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)
(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
(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.
; 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
; ??? 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)))
; 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)
(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 <ifield> 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)))
(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))))
; Given an insn format field from a .cpu file, replace it with a list of
; ifield objects with the values assigned.
-; ISA is an <isa> object or #f.
-; If VERIFY? is non-#f, perform various checks on the format
-; (ISA must be an <isa> 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
; 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
(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.
; 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 ()
(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.
;; 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)
(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))
)
;; Look up ifield X in the current architecture.
+;; Returns the <ifield> 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 <ifield> 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)))
)
(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)
*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 <operand> 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))
)
(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)
*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 <insn> 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))
)
(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)
*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 <macro-insn> 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))
)
(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)
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
(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"))))
; 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
; 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
(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))
; 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)
(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 " ("
; 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)
" } }")
)
\f
"/* " (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"
"-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)
"-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)
(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?
(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?
(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
" "
))
(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"
;; 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)
(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))
; The result is a <derived-ifield> 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))
; ??? 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 <derived-ifield>
operand-name
'derived-ifield ; (string-append "<derived-ifield> for " operand-name)
;; 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.
;; 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))
(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))
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))
; 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)
(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))
mode
base-ifield
(map (lambda (c)
- (/anyof-parse-choice context c))
+ (/anyof-parse-choice context c isa-name-list))
choices)))
(begin
(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)
(elm-get anyof-instance 'name)
)
-(define (/anyof-merge-syntax syntax value-names values)
- (let ((syntax-elements (syntax-break-out syntax)))
+; CONTAINER is the <anyof-operand> 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))
(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)
; Also (defined elsewhere): PCREL-ADDR ABS-ADDR.
(set! pc (make <pc>))
+ (obj-cons-attr! pc (all-isas-attr))
(current-op-add! pc)
*UNSPECIFIED*
; 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)
; ---------------------
; 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
)
;; Build an estate for use in generating C.
-;; EXTRA-VARS-ALIST is an association list of
-;; (symbol <mode>-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
<rtl-c-eval-state>
#: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))
)
)
; 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 <mode> object.
-; EXTRA-VARS-ALIST is an association list of extra
-; (symbol <mode>-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 <operand> -> <xoperand>, and
;; have <xoperand> 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 <mode> value)
+; elements to be used during value lookup.
; MODE is a <mode> 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 <c-expr> object.
; Same as rtl-c-parsed except return a <c-expr> object.
; MODE is a <mode> 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 <operand> -> <xoperand>, and
;; have <xoperand> 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 <mode> 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))
)
\f
; C++ versions of rtl-c routines.
; Build an estate for use in generating C++.
-; EXTRA-VARS-ALIST is an association list of (symbol <mode> 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 <mode> object.
-; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> 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 <operand> -> <xoperand>, and
;; have <xoperand> 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 <mode> 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))
)
\f
; Top level routines for getting/setting values.
(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))
(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
(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))
(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)
)
\f
;; The result is the rtl->c generator table.
;; 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.
(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"
(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)
(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
(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
(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)))
(display (rtx-dump expr))
(newline)
(display (spaces (* 4 depth)))
- (rtx-env-dump env)
+ (rtx-env-stack-dump env)
(force-output)
))
(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
;; - 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 <context> 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 <mode> 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))
)
\f
;; RTL expression traversal support.
; 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
;
; 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.
(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)
)
(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)
)
(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)
(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)
(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))
; 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?
(display "-expected: ")
(display expected)
(newline)
+ (display (spaces (* 4 (tstate-depth tstate))))
+ (display "-conditional: ")
+ (display (tstate-cond? tstate))
+ (newline)
(force-output)
))
(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)
; 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)
)
; 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 <context> object or #f if there is none.
(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)
)
(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)
; 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.
(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)
; Accessors.
(define-getters <eval-state> estate
- (context owner outer-expr expr-fn env depth modifiers)
+ (context owner outer-expr expr-fn isas env-stack depth modifiers)
)
(define-setters <eval-state> estate
- (env depth modifiers)
+ (isas env-stack depth modifiers)
)
; Build an estate for use in producing a value from rtl.
#: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.
(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)
)
(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)
)
(define (tstate->estate t)
(vmake <eval-state>
#:context (tstate-context t)
- #:env (tstate-env t))
+ #:env-stack (tstate-env-stack t))
)
; Issue an error given an estate.
(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?
; 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)
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))
)
(/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)
; (/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))
)
((LOCALS)
#f) ; leave arg untouched
- ((ENV)
+ ((ITERATION SYMBOLLIST ENVSTACK)
#f) ; leave arg untouched for now
((ATTRS)
(define (/rtx-trim-for-doc rtx)
(if (pair? rtx) ; ??? cheap rtx?
+
(let ((name (car rtx))
(options (cadr rtx))
(mode (caddr rtx))
(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)
; 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
'(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)
)
)
(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)
; ((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))))
(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)
)
(define (rtx-env-empty? env) (null? env))
-; Create an initial environment.
-; VAR-LIST is a list of (name <mode>-or-mode-name value) elements.
-
-(define (rtx-env-make var-list)
- ; Convert VAR-LIST to an associative list of <rtx-temp> objects.
- (map (lambda (var-spec)
- (cons (car var-spec)
- (make <rtx-temp>
- (car var-spec)
- (mode-maybe-lookup (cadr var-spec))
- (caddr var-spec))))
- var-list)
+;; Create an environment from VAR-ALIST,
+;; an alist of (name <mode>-or-mode-name value) elements,
+;; or, in the case of /rtx-closure-make, a list of (name . <rtx-temp>).
+
+(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 <rtx-temp> objects.
+ (map (lambda (var-spec)
+ (cons (car var-spec)
+ (make <rtx-temp>
+ (car var-spec)
+ (mode-maybe-lookup (cadr var-spec))
+ (caddr var-spec))))
+ var-alist))
)
; Create an initial environment with local variables.
(list 'INT (rtx-make-iteration-limit-var iter-var))))
)
+;; Convert an alist of (name <mode>-object-or-name value) to
+;; an environment.
+
+(define (rtx-var-alist-to-env var-alist) var-alist)
+
+;; Convert an alist of (name <mode>-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 <rtx-temp>-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.
(cons env env-stack)
)
-; Lookup variable NAME in environment ENV.
+; Lookup variable NAME in environment stack ENV-STACK.
; The result is the <rtx-temp> 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)))
(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))
(define (rtx-ifield-obj rtx)
(let ((ifield (rtx-arg1 rtx)))
(if (symbol? ifield)
- (current-ifield-lookup ifield)
+ (current-ifld-lookup ifield)
ifield))
)
(obj:name operand)))
)
-;; Given an operand rtx, construct the <operand> object.
+;; Given an operand rtx, return the <operand> 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)
(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)
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.
; 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
(cond ((number? index-arg)
(make <hw-index> '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 <hw-index> 'anonymous 'constant UINT
; 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
)
; 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
)
(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)
)
(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)
)
; 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?
)
(define-getters <sfrag> sfrag
- (users user-nums sfmt stmt-numbers semantics compiled-semantics
+ (users user-nums sfmt stmt-numbers semantics
parallel? header? trailer?)
)
(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 <sfrag>
(symbol-append (obj:name first-owner)
(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)
(+ 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 <sfrag>
(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?
'(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?
'(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?
; 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)))
"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)
(define (csem-outputs csem) (vector-ref csem 2))
(define (csem-attrs csem) (vector-ref csem 3))
\f
-; 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
;
; CONTEXT is a <context> object or #f if there is none.
; INSN is the <insn> 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
(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))
(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
(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."
; 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.
(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))
; Each element is (symbol <mode> "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.
(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))
"")
(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
; Generate C code for SEL.
(define (/gen-hw-selector sel)
- (rtl-c++ 'INT sel nil)
+ (rtl-c++ INT #f nil sel)
)
\f
; Instruction operand support code.
<pc> '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.
(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
(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
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)
))
; Do our own error checking.
- (assert (current-insn-lookup 'x-invalid))
+ (assert (current-insn-lookup 'x-invalid #f))
*UNSPECIFIED*
)
(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)
; 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.
cat <<EOF
{
"
- (rtl-c VOID insn-extract nil #:rtl-cover-fns? #t)
+ (rtl-c VOID #f nil insn-extract #:rtl-cover-fns? #t)
"}
EOF
cat <<EOF
{
"
- (rtl-c VOID insn-execute nil #:rtl-cover-fns? #t)
+ (rtl-c VOID #f nil insn-execute #:rtl-cover-fns? #t)
"}
EOF
(let ((decode-code (gen-decoder insn-list initial-bitnums
decode-bitsize
" " lsb0?
- (current-insn-lookup 'x-invalid)
+ (current-insn-lookup 'x-invalid #f)
#f)))
(string-write
(define (sim-test-analyze!)
(opcodes-analyze!)
(map (lambda
- (insn) (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn))))
+ (insn) (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn)
+ (obj-isa-list insn))))
(current-insn-list))
*UNSPECIFIED*
)
(expr (cadr getter)))
(gen-get-macro (gen-sym self)
(if (hw-scalar? self) "" "index")
- (rtl-c mode expr
+ (rtl-c mode
+ #f ;; h/w is not ISA-specific
(if (hw-scalar? self)
nil
(list (list (car args) 'UINT "index")))
+ expr
#:rtl-cover-fns? #t)))
(send self 'gen-sym-get-macro
(obj:name self) (obj:comment self)))))
""
"index")
"x"
- (rtl-c VOID ; not `mode', sets have mode VOID
- expr
+ (rtl-c VOID ;; not `mode', sets have mode VOID
+ #f ;; h/w is not ISA-specific
(if (hw-scalar? self)
(list (list (car args) (hw-mode self) "(x)"))
(list (list (car args) 'UINT "(index)")
(list (cadr args) (hw-mode self) "(x)")))
+ expr
#:rtl-cover-fns? #t #:macro? #t)))
(send self 'gen-sym-set-macro
(obj:name self) (obj:comment self)))))
; Generate C code for SEL.
(define (/gen-hw-selector sel)
- (rtl-c 'INT sel nil)
+ (rtl-c INT #f nil sel)
)
\f
; Instruction operand support code.
<pc> '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.
; 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))
)
; 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))
)
((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)))))
(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
; 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))
)
(set! /sim-insns-analyzed? #t)))
; Do our own error checking.
- (assert (current-insn-lookup 'x-invalid))
+ (assert (current-insn-lookup 'x-invalid #f))
*UNSPECIFIED*
)
; 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
((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)))
; 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)))
)
; 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)))
)
(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")
"")
(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)
OSDN Git Service
