2009-09-23 Doug Evans <dje@sebabeach.org>
+ * xc16x.cpu (h-cr): New hardware.
+ (muls): Comment out parts that won't compile, add fixme.
+ (mulu, divl, divlu, jmpabs, jmpa-, jmprel, jbc, jnbs, callr): Ditto.
+ (scxti, scxtmg, scxtm, bclear, bclr18, bset19, bitset, bmov): Ditto.
+ (bmovn, band, bor, bxor, bcmp, bfldl, bfldh): Ditto.
+
+ Rewrite rtl processing to require it to be "canonicalized" first,
+ and write a full canonicalizer / expression checker.
+ Remove all appearances of DFLT in canonical rtl.
+ * attr.scm (/attr-eval atval owner): Call rtx-canonicalize,
+ then rtx-simplify.
+ * iformat.scm (ifmt-analyze) Use canonical semantics.
+ * insn (<insn>): New member canonical-semantics.
+ * mach.scm (<arch>): New member multi-insns-instantiated?.
+ (/instantiate-multi-insns!): New function.
+ (/canonicalize-insns!): New function.
+ (arch-analyze-insns!): Canonicalize insn semantics before processing
+ them.
+ * mode.scm (/mode-set-word-params!): New function.
+ (mode-void?): New function.
+ (mode-compatible?): VOID is compatible with VOID.
+ (/mode-word-sizes-defined?): New global.
+ (mode-set-word-modes!): Use/set it.
+ (mode-ensure-word-sizes-defined): Update.
+ (mode-builtin!): New builtin "modes" SYM, INSN, MACH.
+ Redo WI/UWI/AI/IAI handling.
+ (op:new-mode): No longer accept DFLT.
+ (<derived-operand> constructor): Ensure all fields are initialized.
+ (<anyof-operand> constructor): Ditto.
+ (/derived-parse-ifield-assertion): Delete arg `args'.
+ All callers updated.
+ * rtl-c.scm (<rtl-c-eval-state>): New member `for-insn?'.
+ (rtl-c): Call rtx-canonicalize instead of rtx-compile.
+ (rtl-c-expr, rtl-c++): Ditto.
+ (/rtl-c-get): Use mode of operand, not containing expression.
+ (rtl-c-set-quiet, rtl-c-set-trace): Remove DFLT support.
+ (/rtx-use-sem-fn?): Don't check for (insn? owner), check
+ estate-for-insn? instead.
+ (s-unop): Use mode of expression, not first operand.
+ (s-binop, s-binop-with-bit, s-shop, s-cmpop): Ditto.
+ (s-sequence): Remove DFLT support.
+ (ifield): Use mode of expression, not UINT.
+ (pc): Comment out, unused.
+ (int-attr): New rtx kind.
+ (attr): Deprecate.
+ (set, set-quiet): Pass src to rtl-c-set-{trace,quiet} for expansion.
+ * rtl-traverse.scm (/rtx-canon-debug?): New global.
+ (/make-cstate): New function.
+ (/cstate-context, /cstate-outer-expr): New functions.
+ (/rtx-canon-error): New function.
+ (/rtx-lookup-hw, /rtx-pick-mode, /rtx-pick-mode3, /rtx-pick-op-mode,
+ /rtx-get-last-cond-case-rtx): New functions.
+ (/rtx-canon-*): New functions.
+ (/rtx-canner-table, /rtx-operand-canoners): New globals.
+ (/rtx-make-canon-table, /rtx-special-expr-canoners): New functions.
+ (/rtx-option, /rtx-option-list?): Rewrite.
+ (rtx-munge-mode&options): Replaces /rtx-munge-mode&options.
+ Rewritten, all callers updated.
+ (/rtx-canon-expr, /rtx-canon): New functions.
+ (rtx-canonicalize): Move here from rtl-xform.scm and rewrite.
+ (rtx-canonicalize-stmt): New function.
+ (tstate-make): Remove arg `set?'. All callers updated.
+ (tstate-new-set?): Delete.
+ (/rtx-traverse-options, /rtx-traverse-*mode): Delete,
+ moved to /rtx-canon-*.
+ (/rtx-traverse-normal-operand): New function.
+ (/rtx-traverse-rtx-list): Delete arg `mode', all callers updated.
+ (/rtx-traverse-rtx, /rtx-traverse-setrtx,, /rtx-traverse-testrtx,
+ /rtx-traverse-condrtx, /rtx-traverse-casertx, /rtx-traverse-locals,
+ /rtx-traverse-iteration, /rtx-traverse-env, /rtx-traverse-attrs):
+ Ditto.
+ (/rtx-traverse-symbol, /rtx-traverse-string, /rtx-traverse-number,
+ /rtx-traverse-symornum, /rtx-traverse-object): Delete.
+ (/rtx-make-traverser-table): Update.
+ (/rtx-traverse-operands): Remove mode processing, now done during
+ canonicalization.
+ (/rtx-traverse-expr): Delete arg `mode', all callers updated.
+ (/rtx-traverse): Ditto.
+ (rtx-init-traverser-tables!): New function.
+ * rtl-xform (/rtx-verify-no-dflt-modes-expr-fn): New function.
+ (rtx-verify-no-dflt-modes): New function.
+ (/rtx-simplify-expr-fn): Update, `arg' mode deleted.
+ (rtx-simplify-insn): Use insn-canonical-semantics.
+ (rtx-canonicalize): Moved to rtl-traverse.scm.
+ (/compile-expr-fn, rtx-compile): Delete.
+ (/rtx-trim-rtx-list): New function.
+ (/rtx-trim-for-doc): Handle set, if.
+ * rtl.scm (<rtx-func>): New members result-mode, matchexpr-index.
+ (/rtx-valid-mode-types): Update.
+ (/rtx-valid-matches): Update.
+ (/rtx-find-matchexpr-index): New function.
+ (rtx-lookup): Require rtx-kind to be the rtx name.
+ (def-rtx-node): New arg result-mode, all callers updated.
+ (def-rtx-syntax-node, def-rtx-operand-node): Ditto.
+ (rtx-lazy-sem-mode): Delete.
+ (/rtx-closure-make): New arg `mode', all callers updated.
+ (rtx-make-ifield, rtx-make-operand, rtx-make-local): Ditto.
+ (rtx-operand-obj): Rewrite.
+ (rtx-make-xop): New functions.
+ (/hw): Renamed from `hw', all callers updated.
+ Use the correct mode instead of DFLT for the index.
+ (rtl-builtin!): Call rtx-init-traversal-tables!.
+ (rtl-finish!): Update.
+ * rtx-funcs.scm (all rtx functions): New parameter: result-mode.
+ Update mode arg-type.
+ (pc): Comment out.
+ (int-attr): New rtx kind.
+ (attr): Deprecate.
+ * sem-frags.scm (/frag-hash-compute!): Update, mode arg deleted.
+ (/frag-cost-compute!): Ditto.
+ * semantics.scm (/build-operand!): Delete args op-name, op.
+ New arg op-expr. All callers updated.
+ (/build-mem-operand!): Remove DFLT support.
+ (semantic-compile): Update process-expr!, mode arg deleted.
+ * sid-cpu.scm (gen-semantic-code): Specify #:for-insn? in
+ rtl-c++ calls.
+ (/gen-sem-case, /gen-sfrag-code): Ditto.
+ * sid.scm (/op-gen-set-trace1): Renamed from /op-gen-set-trace.
+ (/op-gen-set-trace): New function. If not doing profiling,
+ call /op-gen-set-quiet.
+ * sim-cpu.scm (gen-semantic-code): Specify #:for-insn? in rtl-c calls.
+ * utils-gen.scm (/gen-ifld-extract-base): Update call to rtl-c.
+ (/gen-ifld-extract-beyond, gen-multi-ifld-extract): Ditto.
+ * utils.scm (find-first-index): New function.
+ * doc/rtl.texi: Delete docs for `attr'. Add `int-attr'.
+
* rtx-funcs.scm (eq,ne,lt,gt,le,ge,ltu,leu,gtu,geu): Change class
to COMPARE.
* sem-frags.scm (/frag-cost-compute!): Add COMPARE.
(define (/attr-eval atval owner)
(let* ((estate (estate-make-for-eval #f owner))
- (expr (rtx-compile #f (rtx-simplify #f owner atval nil) nil))
+ (expr (rtx-simplify #f owner (rtx-canonicalize #f 'DFLT atval nil) nil))
(value (rtx-eval-with-estate expr DFLT estate)))
(cond ((symbol? value) value)
((number? value) value)
; Infineon XC16X CPU description. -*- Scheme -*-
;
-; Copyright 2006, 2009 Free Software Foundation, Inc.
+; Copyright 2006, 2007, 2009 Free Software Foundation, Inc.
;
; Contributed by KPIT Cummins Infosystems Ltd.; developed under contract
; from Infineon Systems, GMBH , Germany.
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
-; the Free Software Foundation; either version 2 of the License, or
+; the Free Software Foundation; either version 3 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
(indices extern-keyword gr-names)
)
+;; HACK: Various semantics refer to h-cr.
+;; This is here to keep things working.
+(define-hardware
+ (name h-cr)
+ (comment "cr registers")
+ (attrs PROFILE CACHE-ADDR)
+ (type register HI (16))
+ (indices extern-keyword gr-names)
+)
+
(define-keyword
(name ext-names)
(enum-prefix H-EXT-)
((PIPE OS) (IDOC ALU))
"mul $src1,$src2"
(+ OP1_0 OP2_11 src1 src2)
- (reg SI h-md 0)
+ (nop) ;; FIXME: (reg SI h-md 0)
()
)
; MULU Rwn,Rwm
((PIPE OS) (IDOC ALU))
"mulu $src1,$src2"
(+ OP1_1 OP2_11 src1 src2)
- (reg SI h-md 0)
+ (nop) ;; FIXME: (reg SI h-md 0)
()
)
; DIV Rwn
"divl $srdiv"
(+ OP1_6 OP2_11 srdiv )
(sequence ()
- (set HI (reg HI h-cr 6) (div SI (reg SI h-md 0) srdiv))
- (set HI (reg HI h-cr 7) (mod SI (reg SI h-md 0) srdiv))
+ (set HI (reg HI h-cr 6) 0) ;; FIXME: (div SI (reg SI h-md 0) srdiv))
+ (set HI (reg HI h-cr 7) 0) ;; FIXME: (mod SI (reg SI h-md 0) srdiv))
)
()
)
"divlu $srdiv"
(+ OP1_7 OP2_11 srdiv )
(sequence ()
- (set HI (reg HI h-cr 6) (udiv SI (reg SI h-md 0) srdiv))
- (set HI (reg HI h-cr 7) (umod SI (reg SI h-md 0) srdiv))
+ (set HI (reg HI h-cr 6) 0) ;; FIXME: (udiv SI (reg SI h-md 0) srdiv))
+ (set HI (reg HI h-cr 7) 0) ;; FIXME: (umod SI (reg SI h-md 0) srdiv))
)
()
)
(sequence ((HI tmp1) (HI tmp2))
(set tmp1 (mem HI caddr))
(set tmp2 (sub HI pc (mem HI caddr)))
- (if (gt tmp2 (const 0)) (lt tmp2 (const 32)) (eq tmp2 (const 32))
+ (if (gt tmp2 (const 0)) ;; FIXME: (lt tmp2 (const 32)) (eq tmp2 (const 32))
(set bitone (const 1)))
- (if (lt tmp2 (const 0)) (eq tmp2 (const 0)) (gt tmp2 (const 32))
+ (if (lt tmp2 (const 0)) ;; FIXME: (eq tmp2 (const 0)) (gt tmp2 (const 32))
(set bitone (const 0)))
- (if (eq extcond (const 1) (ne extcond cc_Z))
+ (if (eq extcond (const 1)) ;; FIXME: (ne extcond cc_Z))
(set bit01 (const 0))
(set HI pc (mem HI caddr)))
- (if (ne extcond (const 1) (eq extcond cc_Z))
+ (if (ne extcond (const 1)) ;; FIXME: (eq extcond cc_Z))
(set bit01 (const 1))
(set HI pc (add HI pc (const 2))))
)
(sequence ((HI tmp1) (HI tmp2))
(set tmp1 (mem HI caddr))
(set tmp2 (sub HI pc (mem HI caddr)))
- (if (gt tmp2 (const 0)) (lt tmp2 (const 32)) (eq tmp2 (const 32))
+ (if (gt tmp2 (const 0)) ;; FIXME: (lt tmp2 (const 32)) (eq tmp2 (const 32))
(set bitone (const 1)))
- (if (lt tmp2 (const 0)) (eq tmp2 (const 0)) (gt tmp2 (const 32))
+ (if (lt tmp2 (const 0)) ;; FIXME: (eq tmp2 (const 0)) (gt tmp2 (const 32))
(set bitone (const 0)))
(set HI pc (add HI pc (const 2)))
)
(sequence ()
(if QI (lt QI rel (const 0))
(sequence ()
- (neg QI rel)
- (add QI rel (const 1))
- (mul QI rel (const 2))
+ ;; FIXME: (neg QI rel)
+ ;; FIXME: (add QI rel (const 1))
+ ;; FIXME: (mul QI rel (const 2))
(set HI pc (sub HI pc rel))
))
(set HI pc (add HI pc (mul QI rel (const 2))))
(if QI (lt QI relhi (const 0))
(set tmp2 (const 1))
(set tmp1 genreg)
- (sll tmp2 qlobit)
- (inv tmp2)
+ ;; FIXME: (sll tmp2 qlobit)
+ ;; FIXME: (inv tmp2)
(set HI tmp1(and tmp1 tmp2))
(set HI genreg tmp1)
(set HI pc (add HI pc (mul QI relhi (const 2)))))
(if QI (lt QI relhi (const 0))
(set tmp2 (const 1))
(set tmp1 reg8)
- (sll tmp2 qbit)
+ ;; FIXME: (sll tmp2 qbit)
(set BI tmp1(or tmp1 tmp2))
(set HI reg8 tmp1)
(set HI pc (add HI pc (mul QI relhi (const 2)))))
(sequence ()
(if QI (lt QI rel (const 0))
(sequence ()
- (neg QI rel)
- (add QI rel (const 1))
- (mul QI rel (const 2))
+ ;; FIXME: (neg QI rel)
+ ;; FIXME: (add QI rel (const 1))
+ ;; FIXME: (mul QI rel (const 2))
(set HI pc (sub HI pc rel))
))
(set HI pc (add HI pc (mul QI rel (const 2))))
(sequence ((HI tmp1) (HI tmp2))
(set HI tmp1 reg8)
(set HI tmp2 uimm16)
- (sub HI (reg HI h-cr 9) (const 2))
+ ;; FIXME: (sub HI (reg HI h-cr 9) (const 2))
(set HI (reg HI h-cr 9) tmp1)
(set HI reg8 tmp2)
)
(sequence ((HI tmp1) (HI tmp2))
(set HI tmp1 regmem8)
(set HI tmp2 memgr8)
- (sub HI (reg HI h-cr 9) (const 2))
+ ;; FIXME: (sub HI (reg HI h-cr 9) (const 2))
(set HI (reg HI h-cr 9) tmp1)
(set HI regmem8 tmp2)
)
(sequence ((HI tmp1) (HI tmp2))
(set HI tmp1 reg8)
(set HI tmp2 memory)
- (sub HI (reg HI h-cr 9) (const 2))
+ ;; FIXME: (sub HI (reg HI h-cr 9) (const 2))
(set HI (reg HI h-cr 9) tmp1)
(set HI reg8 tmp2)
)
(sequence ((HI tmp1) (HI tmp2))
(set tmp2 (const 1))
(set tmp1 reg8)
- (sll tmp2 qbit)
- (inv tmp2)
+ ;; FIXME: (sll tmp2 qbit)
+ ;; FIXME: (inv tmp2)
(set BI tmp1(and tmp1 tmp2))
(set HI reg8 tmp1))
()
(sequence ((HI tmp1) (HI tmp2))
(set tmp2 (const 1))
(set tmp1 reg8)
- (sll tmp2 qbit)
- (inv tmp2)
+ ;; FIXME: (sll tmp2 qbit)
+ ;; FIXME: (inv tmp2)
(set BI tmp1(and tmp1 tmp2))
(set HI reg8 tmp1))
()
(sequence ((HI tmp1) (HI tmp2))
(set tmp2 (const 1))
(set tmp1 reg8)
- (sll tmp2 qbit)
+ ;; FIXME: (sll tmp2 qbit)
(set BI tmp1(or tmp1 tmp2))
(set HI reg8 tmp1))
()
(sequence ((HI tmp1) (HI tmp2))
(set tmp2 (const 1))
(set tmp1 reg8)
- (sll tmp2 qbit)
+ ;; FIXME: (sll tmp2 qbit)
(set BI tmp1(or tmp1 tmp2))
(set HI reg8 tmp1))
()
(set HI tmp2 reg8)
(set tmp3 (const 1))
(set tmp4 (const 1))
- (sll tmp3 qlobit)
- (sll tmp4 qhibit)
- (and tmp1 tmp3)
- (and tmp2 tmp4)
+ ;; FIXME: (sll tmp3 qlobit)
+ ;; FIXME: (sll tmp4 qhibit)
+ ;; FIXME: (and tmp1 tmp3)
+ ;; FIXME: (and tmp2 tmp4)
(set BI tmp1 tmp2)
(set HI reghi8 tmp1)
(set HI reg8 tmp2))
(set HI tmp2 reg8)
(set tmp3 (const 1))
(set tmp4 (const 1))
- (sll tmp3 qlobit)
- (sll tmp4 qhibit)
- (and tmp1 tmp3)
- (and tmp2 tmp4)
- (inv HI tmp2)
+ ;; FIXME: (sll tmp3 qlobit)
+ ;; FIXME: (sll tmp4 qhibit)
+ ;; FIXME: (and tmp1 tmp3)
+ ;; FIXME: (and tmp2 tmp4)
+ ;; FIXME: (inv HI tmp2)
(set BI tmp1 tmp2)
(set HI reghi8 tmp1)
(set HI reg8 tmp2))
(set HI tmp2 reg8)
(set tmp3 (const 1))
(set tmp4 (const 1))
- (sll tmp3 qlobit)
- (sll tmp4 qhibit)
- (and tmp1 tmp3)
- (and tmp2 tmp4)
+ ;; FIXME: (sll tmp3 qlobit)
+ ;; FIXME: (sll tmp4 qhibit)
+ ;; FIXME: (and tmp1 tmp3)
+ ;; FIXME: (and tmp2 tmp4)
(set BI tmp1(and tmp1 tmp2))
(set HI reghi8 tmp1)
(set HI reg8 tmp2))
(set HI tmp2 reg8)
(set tmp3 (const 1))
(set tmp4 (const 1))
- (sll tmp3 qlobit)
- (sll tmp4 qhibit)
- (and tmp1 tmp3)
- (and tmp2 tmp4)
+ ;; FIXME: (sll tmp3 qlobit)
+ ;; FIXME: (sll tmp4 qhibit)
+ ;; FIXME: (and tmp1 tmp3)
+ ;; FIXME: (and tmp2 tmp4)
(set BI tmp1(or tmp1 tmp2))
(set HI reghi8 tmp1)
(set HI reg8 tmp2))
(set HI tmp2 reg8)
(set tmp3 (const 1))
(set tmp4 (const 1))
- (sll tmp3 qlobit)
- (sll tmp4 qhibit)
- (and tmp1 tmp3)
- (and tmp2 tmp4)
+ ;; FIXME: (sll tmp3 qlobit)
+ ;; FIXME: (sll tmp4 qhibit)
+ ;; FIXME: (and tmp1 tmp3)
+ ;; FIXME: (and tmp2 tmp4)
(set BI tmp1(xor tmp1 tmp2))
(set HI reghi8 tmp1)
(set HI reg8 tmp2))
(set HI tmp2 reg8)
(set tmp3 (const 1))
(set tmp4 (const 1))
- (sll tmp3 qlobit)
- (sll tmp4 qhibit)
- (and tmp1 tmp3)
- (and tmp2 tmp4)
+ ;; FIXME: (sll tmp3 qlobit)
+ ;; FIXME: (sll tmp4 qhibit)
+ ;; FIXME: (and tmp1 tmp3)
+ ;; FIXME: (and tmp2 tmp4)
(set BI tmp1(xor tmp1 tmp2))
(set HI reghi8 tmp1)
(set HI reg8 tmp2))
(set HI tmp1 reg8)
(set QI tmp2 mask8)
(set QI tmp3 datahi8)
- (inv QI tmp2)
+ ;; FIXME: (inv QI tmp2)
(set HI tmp1 (and tmp1 tmp2))
(set HI tmp1 (or tmp1 tmp3))
(set HI reg8 tmp1)
(set HI tmp1 reg8)
(set QI tmp2 masklo8)
(set HI tmp3 data8)
- (sll tmp2 (const 8))
- (inv HI tmp2)
- (sll tmp3 (const 8))
+ ;; FIXME: (sll tmp2 (const 8))
+ ;; FIXME: (inv HI tmp2)
+ ;; FIXME: (sll tmp3 (const 8))
(set HI tmp1 (and tmp1 tmp2))
(set HI tmp1 (or tmp1 tmp3))
(set HI reg8 tmp1)
Skip the next instruction if @samp{yes?} is non-zero. This rtx is
an experiment and will probably change.
-@item (attr mode kind attr-name)
-Return the value of attribute @samp{attr-name} in mode
-@samp{mode}. @samp{kind} must currently be @samp{insn}: the current
-instruction.
-
@item (symbol name)
Return a symbol with value @samp{name}, for use in attribute
processing. This is equivalent to @samp{quote} in Scheme but
@samp{quote} sounds too jargonish.
-@item (eq-attr mode attr-name value)
-Return non-zero if the value of attribute @samp{attr-name} is
-@samp{value}. If @samp{value} is a list return ``true'' if
-@samp{attr-name} is any of the listed values.
+@item (int-attr mode object attr-name)
+Return the value of attribute @samp{attr-name} in mode @samp{mode}.
+@samp{object} must currently be @samp{(current-insn)}, the current instruction,
+or @samp{(current-mach)}, the current machine.
+The attribute's value must be representable as an integer.
+
+@item (eq-attr mode object attr-name value)
+Return non-zero if the value of attribute @samp{attr-name} of
+object @samp{object} is @samp{value}.
+
+@emph{NOTE:} List values of @samp{value} may be changed to allow use the
+@samp{number-list} rtx function.
+If @samp{value} is a list return ``true'' if the attribute is any of
+the listed values. But this is not implemented yet.
@item (index-of operand)
Return the index of @samp{operand}. For registers this is the register number.
; The possibilities are: MEM, FPU.
(define (get-insn-properties insn)
+ (logit 2 "Collecting properties of insn " (obj:name insn) " ...\n")
+
(let*
((context #f) ; ??? do we need a better context?
(sem-attrs (list #f))
; Called for expressions encountered in SEM-CODE-LIST.
- ; MODE is the name of the mode.
(process-expr!
- (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (lambda (rtx-obj expr parent-expr op-pos tstate appstuff)
(case (car expr)
- ((operand) (if (memory? (op:type (rtx-operand-obj expr)))
+ ((operand) (if (memory? (op:type (current-op-lookup (rtx-arg1 expr))))
; Don't change to '(MEM), since we use append!.
(append! sem-attrs (list 'MEM)))
- (if (mode-float? (op:mode (rtx-operand-obj expr)))
+ (if (mode-float? (mode:lookup (rtx-mode expr)))
; Don't change to '(FPU), since we use append!.
(append! sem-attrs (list 'FPU)))
)
; Compute an iformat descriptor used to build an <iformat> object for INSN.
;
-; If COMPUTE-SFORMAT? is #t compile the semantics and compute the semantic
-; format (same as instruction format except that operands are used to
+; If COMPUTE-SFORMAT? is #t compute the semantic format
+; (same as instruction format except that operands are used to
; distinguish insns).
; Attributes derivable from the semantics are also computed.
; This is all done at the same time to minimize the number of times the
; semantic code is traversed.
+; The semantics of INSN must already be compiled and stored in
+; compiled-semantics.
;
-; The result is (descriptor compiled-semantics attrs).
+; The result is (descriptor attrs).
; `descriptor' is #f for insns with an empty field list
; (this happens for virtual insns).
-; `compiled-semantics' is #f if COMPUTE-SFORMAT? is #f.
; `attrs' is an <attr-list> object of attributes derived from the semantics.
;
; ??? We never traverse the semantics of virtual insns.
; Field list is unspecified.
(list #f #f atlist-empty)
- ; FIXME: error checking (e.g. missing or overlapping bits)
- (let* ((sem (insn-semantics insn))
+ (let* ((sem (insn-canonical-semantics insn))
; Compute list of input and output operands if asked for.
(sem-ops (if compute-sformat?
(semantic-compile #f ; FIXME: context
(if sem
(semantic-attrs #f ; FIXME: context
insn sem)
- atlist-empty))))
- )
+ atlist-empty)))))
+
(let ((compiled-sem (csem-code sem-ops))
(in-ops (csem-inputs sem-ops))
(out-ops (csem-outputs sem-ops))
(attrs (csem-attrs sem-ops))
(cti? (or (atlist-cti? (csem-attrs sem-ops))
(insn-cti? insn))))
+
(list (make <fmt-desc>
cti? sorted-ifields in-ops out-ops
(if (and in-ops out-ops)
tmp
; Instruction semantics.
- ; This is the rtl in source form or #f if there is none.
+ ; This is the rtl in source form, as provided in the
+ ; description file, or #f if there is none.
;
; There are a few issues (ick, I hate that word) to consider
; here:
; separate class.
; ??? Contents of trap expressions is wip. It will probably
; be a sequence with an #:errchk modifier or some such.
- (semantics . #f)
+ semantics
+
+ ; The processed form of the semantics.
+ ; This remains #f for virtual insns (FIXME: keep?).
+ (canonical-semantics . #f)
- ; The processed form of the above.
+ ; The processed form of the semantics.
; This remains #f for virtual insns (FIXME: keep?).
(compiled-semantics . #f)
; Another thing that will be needed is [in some cases] a more
; simplified version of the RTL for use by apps like compilers.
; Perhaps that's what this will become.
- host-semantics
+ ;host-semantics
; The function unit usage of the instruction.
timing
(define-getters <insn> insn
(syntax iflds ifield-assertion fmt-desc ifmt sfmt tmp
- semantics compiled-semantics host-semantics timing)
+ semantics canonical-semantics compiled-semantics timing)
)
(define-setters <insn> insn
- (fmt-desc ifmt sfmt tmp ifield-assertion compiled-semantics)
+ (fmt-desc ifmt sfmt tmp ifield-assertion
+ canonical-semantics compiled-semantics)
)
; Return a boolean indicating if X is an <insn>.
(let ((ifield-assertion (if (and ifield-assertion
(not (null? ifield-assertion)))
- (rtx-canonicalize context ifield-assertion)
+ (rtx-canonicalize context 'DFLT ;; BI?
+ ifield-assertion nil)
#f))
(semantics (if (not (null? semantics))
semantics
;; With derived ifields this is really hard, so only do the base insn
;; for now. Do the simple test for now, it doesn't catch everything,
;; but it should catch a lot.
+ ;; ??? One thing we don't catch yet is overlapping bits.
(let* ((base-iflds (find (lambda (f)
(not (ifld-beyond-base? f)))
; standard values derived from the input data
derived
+ ; #t if multi-insns have been instantiated
+ (multi-insns-instantiated? . #f)
; #t if instructions have been analyzed
(insns-analyzed? . #f)
; #t if semantics were included in the analysis
ifld-table hw-list op-table ifmt-list sfmt-list
insn-table minsn-table subr-list
derived
+ multi-insns-instantiated?
insns-analyzed? semantics-analyzed? aliases-analyzed?
next-ordinal
)
ifld-table hw-list op-table ifmt-list sfmt-list
insn-table minsn-table subr-list
derived
+ multi-insns-instantiated?
insns-analyzed? semantics-analyzed? aliases-analyzed?
next-ordinal
)
*UNSPECIFIED*
)
+;; Instantiate the multi-insns of ARCH (if there are any).
+
+(define (/instantiate-multi-insns! arch)
+ ;; Skip if already done, we don't want to create duplicates.
+
+ (if (not (arch-multi-insns-instantiated? arch))
+ (begin
+
+ (if (any-true? (map multi-insn? (arch-insn-list arch)))
+
+ (begin
+ ; Instantiate sub-insns of all multi-insns.
+ (logit 1 "Instantiating multi-insns ...\n")
+
+ ;; FIXME: Hack to remove differences in generated code when we
+ ;; switched to recording insns in hash tables.
+ ;; Multi-insn got instantiated after the list of insns had been
+ ;; reversed and they got added to the front of the list, in
+ ;; reverse order. Blech!
+ ;; Eventually remove this, have a flag day, and check in the
+ ;; updated files.
+ ;; NOTE: This causes major diffs to opcodes/m32c-*.[ch].
+ (let ((orig-ord (arch-next-ordinal arch)))
+ (arch-set-next-ordinal! arch (- MAX-VIRTUAL-INSNS))
+ (for-each (lambda (insn)
+ (multi-insn-instantiate! insn))
+ (multi-insns (arch-insn-list arch)))
+ (arch-set-next-ordinal! arch orig-ord))
+
+ (logit 1 "Done instantiating multi-insns.\n")
+ ))
+
+ (arch-set-multi-insns-instantiated?! arch #t)
+ ))
+)
+
+;; Subroutine of arch-analyze-insns! to simplify it.
+;; Canonicalize INSNS of ARCH.
+
+(define (/canonicalize-insns! arch insn-list)
+ (logit 1 "Canonicalizing instruction semantics ...\n")
+
+ (for-each (lambda (insn)
+ (cond ((insn-canonical-semantics insn)
+ #t) ;; already done
+ ((insn-semantics insn)
+ (logit 2 "Canonicalizing semantics for " (obj:name insn) " ...\n")
+ (let ((canon-sem
+ (rtx-canonicalize
+ (make-obj-context insn
+ (string-append "canonicalizing semantics of "
+ (obj:str-name insn)))
+ 'VOID (insn-semantics insn) nil)))
+ (insn-set-canonical-semantics! insn canon-sem)))
+ (else
+ (logit 2 "Skipping instruction " (obj:name insn) ", no semantics ...\n"))))
+ insn-list)
+
+ (logit 1 "Done canonicalization.\n")
+)
+
; Analyze the instruction set.
; The name is explicitly vague because it's intended that all insn analysis
; would be controlled here.
(begin
- ;; FIXME: This shouldn't be calling current-insn-list,
- ;; it should use (arch-insn-list arch).
- ;; Then again various subroutines assume arch == CURRENT-ARCH.
- ;; Still, something needs to be cleaned up.
- (if (any-true? (map multi-insn? (current-insn-list)))
- (begin
- ; Instantiate sub-insns of all multi-insns.
- (logit 1 "Instantiating multi-insns ...\n")
+ (/instantiate-multi-insns! arch)
- ;; FIXME: Hack to remove differences in generated code when we
- ;; switched to recording insns in hash tables.
- ;; Multi-insn got instantiated after the list of insns had been
- ;; reversed and they got added to the front of the list, in
- ;; reverse order. Blech!
- ;; Eventually remove this, have a flag day, and check in the
- ;; updated files.
- ;; NOTE: This causes major diffs to opcodes/m32c-*.[ch].
- (let ((orig-ord (arch-next-ordinal arch)))
- (arch-set-next-ordinal! arch (- MAX-VIRTUAL-INSNS))
- (for-each (lambda (insn)
- (multi-insn-instantiate! insn))
- (multi-insns (current-insn-list)))
- (arch-set-next-ordinal! arch orig-ord))
- ))
+ (let ((insn-list (non-multi-insns
+ (if include-aliases?
+ (arch-insn-list arch)
+ (non-alias-insns (arch-insn-list arch))))))
- ; This is expensive so indicate start/finish.
- (logit 1 "Analyzing instruction set ...\n")
-
- (let ((fmt-lists
- (ifmt-compute! (non-multi-insns
- (if include-aliases?
- (arch-insn-list arch)
- (non-alias-insns (arch-insn-list arch))))
- analyze-semantics?)))
-
- (arch-set-ifmt-list! arch (car fmt-lists))
- (arch-set-sfmt-list! arch (cadr fmt-lists))
- (arch-set-insns-analyzed?! arch #t)
- (arch-set-semantics-analyzed?! arch analyze-semantics?)
- (arch-set-aliases-analyzed?! arch include-aliases?)
-
- ;; Now that the instruction formats are computed,
- ;; do some sanity checks.
- (logit 1 "Performing sanity checks ...\n")
- (/sanity-check-insns arch)
-
- (logit 1 "Done analysis.\n")
- ))
- )
+ ;; Compile each insns semantics, traversers/evaluators require it.
+ (/canonicalize-insns! arch insn-list)
+
+ ;; This is expensive so indicate start/finish.
+ (logit 1 "Analyzing instruction set ...\n")
+
+ (let ((fmt-lists
+ (ifmt-compute! insn-list
+ analyze-semantics?)))
+
+ (arch-set-ifmt-list! arch (car fmt-lists))
+ (arch-set-sfmt-list! arch (cadr fmt-lists))
+ (arch-set-insns-analyzed?! arch #t)
+ (arch-set-semantics-analyzed?! arch analyze-semantics?)
+ (arch-set-aliases-analyzed?! arch include-aliases?)
+
+ ;; Now that the instruction formats are computed,
+ ;; do some sanity checks.
+ (logit 1 "Performing sanity checks ...\n")
+ (/sanity-check-insns arch)
+
+ (logit 1 "Done analysis.\n")
+ ))
+ ))
*UNSPECIFIED*
)
; ptr-to is currently private so there is no accessor.
(define mode:host? (elm-make-getter <mode> 'host?))
+;; Utility to set the parameters of WI/UWI/AI/IAI modes.
+
+(define (/mode-set-word-params! dst src)
+ (assert (mode? dst))
+ (assert (mode? src))
+ (elm-xset! dst 'bits (elm-xget src 'bits))
+ (elm-xset! dst 'bytes (elm-xget src 'bytes))
+ (elm-xset! dst 'non-mode-c-type (elm-xget src 'non-mode-c-type))
+ (elm-xset! dst 'printf-type (elm-xget src 'printf-type))
+ (elm-xset! dst 'sem-mode (elm-xget src 'sem-mode))
+ *UNSPECIFIED*
+)
+
; Return string C type to use for values of mode M.
(define (mode:c-type m)
(define (mode-class-numeric? class) (memq class '(INT UINT FLOAT)))
-; Return a boolean indicating if MODE has an integral mode class.
+; Return a boolean indicating if <mode> MODE has an integral mode class.
; Similarily for signed/unsigned.
(define (mode-integral? mode) (mode-class-integral? (mode:class mode)))
(define (mode-signed? mode) (mode-class-signed? (mode:class mode)))
(define (mode-unsigned? mode) (mode-class-unsigned? (mode:class mode)))
-; Return a boolean indicating if MODE has a floating point mode class.
+; Return a boolean indicating if <mode> MODE has a floating point mode class.
(define (mode-float? mode) (mode-class-float? (mode:class mode)))
-; Return a boolean indicating if MODE has a numeric mode class.
+; Return a boolean indicating if <mode> MODE has a numeric mode class.
(define (mode-numeric? mode) (mode-class-numeric? (mode:class mode)))
+;; Return a boolean indicating if <mode> MODE is VOID.
+
+(define (mode-void? mode)
+ (eq? mode VOID)
+)
+
; Return a boolean indicating if MODE1 is compatible with MODE2.
; MODE[12] are either names or <mode> objects.
; HOW is a symbol indicating how the test is performed:
; strict: modes must have same name
-; samesize: modes must be both float or both integer (int or uint) and have
-; same size
-; sameclass: modes must be both float or both integer (int or uint)
+; samesize: modes must be both float, or both integer (int or uint),
+; or both VOID and have same size
+; sameclass: modes must be both float, or both integer (int or uint),
+; or both VOID
; numeric: modes must be both numeric
(define (mode-compatible? how mode1 mode2)
((mode-float? m1)
(and (mode-float? m2)
(= (mode:bits m1) (mode:bits m2))))
+ ((mode-void? m1)
+ (mode-void? m2))
(else #f)))
((sameclass)
(cond ((mode-integral? m1) (mode-integral? m2))
((mode-float? m1) (mode-float? m2))
+ ((mode-void? m1) (mode-void? m2))
(else #f)))
((numeric)
(and (mode-numeric? m1) (mode-numeric? m2)))
; IDENTICAL: all word sizes must be identical
(define /mode-word-sizes-kind #f)
+;; Set to true if mode-set-word-modes! has been called.
+(define /mode-word-sizes-defined? #f)
+
; Called when a cpu-family is read in to set the word sizes.
(define (mode-set-word-modes! bitsize)
(error "unable to find precise mode to match cpu word-bitsize" bitsize))
; Enforce word size kind.
- (if (!= current-word-bitsize 0)
- ; word size already set
+ (if /mode-word-sizes-defined?
(case /mode-word-sizes-kind
((IDENTICAL)
(if (!= current-word-bitsize (mode:bits word-mode))
(if (not ignore?)
(begin
- (set! WI word-mode)
- (set! UWI uword-mode)
- (set! AI uword-mode)
- (set! IAI uword-mode)
- (hashq-set! /mode-table 'WI word-mode)
- (hashq-set! /mode-table 'UWI uword-mode)
- (hashq-set! /mode-table 'AI uword-mode)
- (hashq-set! /mode-table 'IAI uword-mode)
+ (/mode-set-word-params! WI word-mode)
+ (/mode-set-word-params! UWI uword-mode)
+ (/mode-set-word-params! AI uword-mode)
+ (/mode-set-word-params! IAI uword-mode)
))
)
+
+ (set! /mode-word-sizes-defined? #t)
)
; Called by apps to indicate cpu:word-bitsize always has one value.
; Ensure word sizes have been defined.
; This must be called after all cpu families have been defined
; and before any ifields, hardware, operand or insns have been read.
+; FIXME: sparc.cpu breaks this
(define (mode-ensure-word-sizes-defined)
- (if (eq? (obj:name WI) 'VOID)
+ (if (not /mode-word-sizes-defined?)
(error "word sizes must be defined"))
)
\f
(define (mode-init!)
(set! /mode-word-sizes-kind 'IDENTICAL)
+ (set! /mode-word-sizes-defined? #f)
(reader-add-command! 'define-full-mode
"\
(let ((dfm define-full-mode))
; This list must be defined in order of increasing size among each type.
+ ; FIXME: still true?
(dfm 'VOID "void" '() 'RANDOM 0 0 "void" "" #f #f #f) ; VOIDmode
; Special marker to indicate "use the default mode".
- ; ??? Not yet used everywhere it should be.
(dfm 'DFLT "default mode" '() 'RANDOM 0 0 "" "" #f #f #f)
+ ; Mode used in `symbol' rtxs.
+ (dfm 'SYM "symbol" '() 'RANDOM 0 0 "" "" #f #f #f)
+
+ ; Mode used in `current-insn' rtxs.
+ (dfm 'INSN "insn" '() 'RANDOM 0 0 "" "" #f #f #f)
+
+ ; Mode used in `current-mach' rtxs.
+ (dfm 'MACH "mach" '() 'RANDOM 0 0 "" "" #f #f #f)
+
; Not UINT on purpose.
(dfm 'BI "one bit (0,1 not 0,-1)" '() 'INT 1 1 "int" "'x'" #f #f #f)
(set! INT (mode:lookup 'INT))
(set! UINT (mode:lookup 'UINT))
- ; While setting the real values of WI/UWI/AI/IAI is defered to
- ; mode-set-word-modes!, create entries in the table.
- (set! WI VOID)
- (set! UWI VOID)
- (set! AI VOID)
- (set! IAI VOID)
- (mode:add! 'WI VOID)
- (mode:add! 'UWI VOID)
- (mode:add! 'AI VOID)
- (mode:add! 'IAI VOID)
+ ;; While setting the real values of WI/UWI/AI/IAI is defered to
+ ;; mode-set-word-modes!, create usable entries in the table.
+ ;; The entries must be usable as h/w elements may be defined that use them.
+ (set! WI (object-copy-top (mode:lookup 'SI)))
+ (set! UWI (object-copy-top (mode:lookup 'USI)))
+ (set! AI (object-copy-top (mode:lookup 'USI)))
+ (set! IAI (object-copy-top (mode:lookup 'USI)))
+ (mode:add! 'WI WI)
+ (mode:add! 'UWI UWI)
+ (mode:add! 'AI AI)
+ (mode:add! 'IAI IAI)
;; Need to have usable mode classes at this point as define-cpu
;; calls mode-set-word-modes!.
; that require a unique hardware element to be refered to are
; required to ensure duplicates are discarded (usually done
; by keeping the appropriate machs).
+ ; All h/w elements with the same semantic name are required
+ ; to be the same kind (register, immediate, etc.).
; FIXME: Rename to hw.
(type . #f)
; NOTE: Even if the mode isn't changing this creates a copy.
; If OP has been subclassed the result must contain the complete class
; (e.g. the behaviour of `object-copy-top').
+; NEW-MODE-NAME must be a valid numeric mode.
(define (op:new-mode op new-mode-name)
(let ((result (object-copy-top op)))
; " hw-name=" (op:hw-name op)
; " mode=" (op:mode op)
; " newmode=" new-mode-name)
- (if (or (eq? new-mode-name 'DFLT)
- (eq? new-mode-name 'VOID) ; temporary: for upward compatibility
- (mode:eq? new-mode-name (op:mode op)))
- ; Mode isn't changing.
- result
+; (if (or (eq? new-mode-name 'DFLT)
+; (eq? new-mode-name 'VOID) ; temporary: for upward compatibility
+; (mode:eq? new-mode-name (op:mode op)))
+; ; Mode isn't changing.
+; result
+ (if #t ;; FIXME
; See if new mode is supported by the hardware.
(if (hw-mode-ok? (op:type op) new-mode-name (op:index op))
(let ((new-mode (mode:lookup new-mode-name)))
'())
)
-(method-make-make! <derived-operand>
- '(name comment attrs mode
- args syntax base-ifield encoding ifield-assertion
- getter setter)
+;; <derived-operand> constructor.
+;; MODE is a <mode> object.
+
+(method-make!
+ <derived-operand> 'make!
+ (lambda (self name comment attrs mode
+ args syntax base-ifield encoding ifield-assertion
+ getter setter)
+ (elm-set! self 'name name)
+ (elm-set! self 'comment comment)
+ (elm-set! self 'attrs attrs)
+ (elm-set! self 'sem-name name)
+ (elm-set! self 'pretty-sem-name #f) ;; FIXME
+ (elm-set! self 'hw-name #f) ;; FIXME
+ (elm-set! self 'mode mode)
+ (elm-set! self 'mode-name (obj:name mode))
+ (elm-set! self 'getter getter)
+ (elm-set! self 'setter setter)
+ ;; These are the additional fields in <derived-operand>.
+ (elm-set! self 'args args)
+ (elm-set! self 'syntax syntax)
+ (elm-set! self 'base-ifield base-ifield)
+ (elm-set! self 'encoding encoding)
+ (elm-set! self 'ifield-assertion ifield-assertion)
+ self)
)
(define (derived-operand? x) (class-instance? <derived-operand> x))
(method-make!
<anyof-operand> 'make!
- (lambda (self name comment attrs mode base-ifield choices)
+ (lambda (self name comment attrs mode-name base-ifield choices)
(elm-set! self 'name name)
(elm-set! self 'comment comment)
(elm-set! self 'attrs attrs)
- (elm-set! self 'mode-name mode)
+ (elm-set! self 'sem-name name)
+ (elm-set! self 'pretty-sem-name #f) ;; FIXME
+ (elm-set! self 'hw-name #f) ;; FIXME
+ (elm-set! self 'mode-name mode-name)
(elm-set! self 'base-ifield base-ifield)
(elm-set! self 'choices choices)
; Set index to a special marker value.
))
)
-; Subroutine of /derived-operand-parse to parse the ifield assertion.
-; The ifield assertion is either () or an RTL expression asserting something
-; about the ifield values of the containing insn.
-; Operands are specified by name, but what is used is their indices (there's
-; an implicit `index-of' going on).
+;; Subroutine of /derived-operand-parse to parse the ifield assertion.
+;; The ifield assertion is either () or a (restricted) RTL expression
+;; 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 args ifield-assertion)
- ; FIXME: for now
+(define (/derived-parse-ifield-assertion context ifield-assertion)
(if (null? ifield-assertion)
#f
- ifield-assertion)
+ (rtx-canonicalize context 'INT ifield-assertion nil))
)
; Parse a derived operand definition.
syntax
base-ifield ; FIXME: validate
parsed-encoding
- (/derived-parse-ifield-assertion context args ifield-assertion)
+ (/derived-parse-ifield-assertion context ifield-assertion)
(if (null? getter)
#f
(/operand-parse-getter context
(list args
- (rtx-canonicalize context getter))
+ (rtx-canonicalize context mode getter nil))
(length args)))
(if (null? setter)
#f
(/operand-parse-setter context
(list (append args '(newval))
- (rtx-canonicalize context setter))
+ (rtx-canonicalize context 'VOID setter
+ (list (list 'newval mode #f))))
(length args)))
)))
(elm-set! result 'hw-name (obj:name (hardware-for-mode mode-obj)))
; (rtl-c mode '(func mode ...) nil)
;
; E.g.
-; (rtl-c DFLT '(add SI (const SI 1) (const SI 2)) nil)
+; (rtl-c SI '(add () SI (const () SI 1) (const () SI 2)) nil)
; -->
; "ADDSI (1, 2)"
-; Mode `DFLT' (DEFAULTmode) means "use the default/natural mode".
;
-; The expression is in source form or may be already compiled (with
-; rtx-compile).
+; The expression is in source form and must be already canonicalized (with
+; rtx-canonicalize).
;
; The `set' rtx needs to be handled a little carefully.
; Both the dest and src are processed first, and then code to perform the
; - gen-set-trace - return string of C code to set operand's value
;
; Instruction fields are refered to by name.
-; (estate-owner estate) must be an instruction that has the field.
; Instruction ifields must have these methods:
; - get-mode
; - cxmake-get
)
; Main routine to create a <c-expr> node object.
-; MODE is either the mode's symbol (e.g. 'QI) or a mode object.
+; MODE is either the mode's symbol (e.g. 'QI) or a <mode> object.
; CODE is a string of C code.
(define (cx:make mode code)
; Each newline is then preceeded with '\\'.
(macro? . #f)
+ ; Boolean indicating if evaluation is for an instruction.
+ ; It's not always possible to look at OWNER, e.g. when we're
+ ; processing semantic fragments.
+ (for-insn? . #f)
+
; #f -> reference ifield values using FLD macro.
; #t -> use C variables.
; ??? This is only needed to get correct ifield references
; FIXME: involves upcasting.
(define-getters <rtl-c-eval-state> estate
- (rtl-cover-fns? output-language macro? ifield-var?)
+ (rtl-cover-fns? output-language macro? for-insn? ifield-var?)
)
; Return booleans indicating if output language is C/C++.
(elm-set! self 'output-language (cadr args)))
((#:macro?)
(elm-set! self 'macro? (cadr args)))
+ ((#:for-insn?)
+ (elm-set! self 'for-insn? (cadr args)))
((#:ifield-var?)
(elm-set! self 'ifield-var? (cadr args)))
(else
)
; Translate parsed RTL expression X to a string of C code.
-; X must have already been fed through rtx-parse/rtx-compile.
+; X 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.
-; ??? Maybe EXTRA-VARS-ALIST should be handled this way.
(define (rtl-c-parsed mode x extra-vars-alist . overrides)
(let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides)))
; MODE is a <mode> object.
(define (rtl-c mode x extra-vars-alist . overrides)
- ; ??? rtx-compile could return a closure, then we wouldn't have to
- ; pass EXTRA-VARS-ALIST to two routines here.
(let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides)))
- (rtl-c-with-estate estate mode (rtx-compile #f x extra-vars-alist)))
+ (rtl-c-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x
+ extra-vars-alist)))
)
; Same as rtl-c-with-estate except return a <c-expr> object.
; MODE is a <mode> object.
(define (rtl-c-expr mode x extra-vars-alist . overrides)
- ; ??? rtx-compile could return a closure, then we wouldn't have to
- ; pass EXTRA-VARS-ALIST to two routines here.
(let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides)))
- (rtl-c-expr-with-estate estate mode (rtx-compile #f x extra-vars-alist)))
+ (rtl-c-expr-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x
+ extra-vars-alist)))
)
\f
; C++ versions of rtl-c routines.
)
; Translate parsed RTL expression X to a string of C++ code.
-; X must have already been fed through rtx-parse/rtx-compile.
+; X 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.
-; ??? Maybe EXTRA-VARS-ALIST should be handled this way.
(define (rtl-c++-parsed mode x extra-vars-alist . overrides)
(let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides)))
(rtl-c-with-estate estate mode x))
)
-; Same as rtl-c-parsed but X is unparsed.
+; Same as rtl-c++-parsed but X is unparsed.
; MODE is a <mode> object.
(define (rtl-c++ mode x extra-vars-alist . overrides)
- ; ??? rtx-compile could return a closure, then we wouldn't have to
- ; pass EXTRA-VARS-ALIST to two routines here.
(let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides)))
- (rtl-c-with-estate estate mode (rtx-compile #f x extra-vars-alist)))
+ (rtl-c-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x
+ extra-vars-alist)))
)
\f
; Top level routines for getting/setting values.
; - sequence's local variable object
; - operand name
; - operand object
+; - an integer
; - a string of C code
; FIXME: Reduce acceptable values of SRC.
; The result has mode MODE, unless MODE is the "default mode indicator"
; (DFLT) in which case the mode of the result is derived from SRC.
-; If SRC is a string, MODE can't be VOID or DFLT.
;
; ??? mode compatibility checks are wip
; The recursive call to /rtl-c-get is in case the result of rtx-eval
; is a hardware object, rtx-func object, or another rtl expression.
+ ; FIXME: simplify
((rtx? src)
(let ((evald-src (rtx-eval-with-estate src mode estate)))
; There must have been some change, otherwise we'll loop forever.
(assert (not (eq? src evald-src)))
(/rtl-c-get estate mode evald-src)))
+ ;; FIXME: Can we ever get a symbol here?
((or (and (symbol? src) (current-op-lookup src))
(operand? src))
(begin
(if (symbol? src)
(set! src (current-op-lookup src)))
(cond ((mode:eq? 'DFLT mode)
+ ; FIXME: Can we get called with 'DFLT anymore?
; FIXME: If we fetch the mode here, operands can assume
; they never get called with "default mode".
(send src 'cxmake-get estate mode #f #f))
((rtx-mode-compatible? mode (op:mode src))
- (let ((mode (rtx-lazy-sem-mode mode)))
+ (let ((mode (op:mode src))) ;; FIXME: (rtx-sem-mode mode)))
(send src 'cxmake-get estate mode #f #f)))
(else
+ ;; FIXME: canonicalization should have already caught this
(estate-error
estate
(string-append "operand " (obj:str-name src)
" referenced in incompatible mode")
(obj:name mode))))))
+ ;; FIXME: Can we ever get a symbol here?
((or (and (symbol? src) (rtx-temp-lookup (estate-env estate) src))
(rtx-temp? src))
(begin
(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 ((mode (rtx-lazy-sem-mode mode)))
+ (let ((mode (rtx-temp-mode src))) ;; FIXME: (rtx-sem-mode mode)))
(send src 'cxmake-get estate mode #f #f)))
- (else (estate-error
- estate
- (string-append "sequence temp " (rtx-temp-name src)
- " referenced in incompatible mode")
- (obj:name mode))))))
+ (else
+ ;; FIXME: canonicalization should have already caught this
+ (estate-error
+ estate
+ (string-append "sequence temp " (rtx-temp-name src)
+ " referenced in incompatible mode")
+ (obj:name mode))))))
((integer? src)
- ; Default mode of string argument is INT.
+ ; Default mode of integer argument is INT.
(if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
(cx:make INT (number->string src))
(cx:make mode (number->string src))))
; Return a <c-expr> object to set the value of DEST to SRC.
; ESTATE is the current rtl evaluation state.
+; MODE is the mode of DEST or DFLT which means fetch the real mode from DEST.
; MODE is either a <mode> object or the mode name.
; DEST is one of:
; - <c-expr> node
; - rtl expression (e.g. '(mem QI dr))
-; SRC is a <c-expr> object.
+; SRC is an RTX expression. It is important that we evaluate it, instead of
+; our caller, because only we know the mode of DEST (which we need to pass
+; when evaluating SRC if MODE is DFLT). ??? Can no longer get DFLT, but
+; it feels right to continue to evaluate SRC here.
; The mode of the result is always VOID (void).
+;
+; ??? One possible optimization is to pass the address of the result
+; to the computation of SRC. Seems dodgey though.
(define (rtl-c-set-quiet estate mode dest src)
;(display (list 'rtl-c-set-quiet mode dest src)) (newline)
(estate-error estate
"rtl-c-set-quiet: invalid dest"
dest)))))
+ (assert (mode? mode))
(if (not (object? xdest))
(estate-error estate "rtl-c-set-quiet: invalid dest" dest))
- (let ((mode (if (mode:eq? 'DFLT mode)
- (rtx-obj-mode xdest)
- (rtx-lazy-sem-mode mode))))
- (assert (mode? mode))
- (cx:make VOID (send xdest 'gen-set-quiet
+ (cx:make VOID (send xdest 'gen-set-quiet
estate mode #f #f
- (rtl-c-get estate mode src)))))
+ (rtl-c-get estate mode src))))
)
; Same as rtl-c-set-quiet except also print TRACE_RESULT message.
(estate-error estate
"rtl-c-set-trace: invalid dest"
dest)))))
+ (assert (mode? mode))
(if (not (object? xdest))
(estate-error estate "rtl-c-set-trace: invalid dest" dest))
- (let ((mode (if (mode:eq? 'DFLT mode)
- (rtx-obj-mode xdest)
- (rtx-lazy-sem-mode mode))))
- (assert (mode? mode))
- (cx:make VOID (send xdest 'gen-set-trace
+ (cx:make VOID (send xdest 'gen-set-trace
estate mode #f #f
- (rtl-c-get estate mode src)))))
+ (rtl-c-get estate mode src))))
)
\f
; Emit C code for each rtx function.
; ??? Bad assumption! VOID expressions may be used
; within sequences without local vars, which are translated
; to comma-expressions.
- (if (or (mode:eq? 'DFLT mode)
+ (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
(mode:eq? 'VOID mode))
");\n"
")")
; ??? Bad assumption! VOID expressions may be used
; within sequences without local vars, which are translated
; to comma-expressions.
- (if (or (mode:eq? 'DFLT mode)
+ (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
(mode:eq? 'VOID mode))
");\n"
")")
(and (not (obj-has-attr? mode 'FORCE-C))
(or (not c-op)
(and (estate-rtl-cover-fns? estate)
- (or (insn? (estate-owner estate))
+ ;; NOTE: We can't check (insn? (estate-owner estate)) here.
+ ;; It's not necessarily present for semantic fragments.
+ (or (estate-for-insn? estate)
(not (mode:host? mode))))))
)
(define (s-unop estate name c-op mode src)
(let* ((val (rtl-c-get estate mode src))
; Refetch mode in case it was DFLT and ensure unsigned->signed.
- (mode (cx:mode val))
+ (mode (mode:lookup mode)) ;;(cx:mode val)) ;; FIXME: can't get DFLT anymore
(sem-mode (rtx-sem-mode mode)))
; FIXME: Argument checking.
; Two operands referenced in the same mode producing a result in the same mode.
; MODE is the mode name.
-; If MODE is DFLT, use the mode of SRC1.
;
; ??? Will eventually want to handle floating point modes specially. Since
; bigger modes may get clumsily passed (there is no pass by reference in C) and
; rather then complicating cxmake-get. Ditto for rtl-c-get-ref/rtl-c-get.
(define (s-binop estate name c-op mode src1 src2)
+ ;(display (list "binop " name ", mode " mode)) (newline)
(let* ((val1 (rtl-c-get estate mode src1))
; Refetch mode in case it was DFLT and ensure unsigned->signed.
- (mode (cx:mode val1))
+ (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
(sem-mode (rtx-sem-mode mode))
(val2 (rtl-c-get estate mode src2)))
; FIXME: Argument checking.
(define (s-binop-with-bit estate name mode src1 src2 src3)
(let* ((val1 (rtl-c-get estate mode src1))
; Refetch mode in case it was DFLT and ensure unsigned->signed.
- (mode (rtx-sem-mode (cx:mode val1)))
+ (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
+ (sem-mode (rtx-sem-mode mode))
(val2 (rtl-c-get estate mode src2))
(val3 (rtl-c-get estate 'BI src3)))
; FIXME: Argument checking.
+
(cx:make mode
- (string-append name (obj:str-name mode)
+ (string-append name (obj:str-name sem-mode)
" ("
(cx:c val1) ", "
(cx:c val2) ", "
; different from a logical one. May need to create `sla' some day. Later.
(define (s-shop estate name c-op mode src1 src2)
+ ;(display (list "shop " name ", mode " mode)) (newline)
(let* ((val1 (rtl-c-get estate mode src1))
; Refetch mode in case it was DFLT and ensure unsigned->signed
; [sign of operation is determined from operation name, not mode].
- (mode (cx:mode val1))
+ (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
(sem-mode (rtx-sem-mode mode))
(val2 (rtl-c-get estate mode src2)))
; FIXME: Argument checking.
(let* ((val1 (rtl-c-get estate DFLT src1))
(val2 (rtl-c-get estate DFLT src2)))
; FIXME: Argument checking.
+
; If this is the simulator and MODE is not a host mode, use a macro.
; ??? MODE here being the mode of SRC1. Maybe later.
(if (estate-rtl-cover-fns? estate)
(define (s-cmpop estate name c-op mode src1 src2)
(let* ((val1 (rtl-c-get estate mode src1))
; Refetch mode in case it was DFLT.
- (mode (cx:mode val1))
+ (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
(val2 (rtl-c-get estate mode src2)))
; FIXME: Argument checking.
(if (> (length else) 1)
(estate-error estate "if: too many elements in `else' part" else))
(let ()
- (if (or (mode:eq? 'DFLT mode)
+ (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
(mode:eq? 'VOID mode))
(cx:make mode
(string-append "if (" (cx:c (rtl-c-get estate DFLT cond)) ")"
; FIXME: Need more error checking of arguments.
(define (s-cond estate mode . cond-code-list)
+ ;; FIXME: can't get DFLT anymore
(let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))))
(if (null? cond-code-list)
(estate-error estate "empty `cond'"))
; FIXME: What to allow for case choices is wip.
(define (s-case estate mode test . case-list)
+ ;; FIXME: can't get DFLT anymore
(if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
(s-case-vm estate test case-list)
(s-case-non-vm estate mode test case-list))
; One can still put a parallel inside an `if' however.
(define (/par-replace-set-dests estate exprs)
+ ;(display exprs) (newline)
(let ((sets (list 'set 'set-quiet
(rtx-lookup 'set) (rtx-lookup 'set-quiet))))
(letrec ((replace
(lambda (expr)
+ ;(display expr) (newline)
(let ((name (car expr))
(options (rtx-options expr))
(mode (rtx-mode expr)))
options
mode
(/par-new-temp! ; replace dest with temp
- (if (mode:eq? 'DFLT mode)
+ (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
(rtx-lvalue-mode-name estate (rtx-set-dest expr))
mode))
(rtx-set-src expr))
(define (s-sequence estate mode env . exprs)
(let* ((env (rtx-env-make-locals env)) ; compile env
(estate (estate-push-env estate env)))
- (if (or (mode:eq? 'DFLT mode)
+ (if (or (mode:eq? 'DFLT mode) ;; FIXME: DFLT can't appear anymore
(mode:eq? 'VOID mode))
- (cx:make mode
+ (cx:make VOID
(string-append
; FIXME: do {} while (0); doesn't get "optimized out"
; internally by gcc, meaning two labels and a loop are
"{\n"
(gen-temp-defs estate env)
(string-map (lambda (e)
- (rtl-c-with-estate estate DFLT e))
+ (rtl-c-with-estate estate VOID e))
exprs)
"}\n"))
(cx:make mode
" ++" c-iter-var ")\n"
" {\n"
(string-map (lambda (e)
- (rtl-c-with-estate estate DFLT e))
+ (rtl-c-with-estate estate VOID e))
exprs)
" }\n"
"}\n"))
(string-append "\""
(backslash "\"" message)
"\""))))
- (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
+ (if (mode:eq? mode VOID)
c-call
(cx:make mode (string-append "(" (cx:c c-call) ", 0)"))))
)
; Instruction field support.
; ??? This should build an operand object like -build-ifield-operand! does
; in semantics.scm.
-; ??? Mode support is wip.
(define-fn ifield (*estate* options mode ifld-name)
(if (estate-ifield-var? *estate*)
- (cx:make 'UINT (gen-c-symbol ifld-name))
- (cx:make 'UINT (string-append "FLD (" (gen-c-symbol ifld-name) ")")))
+ (cx:make mode (gen-c-symbol ifld-name))
+ (cx:make mode (string-append "FLD (" (gen-c-symbol ifld-name) ")")))
; (let ((f (current-ifld-lookup ifld-name)))
; (make <operand> (obj-location f) ifld-name ifld-name
; (atlist-cons (bool-attr-make 'SEM-ONLY #t)
(define-fn operand (*estate* options mode object-or-name)
(cond ((operand? object-or-name)
+ ;; mode checking to be done during canonicalization
object-or-name)
((symbol? object-or-name)
(let ((object (current-op-lookup object-or-name)))
(if (not object)
(estate-error *estate* "undefined operand" object-or-name))
+ ;; mode checking to be done during canonicalization
object))
(else
(estate-error *estate* "bad arg to `operand'" object-or-name)))
(if (pair? sel) (car sel) hw-selector-default))
)
-(define-fn pc (*estate* options mode)
- s-pc
-)
+; ??? Hmmm... needed? The pc is usually specified as `pc' which is shorthand
+; for (operand pc).
+;(define-fn pc (*estate* options mode)
+; s-pc
+;)
(define-fn ref (*estate* options mode name)
(if (not (insn? (estate-owner *estate*)))
; ??? Maybe this should return an operand object.
(define-fn index-of (*estate* options mode op)
- (send (op:index (rtx-eval-with-estate op DFLT *estate*)) 'cxmake-get *estate* 'DFLT)
+ (send (op:index (rtx-eval-with-estate op DFLT *estate*))
+ 'cxmake-get *estate* (mode:lookup mode))
)
(define-fn clobber (*estate* options mode object)
(begin
;; check for proper usage
(if (let* ((hw (case (car rtx)
- ((operand) (op:type (rtx-operand-obj rtx)))
+ ((operand) (op:type (current-op-lookup (rtx-arg1 rtx))))
((xop) (op:type (rtx-xop-obj rtx)))
(else #f))))
(not (and hw (or (pc? hw) (memory? hw) (register? hw)))))
")"))
)
-(define-fn attr (*estate* options mode owner attr-name)
- (cond ((equal? owner '(current-insn () DFLT))
+(define-fn int-attr (*estate* options mode owner attr-name)
+ (cond ((or (equal? owner '(current-insn () DFLT)) ;; FIXME: delete in time
+ (equal? owner '(current-insn () INSN)))
(s-c-raw-call *estate* 'INT "GET_ATTR"
(string-upcase (gen-c-symbol attr-name))))
(else
(define-fn const (*estate* options mode c)
(assert (not (mode:eq? 'VOID mode)))
- (if (mode:eq? 'DFLT mode)
+ (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
(set! mode 'INT))
(let ((mode (mode:lookup mode)))
(cx:make mode
(define-fn subword (*estate* options mode value word-num)
(let* ((mode (mode:lookup mode))
(val (rtl-c-get *estate* DFLT value))
- ; Refetch mode in case it was DFLT.
(val-mode (cx:mode val)))
(cx:make mode
(string-append "SUBWORD"
)
(define-fn set (*estate* options mode dst src)
- (if (insn? (estate-owner *estate*))
- (rtl-c-set-trace *estate* mode dst (rtl-c-get *estate* mode src))
- (rtl-c-set-quiet *estate* mode dst (rtl-c-get *estate* mode src)))
+ (if (estate-for-insn? *estate*)
+ (rtl-c-set-trace *estate* mode dst src)
+ (rtl-c-set-quiet *estate* mode dst src))
)
(define-fn set-quiet (*estate* options mode dst src)
- (rtl-c-set-quiet *estate* mode dst (rtl-c-get *estate* mode src))
+ (rtl-c-set-quiet *estate* mode dst src)
)
(define-fn neg (*estate* options mode s1)
)
(define-fn member (*estate* options mode value set)
- ; FIXME: Multiple evalutions of VALUE.
- (let ((c-value (rtl-c-get *estate* 'DFLT value))
+ ;; NOTE: There are multiple evalutions of VALUE in the generated code.
+ ;; It's probably ok, this comment is more for completeness sake.
+ (let ((c-value (rtl-c-get *estate* mode value))
(set (rtx-number-list-values set)))
(let loop ((set (cdr set))
(code (string-append "(" (cx:c c-value)
(define-fn closure (*estate* options mode expr env)
; ??? estate-push-env?
- (rtl-c-with-estate (estate-new-env *estate* env) DFLT expr)
+ (rtl-c-with-estate (estate-new-env *estate* env) (mode:lookup mode) expr)
)
\f
;; The result is the rtl->c generator table.
-; RTL traversing support.
-; Copyright (C) 2000, 2001, 2009 Red Hat, Inc.
-; This file is part of CGEN.
-; See file COPYING.CGEN for details.
+;; RTL traversing support.
+;; Copyright (C) 2000, 2001, 2009 Red Hat, Inc.
+;; This file is part of CGEN.
+;; See file COPYING.CGEN for details.
+
+;; Canonicalization support.
+;; Canonicalizing an rtl expression involves adding possibly missing options
+;; and mode, and converting occurrences of DFLT into usable modes.
+;; Various error checks are done as well.
+;; This is done differently than traversal support because it has a more
+;; specific purpose, it doesn't need to support arbitrary "expr-fns".
+;; ??? At present the internal form is also the source form (easier debugging).
+
+(define /rtx-canon-debug? #f)
+
+;; Canonicalization state.
+;; 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 (/cstate-context cstate) (vector-ref cstate 0))
+(define (/cstate-outer-expr cstate) (vector-ref cstate 1))
+
+;; Flag an error while canonicalizing rtl.
+
+(define (/rtx-canon-error cstate errmsg expr parent-expr op-num)
+ (let* ((pretty-parent-expr
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (rtx-dump (/cstate-outer-expr cstate))))))
+ (intro (if parent-expr
+ (string-append "While canonicalizing "
+ (rtx-strdump parent-expr)
+ (if op-num
+ (string-append ", operand #"
+ (number->string op-num))
+ "")
+ " of:\n"
+ pretty-parent-expr)
+ (string-append "While canonicalizing:\n" pretty-parent-expr))))
+ (context-error (/cstate-context cstate) intro errmsg (rtx-dump expr)))
+)
+
+;; Lookup h/w object HW-NAME and return it (as a <hardware-base> object).
+;; If multiple h/w objects with the same name are defined, require
+;; all to have the same mode.
+;; CHECK-KIND is a function of one argument to verify the h/w objects
+;; are valid and if not flag an error.
+
+(define (/rtx-lookup-hw cstate hw-name parent-expr check-kind)
+ (let ((hw-objs (current-hw-sem-lookup hw-name)))
+
+ (if (null? hw-objs)
+ (/rtx-canon-error cstate "unknown h/w object"
+ hw-name parent-expr #f))
+
+ ;; Just check the first one with CHECK-KIND.
+ (check-kind (car hw-objs))
+
+ (let* ((hw1 (car hw-objs))
+ (hw1-mode (hw-mode hw1))
+ (hw1-mode-name (obj:name hw1-mode)))
+
+ ;; Allow multiple h/w objects with the same name
+ ;; as long has they have the same mode.
+ (if (> (length hw-objs) 1)
+ (let ((other-hw-mode-names (map (lambda (hw)
+ (obj:name (hw-mode hw)))
+ (cdr hw-objs))))
+ (if (not (all-true? (map (lambda (mode-name)
+ (eq? mode-name hw1-mode-name))
+ other-hw-mode-names)))
+ (/rtx-canon-error cstate "multiple h/w objects with different modes selected"
+ hw-name parent-expr #f))))
+
+ hw1))
+)
+
+;; Return the mode name to use in an expression given the requested mode
+;; and the mode used in the expression.
+;; If both are DFLT, leave it alone and hope the expression provides
+;; enough info to pick a usable mode.
+;; If both are provided, prefer the mode used in the expression.
+;; If the modes are incompatible, return #f.
+
+(define (/rtx-pick-mode cstate requested-mode-name expr-mode-name)
+ (cond ((eq? requested-mode-name 'DFLT)
+ expr-mode-name)
+ ((eq? expr-mode-name 'DFLT)
+ requested-mode-name)
+ (else
+ (let ((requested-mode (mode:lookup requested-mode-name))
+ (expr-mode (mode:lookup expr-mode-name)))
+ (if (not requested-mode)
+ (/rtx-canon-error cstate "invalid mode" requested-mode-name #f #f))
+ (if (not expr-mode)
+ (/rtx-canon-error cstate "invalid mode" expr-mode-name #f #f))
+ ;; FIXME: 'would prefer samesize or "no precision lost", sigh
+ (if (mode-compatible? 'sameclass requested-mode expr-mode)
+ expr-mode-name
+ expr-mode-name)))) ;; FIXME: should be #f, disabled pending completion of rtl mode handling rewrite
+)
+
+;; Return the mode name (as a symbol) to use in an object's rtl given
+;; the requested mode, the mode used in the expression, and the object's
+;; real mode.
+;; If both requested mode and expr mode are DFLT, use the real mode.
+;; If requested mode is DFLT, prefer expr mode.
+;; If expr mode is DFLT, prefer the real mode.
+;; If both requested mode and expr mode are specified, prefer expr-mode.
+;; If there's an error the result is the error message (as a string).
+;;
+;; E.g. in (set SI dest (ifield DFLT f-r1)), the mode of the ifield's
+;; expression is DFLT, the requested mode is SI, and the real mode of f-r1
+;; may be INT.
+;;
+;; REAL-MODE is a <mode> object.
+
+(define (/rtx-pick-mode3 requested-mode-name expr-mode-name real-mode)
+ ;; Leave checking for (symbol? requested-mode-name) to caller (or higher).
+ (let ((expr-mode (mode:lookup expr-mode-name)))
+ (cond ((not expr-mode)
+ "unknown mode")
+ ((eq? requested-mode-name 'DFLT)
+ (if (eq? expr-mode-name 'DFLT)
+ (obj:name real-mode)
+ (if (rtx-mode-compatible? expr-mode real-mode)
+ expr-mode-name
+ (string-append "expression mode "
+ (symbol->string expr-mode-name)
+ " is incompatible with real mode "
+ (obj:str-name real-mode)))))
+ ((eq? expr-mode-name 'DFLT)
+ (if (rtx-mode-compatible? (mode:lookup requested-mode-name)
+ real-mode)
+ (obj:name real-mode)
+ (string-append "mode of containing expression "
+ (symbol->string requested-mode-name)
+ " is incompatible with real mode "
+ (obj:str-name real-mode))))
+ (else
+ (let ((requested-mode (mode:lookup requested-mode-name)))
+ (cond ((not (rtx-mode-compatible? requested-mode expr-mode))
+ (string-append "mode of containing expression "
+ (symbol->string requested-mode-name)
+ " is incompatible with expression mode "
+ (symbol->string expr-mode-name)))
+ ((not (rtx-mode-compatible? expr-mode real-mode))
+ (string-append "expression mode "
+ (symbol->string expr-mode-name)
+ " is incompatible with real mode "
+ (obj:str-name real-mode)))
+ (else
+ expr-mode-name))))))
+)
+
+;; Return the mode name (as a symbol) to use in an operand's rtl given
+;; the requested mode, the mode used in the expression, and the operand's
+;; real mode.
+;; If both requested mode and expr mode are DFLT, use the real mode.
+;; If requested mode is DFLT, prefer expr mode.
+;; If expr mode is DFLT, prefer the real mode.
+;; If both requested mode and expr mode are specified, prefer expr-mode.
+;; If the modes are incompatible an error is signalled.
+;;
+;; E.g. in (set QI (mem QI src2) src1), the mode to set is QI, but if src1
+;; is a 32-bit (SI) register we want QI.
+;; OTOH, in (set QI (mem QI src2) uimm8), the mode to set is QI, but we want
+;; the real mode of uimm8.
+;;
+;; ??? This is different from /rtx-pick-mode3 for compatibility with
+;; pre-full-canonicalization versions.
+; It's currently a toss-up on whether it improves things.
+;;
+;; OP is an <operand> object.
+;;
+;; Things are complicated because multiple versions of a h/w object can be
+;; defined, and the operand refers to the h/w by name.
+;; op:type, which op:mode calls, will flag an error if multiple versions of
+;; a h/w object are defined - only one should have been kept during .cpu
+;; file loading. This is for semantic code generation, but for generating
+;; files covering the entire architecture we need to keep all the versions.
+;; Things are ok, as far as canonicalization is concerned, if all h/w versions
+;; have the same mode (which could be WI for 32/64 arches).
+
+(define (/rtx-pick-op-mode cstate requested-mode-name expr-mode-name op
+ parent-expr)
+ ;; Leave checking for (symbol? requested-mode-name) to caller (or higher).
+ (let* ((op-mode-name (op:mode-name op))
+ (hw (/rtx-lookup-hw cstate (op:hw-name op) parent-expr
+ (lambda (hw) *UNSPECIFIED*)))
+ (op-mode (if (eq? op-mode-name 'DFLT)
+ (hw-mode hw)
+ (mode:lookup op-mode-name)))
+ (expr-mode (mode:lookup expr-mode-name)))
+ (cond ((not expr-mode)
+ (/rtx-canon-error cstate "unknown mode" expr-mode-name
+ parent-expr #f))
+ ((eq? requested-mode-name 'DFLT)
+ (if (eq? expr-mode-name 'DFLT)
+ (obj:name op-mode)
+ (if (rtx-mode-compatible? expr-mode op-mode)
+ expr-mode-name
+ (/rtx-canon-error cstate
+ (string-append
+ "expression mode "
+ (symbol->string expr-mode-name)
+ " is incompatible with operand mode "
+ (obj:str-name op-mode))
+ expr-mode-name parent-expr #f))))
+ ((eq? expr-mode-name 'DFLT)
+ (if (rtx-mode-compatible? (mode:lookup requested-mode-name)
+ op-mode)
+; FIXME: Experiment. It's currently a toss-up on whether it improves things.
+; (cond ((pc? op)
+; (obj:name op-mode))
+; ((register? hw)
+; requested-mode-name)
+; (else
+; (obj:name op-mode)))
+ (obj:name op-mode)
+ (/rtx-canon-error cstate
+ (string-append
+ "mode of containing expression "
+ (symbol->string requested-mode-name)
+ " is incompatible with operand mode "
+ (obj:str-name op-mode))
+ requested-mode-name parent-expr #f)))
+ (else
+ (let ((requested-mode (mode:lookup requested-mode-name)))
+ (cond ((not (rtx-mode-compatible? requested-mode expr-mode))
+ (/rtx-canon-error cstate
+ (string-append
+ "mode of containing expression "
+ (symbol->string requested-mode-name)
+ " is incompatible with expression mode "
+ (symbol->string expr-mode-name))
+ requested-mode-name parent-expr #f))
+ ((not (rtx-mode-compatible? expr-mode op-mode))
+ (/rtx-canon-error cstate
+ (string-append
+ "expression mode "
+ (symbol->string expr-mode-name)
+ " is incompatible with operand mode "
+ (obj:str-name op-mode))
+ expr-mode-name parent-expr #f))
+ (else
+ expr-mode-name))))))
+)
+
+;; Return the last rtx in cond or case expression EXPR.
-; RTL expression traversal support.
-; Traversal (and compilation) involves validating the source form and
-; converting it to internal form.
-; ??? At present the internal form is also the source form (easier debugging).
+(define (/rtx-get-last-cond-case-rtx expr)
+ (let ((len (length expr)))
+ (list-ref expr (- len 1)))
+)
+
+;; Canonicalize a list of rtx's.
+;; The mode of rtxes prior to the last one must be VOID.
+
+(define (/rtx-canon-rtx-list rtx-list mode parent-expr op-num cstate env depth)
+ (let* ((nr-rtxes (length rtx-list))
+ (last-op-num (- nr-rtxes 1)))
+ (map (lambda (rtx op-num)
+ (/rtx-canon rtx 'RTX
+ (if (= op-num last-op-num) mode 'VOID)
+ parent-expr op-num cstate env depth))
+ rtx-list (iota nr-rtxes)))
+)
+
+;; Rtx canonicalizers.
+;; These are defined as individual functions that are then built into a table
+;; mostly for simplicity.
+;
+;; The result is either a pair of the parsed VAL and new environment,
+;; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
+
+(define (/rtx-canon-options val mode parent-expr op-num cstate env depth)
+ #f
+)
+
+(define (/rtx-canon-anyintmode val mode parent-expr op-num cstate env depth)
+ (let ((val-obj (mode:lookup val)))
+ (if (and val-obj
+ (or (memq (mode:class val-obj) '(INT UINT))
+ (eq? val 'DFLT)))
+ #f
+ (/rtx-canon-error cstate "expecting an integer mode"
+ val parent-expr op-num)))
+)
+
+(define (/rtx-canon-anyfloatmode val mode parent-expr op-num cstate env depth)
+ (let ((val-obj (mode:lookup val)))
+ (if (and val-obj
+ (or (memq (mode:class val-obj) '(FLOAT))
+ (eq? val 'DFLT)))
+ #f
+ (/rtx-canon-error cstate "expecting a float mode"
+ val parent-expr op-num)))
+)
+
+(define (/rtx-canon-anynummode val mode parent-expr op-num cstate env depth)
+ (let ((val-obj (mode:lookup val)))
+ (if (and val-obj
+ (or (memq (mode:class val-obj) '(INT UINT FLOAT))
+ (eq? val 'DFLT)))
+ #f
+ (/rtx-canon-error cstate "expecting a numeric mode"
+ val parent-expr op-num)))
+)
+
+(define (/rtx-canon-anyexprmode val mode parent-expr op-num cstate env depth)
+ (let ((val-obj (mode:lookup val)))
+ (if (and val-obj
+ (or (memq (mode:class val-obj) '(INT UINT FLOAT))
+ (memq val '(DFLT PTR VOID))))
+ #f
+ (/rtx-canon-error cstate "expecting a numeric mode, PTR, or VOID"
+ val parent-expr op-num)))
+)
+
+(define (/rtx-canon-explnummode val mode parent-expr op-num cstate env depth)
+ (let ((val-obj (mode:lookup val)))
+ (if (and val-obj
+ (memq (mode:class val-obj) '(INT UINT FLOAT)))
+ #f
+ (/rtx-canon-error cstate "expecting an explicit numeric mode"
+ val parent-expr op-num)))
+)
+
+(define (/rtx-canon-voidornummode val mode parent-expr op-num cstate env depth)
+ (let ((val-obj (mode:lookup val)))
+ (if (and val-obj
+ (or (memq (mode:class val-obj) '(INT UINT FLOAT))
+ (memq val '(DFLT VOID))))
+ #f
+ (/rtx-canon-error cstate "expecting void or a numeric mode"
+ val parent-expr op-num)))
+)
+
+(define (/rtx-canon-voidmode val mode parent-expr op-num cstate env depth)
+ (if (memq val '(DFLT VOID))
+ (cons 'VOID env)
+ (/rtx-canon-error cstate "expecting VOID mode"
+ val parent-expr op-num))
+)
+
+(define (/rtx-canon-bimode val mode parent-expr op-num cstate env depth)
+ (if (memq val '(DFLT BI))
+ (cons 'BI env)
+ (/rtx-canon-error cstate "expecting BI mode"
+ val parent-expr op-num))
+)
+
+(define (/rtx-canon-intmode val mode parent-expr op-num cstate env depth)
+ (if (memq val '(DFLT INT))
+ (cons 'INT env)
+ (/rtx-canon-error cstate "expecting INT mode"
+ val parent-expr op-num))
+)
+
+(define (/rtx-canon-symmode val mode parent-expr op-num cstate env depth)
+ (if (memq val '(DFLT SYM))
+ (cons 'SYM env)
+ (/rtx-canon-error cstate "expecting SYM mode"
+ val parent-expr op-num))
+)
+
+(define (/rtx-canon-insnmode val mode parent-expr op-num cstate env depth)
+ (if (memq val '(DFLT INSN))
+ (cons 'INSN env)
+ (/rtx-canon-error cstate "expecting INSN mode"
+ val parent-expr op-num))
+)
+
+(define (/rtx-canon-machmode val mode parent-expr op-num cstate env depth)
+ (if (memq val '(DFLT MACH))
+ (cons 'MACH env)
+ (/rtx-canon-error cstate "expecting MACH mode"
+ val parent-expr op-num))
+)
+
+(define (/rtx-canon-rtx val mode parent-expr op-num cstate env depth)
+; Commented out 'cus it doesn't quite work yet.
+; (if (not (rtx? val))
+; (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num))
+ (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth)
+ env)
+)
+
+(define (/rtx-canon-setrtx val mode parent-expr op-num cstate env depth)
+; Commented out 'cus it doesn't quite work yet.
+; (if (not (rtx? val))
+; (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num))
+ (let ((dest (/rtx-canon val 'SETRTX mode parent-expr op-num cstate env depth)))
+ (cons dest env))
+)
+
+;; This is the test of an `if'.
+
+(define (/rtx-canon-testrtx val mode parent-expr op-num cstate env depth)
+; Commented out 'cus it doesn't quite work yet.
+; (if (not (rtx? val))
+; (/rtx-canon-error cstate "expecting an rtx"
+; val parent-expr op-num))
+ (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth)
+ env)
+)
+
+(define (/rtx-canon-condrtx val mode parent-expr op-num cstate env depth)
+ (if (not (pair? val))
+ (/rtx-canon-error cstate "expecting an expression"
+ val parent-expr op-num))
+ (if (eq? (car val) 'else)
+ (begin
+ (if (!= (+ op-num 2) (length parent-expr))
+ (/rtx-canon-error cstate "`else' clause not last"
+ val parent-expr op-num))
+ (cons (cons 'else
+ (/rtx-canon-rtx-list
+ (cdr val) mode parent-expr op-num cstate env depth))
+ env))
+ (cons (cons
+ ;; ??? Entries after the first are conditional.
+ (/rtx-canon (car val) 'RTX 'INT parent-expr op-num cstate env depth)
+ (/rtx-canon-rtx-list
+ (cdr val) mode parent-expr op-num cstate env depth))
+ env))
+)
+
+(define (/rtx-canon-casertx val mode parent-expr op-num cstate env depth)
+ (if (or (not (list? val))
+ (< (length val) 2))
+ (/rtx-canon-error cstate "invalid `case' expression"
+ val parent-expr op-num))
+ ;; car is either 'else or list of symbols/numbers
+ (if (not (or (eq? (car val) 'else)
+ (and (list? (car val))
+ (not (null? (car val)))
+ (all-true? (map /rtx-symornum?
+ (car val))))))
+ (/rtx-canon-error cstate "invalid `case' choice"
+ val parent-expr op-num))
+ (if (and (eq? (car val) 'else)
+ (!= (+ op-num 2) (length parent-expr)))
+ (/rtx-canon-error cstate "`else' clause not last"
+ val parent-expr op-num))
+ (cons (cons (car val)
+ (/rtx-canon-rtx-list
+ (cdr val) mode parent-expr op-num cstate env depth))
+ env)
+)
+
+(define (/rtx-canon-locals val mode parent-expr op-num cstate env depth)
+ (if (not (list? val))
+ (/rtx-canon-error cstate "bad locals list"
+ val parent-expr op-num))
+ (for-each (lambda (var)
+ (if (or (not (list? var))
+ (!= (length var) 2)
+ (not (/rtx-any-mode? (car var)))
+ (not (symbol? (cadr var))))
+ (/rtx-canon-error cstate "bad locals list"
+ val parent-expr op-num)))
+ val)
+ (let ((new-env (rtx-env-make-locals val)))
+ (cons val (cons new-env env)))
+)
+
+(define (/rtx-canon-iteration val mode parent-expr op-num cstate env depth)
+ (if (not (symbol? val))
+ (/rtx-canon-error cstate "bad iteration variable name"
+ val parent-expr op-num))
+ (let ((new-env (rtx-env-make-iteration-locals val)))
+ (cons val (cons new-env env)))
+)
+
+(define (/rtx-canon-env 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"
+ val parent-expr op-num))
+ ;; FIXME: Shouldn't this push VAL onto ENV?
+ (cons val env)
+)
+
+(define (/rtx-canon-attrs val mode parent-expr op-num cstate env depth)
+; (cons val ; (atlist-source-form (atlist-parse (make-prefix-cstate "with-attr") val ""))
+; env)
+ #f
+)
+
+(define (/rtx-canon-symbol val mode parent-expr op-num cstate env depth)
+ (if (not (symbol? val))
+ (/rtx-canon-error cstate "expecting a symbol"
+ val parent-expr op-num))
+ #f
+)
+
+(define (/rtx-canon-string val mode parent-expr op-num cstate env depth)
+ (if (not (string? val))
+ (/rtx-canon-error cstate "expecting a string"
+ val parent-expr op-num))
+ #f
+)
+
+(define (/rtx-canon-number val mode parent-expr op-num cstate env depth)
+ (if (not (number? val))
+ (/rtx-canon-error cstate "expecting a number"
+ val parent-expr op-num))
+ #f
+)
+
+(define (/rtx-canon-symornum val mode parent-expr op-num cstate env depth)
+ (if (not (or (symbol? val) (number? val)))
+ (/rtx-canon-error cstate "expecting a symbol or number"
+ val parent-expr op-num))
+ #f
+)
+
+(define (/rtx-canon-object val mode parent-expr op-num cstate env depth)
+ #f
+)
+
+;; Table of rtx canonicalizers.
+;; This is a vector of size rtx-max-num.
+;; Each entry is a list of (arg-type-name . canonicalizer) elements
+;; for rtx-arg-types.
+;; FIXME: Initialized in rtl.scm (i.e. outside this file).
+
+(define /rtx-canoner-table #f)
+
+;; Return a hash table of standard operand canonicalizers.
+;; The result of each canonicalizer is a pair of the canonical form
+;; of `val' and a possibly new environment or #f if there is no change.
+
+(define (/rtx-make-canon-table)
+ (let ((hash-tab (make-hash-table 31))
+ (canoners
+ (list
+ (cons 'OPTIONS /rtx-canon-options)
+ (cons 'ANYINTMODE /rtx-canon-anyintmode)
+ (cons 'ANYFLOATMODE /rtx-canon-anyfloatmode)
+ (cons 'ANYNUMMODE /rtx-canon-anynummode)
+ (cons 'ANYEXPRMODE /rtx-canon-anyexprmode)
+ (cons 'EXPLNUMMODE /rtx-canon-explnummode)
+ (cons 'VOIDORNUMMODE /rtx-canon-voidornummode)
+ (cons 'VOIDMODE /rtx-canon-voidmode)
+ (cons 'BIMODE /rtx-canon-bimode)
+ (cons 'INTMODE /rtx-canon-intmode)
+ (cons 'SYMMODE /rtx-canon-symmode)
+ (cons 'INSNMODE /rtx-canon-insnmode)
+ (cons 'MACHMODE /rtx-canon-machmode)
+ (cons 'RTX /rtx-canon-rtx)
+ (cons 'SETRTX /rtx-canon-setrtx)
+ (cons 'TESTRTX /rtx-canon-testrtx)
+ (cons 'CONDRTX /rtx-canon-condrtx)
+ (cons 'CASERTX /rtx-canon-casertx)
+ (cons 'LOCALS /rtx-canon-locals)
+ (cons 'ITERATION /rtx-canon-iteration)
+ (cons 'ENV /rtx-canon-env)
+ (cons 'ATTRS /rtx-canon-attrs)
+ (cons 'SYMBOL /rtx-canon-symbol)
+ (cons 'STRING /rtx-canon-string)
+ (cons 'NUMBER /rtx-canon-number)
+ (cons 'SYMORNUM /rtx-canon-symornum)
+ (cons 'OBJECT /rtx-canon-object)
+ )))
+
+ (for-each (lambda (canoner)
+ (hashq-set! hash-tab (car canoner) (cdr canoner)))
+ canoners)
+
+ hash-tab)
+)
+
+;; Standard expression operand canonicalizer.
+;; Loop over the operands, verifying them according to the argument type
+;; and mode matcher, and replace DFLT with a usable mode.
+
+(define (/rtx-canon-operands rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ ;; ??? Might want to just leave operands as a list.
+ (let* ((operands (list->vector args))
+ (nr-operands (vector-length operands))
+ (this-expr (cons func args)) ;; For error messages.
+ (expr-mode
+ ;; For sets, the requested mode is DFLT or VOID (the mode of the
+ ;; result), but the mode we want is the mode of the set destination.
+ (if (rtx-result-mode rtx-obj)
+ (cadr args) ;; mode of arg2 doesn't come from containing expr
+ (/rtx-pick-mode cstate requested-mode-name (cadr args))))
+ (all-arg-types (vector-ref /rtx-canoner-table (rtx-num rtx-obj))))
+
+ (if (not expr-mode)
+ (/rtx-canon-error cstate
+ (string-append "requested mode "
+ (symbol->string requested-mode-name)
+ " is incompatible with expression mode "
+ (symbol->string (cadr args)))
+ this-expr parent-expr #f))
+
+ (let loop ((env env)
+ (op-num 0)
+ (arg-types all-arg-types)
+ (arg-modes (rtx-arg-modes rtx-obj)))
+
+ (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
+
+ (if /rtx-canon-debug?
+ (begin
+ (display (spaces (* 4 depth)))
+ (if (= op-num nr-operands)
+ (display "end of operands")
+ (begin
+ (display "op-num ") (display op-num) (display ": ")
+ (display (rtx-dump (vector-ref operands op-num)))
+ (display ", ")
+ (display (if varargs? (car arg-types) (caar arg-types)))
+ (display ", ")
+ (display (if varargs? arg-modes (car arg-modes)))
+ ))
+ (newline)
+ (force-output)))
+
+ (cond ((= op-num nr-operands)
+
+ ;; Out of operands, check if we have the expected number.
+ (if (or (null? arg-types)
+ varargs?)
+
+ ;; We're theoretically done.
+ (let ((set-mode-from-arg!
+ (lambda (arg-num)
+ (if /rtx-canon-debug?
+ (begin
+ (display (spaces (* 4 depth)))
+ (display "Computing expr mode from arguments.")
+ (newline)))
+ (let* ((expr-to-match
+ (case func
+ ((cond case)
+ (/rtx-get-last-cond-case-rtx (vector-ref operands arg-num)))
+ (else
+ (vector-ref operands arg-num))))
+ (expr-to-match-obj (rtx-lookup (rtx-name expr-to-match)))
+ (result-mode (or (rtx-result-mode expr-to-match-obj)
+ (let ((expr-mode (rtx-mode expr-to-match)))
+ (if (eq? expr-mode 'DFLT)
+ (if (eq? requested-mode-name 'DFLT)
+ (/rtx-canon-error cstate
+ "unable to determine mode of expression from arguments, please specify a mode"
+ this-expr parent-expr #f)
+ requested-mode-name)
+ expr-mode)))))
+ (vector-set! operands 1 result-mode)))))
+ ;; The expression's mode might still be DFLT.
+ ;; If it is, fetch the mode of the MATCHEXPR operand,
+ ;; or MATCHSEQ operand, or containing expression.
+ ;; If it's still DFLT, flag an error.
+ (if (eq? (vector-ref operands 1) 'DFLT)
+ (cond ((rtx-matchexpr-index rtx-obj)
+ => (lambda (matchexpr-index)
+ (set-mode-from-arg! matchexpr-index)))
+ ((eq? func 'sequence)
+ (set-mode-from-arg! (- nr-operands 1)))
+ (else
+ (if /rtx-canon-debug?
+ (begin
+ (display (spaces (* 4 depth)))
+ (display "Computing expr mode from containing expression.")
+ (newline)))
+ (if (or (eq? requested-mode-name 'DFLT)
+ (rtx-result-mode rtx-obj))
+ (/rtx-canon-error cstate
+ "unable to determine mode of expression, please specify a mode"
+ this-expr parent-expr #f)
+ (vector-set! operands 1 requested-mode-name)))))
+ (vector->list operands))
+
+ (/rtx-canon-error cstate "missing operands"
+ this-expr parent-expr #f)))
+
+ ((null? arg-types)
+ (/rtx-canon-error cstate "too many operands"
+ this-expr parent-expr #f))
+
+ (else
+ (let ((type (if varargs? arg-types (car arg-types)))
+ (mode (let ((mode-spec (if varargs?
+ arg-modes
+ (car arg-modes))))
+ ;; We don't necessarily have enough information
+ ;; at this point. Just propagate what we do know,
+ ;; and leave it for final processing to fix up what
+ ;; we missed.
+ ;; This is small enough that case is fast enough,
+ ;; and the number of entries should be stable.
+ (case mode-spec
+ ((ANY) 'DFLT)
+ ((ANYINT) 'DFLT) ;; FIXME
+ ((NA) #f)
+ ((MATCHEXPR) expr-mode)
+ ((MATCHSEQ)
+ (if (= (+ op-num 1) nr-operands) ;; last one?
+ expr-mode
+ 'VOID))
+ ((MATCH2)
+ ;; This is complicated by the fact that some
+ ;; rtx have a different result mode than what
+ ;; is specified in the rtl (e.g. set, eq).
+ ;; ??? Make these rtx specify both modes?
+ (let* ((op2 (vector-ref operands 2))
+ (op2-obj (rtx-lookup (rtx-name op2))))
+ (or (rtx-result-mode op2-obj)
+ (rtx-mode op2))))
+ ((MATCH3)
+ ;; This is complicated by the fact that some
+ ;; rtx have a different result mode than what
+ ;; is specified in the rtl (e.g. set, eq).
+ ;; ??? Make these rtx specify both modes?
+ (let* ((op2 (vector-ref operands 3))
+ (op2-obj (rtx-lookup (rtx-name op2))))
+ (or (rtx-result-mode op2-obj)
+ (rtx-mode op2))))
+ ;; Otherwise mode-spec is the mode to use.
+ (else mode-spec))))
+ (val (vector-ref operands op-num))
+ )
+
+ ;; Look up the canoner for this operand and perform it.
+ ;; FIXME: This would benefit from returning multiple values.
+ (let ((canoner (cdr type)))
+ (let ((canon-val (canoner val mode this-expr op-num
+ cstate env depth)))
+ (if canon-val
+ (begin
+ (set! val (car canon-val))
+ (set! env (cdr canon-val))))))
+
+ (vector-set! operands op-num val)
+
+ ;; Done with this operand, proceed to the next.
+ (loop env
+ (+ op-num 1)
+ (if varargs? arg-types (cdr arg-types))
+ (if varargs? arg-modes (cdr arg-modes)))))))))
+)
+
+(define (/rtx-canon-rtx-enum rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to enum, expecting 3"
+ (cons func args) parent-expr #f))
+
+ (let ((mode-name (cadr args))
+ (enum-name (caddr args)))
+ (let ((mode-obj (mode:lookup mode-name))
+ (enum-obj (enum-lookup-val enum-name)))
+
+ (if (not enum-obj)
+ (/rtx-canon-error cstate "unknown enum value"
+ enum-name parent-expr #f))
+
+ (let ((expr-mode-or-errmsg (/rtx-pick-mode3 requested-mode-name mode-name INT)))
+ (if (symbol? expr-mode-or-errmsg)
+ (list (car args) expr-mode-or-errmsg enum-name)
+ (/rtx-canon-error cstate expr-mode-or-errmsg
+ enum-name parent-expr #f)))))
+)
+
+(define (/rtx-canon-rtx-ifield rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to ifield, expecting 3"
+ (cons func args) parent-expr #f))
+
+ (let ((expr-mode-name (cadr args))
+ (ifld-name (caddr args)))
+ (let ((ifld-obj (current-ifld-lookup ifld-name)))
+
+ (if ifld-obj
+
+ (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
+ expr-mode-name
+ (ifld-mode ifld-obj))))
+ (if (symbol? mode-or-errmsg)
+ (list (car args) mode-or-errmsg ifld-name)
+ (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
+ parent-expr parent-op-num)))
+
+ (/rtx-canon-error cstate "unknown ifield"
+ ifld-name parent-expr #f))))
+)
+
+(define (/rtx-canon-rtx-operand rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to operand, expecting 3"
+ (cons func args) parent-expr #f))
+
+ (let ((expr-mode-name (cadr args))
+ (op-name (caddr args)))
+ (let ((op-obj (current-op-lookup op-name)))
+
+ (if op-obj
+
+ (let ((mode (/rtx-pick-op-mode cstate requested-mode-name
+ expr-mode-name op-obj parent-expr)))
+ (list (car args) mode op-name))
+
+ (/rtx-canon-error cstate "unknown operand"
+ op-name parent-expr #f))))
+)
+
+(define (/rtx-canon-rtx-xop rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to xop, expecting 3"
+ (cons func args) parent-expr #f))
+
+ (let ((expr-mode-name (cadr args))
+ (xop-obj (caddr args)))
+
+ (if (operand? xop-obj)
+
+ (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
+ expr-mode-name
+ (op:mode xop-obj))))
+ (if (symbol? mode-or-errmsg)
+ (list (car args) mode-or-errmsg xop-obj)
+ (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
+ parent-expr parent-op-num)))
+
+ (/rtx-canon-error cstate "xop operand #2 not an operand"
+ (obj:name xop-obj) parent-expr #f)))
+)
+
+(define (/rtx-canon-rtx-local rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to local, expecting 3"
+ (cons func args) parent-expr #f))
+
+ (let ((expr-mode-name (cadr args))
+ (local-name (caddr args)))
+ (let ((local-obj (rtx-temp-lookup env local-name)))
+
+ (if local-obj
+
+ (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
+ expr-mode-name
+ (rtx-temp-mode local-obj))))
+ (if (symbol? mode-or-errmsg)
+ (list (car args) mode-or-errmsg local-name)
+ (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
+ parent-expr parent-op-num)))
+
+ (/rtx-canon-error cstate "unknown local"
+ local-name parent-expr #f))))
+)
+
+(define (/rtx-canon-rtx-ref rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to ref, expecting 3"
+ (cons func args) parent-expr #f))
+
+ (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)))
+
+ (if op-obj
+
+ ;; The result of "ref" is canonically an INT.
+ (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
+ expr-mode-name
+ INT)))
+ (if (symbol? mode-or-errmsg)
+ (list (car args) mode-or-errmsg ref-name)
+ (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
+ parent-expr parent-op-num)))
+
+ (/rtx-canon-error cstate "unknown operand"
+ ref-name parent-expr #f))))
+)
+
+(define (/rtx-canon-rtx-reg rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (let ((len (length args)))
+ (if (or (< len 3) (> len 5))
+ (/rtx-canon-error cstate
+ ;; TODO: be more firm on expected number of args
+ (string-append
+ "wrong number of operands to "
+ (symbol->string func)
+ ", expecting 3 (or possibly 4,5)")
+ (cons func args) parent-expr #f))
+
+ (let ((expr-mode-name (cadr args))
+ (hw-name (caddr args))
+ (this-expr (cons func args)))
+ (let* ((hw (/rtx-lookup-hw cstate hw-name parent-expr
+ (lambda (hw)
+ (if (not (register? hw))
+ (/rtx-canon-error cstate "not a register" hw-name
+ parent-expr parent-op-num))
+ *UNSPECIFIED*)))
+ (hw-mode-obj (hw-mode hw)))
+
+ (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name
+ expr-mode-name
+ hw-mode-obj)))
+
+ (if (symbol? mode-or-errmsg)
+
+ ;; Canonicalizing optional index/selector.
+ (let ((index (if (>= len 4)
+ (let ((canon (/rtx-canon-rtx
+ (list-ref args 3) 'INT
+ this-expr 3 cstate env depth)))
+ (car canon)) ;; discard env
+ #f))
+ (sel (if (= len 5)
+ (let ((canon (/rtx-canon-rtx
+ (list-ref args 4) 'INT
+ this-expr 4 cstate env depth)))
+ (car canon)) ;; discard env
+ #f)))
+ (if sel
+ (begin
+ (assert index)
+ (list (car args) mode-or-errmsg hw-name index sel))
+ (if index
+ (list (car args) mode-or-errmsg hw-name index)
+ (list (car args) mode-or-errmsg hw-name))))
+
+ (/rtx-canon-error cstate mode-or-errmsg expr-mode-name
+ parent-expr parent-op-num))))))
+)
+
+(define (/rtx-canon-rtx-mem rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (let ((len (length args)))
+ (if (or (< len 3) (> len 4))
+ (/rtx-canon-error cstate
+ "wrong number of operands to mem, expecting 3 (or possibly 4)"
+ (cons func args) parent-expr #f))
+
+ (let ((expr-mode-name (cadr args))
+ (addr-expr (caddr args))
+ (this-expr (cons func args)))
+
+ ;; Call /rtx-canon-explnummode just for the error checking.
+ (/rtx-canon-explnummode expr-mode-name #f this-expr 1 cstate env depth)
+
+ (if (and (not (eq? requested-mode-name 'DFLT))
+ ;; FIXME: 'would prefer samesize or "no precision lost", sigh
+ (not (mode-compatible? 'sameclass
+ requested-mode-name expr-mode-name)))
+ (/rtx-canon-error cstate
+ (string-append "requested mode "
+ (symbol->string requested-mode-name)
+ " is incompatible with expression mode "
+ (symbol->string expr-mode-name))
+ this-expr parent-expr #f))
+
+ (let ((addr (car ;; discard env
+ (/rtx-canon-rtx (list-ref args 2) 'AI
+ this-expr 2 cstate env depth)))
+ (sel (if (= len 4)
+ (let ((canon (/rtx-canon-rtx (list-ref args 3) 'INT
+ this-expr 3 cstate env depth)))
+ (car canon)) ;; discard env
+ #f)))
+ (if sel
+ (list (car args) expr-mode-name addr sel)
+ (list (car args) expr-mode-name addr)))))
+)
+
+(define (/rtx-canon-rtx-const rtx-obj requested-mode-name
+ func args parent-expr parent-op-num
+ cstate env depth)
+ (if (!= (length args) 3)
+ (/rtx-canon-error cstate "wrong number of operands to const, expecting 3"
+ (cons func args) parent-expr #f))
+
+ ;; ??? floating point support is wip
+ ;; NOTE: (integer? 1.0) == #t, but (inexact? 1.0) ==> #t too.
+
+ (let ((expr-mode-name1 (if (and (eq? requested-mode-name 'DFLT)
+ (eq? (cadr args) 'DFLT))
+ 'INT
+ (cadr args)))
+ (value (caddr args))
+ (this-expr (cons func args)))
+
+ (let ((expr-mode-name (/rtx-pick-mode cstate requested-mode-name
+ expr-mode-name1)))
+
+ (if (not expr-mode-name)
+ (/rtx-canon-error cstate
+ (string-append "requested mode "
+ (symbol->string requested-mode-name)
+ " is incompatible with expression mode "
+ (symbol->string expr-mode-name1))
+ this-expr parent-expr #f))
+
+ (let ((expr-mode (mode:lookup expr-mode-name)))
+
+ (cond ((integer? value)
+ (if (not (memq (mode:class expr-mode) '(INT UINT FLOAT)))
+ (/rtx-canon-error cstate "integer value incompatible with mode"
+ value this-expr 2)))
+ ((inexact? value)
+ (if (not (memq (mode:class expr-mode) '(FLOAT)))
+ (/rtx-canon-error cstate "floating point value incompatible with mode"
+ value this-expr 2)))
+ (else
+ (/rtx-canon-error cstate
+ (string-append "expecting a"
+ (if (eq? (mode:class expr-mode) 'FLOAT)
+ " floating point"
+ "n integer")
+ " constant")
+ value this-expr 2)))
+
+ (list (car args) expr-mode-name value))))
+)
+
+;; Table of operand canonicalizers.
+;; The main one is /rtx-traverse-operands, but a few rtx functions are simple
+;; and special-purpose enough that it's simpler to have specific traversers.
+
+(define /rtx-operand-canoners #f)
+
+;; Return list of rtx functions that have special purpose canoners.
+
+(define (/rtx-special-expr-canoners)
+ (list
+ (cons 'enum /rtx-canon-rtx-enum)
+ (cons 'ifield /rtx-canon-rtx-ifield)
+ (cons 'operand /rtx-canon-rtx-operand)
+ ;;(cons 'name /rtx-canon-rtx-name) ;; ??? needed?
+ (cons 'xop /rtx-canon-rtx-xop) ;; yes, it can appear
+ (cons 'local /rtx-canon-rtx-local)
+ (cons 'ref /rtx-canon-rtx-ref)
+ ;;(cons 'index-of /rtx-canon-rtx-index-of) ;; ??? needed?
+ (cons 'reg /rtx-canon-rtx-reg)
+ (cons 'raw-reg /rtx-canon-rtx-reg)
+ (cons 'mem /rtx-canon-rtx-mem)
+ (cons 'const /rtx-canon-rtx-const)
+ )
+)
+
+;; Subroutine of rtx-munge-mode&options.
+;; Return boolean indicating if X is an rtx option.
+
+(define (/rtx-option? x)
+ (keyword? x)
+)
-; Set to #t to debug rtx traversal.
+;; Subroutine of rtx-munge-mode&options.
+;; Return boolean indicating if X is an rtx option list.
+
+(define (/rtx-option-list? x)
+ (or (null? x)
+ (and (pair? x)
+ (/rtx-option? (car x))))
+)
+
+;; Subroutine of /rtx-canon-expr to fill in the options and mode if absent.
+;; The result is the canonical form of ARGS.
+;;
+;; "munge" is an awkward name to use here, but I like it for now because
+;; it's easy to grep for.
+;; An empty option list requires a mode to be present so that the empty
+;; list in `(sequence () foo bar)' is unambiguously recognized as the locals
+;; list. Icky, sure, but less icky than the alternatives thus far.
+
+(define (rtx-munge-mode&options rtx-obj requested-mode-name func args)
+ (let ((orig-args args)
+ (options #f)
+ (mode-name #f)
+ ;; The mode in a `set' is the mode of the destination,
+ ;; whereas the mode of the result is VOID.
+ ;; The mode in a compare (e.g. `eq') is the mode of the operands,
+ ;; but the mode of the result is BI.
+ (requested-mode-name (if (rtx-result-mode rtx-obj)
+ 'DFLT ;; mode of args doesn't come from containing expr
+ 'DFLT))) ;; FIXME: requested-mode-name)))
+
+ ;; Pick off the option list if present.
+ (if (and (pair? args)
+ (/rtx-option-list? (car args))
+ ;; Handle `(sequence () foo bar)'. If empty list isn't followed
+ ;; by a mode, it is not an option list.
+ (or (not (null? (car args)))
+ (and (pair? (cdr args))
+ (mode-name? (cadr args)))))
+ (begin
+ (set! options (car args))
+ (set! args (cdr args))))
+
+ ;; Pick off the mode if present.
+ (if (and (pair? args)
+ (mode-name? (car args)))
+ (begin
+ (set! mode-name (car args))
+ (set! args (cdr args))))
+
+ ;; Now put option list and mode back.
+ ;; But don't do unnecessary consing.
+ (if options
+ (if (and mode-name (not (eq? mode-name 'DFLT)))
+ orig-args ;; can return ARGS unchanged
+ (cons options (cons requested-mode-name args)))
+ (if (and mode-name (not (eq? mode-name 'DFLT)))
+ (cons nil orig-args) ;; just need to insert options
+ (cons nil (cons requested-mode-name args)))))
+)
+
+;; Subroutine of /rtx-canon to simplify it.
+
+(define (/rtx-canon-expr rtx-obj requested-mode-name
+ func args parent-expr op-num cstate env depth)
+ (let ((args2 (rtx-munge-mode&options rtx-obj requested-mode-name func args)))
+
+ (if /rtx-canon-debug?
+ (begin
+ (display (spaces (* 4 depth)))
+ (display "Traversing operands of: ")
+ (display (rtx-dump (cons func args)))
+ (newline)
+ (display (spaces (* 4 depth)))
+ (display "Requested mode: ")
+ (display requested-mode-name)
+ (newline)
+ (display (spaces (* 4 depth)))
+ (rtx-env-dump env)
+ (force-output)))
+
+ (let* ((canoner (vector-ref /rtx-operand-canoners (rtx-num rtx-obj)))
+ (operands (canoner rtx-obj requested-mode-name
+ func args2 parent-expr op-num
+ cstate env (+ depth 1))))
+ (cons func operands)))
+)
+
+;; Convert rtl expression EXPR from source form to canonical form.
+;; The expression is validated and rtx macros are expanded as well.
+;; Plus DFLT mode is converted to a useful mode.
+;; The result is EXPR in canonical form.
+;;
+;; CSTATE is a <cstate> object or #f if there is none.
+;; It is used in error messages.
+
+(define (/rtx-canon expr expected mode parent-expr op-num cstate env depth)
+ (if /rtx-canon-debug?
+ (begin
+ (display (spaces (* 4 depth)))
+ (display "Canonicalizing (")
+ (display mode)
+ (display "): ")
+ (display (rtx-dump expr))
+ (newline)
+ (display (spaces (* 4 depth)))
+ (rtx-env-dump env)
+ (force-output)
+ ))
+
+ (let ((result
+ (if (pair? expr) ;; pair? -> cheap non-null-list?
+
+ (let ((rtx-obj (rtx-lookup (car expr))))
+ (if rtx-obj
+ (/rtx-canon-expr rtx-obj mode (car expr) (cdr expr)
+ parent-expr op-num cstate env depth)
+ (let ((rtx-obj (/rtx-macro-lookup (car expr))))
+ (if rtx-obj
+ (/rtx-canon (/rtx-macro-expand expr rtx-evaluator)
+ expected mode parent-expr op-num cstate env (+ depth 1))
+ (/rtx-canon-error cstate "unknown rtx function"
+ expr parent-expr op-num)))))
+
+ ;; EXPR is not a list.
+ ;; See if it's an operand shortcut.
+ (if (memq expected '(RTX SETRTX))
+
+ (cond ((symbol? expr)
+ (cond ((current-op-lookup expr)
+ => (lambda (op)
+ ;; NOTE: We can't simply call
+ ;; op:mode-name here, we need the real
+ ;; mode, not (potentially) DFLT.
+ ;; See /rtx-pick-op-mode.
+ (rtx-make-operand (/rtx-pick-op-mode cstate mode 'DFLT op parent-expr)
+ expr)))
+ ((rtx-temp-lookup env expr)
+ => (lambda (tmp)
+ (rtx-make-local (obj:name (rtx-temp-mode tmp)) expr)))
+ ((current-ifld-lookup expr)
+ => (lambda (f)
+ (rtx-make-ifield (obj:name (ifld-mode f)) expr)))
+ ((enum-lookup-val expr)
+ ;; ??? If enums could have modes other than INT,
+ ;; we'd want to propagate that mode here.
+ (rtx-make-enum 'INT expr))
+ (else
+ (/rtx-canon-error cstate "unknown operand"
+ expr parent-expr op-num))))
+ ((integer? expr)
+ (rtx-make-const 'INT expr))
+ (else
+ (/rtx-canon-error cstate "unexpected operand"
+ expr parent-expr op-num)))
+
+ ;; Not expecting RTX or SETRTX.
+ (/rtx-canon-error cstate "unexpected operand"
+ expr parent-expr op-num)))))
+
+ (if /rtx-canon-debug?
+ (begin
+ (display (spaces (* 4 depth)))
+ (display "Result: ")
+ (display (rtx-dump result))
+ (newline)
+ (force-output)
+ ))
+
+ result)
+)
+
+;; Public entry point.
+;; Convert rtl expression EXPR from source form to canonical form.
+;; The expression is validated and rtx macros are expanded as well.
+;; Plus operand shortcuts are expanded:
+;; - numbers -> (const number)
+;; - operand-name -> (operand operand-name)
+;; - ifield-name -> (ifield ifield-name)
+;; Plus an absent option list is replaced with ().
+;; Plus DFLT mode is converted to a useful mode.
+;;
+;; The result is EXPR in canonical form.
+;;
+;; CONTEXT is a <context> object or #f if there is none.
+;; It is used in error messages.
+;;
+;; 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)
+ (let ((result
+ (/rtx-canon expr 'RTX mode-name #f 0
+ (/make-cstate context 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)
+)
+\f
+;; RTL expression traversal support.
+;; This is for analyzing the semantics in some way.
+;; The rtl must already be in canonical form.
+
+;; Set to #t to debug rtx traversal.
(define /rtx-traverse-debug? #f)
; lookup the function which will then process the expression.
; It is applied recursively to the expression and each sub-expression.
; It must be defined as
-; (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) ...).
-; MODE is the name of the mode.
+; (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) ...).
; If the result of EXPR-FN is a lambda, it is applied to
-; (cons TSTATE (cdr EXPR)). TSTATE is prepended to the arguments.
+; (cons TSTATE EXPR), TSTATE is prepended to the arguments.
; For syntax expressions if the result of EXPR-FN is #f, the operands are
; processed using the builtin traverser.
; So to repeat: EXPR-FN can process the expression, and if its result is a
; lambda then it also processes the expression. The arguments to EXPR-FN
-; are (rtx-obj expr mode parent-expr op-pos tstate appstuff). The format
-; of the result of EXPR-FN are (cons TSTATE (cdr EXPR)).
+; are (rtx-obj expr parent-expr op-pos tstate appstuff). The format
+; of the result of EXPR-FN are (cons TSTATE EXPR).
; The reason for the duality is that when trying to understand EXPR (e.g. when
; 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.
; track of whether an operand has been assigned to (or potentially read from)
; if it's known it's always assigned to.
;
-; SET? is a boolean indicating if the current expression is an operand being
-; set.
-;
; OWNER is the owner of the expression or #f if there is none.
; Typically it is an <insn> object.
;
;
; DEPTH is the current traversal depth.
-(define (tstate-make context owner expr-fn env cond? set? known depth)
- (vector context owner expr-fn env cond? set? known 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-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-set? state) (vector-ref state 5))
-(define (tstate-set-set?! 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))
+(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))
; Create a copy of STATE.
result)
)
-; Create a copy of STATE with a new SET? value.
-
-(define (tstate-new-set? state set?)
- (let ((result (tstate-copy state)))
- (tstate-set-set?! result set?)
- result)
-)
-
; Lookup NAME in the known value table.
; Returns the value or #f if not found.
; The value is either a const rtx or a number-list rtx.
(cons errmsg expr)))))
)
\f
-; Traversal/compilation support.
+; Traversal support.
; Return a boolean indicating if X is a mode.
; Traverse a list of rtx's.
-(define (/rtx-traverse-rtx-list rtx-list mode expr op-num tstate appstuff)
+(define (/rtx-traverse-rtx-list rtx-list expr op-num tstate appstuff)
(map (lambda (rtx)
; ??? Shouldn't OP-NUM change for each element?
- (/rtx-traverse rtx 'RTX mode expr op-num tstate appstuff))
+ (/rtx-traverse rtx 'RTX expr op-num tstate appstuff))
rtx-list)
)
(define (/rtx-traverse-error tstate errmsg rtl-expr op-num)
(tstate-error tstate
(string-append errmsg ", operand #" (number->string op-num))
- (rtx-strdump rtl-expr))
+ (rtx-dump rtl-expr))
)
; Rtx traversers.
-; These are defined as individual functions that are then built into a table
-; so that we can use Hobbit's "fastcall" support.
;
; The result is either a pair of the parsed VAL and new TSTATE,
; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
-(define (/rtx-traverse-options val mode expr op-num tstate appstuff)
- #f
-)
-
-(define (/rtx-traverse-anymode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (not val-obj)
- (/rtx-traverse-error tstate "expecting a mode"
- expr op-num))
- #f)
-)
-
-(define (/rtx-traverse-intmode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (and val-obj
- (or (memq (mode:class val-obj) '(INT UINT))
- (eq? val 'DFLT)))
- #f
- (/rtx-traverse-error tstate "expecting an integer mode"
- expr op-num)))
-)
-
-(define (/rtx-traverse-floatmode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (and val-obj
- (or (memq (mode:class val-obj) '(FLOAT))
- (eq? val 'DFLT)))
- #f
- (/rtx-traverse-error tstate "expecting a float mode"
- expr op-num)))
-)
-
-(define (/rtx-traverse-nummode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (and val-obj
- (or (memq (mode:class val-obj) '(INT UINT FLOAT))
- (eq? val 'DFLT)))
- #f
- (/rtx-traverse-error tstate "expecting a numeric mode"
- expr op-num)))
-)
-
-(define (/rtx-traverse-explnummode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (not val-obj)
- (/rtx-traverse-error tstate "expecting a mode"
- expr op-num))
- (if (memq val '(DFLT VOID))
- (/rtx-traverse-error tstate "DFLT and VOID not allowed here"
- expr op-num))
- #f)
-)
-
-(define (/rtx-traverse-nonvoidmode val mode expr op-num tstate appstuff)
- (if (eq? val 'VOID)
- (/rtx-traverse-error tstate "mode can't be VOID"
- expr op-num))
+(define (/rtx-traverse-normal-operand val expr op-num tstate appstuff)
#f
)
-(define (/rtx-traverse-voidmode val mode expr op-num tstate appstuff)
- (if (memq val '(DFLT VOID))
- #f
- (/rtx-traverse-error tstate "expecting mode VOID"
- expr op-num))
-)
-
-(define (/rtx-traverse-dfltmode val mode expr op-num tstate appstuff)
- (if (eq? val 'DFLT)
- #f
- (/rtx-traverse-error tstate "expecting mode DFLT"
- expr op-num))
-)
-
-(define (/rtx-traverse-rtx val mode expr op-num tstate appstuff)
-; Commented out 'cus it doesn't quite work yet.
-; (if (not (rtx? val))
-; (/rtx-traverse-error tstate "expecting an rtx"
-; expr op-num))
- (cons (/rtx-traverse val 'RTX mode expr op-num tstate appstuff)
+(define (/rtx-traverse-rtx val expr op-num tstate appstuff)
+ (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff)
tstate)
)
-(define (/rtx-traverse-setrtx val mode expr op-num tstate appstuff)
- ; FIXME: Still need to turn it off for sub-exprs.
- ; e.g. (mem (reg ...))
-; Commented out 'cus it doesn't quite work yet.
-; (if (not (rtx? val))
-; (/rtx-traverse-error tstate "expecting an rtx"
-; expr op-num))
- (cons (/rtx-traverse val 'SETRTX mode expr op-num
- (tstate-new-set? tstate #t)
- appstuff)
+(define (/rtx-traverse-setrtx val expr op-num tstate appstuff)
+ (cons (/rtx-traverse val 'SETRTX expr op-num tstate appstuff)
tstate)
)
; This is the test of an `if'.
-(define (/rtx-traverse-testrtx val mode expr op-num tstate appstuff)
-; Commented out 'cus it doesn't quite work yet.
-; (if (not (rtx? val))
-; (/rtx-traverse-error tstate "expecting an rtx"
-; expr op-num))
- (cons (/rtx-traverse val 'RTX mode expr op-num tstate appstuff)
+(define (/rtx-traverse-testrtx val expr op-num tstate appstuff)
+ (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff)
(tstate-new-cond?
tstate
(not (rtx-compile-time-constant? val))))
)
-(define (/rtx-traverse-condrtx val mode expr op-num tstate appstuff)
- (if (not (pair? val))
- (/rtx-traverse-error tstate "expecting an expression"
- expr op-num))
+(define (/rtx-traverse-condrtx val expr op-num tstate appstuff)
(if (eq? (car val) 'else)
- (begin
- (if (!= (+ op-num 2) (length expr))
- (/rtx-traverse-error tstate
- "`else' clause not last"
- expr op-num))
- (cons (cons 'else
- (/rtx-traverse-rtx-list
- (cdr val) mode expr op-num
- (tstate-new-cond? tstate #t)
- appstuff))
- (tstate-new-cond? tstate #t)))
+ (cons (cons 'else
+ (/rtx-traverse-rtx-list
+ (cdr val) expr op-num
+ (tstate-new-cond? tstate #t)
+ appstuff))
+ (tstate-new-cond? tstate #t))
(cons (cons
; ??? Entries after the first are conditional.
- (/rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff)
+ (/rtx-traverse (car val) 'RTX expr op-num tstate appstuff)
(/rtx-traverse-rtx-list
- (cdr val) mode expr op-num
+ (cdr val) expr op-num
(tstate-new-cond? tstate #t)
appstuff))
(tstate-new-cond? tstate #t)))
)
-(define (/rtx-traverse-casertx val mode expr op-num tstate appstuff)
- (if (or (not (list? val))
- (< (length val) 2))
- (/rtx-traverse-error tstate
- "invalid `case' expression"
- expr op-num))
- ; car is either 'else or list of symbols/numbers
- (if (not (or (eq? (car val) 'else)
- (and (list? (car val))
- (not (null? (car val)))
- (all-true? (map /rtx-symornum?
- (car val))))))
- (/rtx-traverse-error tstate
- "invalid `case' choice"
- expr op-num))
- (if (and (eq? (car val) 'else)
- (!= (+ op-num 2) (length expr)))
- (/rtx-traverse-error tstate "`else' clause not last"
- expr op-num))
+(define (/rtx-traverse-casertx val expr op-num tstate appstuff)
(cons (cons (car val)
(/rtx-traverse-rtx-list
- (cdr val) mode expr op-num
+ (cdr val) expr op-num
(tstate-new-cond? tstate #t)
appstuff))
(tstate-new-cond? tstate #t))
)
-(define (/rtx-traverse-locals val mode expr op-num tstate appstuff)
- (if (not (list? val))
- (/rtx-traverse-error tstate "bad locals list"
- expr op-num))
- (for-each (lambda (var)
- (if (or (not (list? var))
- (!= (length var) 2)
- (not (/rtx-any-mode? (car var)))
- (not (symbol? (cadr var))))
- (/rtx-traverse-error tstate
- "bad locals list"
- expr op-num)))
- val)
+(define (/rtx-traverse-locals val expr op-num tstate appstuff)
(let ((env (rtx-env-make-locals val)))
(cons val (tstate-push-env tstate env)))
)
-(define (/rtx-traverse-iteration val mode expr op-num tstate appstuff)
- (if (not (symbol? val))
- (/rtx-traverse-error tstate "bad iteration variable name"
- expr op-num))
+(define (/rtx-traverse-iteration val expr op-num tstate appstuff)
(let ((env (rtx-env-make-iteration-locals val)))
(cons val (tstate-push-env tstate env)))
)
-(define (/rtx-traverse-env val mode expr op-num tstate appstuff)
- ; VAL is an environment stack.
- (if (not (list? val))
- (/rtx-traverse-error tstate "environment not a list"
- expr op-num))
+(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 mode expr op-num tstate appstuff)
+(define (/rtx-traverse-attrs val expr op-num tstate appstuff)
; (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
; tstate)
#f
)
-(define (/rtx-traverse-symbol val mode expr op-num tstate appstuff)
- (if (not (symbol? val))
- (/rtx-traverse-error tstate "expecting a symbol"
- expr op-num))
- #f
-)
-
-(define (/rtx-traverse-string val mode expr op-num tstate appstuff)
- (if (not (string? val))
- (/rtx-traverse-error tstate "expecting a string"
- expr op-num))
- #f
-)
-
-(define (/rtx-traverse-number val mode expr op-num tstate appstuff)
- (if (not (number? val))
- (/rtx-traverse-error tstate "expecting a number"
- expr op-num))
- #f
-)
-
-(define (/rtx-traverse-symornum val mode expr op-num tstate appstuff)
- (if (not (or (symbol? val) (number? val)))
- (/rtx-traverse-error tstate
- "expecting a symbol or number"
- expr op-num))
- #f
-)
-
-(define (/rtx-traverse-object val mode expr op-num tstate appstuff)
- #f
-)
-
; Table of rtx traversers.
; This is a vector of size rtx-max-num.
; Each entry is a list of (arg-type-name . traverser) elements
(let ((hash-tab (make-hash-table 31))
(traversers
(list
- ; /fastcall-make is recognized by Hobbit and handled specially.
- ; When not using Hobbit it is a macro that returns its argument.
- (cons 'OPTIONS (/fastcall-make /rtx-traverse-options))
- (cons 'ANYMODE (/fastcall-make /rtx-traverse-anymode))
- (cons 'INTMODE (/fastcall-make /rtx-traverse-intmode))
- (cons 'FLOATMODE (/fastcall-make /rtx-traverse-floatmode))
- (cons 'NUMMODE (/fastcall-make /rtx-traverse-nummode))
- (cons 'EXPLNUMMODE (/fastcall-make /rtx-traverse-explnummode))
- (cons 'NONVOIDMODE (/fastcall-make /rtx-traverse-nonvoidmode))
- (cons 'VOIDMODE (/fastcall-make /rtx-traverse-voidmode))
- (cons 'DFLTMODE (/fastcall-make /rtx-traverse-dfltmode))
- (cons 'RTX (/fastcall-make /rtx-traverse-rtx))
- (cons 'SETRTX (/fastcall-make /rtx-traverse-setrtx))
- (cons 'TESTRTX (/fastcall-make /rtx-traverse-testrtx))
- (cons 'CONDRTX (/fastcall-make /rtx-traverse-condrtx))
- (cons 'CASERTX (/fastcall-make /rtx-traverse-casertx))
- (cons 'LOCALS (/fastcall-make /rtx-traverse-locals))
- (cons 'ITERATION (/fastcall-make /rtx-traverse-iteration))
- (cons 'ENV (/fastcall-make /rtx-traverse-env))
- (cons 'ATTRS (/fastcall-make /rtx-traverse-attrs))
- (cons 'SYMBOL (/fastcall-make /rtx-traverse-symbol))
- (cons 'STRING (/fastcall-make /rtx-traverse-string))
- (cons 'NUMBER (/fastcall-make /rtx-traverse-number))
- (cons 'SYMORNUM (/fastcall-make /rtx-traverse-symornum))
- (cons 'OBJECT (/fastcall-make /rtx-traverse-object))
+ (cons 'OPTIONS /rtx-traverse-normal-operand)
+ (cons 'ANYINTMODE /rtx-traverse-normal-operand)
+ (cons 'ANYFLOATMODE /rtx-traverse-normal-operand)
+ (cons 'ANYNUMMODE /rtx-traverse-normal-operand)
+ (cons 'ANYEXPRMODE /rtx-traverse-normal-operand)
+ (cons 'EXPLNUMMODE /rtx-traverse-normal-operand)
+ (cons 'VOIDORNUMMODE /rtx-traverse-normal-operand)
+ (cons 'VOIDMODE /rtx-traverse-normal-operand)
+ (cons 'BIMODE /rtx-traverse-normal-operand)
+ (cons 'INTMODE /rtx-traverse-normal-operand)
+ (cons 'SYMMODE /rtx-traverse-normal-operand)
+ (cons 'INSNMODE /rtx-traverse-normal-operand)
+ (cons 'MACHMODE /rtx-traverse-normal-operand)
+ (cons 'RTX /rtx-traverse-rtx)
+ (cons 'SETRTX /rtx-traverse-setrtx)
+ (cons 'TESTRTX /rtx-traverse-testrtx)
+ (cons 'CONDRTX /rtx-traverse-condrtx)
+ (cons 'CASERTX /rtx-traverse-casertx)
+ (cons 'LOCALS /rtx-traverse-locals)
+ (cons 'ITERATION /rtx-traverse-iteration)
+ (cons 'ENV /rtx-traverse-env)
+ (cons 'ATTRS /rtx-traverse-attrs)
+ (cons 'SYMBOL /rtx-traverse-normal-operand)
+ (cons 'STRING /rtx-traverse-normal-operand)
+ (cons 'NUMBER /rtx-traverse-normal-operand)
+ (cons 'SYMORNUM /rtx-traverse-normal-operand)
+ (cons 'OBJECT /rtx-traverse-normal-operand)
)))
(for-each (lambda (traverser)
)
; Traverse the operands of EXPR, a canonicalized RTL expression.
-; Here "canonicalized" means that /rtx-munge-mode&options has been called to
-; insert an option list and mode if they were absent in the original
-; expression.
+; Here "canonicalized" means that EXPR has been run through rtx-canonicalize.
; Note that this means that, yes, the options and mode are "traversed" too.
(define (/rtx-traverse-operands rtx-obj expr tstate appstuff)
(display (rtx-dump expr))
(newline)
(rtx-env-dump (tstate-env tstate))
- (force-output)
- ))
+ (force-output)))
(let loop ((operands (cdr expr))
(op-num 0)
(arg-types (vector-ref /rtx-traverser-table (rtx-num rtx-obj)))
(arg-modes (rtx-arg-modes rtx-obj))
- (result nil)
- )
+ (result nil))
(let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
(display (if varargs? arg-modes (car arg-modes)))
))
(newline)
- (force-output)
- ))
+ (force-output)))
(cond ((null? operands)
- ; Out of operands, check if we have the expected number.
+ ;; Out of operands, check if we have the expected number.
(if (or (null? arg-types)
varargs?)
(reverse! result)
- (tstate-error tstate "missing operands" (rtx-strdump expr))))
+ (tstate-error tstate "missing operands" (rtx-dump expr))))
((null? arg-types)
- (tstate-error tstate "too many operands" (rtx-strdump expr)))
+ (tstate-error tstate "too many operands" (rtx-dump expr)))
(else
- (let ((type (if varargs? arg-types (car arg-types)))
- (mode (let ((mode-spec (if varargs?
- arg-modes
- (car arg-modes))))
- ; This is small enough that this is fast enough,
- ; and the number of entries should be stable.
- ; FIXME: for now
- (case mode-spec
- ((ANY) 'DFLT)
- ((NA) #f)
- ((OP0) (rtx-mode expr))
- ((MATCH1)
- ; If there is an explicit mode, use it.
- ; Otherwise we have to look at operand 1.
- (if (eq? (rtx-mode expr) 'DFLT)
- 'DFLT
- (rtx-mode expr)))
- ((MATCH2)
- ; If there is an explicit mode, use it.
- ; Otherwise we have to look at operand 2.
- (if (eq? (rtx-mode expr) 'DFLT)
- 'DFLT
- (rtx-mode expr)))
- (else mode-spec))))
- (val (car operands))
- )
-
- ; Look up the traverser for this kind of operand and perform it.
+ (let* ((val (car operands))
+ (type (if varargs? arg-types (car arg-types))))
+
+ ;; Look up the traverser for this kind of operand and perform it.
+ ;; FIXME: This would benefit from returning multiple values.
(let ((traverser (cdr type)))
- (let ((traversed-val (fastcall6 traverser val mode expr op-num tstate appstuff)))
+ (let ((traversed-val (traverser val expr op-num tstate appstuff)))
(if traversed-val
(begin
(set! val (car traversed-val))
(set! tstate (cdr traversed-val))))))
- ; Done with this operand, proceed to the next.
+ ;; Done with this operand, proceed to the next.
(loop (cdr operands)
(+ op-num 1)
(if varargs? arg-types (cdr arg-types))
(define rtx-traverse-operands /rtx-traverse-operands)
-; Subroutine of /rtx-munge-mode&options.
-; Return boolean indicating if X is an rtx option.
-
-(define (/rtx-option? x)
- (and (symbol? x)
- (char=? (string-ref (symbol->string x) 0) #\:))
-)
-
-; Subroutine of /rtx-munge-mode&options.
-; Return boolean indicating if X is an rtx option list.
-
-(define (/rtx-option-list? x)
- (or (null? x)
- (and (pair? x)
- (/rtx-option? (car x))))
-)
-
-; Subroutine of /rtx-traverse-expr to fill in the mode if absent and to
-; collect the options into one list.
-;
-; ARGS is the list of arguments to the rtx function
-; (e.g. (1 2) in (add 1 2)).
-; ??? "munge" is an awkward name to use here, but I like it for now because
-; it's easy to grep for.
-; ??? An empty option list requires a mode to be present so that the empty
-; list in `(sequence () foo bar)' is unambiguously recognized as the locals
-; list. Icky, sure, but less icky than the alternatives thus far.
-
-(define (/rtx-munge-mode&options args)
- (let ((options nil)
- (mode-name 'DFLT))
- ; Pick off the option list if present.
- (if (and (pair? args)
- (/rtx-option-list? (car args))
- ; Handle `(sequence () foo bar)'. If empty list isn't followed
- ; by a mode, it is not an option list.
- (or (not (null? (car args)))
- (and (pair? (cdr args))
- (mode-name? (cadr args)))))
- (begin
- (set! options (car args))
- (set! args (cdr args))))
- ; Pick off the mode if present.
- (if (and (pair? args)
- (mode-name? (car args)))
- (begin
- (set! mode-name (car args))
- (set! args (cdr args))))
- ; Now put option list and mode back.
- (cons options (cons mode-name args)))
-)
-
; Subroutine of /rtx-traverse to traverse an expression.
;
; RTX-OBJ is the <rtx-func> object of the (outer) expression being traversed.
;
; EXPR is the expression to be traversed.
-;
-; MODE is the name of the mode of EXPR.
+; It must be fully canonical.
;
; PARENT-EXPR is the expression EXPR is contained in. The top-level
; caller must pass #f for it.
; This is for semantic-compile's sake and all traversal handlers are
; required to do this if the expr-fn returns #f.
-(define (/rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
- (let* ((expr2 (cons (car expr)
- (/rtx-munge-mode&options (cdr expr))))
- (fn (fastcall7 (tstate-expr-fn tstate)
- rtx-obj expr2 mode parent-expr op-pos tstate appstuff)))
+(define (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff)
+ (let ((fn ((tstate-expr-fn tstate)
+ rtx-obj expr parent-expr op-pos tstate appstuff)))
(if fn
(if (procedure? fn)
; Don't traverse operands for syntax expressions.
- (if (rtx-style-syntax? rtx-obj)
- (apply fn (cons tstate (cdr expr2)))
- (let ((operands (/rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
+ (if (eq? (rtx-style rtx-obj) 'SYNTAX)
+ (apply fn (cons tstate cdr expr))
+ (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff)))
(apply fn (cons tstate operands))))
fn)
- (let ((operands (/rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
- (cons (car expr2) operands))))
+ (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff)))
+ (cons (car expr) operands))))
)
; Main entry point for expression traversal.
; in the case of operands.
;
; EXPR is the expression to be traversed.
+; It must be fully canonical.
;
; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
; or #f if it doesn't matter.
;
-; MODE is the name of the mode of EXPR.
-;
; PARENT-EXPR is the expression EXPR is contained in. The top-level
; caller must pass #f for it.
;
; - operands, ifields, and numbers appearing where an rtx is expected are
; converted to use `operand', `ifield', or `const'.
-(define (/rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
+(define (/rtx-traverse expr expected parent-expr op-pos tstate appstuff)
(if /rtx-traverse-debug?
(begin
(display (spaces (* 4 (tstate-depth tstate))))
(display "-expected: ")
(display expected)
(newline)
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "-mode: ")
- (display mode)
- (newline)
(force-output)
))
+ ;; FIXME: error checking here should be deleteable.
+
(if (pair? expr) ; pair? -> cheap non-null-list?
(let ((rtx-obj (rtx-lookup (car expr))))
(tstate-incr-depth! tstate)
(let ((result
(if rtx-obj
- (/rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff)
(let ((rtx-obj (/rtx-macro-lookup (car expr))))
(if rtx-obj
(/rtx-traverse (/rtx-macro-expand expr rtx-evaluator)
- expected mode parent-expr op-pos tstate appstuff)
+ expected parent-expr op-pos tstate appstuff)
(tstate-error tstate "unknown rtx function" expr))))))
(tstate-decr-depth! tstate)
result))
(cond ((symbol? expr)
(cond ((current-op-lookup expr)
- (/rtx-traverse
- (rtx-make-operand expr) ; (current-op-lookup expr))
- expected mode parent-expr op-pos tstate appstuff))
+ => (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-traverse
- (rtx-make-local expr) ; (rtx-temp-lookup (tstate-env tstate) expr))
- expected mode parent-expr op-pos tstate appstuff))
+ => (lambda (tmp)
+ (/rtx-traverse
+ (rtx-make-local (rtx-temp-mode tmp) expr)
+ expected parent-expr op-pos tstate appstuff)))
((current-ifld-lookup expr)
- (/rtx-traverse
- (rtx-make-ifield expr)
- expected mode parent-expr op-pos tstate appstuff))
+ => (lambda (f)
+ (/rtx-traverse
+ (rtx-make-ifield (obj:name (ifld-mode f)) expr)
+ expected parent-expr op-pos tstate appstuff)))
((enum-lookup-val expr)
;; ??? If enums could have modes other than INT,
;; we'd want to propagate that mode here.
(/rtx-traverse
(rtx-make-enum 'INT expr)
- expected mode parent-expr op-pos tstate appstuff))
+ expected parent-expr op-pos tstate appstuff))
(else
(tstate-error tstate "unknown operand" expr))))
((integer? expr)
(/rtx-traverse (rtx-make-const 'INT expr)
- expected mode parent-expr op-pos tstate appstuff))
+ expected parent-expr op-pos tstate appstuff))
(else
(tstate-error tstate "unexpected operand" expr)))
)
; User visible procedures to traverse an rtl expression.
+; EXPR must be fully canonical (i.e. compiled).
; 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.
; APPSTUFF is for application specific use.
(define (rtx-traverse context owner expr expr-fn appstuff)
- (/rtx-traverse expr #f 'DFLT #f 0
+ (/rtx-traverse expr #f #f 0
(tstate-make context owner expr-fn (rtx-env-empty-stack)
- #f #f nil 0)
+ #f nil 0)
appstuff)
)
(define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
- (/rtx-traverse expr #f 'DFLT #f 0
+ (/rtx-traverse expr #f #f 0
(tstate-make context owner expr-fn
(rtx-env-push (rtx-env-empty-stack)
(rtx-env-make-locals locals))
- #f #f nil 0)
+ #f nil 0)
appstuff)
)
; Traverser debugger.
+; This just traverses EXPR printing everything it sees.
(define (rtx-traverse-debug expr)
(rtx-traverse
#f #f expr
- (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (lambda (rtx-obj expr parent-expr op-pos tstate appstuff)
(display "-expr: ")
(display (string-append "rtx=" (obj:str-name rtx-obj)))
(display " expr=")
(display expr)
- (display " mode=")
- (display mode)
(display " parent=")
(display parent-expr)
(display " op-pos=")
; RTX expression evaluator.
;
-; EXPR is the expression to be eval'd. It must be in compiled form.
-; MODE is the mode of EXPR, a <mode> object.
+; EXPR is the expression to be eval'd. It must be in compiled(canonical) form.
+; MODE is the desired mode of EXPR, a <mode> object.
; ESTATE is the current evaluation state.
(define (rtx-eval-with-estate expr mode estate)
(if /rtx-eval-debug?
(begin
- (display "Traversing ")
- (display expr)
+ (display "Evaluating expr with mode ")
+ (display (if (symbol? mode) mode (obj:name mode)))
+ (newline)
+ (display (rtx-dump expr))
(newline)
(rtx-env-dump (estate-env estate))
))
(if (procedure? fn)
(apply fn (cons estate (cdr expr)))
; ; Don't eval operands for syntax expressions.
-; (if (rtx-style-syntax? rtx-obj)
+; (if (eq? (rtx-style rtx-obj) 'SYNTAX)
; (apply fn (cons estate (cdr expr)))
; (let ((operands
; (/rtx-eval-operands rtx-obj expr estate)))
)
; Evaluate rtx expression EXPR and return the computed value.
-; EXPR must already be in compiled form (the result of rtx-compile).
+; 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.
; FIXME: context?
(define (rtx-value expr owner)
(rtx-eval-with-estate expr DFLT (estate-make-for-eval #f owner))
)
+\f
+;; Initialize the tables.
+
+(define (rtx-init-traversal-tables!)
+ (let ((compiler-hash-table (/rtx-make-canon-table))
+ (traverser-hash-table (/rtx-make-traverser-table)))
+
+ (set! /rtx-canoner-table (make-vector (rtx-max-num) #f))
+ (set! /rtx-traverser-table (make-vector (rtx-max-num) #f))
+
+ (for-each (lambda (rtx-name)
+ (let ((rtx (rtx-lookup rtx-name)))
+ (if rtx
+ (let ((num (rtx-num rtx))
+ (arg-types (rtx-arg-types rtx)))
+ (vector-set! /rtx-canoner-table num
+ (map1-improper
+ (lambda (arg-type)
+ (cons arg-type
+ (hashq-ref compiler-hash-table arg-type)))
+ arg-types))
+ (vector-set! /rtx-traverser-table num
+ (map1-improper
+ (lambda (arg-type)
+ (cons arg-type
+ (hashq-ref traverser-hash-table arg-type)))
+ arg-types))))))
+ (rtx-name-list)))
+
+ (set! /rtx-operand-canoners (make-vector (rtx-max-num) /rtx-canon-operands))
+ (for-each (lambda (rtx-canoner)
+ (let ((rtx-obj (rtx-lookup (car rtx-canoner))))
+ (vector-set! /rtx-operand-canoners (rtx-num rtx-obj) (cdr rtx-canoner))))
+ (/rtx-special-expr-canoners))
+)
;; In particular:
;; rtx-simplify
;; rtx-solve
-;; rtx-canonicalize
-;; rtx-compile
;; rtx-trim-for-doc
\f
+;; Utility to verify there are no DFLT modes present in EXPR
+
+;; Subroutine of rtx-verify-no-dflt-modes to simplify it.
+;; This is the EXPR-FN argument to rtl-traverse.
+
+(define (/rtx-verify-no-dflt-modes-expr-fn rtx-obj expr parent-expr op-pos
+ tstate appstuff)
+ (if (eq? (rtx-mode expr) 'DFLT)
+ (tstate-error tstate "DFLT mode present" expr))
+
+ ;; Leave EXPR unchanged and continue.
+ #f
+)
+
+;; Entry point. Verify there are no DFLT modes in EXPR.
+
+(define (rtx-verify-no-dflt-modes context expr)
+ (rtx-traverse context #f expr /rtx-verify-no-dflt-modes-expr-fn #f)
+)
+\f
;; rtx-simplify (and supporting cast)
; Subroutine of /rtx-simplify-expr-fn to compare two values for equality.
; Subroutine of rtx-simplify.
; This is the EXPR-FN argument to rtx-traverse.
-; MODE is the name of the mode.
-(define (/rtx-simplify-expr-fn rtx-obj expr mode parent-expr op-pos
+(define (/rtx-simplify-expr-fn rtx-obj expr parent-expr op-pos
tstate appstuff)
;(display "Processing ") (display (rtx-dump expr)) (newline)
((not)
(let* ((arg (/rtx-traverse (rtx-alu-op-arg expr 0)
- 'RTX
- (rtx-alu-op-mode expr)
- expr 1 tstate appstuff))
+ 'RTX expr 1 tstate appstuff))
(no-side-effects? (not (rtx-side-effects? arg))))
(cond ((and no-side-effects? (rtx-false? arg))
(rtx-true))
((orif)
(let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
- 'RTX 'DFLT expr 0 tstate appstuff))
+ 'RTX expr 0 tstate appstuff))
(arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
- 'RTX 'DFLT expr 1 tstate appstuff)))
+ 'RTX expr 1 tstate appstuff)))
(let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
(no-side-effects-1? (not (rtx-side-effects? arg1))))
(cond ((and no-side-effects-0? (rtx-true? arg0))
((andif)
(let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
- 'RTX 'DFLT expr 0 tstate appstuff))
+ 'RTX expr 0 tstate appstuff))
(arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
- 'RTX 'DFLT expr 1 tstate appstuff)))
+ 'RTX expr 1 tstate appstuff)))
(let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
(no-side-effects-1? (not (rtx-side-effects? arg1))))
(cond ((and no-side-effects-0? (rtx-false? arg0))
; ??? Was this but that calls rtx-traverse again which
; resets the temp stack!
; (rtx-simplify context (caddr expr))))
- (/rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff)))
+ (/rtx-traverse (rtx-if-test expr) 'RTX expr 1 tstate appstuff)))
(cond ((rtx-true? test)
- (/rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff))
+ (/rtx-traverse (rtx-if-then expr) 'RTX expr 2 tstate appstuff))
((rtx-false? test)
(if (rtx-if-else expr)
- (/rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff)
+ (/rtx-traverse (rtx-if-else expr) 'RTX expr 3 tstate appstuff)
; Sanity check, mode must be VOID.
+ ; FIXME: DFLT can no longer appear
(if (or (mode:eq? 'DFLT (rtx-mode expr))
(mode:eq? 'VOID (rtx-mode expr)))
- (rtx-make 'nop)
+ (rtx-make 'nop 'VOID)
(error "rtx-simplify: non-void-mode `if' missing `else' part" expr))))
; Can't simplify.
; We could traverse the then/else clauses here, but it's simpler
(let ((name (rtx-name expr))
(cmp-mode (rtx-cmp-op-mode expr))
(arg0 (/rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
- (rtx-cmp-op-mode expr)
expr 1 tstate appstuff))
(arg1 (/rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
- (rtx-cmp-op-mode expr)
expr 2 tstate appstuff)))
(if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
(rtx-make name cmp-mode arg0 arg1)
; Simplify an rtl expression.
;
-; EXPR must be in source form.
+; EXPR must be in canonical source form.
; The result is a possibly simplified EXPR, still in source form.
;
; CONTEXT is a <context> object or #f, used for error messages.
; ??? Will become more intelligent as needed.
(define (rtx-simplify context owner expr known)
- (/rtx-traverse expr #f 'DFLT #f 0
+ (/rtx-traverse expr #f #f 0
(tstate-make context owner
- (/fastcall-make /rtx-simplify-expr-fn)
+ /rtx-simplify-expr-fn
(rtx-env-empty-stack)
- #f #f known 0)
+ #f known 0)
#f)
)
;; CONTEXT is a <context> object or #f, used for error messages.
(define (rtx-simplify-insn context insn)
- (rtx-simplify context insn (insn-semantics insn)
+ (rtx-simplify context insn (insn-canonical-semantics insn)
(insn-build-known-values insn))
)
\f
; Subroutine of rtx-solve.
; This is the EXPR-FN argument to rtx-traverse.
-; MODE is the name of the mode.
-(define (/solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(define (/solve-expr-fn rtx-obj expr parent-expr op-pos tstate appstuff)
#f ; wip
)
(let* ((simplified-expr (rtx-simplify context owner expr known))
(maybe-solved-expr
simplified-expr) ; FIXME: for now
-; (/rtx-traverse simplified-expr #f 'DFLT #f 0
+; (/rtx-traverse simplified-expr #f #f 0
; (tstate-make context owner
-; (/fastcall-make /solve-expr-fn)
+; /solve-expr-fn
; (rtx-env-empty-stack)
-; #f #f known 0)
+; #f known 0)
; #f))
)
(cond ((rtx-true? maybe-solved-expr) #t)
(else '?)))
)
\f
-;; rtx-canonicalize (and supporting cast)
-
-; RTX canonicalization.
-; ??? wip
-
-; Subroutine of rtx-canonicalize.
-; Return canonical form of rtx expression EXPR.
-; CONTEXT is a <context> object or #f if there is none.
-; It is used for error message.
-; RTX-OBJ is the <rtx-func> object of (car expr).
-
-(define (/rtx-canonicalize-expr context rtx-obj expr)
- #f
-)
+;; rtx-trim-for-doc (and supporting cast)
+;; RTX trimming (removing fluff not normally needed for the human viewer).
-; Return canonical form of EXPR.
-; CONTEXT is a <context> object or #f if there is none.
-; It is used for error message.
-;
-; Does:
-; - operand shortcuts expanded
-; - numbers -> (const number)
-; - operand-name -> (operand operand-name)
-; - ifield-name -> (ifield ifield-name)
-; - no options -> null option list
-; - absent result mode of those that require a mode -> DFLT
-; - rtx macros are expanded
-;
-; EXPR is returned in source form. We could speed up future processing by
-; transforming it into a more compiled form, but that makes debugging more
-; difficult, so for now we don't.
-
-(define (rtx-canonicalize context expr)
- ; FIXME: wip
- (cond ((integer? expr)
- (rtx-make-const 'INT expr))
- ((symbol? expr)
- (let ((op (current-op-lookup expr)))
- (if op
- (rtx-make-operand expr)
- (context-error context
- "While canonicalizing rtl"
- "can't canonicalize, unknown symbol"
- expr))))
- ((pair? expr)
- expr)
- (else
- (context-error context
- "While canonicalizing rtl"
- "can't canonicalize, syntax error"
- expr)))
-)
-\f
-;; rtx-compile (and supporting cast)
-
-;; Subroutine of rtx-compile.
-;; This is the tstate-expr-fn.
-;; MODE is the name of the mode.
-
-(define (/compile-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
-; (cond
-; The intent of this is to handle sequences/closures, but is it needed?
-; ((rtx-style-syntax? rtx-obj)
-; ((rtx-evaluator rtx-obj) rtx-obj expr mode
-; parent-expr op-pos tstate))
-; (else
- (cons (car expr) ; rtx-obj
- (/rtx-traverse-operands rtx-obj expr tstate appstuff))
-)
+;; Subroutine of /rtx-trim-args to simplify it.
+;; Trim a list of rtxes.
-; Convert rtl expression EXPR from source form to compiled form.
-; The expression is validated and rtx macros are expanded as well.
-; CONTEXT is a <context> object or #f if there is none.
-; It is used in error messages.
-; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
-; elements to be used during value lookup.
-;
-; This does the same operation that rtx-traverse does, except that it provides
-; a standard value for EXPR-FN.
-;
-; ??? In the future the compiled form may be the same as the source form
-; except that all elements would be converted to their respective objects.
-
-(define (rtx-compile context expr extra-vars-alist)
- (/rtx-traverse expr #f 'DFLT #f 0
- (tstate-make context #f
- (/fastcall-make /compile-expr-fn)
- (rtx-env-init-stack1 extra-vars-alist)
- #f #f nil 0)
- #f)
+(define (/rtx-trim-rtx-list rtx-list)
+ (map /rtx-rtim-for-doc rtx-list)
)
-\f
-;; rtx-trim-for-doc (and supporting cast)
-
-; RTX trimming (removing fluff not normally needed for the human viewer).
; Subroutine of /rtx-trim-for-doc to simplify it.
; Trim all the arguments of rtx NAME.
((OPTIONS)
(assert #f)) ; shouldn't get here
- ((ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE)
+ ((ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE
+ VOIDORNUMMODE VOIDMODE BIMODE INTMODE
+ SYMMODE INSNMODE MACHMODE)
#f) ; leave arg untouched
((RTX SETRTX TESTRTX)
(cons new-arg result))))))
)
-; Given a fully specified rtx expression, usually the result of rtx-simplify,
+; Given a canonical rtl expression, usually the result of rtx-simplify,
; remove bits unnecessary for documentation purposes.
-; rtx-simplify adds a lot of verbosity because in the process of
-; simplifying the rtl it produces fully-specified rtl.
-; Examples of things to remove: empty options list, DFLT mode.
+; Canonical rtl too verbose for docs.
+; Examples of things to remove:
+; - empty options list
+; - ifield/operand/local/const wrappers
;
; NOTE: While having to trim the result of rtx-simplify may seem ironical,
; it isn't. You need to keep separate the notions of simplifying "1+1" to "2"
(case name
- ((const) (car rest))
-
- ((ifield operand local)
+ ((const ifield operand local)
(if (null? options)
- (if (eq? mode 'DFLT)
- (car rest)
- (cons name (cons mode rest)))
+ (car rest)
rtx))
+ ((set)
+ (let ((trimmed-args (/rtx-trim-args name rest)))
+ (if (null? options)
+ (cons name trimmed-args)
+ (cons name (cons options (cons mode trimmed-args))))))
+
+ ((if)
+ (let ((trimmed-args (/rtx-trim-args name rest)))
+ (if (null? options)
+ (if (eq? mode 'VOID)
+ (cons name trimmed-args)
+ (cons name (cons mode trimmed-args)))
+ (cons name (cons options (cons mode trimmed-args))))))
+
((sequence parallel)
; No special support is needed, except it's nice to remove nop
; statements. These can be created when an `if' get simplified.
(set! result (cons rtx result))))
trimmed-args)
(if (null? options)
- (if (eq? mode 'DFLT)
+ (if (eq? mode 'VOID)
(cons name (reverse result))
(cons name (cons mode (reverse result))))
(cons name (cons options (cons mode (reverse result)))))))
(else
(let ((trimmed-args (/rtx-trim-args name rest)))
(if (null? options)
- (if (eq? mode 'DFLT)
+ (if (eq? mode 'DFLT) ;; FIXME: DFLT can no longer appear
(cons name trimmed-args)
(cons name (cons mode trimmed-args)))
(cons name (cons options (cons mode trimmed-args))))))))
(class-make '<rtx-func> nil
'(
; name as it appears in RTL
+ ; must be accessed via obj:name
name
; argument list
+ ; ??? Not used I think, but keep.
args
+ ; result mode, or #f if from arg 2
+ ; (or the containing expression when canonicalizing)
+ result-mode
+
; types of each argument, as symbols
; This is #f for macros.
; Possible values:
- ; OPTIONS - optional list of :-prefixed options.
- ; ANYMODE - any mode
- ; INTMODE - any integer mode
- ; FLOATMODE - any floating point mode
- ; NUMMODE - any numeric mode
+ ; OPTIONS - optional list of keyword-prefixed options
+ ; ANYINTMODE - any integer mode
+ ; ANYFLOATMODE - any floating point mode
+ ; ANYNUMMODE - any numeric mode
+ ; ANYEXPRMODE - VOID, PTR, or any numeric mode
; EXPLNUMMODE - explicit numeric mode, can't be DFLT or VOID
- ; NONVOIDMODE - can't be `VOID'
+ ; VOIDORNUMMODE - VOID or any numeric mode
; VOIDMODE - must be `VOID'
- ; DFLTMODE - must be `DFLT', used when any mode is inappropriate
+ ; BIMODE - BI (boolean or bit int)
+ ; INTMODE - must be `INT'
+ ; SYMMODE - must be SYM
+ ; INSNMODE - must be INSN
+ ; MACHMODE - must be MACH
; RTX - any rtx
; SETRTX - any rtx allowed to be `set'
; TESTRTX - the test of an `if'
; LOCALS - the locals list of a sequence
; ENV - environment stack
; ATTRS - attribute list
- ; SYMBOL - operand must be a symbol
- ; STRING - operand must be a string
- ; NUMBER - operand must be a number
- ; SYMORNUM - operand must be a symbol or number
- ; OBJECT - operand is an object
+ ; SYMBOL - arg must be a symbol
+ ; STRING - arg must be a string
+ ; NUMBER - arg must be a number
+ ; SYMORNUM - arg must be a symbol or number
+ ; OBJECT - arg is an object (FIXME: restrict to <operand>?)
arg-types
; required mode of each argument
; This is #f for macros.
; Possible values include any mode name and:
; ANY - any mode
+ ; ANYINT - any integer mode
; NA - not applicable
- ; OP0 - mode is specified in operand 0
- ; unless it is DFLT in which case use the default mode
- ; of the operand
- ; MATCH1 - must match mode of operand 1
- ; which will have OP0 for its mode spec
- ; MATCH2 - must match mode of operand 2
- ; which will have OP0 for its mode spec
+ ; MATCHEXPR - mode has to match the mode specified in the
+ ; containing expression
+ ; NOTE: This isn't necessarily the mode of the
+ ; result of the expression. E.g. in `set', the
+ ; result always has mode VOID, but the mode
+ ; specified in the expression is the mode of the
+ ; set destination.
+ ; MATCHSEQ - for sequences
+ ; last expression has to match mode of sequence,
+ ; preceding expressions must be VOID
+ ; MATCH2 - must match mode of arg 2
+ ; MATCH3 - must match mode of arg 3
; <MODE-NAME> - must match specified mode
arg-modes
+ ; arg number of the MATCHEXPR arg,
+ ; or #f if there is none
+ matchexpr-index
+
; The class of rtx.
; This is #f for macros.
; ARG - operand, local, const
- ; SET - set
+ ; SET - set, set-quiet
; UNARY - not, inv, etc.
; BINARY - add, sub, etc.
; TRINARY - addc, subc, etc.
class
; A symbol indicating the flavour of rtx node this is.
- ; function - normal function
- ; syntax - don't pre-eval arguments
- ; operand - result is an operand
- ; macro - converts one rtx expression to another
+ ; FUNCTION - normal function
+ ; SYNTAX - don't pre-eval arguments
+ ; OPERAND - result is an operand
+ ; MACRO - converts one rtx expression to another
; The word "style" was chosen to be sufficiently different
; from "type", "kind", and "class".
style
; Accessor fns
(define-getters <rtx-func> rtx
- (name args arg-types arg-modes class style evaluator num)
+ (result-mode arg-types arg-modes matchexpr-index class style evaluator num)
)
(define (rtx-style-syntax? rtx) (eq? (rtx-style rtx) 'syntax))
(define /rtx-valid-mode-types
'(
- ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
+ ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE VOIDORNUMMODE
+ VOIDMODE BIMODE INTMODE SYMMODE INSNMODE MACHMODE
)
)
; List of valid mode matchers, excluding mode names.
(define /rtx-valid-matches
- '(ANY NA OP0 MATCH1 MATCH2)
+ '(ANY ANYINT NA MATCHEXPR MATCHSEQ MATCH2 MATCH3)
+)
+
+;; Return arg number of MATCHEXPR in ARG-MODES or #f if not present.
+
+(define (/rtx-find-matchexpr-index arg-modes)
+ ;; We can't use find-first-index here because arg-modes can be an
+ ;; improper list (a b c . d).
+ ;;(find-first-index 0 (lambda (t) (eq? t 'MATCHEXPR)) arg-modes)
+ (define (improper-find-first-index i pred l)
+ (cond ((null? l) #f)
+ ((pair? l)
+ (cond ((pred (car l)) i)
+ (else (improper-find-first-index (+ 1 i) pred (cdr l)))))
+ ((pred l) i)
+ (else #f)))
+ (improper-find-first-index 0 (lambda (t) (eq? t 'MATCHEXPR)) arg-modes)
)
; List of all defined rtx names. This can be map'd over without having
; Look up the <rtx-func> object for RTX-KIND.
; Returns the object or #f if not found.
-; RTX-KIND may already be an <rtx-func> object. FIXME: delete?
+; RTX-KIND is the name of the rtx function.
(define (rtx-lookup rtx-kind)
- (cond ((symbol? rtx-kind)
- (hashq-ref /rtx-func-table rtx-kind))
- ((rtx-func? rtx-kind)
- rtx-kind)
- (else #f))
+ (assert (symbol? rtx-kind))
+ (hashq-ref /rtx-func-table rtx-kind)
)
; Table of rtx macro objects.
;
; ??? Note that we can support variables. Not sure it should be done.
-(define (def-rtx-node name-args arg-types arg-modes class action)
- (let ((name (car name-args))
- (args (cdr name-args)))
+(define (def-rtx-node name-args result-mode arg-types arg-modes class action)
+ (let* ((name (car name-args))
+ (args (cdr name-args))
+ (context (make-prefix-context (string-append "defining rtx "
+ (symbol->string name))))
+ (matchexpr-index (/rtx-find-matchexpr-index arg-modes)))
+
+; (map1-improper (lambda (arg-type)
+; (if (not (memq arg-type /rtx-valid-types))
+; (context-error context "While defining rtx functions"
+; "invalid arg type" arg-type)))
+; arg-types)
+; (map1-improper (lambda (arg-mode)
+; (if (and (not (memq arg-mode /rtx-valid-matches))
+; (not (symbol? arg-mode))) ;; FIXME: mode-name?
+; (context-error context "While defining rtx functions"
+; "invalid arg mode match" arg-mode)))
+; arg-modes)
+
(let ((rtx (make <rtx-func> name args
- arg-types arg-modes
+ result-mode arg-types arg-modes matchexpr-index
class
'function
(if action
- (eval1 (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda
+ (cons '*estate* args)
+ action))
#f)
/rtx-num-next)))
; Add it to the table of rtx handlers.
; Same as define-rtx-node but don't pre-evaluate the arguments.
; Remember that `mode' must be the first argument.
-(define (def-rtx-syntax-node name-args arg-types arg-modes class action)
+(define (def-rtx-syntax-node name-args result-mode arg-types arg-modes class action)
(let ((name (car name-args))
- (args (cdr name-args)))
+ (args (cdr name-args))
+ (matchexpr-index (/rtx-find-matchexpr-index arg-modes)))
(let ((rtx (make <rtx-func> name args
- arg-types arg-modes
+ result-mode arg-types arg-modes matchexpr-index
class
'syntax
(if action
- (eval1 (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda
+ (cons '*estate* args)
+ action))
#f)
/rtx-num-next)))
; Add it to the table of rtx handlers.
; Same as define-rtx-node but return an operand (usually an <operand> object).
; ??? `mode' must be the first argument?
-(define (def-rtx-operand-node name-args arg-types arg-modes class action)
+(define (def-rtx-operand-node name-args result-mode arg-types arg-modes class action)
; Operand nodes must specify an action.
(assert action)
(let ((name (car name-args))
- (args (cdr name-args)))
+ (args (cdr name-args))
+ (matchexpr-index (/rtx-find-matchexpr-index arg-modes)))
(let ((rtx (make <rtx-func> name args
- arg-types arg-modes
+ result-mode arg-types arg-modes matchexpr-index
class
'operand
- (eval1 (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda
+ (cons '*estate* args)
+ action))
/rtx-num-next)))
; Add it to the table of rtx handlers.
(hashq-set! /rtx-func-table name rtx)
(assert action)
(let ((name (car name-args))
(args (cdr name-args)))
- (let ((rtx (make <rtx-func> name args #f #f
+ (let ((rtx (make <rtx-func> name args #f #f #f #f
#f ; class
'macro
(eval1 (list 'lambda args action))
(define (rtx-sem-mode mode) (or (mode:sem-mode mode) mode))
-; MODE is a <mode> object.
-
-(define (rtx-lazy-sem-mode mode) (rtx-sem-mode mode))
-
; Return the mode of object OBJ.
(define (rtx-obj-mode obj) (send obj 'get-mode))
; M1,M2 are <mode> objects.
(define (rtx-mode-compatible? m1 m2)
- (let ((mode1 (rtx-lazy-sem-mode m1))
- (mode2 (rtx-lazy-sem-mode m2)))
- ;(eq? (obj:name mode1) (obj:name mode2)))
- ; ??? This is more permissive than is perhaps proper.
+ ;; ??? This is more permissive than is perhaps proper.
+ (let ((mode1 (rtx-sem-mode m1))
+ (mode2 (rtx-sem-mode m2)))
+ ;;(eq? (obj:name mode1) (obj:name mode2)))
(mode-compatible? 'sameclass mode1 mode2))
)
\f
; Temporaries are created within a sequence.
; MODE is a <mode> object.
+; VALUE is #f if not set yet.
; e.g. (sequence ((WI tmp)) (set tmp reg0) ...)
; ??? Perhaps what we want here is `let' but for now I prefer `sequence'.
; This isn't exactly `let' either as no initial value is specified.
; ??? Should environments only have rtx-temps?
(define (rtx-temp-lookup env name)
- ;(display "looking up:") (display name) (newline)
(let loop ((stack (rtx-env-var-list env)))
(if (null? stack)
#f
; Create a "closure" of EXPR using the current temp stack.
-(define (/rtx-closure-make estate expr)
- (rtx-make 'closure expr (estate-env estate))
+(define (/rtx-closure-make estate mode expr)
+ (rtx-make 'closure mode expr (estate-env estate))
)
(define (rtx-env-dump env)
; that much.
(define (rtx-make kind . args)
- (cons kind (/rtx-munge-mode&options args))
+ (cons kind (rtx-munge-mode&options (rtx-lookup kind) 'DFLT kind args))
)
(define rtx-name car)
; Return argument to `symbol' rtx.
(define rtx-symbol-name rtx-arg1)
-(define (rtx-make-ifield ifield-name) (rtx-make 'ifield ifield-name))
+(define (rtx-make-ifield mode-name ifield-name)
+ (rtx-make 'ifield mode-name ifield-name)
+)
(define (rtx-ifield? rtx) (eq? 'ifield (rtx-name rtx)))
(define (rtx-ifield-name rtx)
(let ((ifield (rtx-arg1 rtx)))
ifield))
)
-(define (rtx-make-operand op-name) (rtx-make 'operand op-name))
+(define (rtx-make-operand mode-name op-name)
+ (rtx-make 'operand mode-name op-name)
+)
(define (rtx-operand? rtx) (eq? 'operand (rtx-name rtx)))
+;; FIXME: This should just fetch rtx-arg1,
+;; operand rtxes shouldn't have objects, that's what xop is for.
(define (rtx-operand-name rtx)
(let ((operand (rtx-arg1 rtx)))
(if (symbol? operand)
operand
(obj:name operand)))
)
+
+;; Given an operand rtx, construct the <operand> object.
+;; RTX must be canonical rtl.
+
(define (rtx-operand-obj rtx)
- (let ((operand (rtx-arg1 rtx)))
- (if (symbol? operand)
- (current-op-lookup operand)
- operand))
+ (let ((op (current-op-lookup (rtx-arg1 rtx)))
+ (mode (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)))
)
-(define (rtx-make-local local-name) (rtx-make 'local local-name))
+(define (rtx-make-local mode-name local-name)
+ (rtx-make 'local mode-name local-name)
+)
(define (rtx-local? rtx) (eq? 'local (rtx-name rtx)))
(define (rtx-local-name rtx)
(let ((local (rtx-arg1 rtx)))
local))
)
+(define (rtx-make-xop op)
+ (rtx-make 'xop (op:mode-name op) op)
+)
+
(define rtx-xop-obj rtx-arg1)
;(define (rtx-opspec? rtx) (eq? 'opspec (rtx-name rtx)))
(if (pair? rtx)
(case (car rtx)
((const) (number->string (rtx-const-value rtx)))
- ((operand) (symbol->string (obj:name (rtx-operand-obj rtx))))
+ ((operand) (symbol->string (rtx-operand-name rtx)))
((local) (symbol->string (rtx-local-name rtx)))
((xop) (symbol->string (obj:name (rtx-xop-obj rtx))))
(else
; Maybe in the future allow arrays although there's significant utility in
; allowing only at most a scalar index.
-(define (hw estate mode-name hw-name index-arg selector)
+(define (/hw estate mode-name hw-name index-arg selector)
; Enforce some rules to keep things in line with the current design.
(if (not (symbol? mode-name))
(parse-error (estate-context estate) "invalid mode name" mode-name))
(let* ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name)))
(hw-name-with-mode (symbol-append hw-name '- (obj:name mode)))
+ (index-mode (if (eq? hw-name 'h-memory) 'AI 'INT))
(result (new <operand>))) ; ??? lookup-for-new?
(if (not mode)
(if (rtx-constant? index-arg)
(make <hw-index> 'anonymous 'constant UINT
(rtx-constant-value index-arg))
- (make <hw-index> 'anonymous 'rtx DFLT
- (/rtx-closure-make estate index-arg))))
+ (make <hw-index> 'anonymous 'rtx (mode:lookup index-mode)
+ (/rtx-closure-make estate index-mode index-arg))))
(else (parse-error (estate-context estate)
"invalid index" index-arg))))
; ESTATE is the current rtx evaluation state.
; INDX-SEL is an optional register number and possible selector.
; The register number, if present, is (car indx-sel) and must be a number or
-; unevaluated RTX expression.
+; unevaluated canonical RTX expression.
; The selector, if present, is (cadr indx-sel) and must be a number or
-; unevaluated RTX expression.
+; unevaluated canonical RTX expression.
; ??? A register selector isn't supported yet. It's just an idea that's
; been put down on paper for future reference.
)
; This is shorthand for (hw estate mode-name h-memory addr selector).
-; ADDR must be an unevaluated RTX expression.
-; If present (car sel) must be a number or unevaluated RTX expression.
+; ADDR must be an unevaluated canonical RTX expression.
+; If present (car sel) must be a number or unevaluated canonical
+; RTX expression.
(define (mem estate mode-name addr . sel)
(s-hw estate mode-name 'h-memory addr
; For the rtx nodes to use.
-(define s-hw hw)
+(define s-hw /hw)
; The program counter.
; When this code is loaded, global `pc' is nil, it hasn't been set to the
; The argument to drn,drmn,drsn must be Scheme code (or a fixed subset
; thereof). .str/.sym are used in pmacros so it makes sense to include them
; in the subset.
+; FIXME: Huh?
(define .str string-append)
(define .sym symbol-append)
Define an rtx subroutine, name/value pair list version.
"
nil 'arg-list define-subr)
+
*UNSPECIFIED*
)
-; Install builtins
+;; Install builtins
(define (rtl-builtin!)
+ (rtx-init-traversal-tables!)
+
*UNSPECIFIED*
)
; Update s-pc, must be called after operand-init!.
(set! s-pc pc)
- ; Table of traversers for the various rtx elements.
- (let ((hash-table (/rtx-make-traverser-table)))
- (set! /rtx-traverser-table (make-vector (rtx-max-num) #f))
- (for-each (lambda (rtx-name)
- (let ((rtx (rtx-lookup rtx-name)))
- (if rtx
- (vector-set! /rtx-traverser-table (rtx-num rtx)
- (map1-improper
- (lambda (arg-type)
- (cons arg-type
- (hashq-ref hash-table arg-type)))
- (rtx-arg-types rtx))))))
- (rtx-name-list)))
-
; Initialize the operand hash table.
(set! /rtx-operand-table (make-hash-table 127))
\f
; Error reporting.
; MODE is present for use in situations like non-VOID mode cond's.
+; The code will expect the mode to be compatible even though `error'
+; "doesn't return". A small concession for simpler code.
(drn (error &options &mode message)
- (OPTIONS ANYMODE STRING) (NA NA NA)
+ #f
+ (OPTIONS VOIDORNUMMODE STRING) (NA NA NA)
MISC
(estate-error *estate* "error in rtl" message)
)
; Default mode is INT.
(drn (enum &options &mode enum-name)
- (OPTIONS NUMMODE SYMBOL) (NA NA NA)
+ #f
+ (OPTIONS ANYINTMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/ENUM-NAME/ ?
ARG
; When computing a value, return the enum's value.
(enum-lookup-val enum-name)
; in this.
(dron (ifield &options &mode ifld-name)
- (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+ #f
+ (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/IFIELD-NAME/ ?
ARG
(let ((f (current-ifld-lookup ifld-name)))
(make <operand> (obj-location f)
; in this.
(dron (operand &options &mode op-name)
- (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+ #f
+ (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/OPERAND-NAME/ ?
ARG
(current-op-lookup op-name)
)
; ??? Might also support numbering by allowing NEW-NAME to be a number.
(drsn (name &options &mode new-name value)
- (OPTIONS DFLTMODE SYMBOL RTX) (NA NA NA ANY)
+ #f
+ (OPTIONS ANYNUMMODE SYMBOL RTX) (NA NA NA ANY)
ARG
+ ;; FIXME: s/DFLT/&mode/ ?
(let ((result (object-copy (rtx-get 'DFLT value))))
(op:set-sem-name! result new-name)
result)
; Compiled operands are wrapped in this so that they still look like rtx.
(dron (xop &options &mode object)
- (OPTIONS DFLTMODE OBJECT) (NA NA NA)
+ #f
+ (OPTIONS ANYNUMMODE OBJECT) (NA NA NA) ;; FIXME: s/OBJECT/OPERAND/ ?
ARG
object
)
;(dron (opspec: &options &mode op-name op-num hw-ref attrs)
-; (OPTIONS ANYMODE SYMBOL NUMBER RTX ATTRS) (NA NA NA NA ANY NA)
+; (OPTIONS ANYNUMMODE SYMBOL NUMBER RTX ATTRS) (NA NA NA NA ANY NA)
; ARG
; (let ((opval (rtx-eval-with-estate hw-ref (mode:lookup &mode) *estate*)))
; (assert (operand? opval))
; wrapped in this.
(dron (local &options &mode local-name)
- (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+ #f
+ (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/LOCAL-NAME/ ?
ARG
(rtx-temp-lookup (tstate-env *tstate*) local-name)
)
; ??? Since operands are given names and not numbers this isn't currently used.
;
;(drsn (dup &options &mode op-name)
-; (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+; #f
+; (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA)
; ;(s-dup *estate* op-name)
; (begin
; (if (not (insn? (estate-owner *estate*)))
; ??? What about input/output operands.
(drsn (ref &options &mode name)
- (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+ BI
+ (OPTIONS BIMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/OPERAND-NAME/ ?
ARG
#f
)
; Return the index of an operand.
; For registers this is the register number.
-; ??? Mode handling incomplete.
+; ??? Mode handling incomplete, this doesn't handle mem, which it could.
+; Until then we fix the mode of the result to INT.
(dron (index-of &options &mode op-rtx)
- (OPTIONS DFLTMODE RTX) (NA NA ANY)
+ INT
+ (OPTIONS INTMODE RTX) (NA NA ANY)
ARG
+ ;; FIXME: s/DFLT/&mode/ ?
(let* ((operand (rtx-eval-with-estate op-rtx DFLT *estate*))
(f (hw-index:value (op:index operand)))
(f-name (obj:name f)))
; unevaluated.
; ??? Not currently supported. Not sure whether it should be.
;(drsn (hw &options &mode hw-elm . indx-sel)
-; (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT)
+; (OPTIONS ANYNUMMODE SYMBOL . RTX) (NA NA NA . INT)
; ARG
; (let ((indx (if (pair? indx-sel) (car indx-sel) 0))
; (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
; Register accesses.
; INDX-SEL is an optional index and possible selector.
(dron (reg &options &mode hw-elm . indx-sel)
- (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT)
+ #f
+ (OPTIONS ANYNUMMODE SYMBOL . RTX) (NA NA NA . INT) ;; FIXME: s/SYMBOL/HW-NAME/ ?
ARG
(let ((indx (if (pair? indx-sel) (car indx-sel) 0))
(selector (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
; getter/setter definitions.
(dron (raw-reg &options &mode hw-elm . indx-sel)
- (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT)
+ #f
+ (OPTIONS ANYNUMMODE SYMBOL . RTX) (NA NA NA . INT) ;; FIXME: s/SYMBOL/HW-NAME/ ?
ARG
(let ((indx (if (pair? indx-sel) (car indx-sel) 0))
(selector (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
; Memory accesses.
(dron (mem &options &mode addr . sel)
+ #f
(OPTIONS EXPLNUMMODE RTX . RTX) (NA NA AI . INT)
ARG
(s-hw *estate* mode 'h-memory addr
; The program counter.
; ??? Hmmm... needed? The pc is usually specified as `pc' which is shorthand
; for (operand pc).
-(dron (pc) () () ARG s-pc)
+;(dron (pc) () () ARG s-pc)
; Fetch bytes from the instruction stream of size MODE.
; FIXME: Later need to augment this by passing an indicator to the mem-fetch
; Indicate there are N delay slots in the processing of RTX.
; N is a `const' node.
+; The mode of the result is the mode of RTX.
; ??? wip!
(drn (delay &options &mode n rtx)
- (OPTIONS DFLTMODE RTX RTX) (NA NA INT ANY)
+ #f
+ (OPTIONS VOIDORNUMMODE RTX RTX) (NA NA INT MATCHEXPR)
MISC
#f ; (s-sequence *estate* VOID '() rtx) ; wip!
)
; ??? wip!
(drn (skip &options &mode yes?)
- (OPTIONS DFLTMODE RTX) (NA NA INT)
+ VOID
+ (OPTIONS VOIDMODE RTX) (NA NA INT)
MISC
#f
)
; OWNER is the result of either (current-insn) or (current-mach)
; [note that canonicalization will turn them into
; (current-{insn,mach} () DFLT)].
-; The result is always of mode INT.
+; The result is always of mode BI.
; FIXME: wip
;
; This is a syntax node so the args are not pre-evaluated.
; FIXME: Hmmm... it currently isn't a syntax node.
(drn (eq-attr &options &mode owner attr value)
- (OPTIONS DFLTMODE RTX SYMBOL SYMORNUM) (NA NA ANY NA NA)
+ BI
+ (OPTIONS BIMODE RTX SYMBOL SYMORNUM) (NA NA ANY NA NA)
MISC
(let ((atval (if owner
(obj-attr-value owner attr)
(eq? atval value)))
)
-; Get the value of attribute ATTR-NAME.
-; OBJ is the result of either (current-insn) or (current-mach)
-; [note that canonicalization will turn them into
-; (current-{insn,mach} () DFLT)].
+; Get the value of attribute ATTR-NAME, expressable as an integer.
+; OBJ is the result of either (current-insn) or (current-mach).
+; Note that canonicalization will turn them into
+; (current-{insn,mach} () {INSN,MACH}MODE).
; FIXME:wip
+; This uses INTMODE because we can't otherwise determine the
+; mode of the result (if elided).
-(drn (attr &options &mode obj attr-name)
- (OPTIONS DFLTMODE RTX SYMBOL) (NA NA NA NA)
+(drn (int-attr &options &mode obj attr-name)
+ #f
+ (OPTIONS INTMODE RTX SYMBOL) (NA NA ANY NA)
MISC
#f
)
+;; Deprecated alias for int-attr.
+
+(drmn (attr arg1 . rest)
+ (cons 'int-attr (cons arg1 rest))
+)
+
; Same as `quote', for use in attributes cus "quote" sounds too jargonish.
; [Ok, not a strong argument for using "symbol", but so what?]
(drsn (symbol &options &mode name)
- (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+ SYM
+ (OPTIONS SYMMODE SYMBOL) (NA NA NA)
ARG
name
)
; Return the current instruction.
(drn (current-insn &options &mode)
- (OPTIONS DFLTMODE) (NA NA)
+ INSN
+ (OPTIONS INSNMODE) (NA NA)
MISC
(let ((obj (estate-owner *estate*)))
(if (not (insn? obj))
; This can either be a compile-time or run-time value.
(drn (current-mach &options &mode)
- (OPTIONS DFLTMODE) (NA NA)
+ MACH
+ (OPTIONS MACHMODE) (NA NA)
MISC
-rtx-current-mach
)
; FIXME: Need to consider 64 bit hosts.
(drn (const &options &mode c)
- (OPTIONS NUMMODE NUMBER) (NA NA NA)
+ #f
+ (OPTIONS ANYNUMMODE NUMBER) (NA NA NA)
ARG
; When computing a value, just return the constant unchanged.
c
; ??? Not all of the combinations are supported in the simulator.
; They'll get added as necessary.
(drn (join &options &out-mode in-mode arg1 . arg-rest)
- (OPTIONS NUMMODE NUMMODE RTX . RTX) (NA NA NA ANY . ANY)
+ #f
+ (OPTIONS ANYNUMMODE ANYNUMMODE RTX . RTX) (NA NA NA ANY . ANY)
MISC
; FIXME: Ensure correct number of args for in/out modes.
; FIXME: Ensure compatible modes.
; ??? GCC plans to switch to SUBREG_BYTE. Keep an eye out for the switch
; (which is extensive so probably won't happen anytime soon).
;
-; The mode spec of operand0 use to be OP0, but subword is not a normal rtx.
+; The mode spec of operand0 use to be MATCHEXPR, but subword is not a normal rtx.
; The mode of operand0 is not necessarily the same as the mode of the result,
; and code which analyzes it would otherwise use the result mode (specified by
; `&mode') for the mode of operand0.
(drn (subword &options &mode value word-num)
- (OPTIONS NUMMODE RTX RTX) (NA NA ANY INT)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA ANY INT)
ARG
#f
)
; independent name.
(drn (c-code &options &mode text)
- (OPTIONS ANYMODE STRING) (NA NA NA)
+ #f
+ (OPTIONS ANYEXPRMODE STRING) (NA NA NA)
UNSPEC
#f
)
; Otherwise it is part of an expression.
(drn (c-call &options &mode name . args)
- (OPTIONS ANYMODE STRING . RTX) (NA NA NA . ANY)
+ #f
+ (OPTIONS ANYEXPRMODE STRING . RTX) (NA NA NA . ANY)
UNSPEC
#f
)
; Same as c-call but without implicit first arg of `current_cpu'.
(drn (c-raw-call &options &mode name . args)
- (OPTIONS ANYMODE STRING . RTX) (NA NA NA . ANY)
+ #f
+ (OPTIONS ANYEXPRMODE STRING . RTX) (NA NA NA . ANY)
UNSPEC
#f
)
; Set/get/miscellaneous
(drn (nop &options &mode)
+ VOID
(OPTIONS VOIDMODE) (NA NA)
MISC
#f
; Clobber - mark an object as modified without explaining why or how.
(drn (clobber &options &mode object)
- (OPTIONS ANYMODE RTX) (NA NA OP0)
+ VOID
+ (OPTIONS VOIDORNUMMODE RTX) (NA NA MATCHEXPR)
MISC
#f
)
; Scheme too closely.
(drn (set &options &mode dst src)
- (OPTIONS ANYMODE SETRTX RTX) (NA NA OP0 MATCH1)
+ VOID
+ (OPTIONS ANYNUMMODE SETRTX RTX) (NA NA MATCHEXPR MATCH2)
SET
#f
)
(drn (set-quiet &options &mode dst src)
- (OPTIONS ANYMODE SETRTX RTX) (NA NA OP0 MATCH1)
+ VOID
+ (OPTIONS ANYNUMMODE SETRTX RTX) (NA NA MATCHEXPR MATCH2)
SET
#f
)
; - ???
(drn (neg &options &mode s1)
- (OPTIONS ANYMODE RTX) (NA NA OP0)
+ #f
+ (OPTIONS ANYNUMMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
(drn (abs &options &mode s1)
- (OPTIONS ANYMODE RTX) (NA NA OP0)
+ #f
+ (OPTIONS ANYNUMMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
; For floating point values this produces 1/x.
; ??? Might want different names.
(drn (inv &options &mode s1)
- (OPTIONS ANYMODE RTX) (NA NA OP0)
+ #f
+ (OPTIONS ANYINTMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
; MODE is the mode of S1. The result always has mode BI.
; ??? Perhaps `mode' shouldn't be here.
(drn (not &options &mode s1)
- (OPTIONS ANYMODE RTX) (NA NA OP0)
+ BI
+ (OPTIONS ANYINTMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
(drn (add &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (sub &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
; For the *flag rtx's, MODE is the mode of S1,S2; the result always has
; mode BI.
(drn (addc &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (addc-cflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (addc-oflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (subc &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (subc-cflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (subc-oflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
;; ??? These are deprecated. Delete in time.
(drn (add-cflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (add-oflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (sub-cflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
(drn (sub-oflag &options &mode s1 s2 s3)
- (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+ BI
+ (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI)
TRINARY
#f
)
; Multiply/divide.
(drn (mul &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
; [both host and target], and one that specifies implementation defined
; situations [target].
(drn (div &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (udiv &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (mod &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (umod &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
; various floating point routines
(drn (sqrt &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA OP0)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
(drn (cos &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA OP0)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
(drn (sin &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA OP0)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA MATCHEXPR)
UNARY
#f
)
; min/max
(drn (min &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (max &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (umin &options &mode s1 s2)
- (OPTIONS INTMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (umax &options &mode s1 s2)
- (OPTIONS INTMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
; These are bitwise operations.
(drn (and &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (or &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
(drn (xor &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
BINARY
#f
)
; Shift operations.
(drn (sll &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT)
BINARY
#f
)
(drn (srl &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT)
BINARY
#f
)
; ??? In non-sim case, ensure s1 is in right C type for right result.
(drn (sra &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT)
BINARY
#f
)
; Rotates don't really have a sign, so doesn't matter what we say.
(drn (ror &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT)
BINARY
#f
)
(drn (rol &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+ #f
+ (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT)
BINARY
#f
)
; On the other hand, handling an arbitrary number of args isn't supported by
; ISA's, which the main goal of what we're trying to represent.
(drn (andif &options &mode s1 s2)
- (OPTIONS DFLTMODE RTX RTX) (NA NA ANY ANY)
+ BI
+ (OPTIONS BIMODE RTX RTX) (NA NA ANYINT ANYINT)
BINARY ; IF?
#f
)
(drn (orif &options &mode s1 s2)
- (OPTIONS DFLTMODE RTX RTX) (NA NA ANY ANY)
+ BI
+ (OPTIONS BIMODE RTX RTX) (NA NA ANYINT ANYINT)
BINARY ; IF?
#f
)
; Conversions.
(drn (ext &options &mode s1)
- (OPTIONS INTMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYINTMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (zext &options &mode s1)
- (OPTIONS INTMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYINTMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (trunc &options &mode s1)
- (OPTIONS INTMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYINTMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (fext &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (ftrunc &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (float &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (ufloat &options &mode s1)
- (OPTIONS FLOATMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYFLOATMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (fix &options &mode s1)
- (OPTIONS INTMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYINTMODE RTX) (NA NA ANY)
UNARY
#f
)
(drn (ufix &options &mode s1)
- (OPTIONS INTMODE RTX) (NA NA ANY)
+ #f
+ (OPTIONS ANYINTMODE RTX) (NA NA ANY)
UNARY
#f
)
; MODE is the mode of S1,S2. The result always has mode BI.
(drn (eq &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (ne &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
; ??? In non-sim case, ensure s1,s2 is in right C type for right result.
(drn (lt &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (le &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (gt &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (ge &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
; ??? In non-sim case, ensure s1,s2 is in right C type for right result.
(drn (ltu &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (leu &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (gtu &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
(drn (geu &options &mode s1 s2)
- (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+ BI
+ (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2)
COMPARE
#f
)
; VALUE is any constant rtx. SET is a `number-list' rtx.
(drn (member &options &mode value set)
- (OPTIONS DFLTMODE RTX RTX) (NA NA INT INT)
+ #f
+ (OPTIONS BIMODE RTX RTX) (NA NA INT INT)
MISC
(begin
(if (not (rtx-constant? value))
(rtx-false)))
)
+;; FIXME: "number" in "number-list" implies floats are ok.
+;; Rename to integer-list, int-list, or some such.
+
(drn (number-list &options &mode value-list)
+ #f
(OPTIONS INTMODE NUMBER . NUMBER) (NA NA NA . NA)
MISC
#f
; FIXME: make syntax node?
(drn (if &options &mode cond then . else)
- (OPTIONS ANYMODE TESTRTX RTX . RTX) (NA NA ANY OP0 . MATCH2)
+ #f
+ ;; ??? It would be cleaner if TESTRTX had to have BI mode.
+ (OPTIONS VOIDORNUMMODE TESTRTX RTX . RTX) (NA NA ANYINT MATCHEXPR . MATCH3)
IF
(apply e-if (append! (list *estate* mode cond then) else))
)
; ??? The syntax here isn't quite that of Scheme. A condition must be
; followed by a result expression.
+; ??? The syntax here isn't quite right, there must be at least one cond rtx.
; ??? Intermediate expressions (the ones before the last one) needn't have
; the same mode as the result.
(drsn (cond &options &mode . cond-code-list)
- (OPTIONS ANYMODE . CONDRTX) (NA NA . OP0)
+ #f
+ (OPTIONS VOIDORNUMMODE . CONDRTX) (NA NA . MATCHEXPR)
COND
#f
)
+; ??? The syntax here isn't quite right, there must be at least one case.
; ??? Intermediate expressions (the ones before the last one) needn't have
; the same mode as the result.
(drn (case &options &mode test . case-list)
- (OPTIONS ANYMODE RTX . CASERTX) (NA NA ANY . OP0)
+ #f
+ (OPTIONS VOIDORNUMMODE RTX . CASERTX) (NA NA ANY . MATCHEXPR)
COND
#f
)
\f
-; parallel, sequence, do-count
+; parallel, sequence, do-count, closure
; This has to be a syntax node as we don't want EXPRS to be pre-evaluated.
; All semantic ops must have a mode, though here it must be VOID.
; ??? There's no real need for mode either, but convention requires it.
(drsn (parallel &options &mode ignore expr . exprs)
+ #f
(OPTIONS VOIDMODE LOCALS RTX . RTX) (NA NA NA VOID . VOID)
SEQUENCE
#f
; ??? This should create a closure.
(drsn (sequence &options &mode locals expr . exprs)
- (OPTIONS ANYMODE LOCALS RTX . RTX) (NA NA NA OP0 . OP0)
+ #f
+ (OPTIONS VOIDORNUMMODE LOCALS RTX . RTX) (NA NA NA MATCHSEQ . MATCHSEQ)
SEQUENCE
#f
)
; yet and thus pre-evaluating the expressions doesn't work.
(drsn (do-count &options &mode iter-var nr-times expr . exprs)
+ #f
(OPTIONS VOIDMODE ITERATION RTX RTX . RTX) (NA NA NA INT VOID . VOID)
SEQUENCE
#f
)
-\f
+
; Internal rtx to create a closure.
; Internal, so it does not appear in rtl.texi.
(drsn (closure &options &mode expr env)
- (OPTIONS DFLTMODE RTX ENV) (NA NA NA NA)
+ #f
+ (OPTIONS VOIDORNUMMODE RTX ENV) (NA NA MATCHEXPR NA)
MISC
#f
)
;; MODE is the name of the mode.
-(define (/frag-hash-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(define (/frag-hash-compute! rtx-obj expr parent-expr op-pos tstate appstuff)
(let ((h 0))
(case (rtx-name expr)
((operand)
;; MODE is the name of the mode.
-(define (/frag-cost-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(define (/frag-cost-compute! rtx-obj expr parent-expr op-pos tstate appstuff)
; FIXME: wip
(let ((speed 0)
(size 0))
(define (sem-find-common-frags insn-list)
(/sem-find-common-frags-1
(begin
- (logit 2 "Simplifying/canonicalizing rtl ...\n")
+ (logit 2 "Simplifying rtl ...\n")
(map (lambda (insn)
(rtx-simplify-insn #f insn))
insn-list))
; Subroutine of semantic-compile:process-expr!, to simplify it.
; Looks up the operand in the current set, returns it if found,
; otherwise adds it.
-; MODE is the mode name.
; REF-TYPE is one of 'use, 'set, 'set-quiet.
; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc.
-(define (/build-operand! op-name op mode tstate ref-type op-list sem-attrs)
- ;(display (list op-name mode ref-type)) (newline) (force-output)
- (let* ((mode (mode-real-name (if (eq? mode 'DFLT)
- (op:mode op)
- (mode:lookup mode))))
- ; The first #f is a placeholder for the object.
- (try (list '-op- #f mode op-name #f))
+(define (/build-operand! op-expr tstate ref-type op-list sem-attrs)
+ (let* ((op (rtx-operand-obj op-expr))
+ (mode (rtx-mode op-expr))
+ ;; 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)))
+ (assert (not (eq? (op:mode-name op) 'DFLT)))
+
(if (and (pc? op)
(memq ref-type '(set set-quiet)))
(append! sem-attrs
; operands. This is done by creating shared rtx (a la gcc) - the
; operand number then need only be updated in one place.
- (let ((xop (op:new-mode op mode)))
- (op:set-cond?! xop (tstate-cond? tstate))
+ (begin
+ (op:set-cond?! op (tstate-cond? tstate))
; Set the object rtx in `try', now that we have it.
- (set-car! (cdr try) (rtx-make 'xop xop))
+ (set-car! (cdr try) (rtx-make-xop op))
; Add the operand to in/out-ops.
(append! op-list (list try))
(cadr try))))
(if hw
- ; If the mode is DFLT, use the object's natural mode.
- (let* ((mode (mode-real-name (if (eq? (rtx-mode expr) 'DFLT)
- (hw-mode hw)
- (mode:lookup (rtx-mode expr)))))
+ (let* ((mode (rtx-mode expr))
(indx-sel (rtx-reg-index-sel expr))
; #f is a place-holder for the object (filled in later)
(try (list 'reg #f mode hw-name indx-sel))
(cons hw-name indx-sel))))))
(op:set-cond?! xop (tstate-cond? tstate))
; Set the object rtx in `try', now that we have it.
- (set-car! (cdr try) (rtx-make 'xop xop))
+ (set-car! (cdr try) (rtx-make-xop xop))
; Add the operand to in/out-ops.
(append! op-list (list try))
(cadr try))))
; Subroutine of semantic-compile:process-expr!, to simplify it.
(define (/build-mem-operand! expr tstate op-list)
- (let ((mode (mode-real-name (mode:lookup (rtx-mode expr))))
+ (let ((mode (rtx-mode expr))
(indx-sel (rtx-mem-index-sel expr)))
- (if (memq mode '(DFLT VOID))
- (parse-error (tstate-context tstate)
- "memory must have explicit mode" expr))
-
(let* ((try (list 'mem #f mode 'h-memory indx-sel))
(existing-op (/rtx-find-op try op-list)))
(cons mode indx-sel)))))
(op:set-cond?! xop (tstate-cond? tstate))
; Set the object in `try', now that we have it.
- (set-car! (cdr try) (rtx-make 'xop xop))
+ (set-car! (cdr try) (rtx-make-xop xop))
; Add the operand to in/out-ops.
(append! op-list (list try))
(cadr try)))))
(make <hw-index> 'anonymous
'ifield (ifld-mode f) f)
nil #f #f)))
- (set-car! (cdr try) (rtx-make 'xop xop))
+ (set-car! (cdr try) (rtx-make-xop xop))
(append! op-list (list try))
(cadr try)))))
)
; (send (op:type op) 'get-index-mode)
f)
nil #f #f)))
- (set-car! (cdr try) (rtx-make 'xop xop))
+ (set-car! (cdr try) (rtx-make-xop xop))
(append! op-list (list try))
(cadr try)))))))
)
(sem-attrs (list #f))
; Called for expressions encountered in SEM-CODE.
- ; MODE is the name of the mode.
; Don't waste cpu here, this is part of the slowest piece in CGEN.
(process-expr!
- (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (lambda (rtx-obj expr parent-expr op-pos tstate appstuff)
(case (car expr)
+ ;; NOTE: Despite the ! in, e.g., /build-reg-operand!,
+ ;; it does return a result.
+
; Registers.
((reg) (let ((ref-type (/rtx-ref-type parent-expr op-pos))
; ??? could verify reg is a scalar
out-ops))))
; Operands.
- ((operand) (let ((op (rtx-operand-obj expr))
- (ref-type (/rtx-ref-type parent-expr op-pos)))
- (/build-operand! (obj:name op) op mode tstate ref-type
+ ((operand) (let ((ref-type (/rtx-ref-type parent-expr op-pos)))
+ (/build-operand! expr tstate ref-type
(if (eq? ref-type 'use)
in-ops
out-ops)
sem-attrs)))
; Give operand new name.
- ((name) (let ((result (/rtx-traverse (caddr expr) 'RTX mode
+ ((name) (let ((result (/rtx-traverse (caddr expr) 'RTX
parent-expr op-pos tstate appstuff)))
(if (not (operand? result))
(error "name: invalid argument:" expr result))
(sem-attrs (list #f))
; Called for expressions encountered in SEM-CODE.
- ; MODE is the name of the mode.
(process-expr!
- (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (lambda (rtx-obj expr parent-expr op-pos tstate appstuff)
(case (car expr)
- ((operand) (if (and (eq? 'pc (obj:name (rtx-operand-obj expr)))
+ ;; FIXME: What's the result for the operand case?
+ ((operand) (if (and (eq? 'pc (rtx-operand-name expr))
(memq (/rtx-ref-type parent-expr op-pos)
'(set set-quiet)))
(append! sem-attrs
(define (gen-semantic-code insn)
; Indicate generating code for INSN.
- ; Use the compiled form if available.
- ; The case when they're not available is for virtual insns.
- (let ((sem-c-code
- (if (insn-compiled-semantics insn)
- (rtl-c++-parsed VOID (insn-compiled-semantics insn) nil
- #:rtl-cover-fns? #t
- #:owner insn)
- (rtl-c++ VOID (insn-semantics insn) nil
- #:rtl-cover-fns? #t
- #:owner insn)))
- )
- sem-c-code)
+ ; 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
+ #:for-insn? #t
+ #:rtl-cover-fns? #t
+ #:owner insn)))
+ ((insn-canonical-semantics insn)
+ => (lambda (sem)
+ (rtl-c++-parsed VOID sem nil
+ #: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)))
)
; Return definition of C function to perform INSN.
(string-append
" "
(rtl-c++ VOID (isa-setup-semantics (current-isa)) nil
+ #:for-insn? #t
#:rtl-cover-fns? #t
#:owner insn))
"")
(let ((sem (sfrag-compiled-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.
+ ; 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)))
)
(method-make!
<hw-memory> 'cxmake-get
(lambda (self estate mode index selector)
- (let ((mode (if (mode:eq? 'DFLT mode)
+ (let ((mode (if (mode:eq? 'DFLT mode) ;; FIXME: delete, DFLT
(hw-mode self)
mode))
(default-selector? (hw-selector-default? selector)))
(/op-gen-delayed-set-maybe-trace op estate mode index selector newval #f))
-(define (/op-gen-set-trace op estate mode index selector newval)
+(define (/op-gen-set-trace1 op estate mode index selector newval)
(string-append
" {\n"
" " (mode:c-type mode) " opval = " (cx:c newval) ";\n"
" }\n")
)
+(define (/op-gen-set-trace op estate mode index selector newval)
+ ;; If tracing hasn't been enabled, use gen-set-quiet, mostly to reduce
+ ;; diffs in the generated source from pre-full-canonicalization cgen.
+ (if (or (and (with-profile?)
+ (op:cond? op))
+ (not (current-pbb-engine?))
+ ;; FIXME: Why doesn't gen-set-quiet check op:setter?
+ (op:setter op))
+ (/op-gen-set-trace1 op estate mode index selector newval)
+ (/op-gen-set-quiet op estate mode index selector newval))
+)
+
(define (/op-gen-delayed-set-trace op estate mode index selector newval)
(/op-gen-delayed-set-maybe-trace op estate mode index selector newval #t))
(string-append
" "
(rtl-c VOID (isa-setup-semantics (current-isa)) nil
+ #:for-insn? #t
#:rtl-cover-fns? #t
#:owner insn)
"\n")
; Indicate generating code for INSN.
; Use the compiled form if available.
- ; The case when they're not available is for virtual insns.
- (let ((sem (insn-compiled-semantics insn)))
- (if sem
- (rtl-c-parsed VOID sem nil
- #:rtl-cover-fns? #t #:owner insn)
- (rtl-c VOID (insn-semantics insn) nil
- #:rtl-cover-fns? #t #:owner insn))))
+ ; 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
+ #:for-insn? #t
+ #:rtl-cover-fns? #t
+ #:owner insn)))
+ ((insn-canonical-semantics insn)
+ => (lambda (sem)
+ (rtl-c-parsed VOID sem nil
+ #: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))))
)
; Return definition of C function to perform INSN.
; cadr: fetches expression to be evaluated
; caar: fetches symbol in arglist
; cadar: fetches `pc' symbol in arglist
- (rtl-c VOID (cadr decode)
+ (rtl-c DFLT (cadr decode)
(list (list (caar decode) 'UINT extraction)
(list (cadar decode) 'IAI "pc"))
#: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 VOID (cadr decode)
+ (rtl-c DFLT (cadr decode)
(list (list (caar decode) 'UINT extraction)
(list (cadar decode) 'IAI "pc"))
#:rtl-cover-fns? #f #:ifield-var? #t)))
(let* ((decode-proc (ifld-decode f))
(varname (gen-sym f))
(decode (string-list
- ;; First, the block that extract the multi-ifield into the ifld variable
+ ;; First, the block that extract the multi-ifield into the ifld variable.
(rtl-c VOID (multi-ifld-extract f) nil
#:rtl-cover-fns? #f #:ifield-var? #t)
- ;; Next, the decode routine that modifies it
+ ;; Next, the decode routine that modifies it.
(if decode-proc
(string-append
" " varname " = "
- (rtl-c VOID (cadr decode-proc)
+ (rtl-c DFLT (cadr decode-proc)
(list (list (caar decode-proc) 'UINT varname)
(list (cadar decode-proc) 'IAI "pc"))
#:rtl-cover-fns? #f #:ifield-var? #t)
)
; Return list of index numbers of elements in list L that satisfy PRED.
-; I is usually 0.
+; I is added to each index, it's usually 0.
(define (find-index i pred l)
(define (find1 i pred l result)
(reverse! (find1 i pred l nil))
)
+; Return index number of first element in list L that satisfy PRED.
+; Returns #f if not present.
+; I is added to the result, it's usually 0.
+
+(define (find-first-index i pred l)
+ (cond ((null? l) #f)
+ ((pred (car l)) i)
+ (else (find-first-index (+ 1 i) pred (cdr l))))
+)
+
; Return list of elements of L that satisfy PRED.
(define (find pred l)
OSDN Git Service
