+2003-06-10 Doug Evans <dje@sebabeach.org>
+
+ * mach.scm (current-*-add!): Disallow redefinition. Make result
+ "unspecified".
+ * insn.scm (insn-builtin!): Don't define relaxable here, now defined in
+ operand.scm.
+ * operand.scm (operand-builtin!): Define RELAXABLE for insns too.
+ * cpu/m32r.cpu (disp8,disp24): RELAX renamed to RELAXABLE.
+
+ * gen-all-doc: Split arm and frv docs up a bit.
+
+ * cpu/arm.cpu: Add IDOC attribute.
+ * cpu/frv.cpu: Ditto.
+ * cpu/i960.cpu: Ditto.
+ * cpu/openrisc.cpu: Ditto.
+ * cpu/xstormy16.cpu: Ditto.
+ * cpu/m32r.cpu: Ditto.
+ (all insns): Explicitly specify IDOC attribute.
+
+ * Makefile.am (MACH,ISAS,INSN_FILE_NAME): New vars.
+ (desc,opcodes,sim-arch,sim-cpu,gas-test,sim-test): Use MACH,ISAS.
+ (html): Use MACH,ISAS,INSN_FILE_NAME. Generate insn.html separately.
+ * Makefile.in: Regenerate.
+ * attr.scm (<integer-attribute>:parse-value-def): Implement.
+ (-attr-read): Defer computing default value until we know the type.
+ (attr-has-attr?): Delete, move contents to <attr-list>:has-attr?.
+ (<attr-list>:attr-present?): New method.
+ (atlist-attr-present?,obj-attr-present?): New fns.
+ (obj-has-attr-value?,obj-has-attr-value-no-default?): New fns.
+ (attr-builtin!): New insn attr IDOC.
+ * cgen-doc.scm (doc-arguments): New args -I,-N.
+ * enum.scm (parse-enum-vals): New arg errtxt, all callers updated.
+ Support comment as fourth element of enum value.
+ (enum-val-name,enum-val-value,enum-val-attrs,enum-val-comment): New fns.
+ * html.scm (gen-html-header): New arg kind, all callers updated.
+ (gen-table-of-contents): New arg insn-file, all callers updated.
+ (gen-list-entry,gen-doc-header): New fn.
+ (get-operands): Delete.
+ (gen-iformat-table): Rewrite.
+ (gen-insn-doc-1): Print constant-folded and trimmed semantics.
+ (gen-insn-doc-list): New args name, comment, insns. All callers updated.
+ (get-insn-properties,guess-insn-idoc-attr!): New fn.
+ (insn-sets-pc?,insn-refs-mem?,insn-uses-fpu?): New fns.
+ (get-insns-for-category,gen-categories-insn-lists): New fns.
+ (gen-insn-docs): Simplify each insn's semantics first.
+ Print insn tables sorted by IDOC categories.
+ (*insn-html-file-name*): New global.
+ (cgen-insn.html): New fn.
+ (cgen-all): Update.
+ * insn.scm (<insn>): Create a setter for the `tmp' member.
+ * semantics.scm (insn-build-known-values): Renamed from
+ -build-known-values. All callers updated.
+
+ * rtl.scm: Move traveral/evaluation support to ...
+ * rtl-traverse.scm: New file.
+ * read.scm: Maybe-load rtl-traverse.scm.
+
+ * rtl.scm (-rtx-valid-types): Add SETRTX.
+
+ * rtx-funcs.scm (nop,parallel): Fix mode.
+
+ * utils.scm (eqv-lookup-index): New fn.
+ (assq-lookup-index): Renamed from lookup-index. All callers updated.
+
+ * dev.scm (load-doc): Set APPLICATION.
+
2003-06-10 Dave Brolley <brolley@redhat.com>
* sid-cpu.scm: Generate #include of config.h into @prefix@-sem.cxx.
CGENFLAGS = -v
ARCH = @arch@
+# for various utility rules
+MACHS = all
+ISAS = all
+
+# for the html rule
+INSN_FILE_NAME = $(ARCH)-insn.html
+
srcroot = $(srcdir)/..
# Applications depend on stamp-cgen to tell them when .scm files have
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -m all -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-H tmp-desc.h -C tmp-desc.c
.PHONY: html
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -m all -a $(ARCH) \
- -H tmp-doc.html
- $(SHELL) $(srcroot)/move-if-change tmp-doc.html $(ARCH)-doc.html
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
+ -N $(INSN_FILE_NAME) \
+ -H tmp.html \
+ -I tmp-insn.html
+ $(SHELL) $(srcroot)/move-if-change tmp.html $(ARCH).html
+ $(SHELL) $(srcroot)/move-if-change tmp-insn.html $(ARCH)-insn.html
# Build the opcodes files.
# We just stuff them in tmp-* files.
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS) opinst" \
- -m all -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-O tmp-opc.h -P tmp-opc.c -Q tmp-opinst.c \
-B tmp-ibld.h -L tmp-ibld.in \
-A tmp-asm.in -D tmp-dis.in
# Build the simulator files.
# We just stuff them in tmp-* files.
# Usage: make sim-arch ARCH=<arch> OPTIONS="<option list>"
-# make sim-cpu ARCH=<arch> ISA="<isa>" MACHS="<mach list>" \
+# make sim-cpu ARCH=<arch> ISAS="<isa>" MACHS="<mach list>" \
# OPTIONS="<option list>"
.PHONY: sim-arch sim-cpu
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -m all -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-A tmp-arch.h -B tmp-arch.c -N tmp-cpuall.h
sim-cpu: sim.scm
rm -f tmp-cpu.h tmp-cpu.c tmp-decode.h tmp-decode.c
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -i "$(ISA)" -m "$(MACHS)" -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-C tmp-cpu.h -U tmp-cpu.c \
-T tmp-decode.h -D tmp-decode.c \
-M tmp-model.c \
.PHONY: gas-test
gas-test: gas-test.scm cgen-gas.scm
- @if test -z "$(ISA)" ; then \
- echo "ISA not specified!" ;\
+ @if test -z "$(ISAS)" ; then \
+ echo "ISAS not specified!" ;\
exit 1 ;\
fi
$(GUILE) -s $(srcdir)/cgen-gas.scm \
-s $(srcdir) \
$(CGENFLAGS) \
- -m all \
- -i $(ISA) \
-a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-B gas-build.sh \
-E gas-allinsn.exp
.PHONY: sim-test
sim-test: sim-test.scm cgen-stest.scm
- @if test -z "$(ISA)" ; then \
- echo "ISA not specified!" ;\
+ @if test -z "$(ISAS)" ; then \
+ echo "ISAS not specified!" ;\
exit 1 ;\
fi
$(GUILE) -s $(srcdir)/cgen-stest.scm \
-s $(srcdir) \
$(CGENFLAGS) \
- -m all \
- -i $(ISA) \
-a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-B sim-build.sh \
-E sim-allinsn.exp
CGENFLAGS = -v
ARCH = @arch@
+# for various utility rules
+MACHS = all
+ISAS = all
+
+# for the html rule
+INSN_FILE_NAME = $(ARCH)-insn.html
+
srcroot = $(srcdir)/..
CLEANFILES = tmp-*
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -m all -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-H tmp-desc.h -C tmp-desc.c
.PHONY: html
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -m all -a $(ARCH) \
- -H tmp-doc.html
- $(SHELL) $(srcroot)/move-if-change tmp-doc.html $(ARCH)-doc.html
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
+ -N $(INSN_FILE_NAME) \
+ -H tmp.html \
+ -I tmp-insn.html
+ $(SHELL) $(srcroot)/move-if-change tmp.html $(ARCH).html
+ $(SHELL) $(srcroot)/move-if-change tmp-insn.html $(ARCH)-insn.html
# Build the opcodes files.
# We just stuff them in tmp-* files.
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS) opinst" \
- -m all -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-O tmp-opc.h -P tmp-opc.c -Q tmp-opinst.c \
-B tmp-ibld.h -L tmp-ibld.in \
-A tmp-asm.in -D tmp-dis.in
# Build the simulator files.
# We just stuff them in tmp-* files.
# Usage: make sim-arch ARCH=<arch> OPTIONS="<option list>"
-# make sim-cpu ARCH=<arch> ISA="<isa>" MACHS="<mach list>" \
+# make sim-cpu ARCH=<arch> ISAS="<isa>" MACHS="<mach list>" \
# OPTIONS="<option list>"
.PHONY: sim-arch sim-cpu
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -m all -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-A tmp-arch.h -B tmp-arch.c -N tmp-cpuall.h
sim-cpu: sim.scm
rm -f tmp-cpu.h tmp-cpu.c tmp-decode.h tmp-decode.c
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
- -i "$(ISA)" -m "$(MACHS)" -a $(ARCH) \
+ -a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-C tmp-cpu.h -U tmp-cpu.c \
-T tmp-decode.h -D tmp-decode.c \
-M tmp-model.c \
.PHONY: gas-test
gas-test: gas-test.scm cgen-gas.scm
- @if test -z "$(ISA)" ; then \
- echo "ISA not specified!" ;\
+ @if test -z "$(ISAS)" ; then \
+ echo "ISAS not specified!" ;\
exit 1 ;\
fi
$(GUILE) -s $(srcdir)/cgen-gas.scm \
-s $(srcdir) \
$(CGENFLAGS) \
- -m all \
- -i $(ISA) \
-a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-B gas-build.sh \
-E gas-allinsn.exp
.PHONY: sim-test
sim-test: sim-test.scm cgen-stest.scm
- @if test -z "$(ISA)" ; then \
- echo "ISA not specified!" ;\
+ @if test -z "$(ISAS)" ; then \
+ echo "ISAS not specified!" ;\
exit 1 ;\
fi
$(GUILE) -s $(srcdir)/cgen-stest.scm \
-s $(srcdir) \
$(CGENFLAGS) \
- -m all \
- -i $(ISA) \
-a $(ARCH) \
+ -i "$(ISAS)" \
+ -m "$(MACHS)" \
-B sim-build.sh \
-E sim-allinsn.exp
nil)
)
-; For bitset attributes, VALUES is a list of symbols, one for each bit.
+; For bitset attributes VALUES is a list of
+; (symbol bit-number-or-#f attr-list comment-or-#f),
+; one for each bit.
+; If bit-number is #f (unspecified), cgen will choose.
; Int's are used to record the bitset in the generated code so there's a limit
; of 32 elements, though there's nothing inherent in the description language
; that precludes removing the limit.
+; NOTE: While one might want to record each element as an object, there's
+; currently no need for the added complexity.
(define <bitset-attribute>
(class-make '<bitset-attribute>
nil)
)
-; For integer attributes, VALUES is a list of ints, one for each possible
-; value, or the empty list of all values are permissible.
+; For integer attributes VALUES is a list of (int),
+; one for each possible value,
+; or the empty list of all values are permissible.
+; Note that each element is itself a list. This is for consistency.
(define <integer-attribute>
(class-make '<integer-attribute>
nil)
)
-; For enum attributes, VALUES is a list of symbols, one for each possible
-; value.
+; For enum attributes VALUES is a list of
+; (symbol enum-value-or-#f attr-list comment-or-#f),
+; one for each possible.
+; If enum-value is #f (unspecified) cgen will apply the standard rule for
+; assigning enum values.
+; NOTE: While one might want to record each element as an object, there's
+; currently no need for the added complexity.
(define <enum-attribute>
(class-make '<enum-attribute>
; VALUES must be a comma separated list of symbols
; (e.g. val1,val2 not (val1 val2)).
+; FIXME: require values to be a string (i.e. "val1,val2")
(define (bitset-attr-make name values) (cons name values))
(method-make!
<bitset-attribute> 'parse-value-def
(lambda (self errtxt values)
- (parse-enum-vals "" values))
+ (parse-enum-vals errtxt "" values))
)
; Parse an integer attribute's value definition.
-; FIXME: Unfinished.
+; VALUES may be #f which means any value is ok.
(method-make!
<integer-attribute> 'parse-value-def
- (lambda (self errtxt values) values)
+ (lambda (self errtxt values)
+ (if values
+ (for-each (lambda (val)
+ (if (or (not (list? val))
+ (not (number? (car val))))
+ (parse-error errtxt "invalid element in integer attribute list" val)))
+ values))
+ values)
)
; Parse an enum attribute's value definition.
(method-make!
<enum-attribute> 'parse-value-def
(lambda (self errtxt values)
- (parse-enum-vals "" values))
+ (parse-enum-vals errtxt "" values))
)
; Make an attribute list object from a list of name/value pairs.
(comment "")
(attrs nil)
(for #f) ; assume for everything
- (default #f) ; assume boolean
- (values '(#f #t)) ; assume boolean
+ (default #f) ; indicates "not set"
+ (values #f) ; indicates "not set"
)
; Loop over each element in ARG-LIST, recording what's found.
(let loop ((arg-list arg-list))
((values) (set! values (cdr arg)))
(else (parse-error errtxt "invalid attribute arg" arg)))
(loop (cdr arg-list)))))
+ ; Must have type now.
+ (if (eq? type-class 'not-set)
+ (parse-error errtxt "type not specified"))
+ ; Establish proper defaults now that we know the type.
+ (case (class-name type-class)
+ ((<boolean-attribute>)
+ (if (eq? default #f)
+ (set! default #f)) ; really a nop, but for consistency
+ (if (eq? values #f)
+ (set! values '(#f #t))))
+ ((bitset-attribute>)
+ (if (eq? default #f)
+ (parse-error errtxt "bitset-attribute default not specified"))
+ (if (eq? values #f)
+ (parse-error errtxt "bitset-attribute values not specified")))
+ ((integer-attribute>)
+ (if (eq? default #f)
+ (set! default 0))
+ (if (eq? values #f)
+ (set! values #f))) ; really a nop, but for consistency
+ ((enum-attribute>)
+ (if (eq? default #f)
+ (parse-error errtxt "enum-attribute default not specified"))
+ (if (eq? values #f)
+ (parse-error errtxt "bitset-attribute values not specified")))
+ )
; Now that we've identified the elements, build the object.
(-attr-parse errtxt type-class name comment attrs for default values)
)
)
-; Main routine for defining attributes in .cpu files.
+; Main routines for defining attributes in .cpu files.
(define define-attr
(lambda arg-list
; attribute alist ALIST.
; Note that if the attribute isn't present, it is defined to be #f.
-(define (attr-has-attr? alist attr)
- (let ((a (assq attr alist)))
- (cond ((not a) a)
- ((boolean? (cdr a)) (cdr a))
- (else (error "Not a boolean attribute:" attr))))
-)
-
-(method-make! <attr-list> 'has-attr?
- (lambda (self attr) (attr-has-attr? (elm-get self 'attrs) attr))
+(method-make!
+ <attr-list> 'has-attr?
+ (lambda (self attr)
+ (let ((a (assq attr (elm-get self 'attrs))))
+ (cond ((not a) a)
+ ((boolean? (cdr a)) (cdr a))
+ (else (error "Not a boolean attribute:" attr)))))
)
(define (atlist-has-attr? atlist attr)
(send atlist 'has-attr? attr)
)
+; Return a boolean indicating if attribute ATTR is present in
+; attribute alist ALIST.
+
+(method-make!
+ <attr-list> 'attr-present?
+ (lambda (self attr)
+ (->bool (assq attr (elm-get self 'attrs))))
+)
+
+(define (atlist-attr-present? atlist attr)
+ (send atlist 'attr-present? attr)
+)
+
; Expand attribute value ATVAL, which is an rtx expression.
; OWNER is the containing object or #f if there is none.
; OWNER is needed if an attribute is defined in terms of other attributes.
atlist-empty
result))
)
+
(define (obj-set-atlist! obj attrs) (send obj 'set-atlist! attrs))
; Add attribute ATTR to OBJ.
)
; Return boolean of whether OBJ has boolean attribute ATTR or not.
-; OBJ is any object.
+; OBJ is any object that supports attributes.
(define (obj-has-attr? obj attr)
(atlist-has-attr? (obj-atlist obj) attr)
; FIXME: for backward compatibility. Delete in time.
(define has-attr? obj-has-attr?)
+; Return a boolean indicating if attribute ATTR is present in OBJ.
+
+(define (obj-attr-present? obj attr)
+ (atlist-attr-present? (obj-atlist obj) attr)
+)
+
; Return value of attribute ATTR in OBJ.
; If the attribute isn't present, the default is returned.
; OBJ is any object that supports the get-atlist method.
(let ((atlist (obj-atlist obj)))
(atlist-attr-value atlist attr obj))
)
+
+; Return boolean of whether OBJ has attribute ATTR value VALUE or not.
+; OBJ is any object that supports attributes.
+; NOTE: The default value of the attribute IS considered.
+
+(define (obj-has-attr-value? obj attr value)
+ (let ((a (obj-attr-value obj attr)))
+ (eq? a value))
+)
+
+; Return boolean of whether OBJ explicitly has attribute ATTR value VALUE
+; or not.
+; OBJ is any object that supports attributes.
+; NOTE: The default value of the attribute IS NOT considered.
+
+(define (obj-has-attr-value-no-default? obj attr value)
+ (let* ((atlist (obj-atlist obj))
+ (objs-value (atlist-attr-value-no-default atlist attr obj)))
+ (and (not (null? objs-value)) (eq? value objs-value)))
+)
\f
; Utilities.
; CPU description file generator for CGEN cpu documentation
-; This is invoked to build: $arch-doc.html.
+; This is invoked to build: $arch.html.
; Copyright (C) 2003 Doug Evans
; This file is part of CGEN.
;
(define doc-arguments
(list
- (list '-H "file" "generate $arch-doc.html in <file>"
- (lambda (arg) (file-write arg cgen-doc.html)))
+ (list '-H "file" "generate $arch.html in <file>"
+ (lambda (arg) (file-write arg cgen.html)))
+ ; can't use '-I because that gets interpreted as a complex number
+ (list (string->symbol "-I") "file" "generate $arch-insn.html in <file>"
+ (lambda (arg) (file-write arg cgen-insn.html)))
+ (list '-N "file" "specify name of insn.html file"
+ (lambda (arg) (set! *insn-html-file-name* arg)))
)
)
1 1 ; issue done
() () () ())
)
+
+; IDOC attribute for instruction documentation.
+; FIXME: Categorization is a bit tricky when alu ops can set the pc.
+
+(define-attr
+ (for insn)
+ (type enum)
+ (name IDOC)
+ (comment "insn kind for documentation")
+ (attrs META)
+ (values
+ (MEM - () "Memory")
+ (ALU - () "ALU")
+ (FPU - () "FPU")
+ (BR - () "Branch")
+ (PRIV - () "Priviledged")
+ (MISC - () "Miscellaneous")
+ )
+)
\f
; Hardware.
(comment "placeholder attribute")
(attrs META) ; do not define in any generated file for now
)
+
+; IDOC attribute for instruction documentation.
+
+(define-attr
+ (for insn)
+ (type enum)
+ (name IDOC)
+ (comment "insn kind for documentation")
+ (attrs META)
+ (values
+ (MEM - () "Memory")
+ (ALU - () "ALU")
+ (FPU - () "FPU")
+ (BR - () "Branch")
+ (PRIV - () "Priviledged")
+ (MISC - () "Miscellaneous")
+ )
+)
\f
; Instruction fields.
;
\f
; Instruction definitions.
+; IDOC attribute for instruction documentation.
+
+(define-attr
+ (for insn)
+ (type enum)
+ (name IDOC)
+ (comment "insn kind for documentation")
+ (attrs META)
+ (values
+ (MEM - () "Memory")
+ (ALU - () "ALU")
+ (FPU - () "FPU")
+ (BR - () "Branch")
+ (PRIV - () "Priviledged")
+ (MISC - () "Miscellaneous")
+ )
+)
+
; ??? Maybe I should just reverse the operands in the alu-op macro.
(define-pmacro (divo-expr expr1 expr2) (udiv expr2 expr1))
; Attributes.
; An attribute to describe which pipeline an insn runs in.
+
(define-attr
(for insn)
(type enum)
(comment "parallel execution pipeline selection")
(values NONE O S OS)
)
+
; A derived attribute that says which insns can be executed in parallel
; with others. This is a required attribute for architectures with
; parallel execution.
+
(define-attr
(for insn)
(type enum)
(define-operand
(name disp8)
(comment "8 bit displacement")
- (attrs RELAX)
+ (attrs RELAXABLE)
(type h-iaddr)
(index f-disp8)
; ??? Early experiments had insert/extract fields here.
; fields here to handle more complicated cases.
)
-(dnop disp16 "16 bit displacement" () h-iaddr f-disp16)
-(dnop disp24 "24 bit displacement" (RELAX) h-iaddr f-disp24)
+(dnop disp16 "16 bit displacement" () h-iaddr f-disp16)
+(dnop disp24 "24 bit displacement" (RELAXABLE) h-iaddr f-disp24)
; These hardware elements are refered to frequently.
(comment "non-public m32rx insn")
)
+; IDOC attribute for instruction documentation.
+
+(define-attr
+ (for insn)
+ (type enum)
+ (name IDOC)
+ (comment "insn kind for documentation")
+ (attrs META)
+ (values
+ (MEM - () "Memory")
+ (ALU - () "ALU")
+ (BR - () "Branch")
+ (ACCUM - () "Accumulator")
+ (MAC - () "Multiply/Accumulate")
+ (MISC - () "Miscellaneous")
+ )
+)
+
(define-pmacro (bin-op mnemonic op2-op sem-op imm-prefix imm)
(begin
(dni mnemonic
(.str mnemonic " reg/reg")
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
(.str mnemonic " $dr,$sr")
(+ OP1_0 op2-op dr sr)
(set dr (sem-op dr sr))
)
(dni (.sym mnemonic "3")
(.str mnemonic " reg/" imm)
- ()
+ ((IDOC ALU))
(.str mnemonic "3 $dr,$sr," imm-prefix "$" imm)
(+ OP1_8 op2-op dr sr imm)
(set dr (sem-op sr imm))
(bin-op xor OP2_13 xor "" uimm16)
(dni addi "addi"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
; #.: experiment
#.(string-append "addi " "$dr,$simm8")
(+ OP1_4 dr simm8)
)
(dni addv "addv"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"addv $dr,$sr"
(+ OP1_0 OP2_8 dr sr)
(parallel ()
)
(dni addv3 "addv3"
- ()
+ ((IDOC ALU))
"addv3 $dr,$sr,$simm16"
(+ OP1_8 OP2_8 dr sr simm16)
(parallel ()
)
(dni addx "addx"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"addx $dr,$sr"
(+ OP1_0 OP2_9 dr sr)
(parallel ()
)
(dni bc8 "bc with 8 bit displacement"
- (COND-CTI (PIPE O))
+ (COND-CTI (PIPE O) (IDOC BR))
"bc.s $disp8"
(+ OP1_7 (f-r1 12) disp8)
(if condbit (set pc disp8))
)
(dnmi bc8r "relaxable bc8"
- (COND-CTI RELAXABLE (PIPE O))
+ (COND-CTI RELAXABLE (PIPE O) (IDOC BR))
"bc $disp8"
(emit bc8 disp8)
)
(dni bc24 "bc with 24 bit displacement"
- (COND-CTI)
+ (COND-CTI (IDOC BR))
"bc.l $disp24"
(+ OP1_15 (f-r1 12) disp24)
(if condbit (set pc disp24))
)
(dnmi bc24r "relaxable bc24"
- (COND-CTI RELAX)
+ (COND-CTI RELAX (IDOC BR))
"bc $disp24"
(emit bc24 disp24)
)
(dni beq "beq"
- (COND-CTI)
+ (COND-CTI (IDOC BR))
"beq $src1,$src2,$disp16"
(+ OP1_11 OP2_0 src1 src2 disp16)
(if (eq src1 src2) (set pc disp16))
)
(define-pmacro (cbranch sym comment op2-op comp-op)
- (dni sym comment (COND-CTI)
+ (dni sym comment (COND-CTI (IDOC BR))
(.str sym " $src2,$disp16")
(+ OP1_11 op2-op (f-r1 0) src2 disp16)
(if (comp-op src2 (const WI 0)) (set pc disp16))
(cbranch bnez "bnez" OP2_9 ne)
(dni bl8 "bl with 8 bit displacement"
- (UNCOND-CTI FILL-SLOT (PIPE O))
+ (UNCOND-CTI FILL-SLOT (PIPE O) (IDOC BR))
"bl.s $disp8"
(+ OP1_7 (f-r1 14) disp8)
(sequence ()
)
(dnmi bl8r "relaxable bl8"
- (UNCOND-CTI FILL-SLOT RELAXABLE (PIPE O))
+ (UNCOND-CTI FILL-SLOT RELAXABLE (PIPE O) (IDOC BR))
"bl $disp8"
(emit bl8 disp8)
)
(dni bl24 "bl with 24 bit displacement"
- (UNCOND-CTI)
+ (UNCOND-CTI (IDOC BR))
"bl.l $disp24"
(+ OP1_15 (f-r1 14) disp24)
(sequence ()
)
(dnmi bl24r "relaxable bl24"
- (UNCOND-CTI RELAX)
+ (UNCOND-CTI RELAX (IDOC BR))
"bl $disp24"
(emit bl24 disp24)
)
(dni bcl8 "bcl with 8 bit displacement"
- (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O))
+ (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) (IDOC BR))
"bcl.s $disp8"
(+ OP1_7 (f-r1 8) disp8)
(if condbit
)
(dnmi bcl8r "relaxable bcl8"
- (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) RELAXABLE)
+ (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) RELAXABLE (IDOC BR))
"bcl $disp8"
(emit bcl8 disp8)
)
(dni bcl24 "bcl with 24 bit displacement"
- (COND-CTI (MACH m32rx))
+ (COND-CTI (MACH m32rx) (IDOC BR))
"bcl.l $disp24"
(+ OP1_15 (f-r1 8) disp24)
(if condbit
)
(dnmi bcl24r "relaxable bcl24"
- (COND-CTI (MACH m32rx) RELAX)
+ (COND-CTI (MACH m32rx) RELAX (IDOC BR))
"bcl $disp24"
(emit bcl24 disp24)
)
(dni bnc8 "bnc with 8 bit displacement"
- (COND-CTI (PIPE O))
+ (COND-CTI (PIPE O) (IDOC BR))
"bnc.s $disp8"
(+ OP1_7 (f-r1 13) disp8)
(if (not condbit) (set pc disp8))
)
(dnmi bnc8r "relaxable bnc8"
- (COND-CTI RELAXABLE (PIPE O))
+ (COND-CTI RELAXABLE (PIPE O) (IDOC BR))
"bnc $disp8"
(emit bnc8 disp8)
)
(dni bnc24 "bnc with 24 bit displacement"
- (COND-CTI)
+ (COND-CTI (IDOC BR))
"bnc.l $disp24"
(+ OP1_15 (f-r1 13) disp24)
(if (not condbit) (set pc disp24))
)
(dnmi bnc24r "relaxable bnc24"
- (COND-CTI RELAX)
+ (COND-CTI RELAX (IDOC BR))
"bnc $disp24"
(emit bnc24 disp24)
)
(dni bne "bne"
- (COND-CTI)
+ (COND-CTI (IDOC BR))
"bne $src1,$src2,$disp16"
(+ OP1_11 OP2_1 src1 src2 disp16)
(if (ne src1 src2) (set pc disp16))
)
(dni bra8 "bra with 8 bit displacement"
- (UNCOND-CTI FILL-SLOT (PIPE O))
+ (UNCOND-CTI FILL-SLOT (PIPE O) (IDOC BR))
"bra.s $disp8"
(+ OP1_7 (f-r1 15) disp8)
(set pc disp8)
)
(dnmi bra8r "relaxable bra8"
- (UNCOND-CTI FILL-SLOT RELAXABLE (PIPE O))
+ (UNCOND-CTI FILL-SLOT RELAXABLE (PIPE O) (IDOC BR))
"bra $disp8"
(emit bra8 disp8)
)
(dni bra24 "bra with 24 displacement"
- (UNCOND-CTI)
+ (UNCOND-CTI (IDOC BR))
"bra.l $disp24"
(+ OP1_15 (f-r1 15) disp24)
(set pc disp24)
)
(dnmi bra24r "relaxable bra24"
- (UNCOND-CTI RELAX)
+ (UNCOND-CTI RELAX (IDOC BR))
"bra $disp24"
(emit bra24 disp24)
)
(dni bncl8 "bncl with 8 bit displacement"
- (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O))
+ (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) (IDOC BR))
"bncl.s $disp8"
(+ OP1_7 (f-r1 9) disp8)
(if (not condbit)
)
(dnmi bncl8r "relaxable bncl8"
- (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) RELAXABLE)
+ (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) RELAXABLE (IDOC BR))
"bncl $disp8"
(emit bncl8 disp8)
)
(dni bncl24 "bncl with 24 bit displacement"
- (COND-CTI (MACH m32rx))
+ (COND-CTI (MACH m32rx) (IDOC BR))
"bncl.l $disp24"
(+ OP1_15 (f-r1 9) disp24)
(if (not condbit)
)
(dnmi bncl24r "relaxable bncl24"
- (COND-CTI (MACH m32rx) RELAX)
+ (COND-CTI (MACH m32rx) RELAX (IDOC BR))
"bncl $disp24"
(emit bncl24 disp24)
)
(dni cmp "cmp"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"cmp $src1,$src2"
(+ OP1_0 OP2_4 src1 src2)
(set condbit (lt src1 src2))
)
(dni cmpi "cmpi"
- ()
+ ((IDOC ALU))
"cmpi $src2,$simm16"
(+ OP1_8 (f-r1 0) OP2_4 src2 simm16)
(set condbit (lt src2 simm16))
)
(dni cmpu "cmpu"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"cmpu $src1,$src2"
(+ OP1_0 OP2_5 src1 src2)
(set condbit (ltu src1 src2))
)
(dni cmpui "cmpui"
- ()
+ ((IDOC ALU))
"cmpui $src2,$simm16"
(+ OP1_8 (f-r1 0) OP2_5 src2 simm16)
(set condbit (ltu src2 simm16))
)
(dni cmpeq "cmpeq"
- ((MACH m32rx) (PIPE OS))
+ ((MACH m32rx) (PIPE OS) (IDOC ALU))
"cmpeq $src1,$src2"
(+ OP1_0 OP2_6 src1 src2)
(set condbit (eq src1 src2))
)
(dni cmpz "cmpz"
- ((MACH m32rx) (PIPE OS))
+ ((MACH m32rx) (PIPE OS) (IDOC ALU))
"cmpz $src2"
(+ OP1_0 OP2_7 (f-r1 0) src2)
(set condbit (eq src2 (const 0)))
)
(dni div "div"
- ()
+ ((IDOC ALU))
"div $dr,$sr"
(+ OP1_9 OP2_0 dr sr (f-simm16 0))
(if (ne sr (const 0)) (set dr (div dr sr)))
)
(dni divu "divu"
- ()
+ ((IDOC ALU))
"divu $dr,$sr"
(+ OP1_9 OP2_1 dr sr (f-simm16 0))
(if (ne sr (const 0)) (set dr (udiv dr sr)))
)
(dni rem "rem"
- ()
+ ((IDOC ALU))
"rem $dr,$sr"
(+ OP1_9 OP2_2 dr sr (f-simm16 0))
; FIXME: Check rounding direction.
)
(dni remu "remu"
- ()
+ ((IDOC ALU))
"remu $dr,$sr"
(+ OP1_9 OP2_3 dr sr (f-simm16 0))
; FIXME: Check rounding direction.
)
(dni divh "divh"
- ((MACH m32rx))
+ ((MACH m32rx) (IDOC ALU))
"divh $dr,$sr"
(+ OP1_9 OP2_0 dr sr (f-simm16 #x10))
(if (ne sr (const 0)) (set dr (div (ext WI (trunc HI dr)) sr)))
)
(dni jc "jc"
- (COND-CTI (MACH m32rx) (PIPE O) SPECIAL)
+ (COND-CTI (MACH m32rx) (PIPE O) SPECIAL (IDOC BR))
"jc $sr"
(+ OP1_1 (f-r1 12) OP2_12 sr)
(if condbit (set pc (and sr (const -4))))
)
(dni jnc "jnc"
- (COND-CTI (MACH m32rx) (PIPE O) SPECIAL)
+ (COND-CTI (MACH m32rx) (PIPE O) SPECIAL (IDOC BR))
"jnc $sr"
(+ OP1_1 (f-r1 13) OP2_12 sr)
(if (not condbit) (set pc (and sr (const -4))))
)
(dni jl "jl"
- (UNCOND-CTI FILL-SLOT (PIPE O))
+ (UNCOND-CTI FILL-SLOT (PIPE O) (IDOC BR))
"jl $sr"
(+ OP1_1 (f-r1 14) OP2_12 sr)
(parallel ()
)
(dni jmp "jmp"
- (UNCOND-CTI (PIPE O))
+ (UNCOND-CTI (PIPE O) (IDOC BR))
"jmp $sr"
(+ OP1_1 (f-r1 15) OP2_12 sr)
(set pc (and sr (const -4)))
(define-pmacro (load-op suffix op2-op mode ext-op)
(begin
(dni (.sym ld suffix) (.str "ld" suffix)
- ((PIPE O))
+ ((PIPE O) (IDOC MEM))
(.str "ld" suffix " $dr,@$sr")
(+ OP1_2 op2-op dr sr)
(set dr (ext-op WI (mem mode sr)))
(m32rx (unit u-load)))
)
(dnmi (.sym ld suffix "-2") (.str "ld" suffix "-2")
- (NO-DIS (PIPE O))
+ (NO-DIS (PIPE O) (IDOC MEM))
(.str "ld" suffix " $dr,@($sr)")
(emit (.sym ld suffix) dr sr))
(dni (.sym ld suffix -d) (.str "ld" suffix "-d")
- ()
+ ((IDOC MEM))
(.str "ld" suffix " $dr,@($slo16,$sr)")
(+ OP1_10 op2-op dr sr slo16)
(set dr (ext-op WI (mem mode (add sr slo16))))
(m32rx (unit u-load (cycles 2))))
)
(dnmi (.sym ld suffix -d2) (.str "ld" suffix "-d2")
- (NO-DIS)
+ (NO-DIS (IDOC MEM))
(.str "ld" suffix " $dr,@($sr,$slo16)")
(emit (.sym ld suffix -d) dr sr slo16))
)
(load-op uh OP2_11 HI zext-expr)
(dni ld-plus "ld+"
- ((PIPE O))
+ ((PIPE O) (IDOC MEM))
"ld $dr,@$sr+"
(+ OP1_2 dr OP2_14 sr)
(parallel ()
)
(dnmi pop "pop"
- ()
+ ((IDOC MEM))
"pop $dr"
(emit ld-plus dr (sr 15)) ; "ld %0,@sp+"
)
(dni ld24 "ld24"
- ()
+ ((IDOC MEM))
"ld24 $dr,$uimm24"
(+ OP1_14 dr uimm24)
(set dr uimm24)
; ldi8 appears before ldi16 so we try the shorter version first
(dni ldi8 "ldi8"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"ldi8 $dr,$simm8"
(+ OP1_6 dr simm8)
(set dr simm8)
)
(dnmi ldi8a "ldi8 alias"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"ldi $dr,$simm8"
(emit ldi8 dr simm8)
)
(dni ldi16 "ldi16"
- ()
+ ((IDOC ALU))
"ldi16 $dr,$hash$slo16"
(+ OP1_9 OP2_15 (f-r2 0) dr slo16)
(set dr slo16)
)
(dnmi ldi16a "ldi16 alias"
- ()
+ ((IDOC ALU))
"ldi $dr,$hash$slo16"
(emit ldi16 dr slo16)
)
(dni lock "lock"
- ((PIPE O))
+ ((PIPE O) (IDOC MISC))
"lock $dr,@$sr"
(+ OP1_2 OP2_13 dr sr)
(sequence ()
(
; (MACH m32r) is a temporary hack. This insn collides with machi-a
; in the simulator so disable it for m32rx.
- (MACH m32r) (PIPE S)
+ (MACH m32r) (PIPE S) (IDOC MAC)
)
"machi $src1,$src2"
(+ OP1_3 OP2_4 src1 src2)
)
(dni machi-a "machi-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"machi $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 4) src2)
(set acc
)
(dni maclo "maclo"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC MAC))
"maclo $src1,$src2"
(+ OP1_3 OP2_5 src1 src2)
(set accum
)
(dni maclo-a "maclo-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"maclo $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 5) src2)
(set acc
)
(dni macwhi "macwhi"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC MAC))
"macwhi $src1,$src2"
(+ OP1_3 OP2_6 src1 src2)
(set accum
)
(dni macwhi-a "macwhi-a"
- ((MACH m32rx) (PIPE S) SPECIAL)
+ ((MACH m32rx) (PIPE S) SPECIAL (IDOC MAC))
"macwhi $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 6) src2)
; Note that this doesn't do the sign extension, which is correct.
)
(dni macwlo "macwlo"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC MAC))
"macwlo $src1,$src2"
(+ OP1_3 OP2_7 src1 src2)
(set accum
)
(dni macwlo-a "macwlo-a"
- ((MACH m32rx) (PIPE S) SPECIAL)
+ ((MACH m32rx) (PIPE S) SPECIAL (IDOC MAC))
"macwlo $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 7) src2)
; Note that this doesn't do the sign extension, which is correct.
)
(dni mul "mul"
- ((PIPE S))
+ ((PIPE S) (IDOC ALU))
"mul $dr,$sr"
(+ OP1_1 OP2_6 dr sr)
(set dr (mul dr sr))
)
(dni mulhi "mulhi"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mulhi $src1,$src2"
(+ OP1_3 OP2_0 src1 src2)
(set accum
)
(dni mulhi-a "mulhi-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mulhi $src1,$src2,$acc"
(+ OP1_3 (f-op23 0) src1 acc src2)
(set acc
)
(dni mullo "mullo"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mullo $src1,$src2"
(+ OP1_3 OP2_1 src1 src2)
(set accum
)
(dni mullo-a "mullo-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mullo $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 1) src2)
(set acc
)
(dni mulwhi "mulwhi"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mulwhi $src1,$src2"
(+ OP1_3 OP2_2 src1 src2)
(set accum
)
(dni mulwhi-a "mulwhi-a"
- ((MACH m32rx) (PIPE S) SPECIAL)
+ ((MACH m32rx) (PIPE S) SPECIAL (IDOC ACCUM))
"mulwhi $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 2) src2)
; Note that this doesn't do the sign extension, which is correct.
)
(dni mulwlo "mulwlo"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mulwlo $src1,$src2"
(+ OP1_3 OP2_3 src1 src2)
(set accum
)
(dni mulwlo-a "mulwlo-a"
- ((MACH m32rx) (PIPE S) SPECIAL)
+ ((MACH m32rx) (PIPE S) SPECIAL (IDOC ACCUM))
"mulwlo $src1,$src2,$acc"
(+ OP1_3 src1 acc (f-op23 3) src2)
; Note that this doesn't do the sign extension, which is correct.
)
(dni mv "mv"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"mv $dr,$sr"
(+ OP1_1 OP2_8 dr sr)
(set dr sr)
)
(dni mvfachi "mvfachi"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mvfachi $dr"
(+ OP1_5 OP2_15 (f-r2 0) dr)
(set dr (trunc WI (sra DI accum (const 32))))
)
(dni mvfachi-a "mvfachi-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mvfachi $dr,$accs"
(+ OP1_5 dr OP2_15 accs (f-op3 0))
(set dr (trunc WI (sra DI accs (const 32))))
)
(dni mvfaclo "mvfaclo"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mvfaclo $dr"
(+ OP1_5 OP2_15 (f-r2 1) dr)
(set dr (trunc WI accum))
)
(dni mvfaclo-a "mvfaclo-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mvfaclo $dr,$accs"
(+ OP1_5 dr OP2_15 accs (f-op3 1))
(set dr (trunc WI accs))
)
(dni mvfacmi "mvfacmi"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mvfacmi $dr"
(+ OP1_5 OP2_15 (f-r2 2) dr)
(set dr (trunc WI (sra DI accum (const 16))))
)
(dni mvfacmi-a "mvfacmi-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mvfacmi $dr,$accs"
(+ OP1_5 dr OP2_15 accs (f-op3 2))
(set dr (trunc WI (sra DI accs (const 16))))
)
(dni mvfc "mvfc"
- ((PIPE O))
+ ((PIPE O) (IDOC MISC))
"mvfc $dr,$scr"
(+ OP1_1 OP2_9 dr scr)
(set dr scr)
)
(dni mvtachi "mvtachi"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mvtachi $src1"
(+ OP1_5 OP2_7 (f-r2 0) src1)
(set accum
)
(dni mvtachi-a "mvtachi-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mvtachi $src1,$accs"
(+ OP1_5 src1 OP2_7 accs (f-op3 0))
(set accs
)
(dni mvtaclo "mvtaclo"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC ACCUM))
"mvtaclo $src1"
(+ OP1_5 OP2_7 (f-r2 1) src1)
(set accum
)
(dni mvtaclo-a "mvtaclo-a"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"mvtaclo $src1,$accs"
(+ OP1_5 src1 OP2_7 accs (f-op3 1))
(set accs
)
(dni mvtc "mvtc"
- ((PIPE O))
+ ((PIPE O) (IDOC MISC))
"mvtc $sr,$dcr"
(+ OP1_1 OP2_10 dcr sr)
(set dcr sr)
)
(dni neg "neg"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"neg $dr,$sr"
(+ OP1_0 OP2_3 dr sr)
(set dr (neg sr))
)
(dni nop "nop"
- ((PIPE OS))
+ ((PIPE OS) (IDOC MISC))
"nop"
(+ OP1_7 OP2_0 (f-r1 0) (f-r2 0))
(c-code VOID "PROFILE_COUNT_FILLNOPS (current_cpu, abuf->addr);\n")
)
(dni not "not"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"not $dr,$sr"
(+ OP1_0 OP2_11 dr sr)
(set dr (inv sr))
)
(dni rac "rac"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC MAC))
"rac"
(+ OP1_5 OP2_9 (f-r1 0) (f-r2 0))
(sequence ((DI tmp1))
)
(dni rac-dsi "rac-dsi"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"rac $accd,$accs,$imm1"
(+ OP1_5 accd (f-bits67 0) OP2_9 accs (f-bit14 0) imm1)
(sequence ((DI tmp1))
)
(dnmi rac-d "rac-d"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"rac $accd"
(emit rac-dsi accd (f-accs 0) (f-imm1 0))
)
(dnmi rac-ds "rac-ds"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"rac $accd,$accs"
(emit rac-dsi accd accs (f-imm1 0))
)
(dni rach "rach"
- ((MACH m32r) (PIPE S))
+ ((MACH m32r) (PIPE S) (IDOC MAC))
"rach"
(+ OP1_5 OP2_8 (f-r1 0) (f-r2 0))
(sequence ((DI tmp1))
)
(dni rach-dsi "rach-dsi"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"rach $accd,$accs,$imm1"
(+ OP1_5 accd (f-bits67 0) OP2_8 accs (f-bit14 0) imm1)
(sequence ((DI tmp1))
)
(dnmi rach-d "rach-d"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"rach $accd"
(emit rach-dsi accd (f-accs 0) (f-imm1 0))
)
(dnmi rach-ds "rach-ds"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"rach $accd,$accs"
(emit rach-dsi accd accs (f-imm1 0))
)
(dni rte "rte"
- (UNCOND-CTI (PIPE O))
+ (UNCOND-CTI (PIPE O) (IDOC BR))
"rte"
(+ OP1_1 OP2_13 (f-r1 0) (f-r2 6))
(sequence ()
)
(dni seth "seth"
- ()
+ ((IDOC ALU))
"seth $dr,$hash$hi16"
(+ OP1_13 OP2_12 dr (f-r2 0) hi16)
(set dr (sll WI hi16 (const 16)))
(define-pmacro (shift-op sym op2-r-op op2-3-op op2-i-op sem-op)
(begin
- (dni sym sym ((PIPE O))
+ (dni sym sym ((PIPE O) (IDOC ALU))
(.str sym " $dr,$sr")
(+ OP1_1 op2-r-op dr sr)
(set dr (sem-op dr (and sr (const 31))))
()
)
- (dni (.sym sym "3") sym ()
+ (dni (.sym sym "3") sym ((IDOC ALU))
(.str sym "3 $dr,$sr,$simm16")
(+ OP1_9 op2-3-op dr sr simm16)
(set dr (sem-op sr (and WI simm16 (const 31))))
()
)
- (dni (.sym sym "i") sym ((PIPE O))
+ (dni (.sym sym "i") sym ((PIPE O) (IDOC ALU))
(.str sym "i $dr,$uimm5")
(+ OP1_5 (f-shift-op2 op2-i-op) dr uimm5)
(set dr (sem-op dr uimm5))
(define-pmacro (store-op suffix op2-op mode)
(begin
(dni (.sym st suffix) (.str "st" suffix)
- ((PIPE O))
+ ((PIPE O) (IDOC MEM))
(.str "st" suffix " $src1,@$src2")
(+ OP1_2 op2-op src1 src2)
(set mode (mem mode src2) src1)
(m32rx (unit u-store (cycles 1))))
)
(dnmi (.sym st suffix "-2") (.str "st" suffix "-2")
- (NO-DIS (PIPE O))
+ (NO-DIS (PIPE O) (IDOC MEM))
(.str "st" suffix " $src1,@($src2)")
(emit (.sym st suffix) src1 src2))
(dni (.sym st suffix -d) (.str "st" suffix "-d")
- ()
+ ((IDOC MEM))
(.str "st" suffix " $src1,@($slo16,$src2)")
(+ OP1_10 op2-op src1 src2 slo16)
(set mode (mem mode (add src2 slo16)) src1)
(m32rx (unit u-store (cycles 2))))
)
(dnmi (.sym st suffix -d2) (.str "st" suffix "-d2")
- (NO-DIS)
+ (NO-DIS (IDOC MEM))
(.str "st" suffix " $src1,@($src2,$slo16)")
(emit (.sym st suffix -d) src1 src2 slo16))
)
(store-op h OP2_2 HI)
(dni st-plus "st+"
- ((PIPE O))
+ ((PIPE O) (IDOC MEM))
"st $src1,@+$src2"
(+ OP1_2 OP2_6 src1 src2)
; This has to be coded carefully to avoid an "earlyclobber" of src2.
)
(dni st-minus "st-"
- ((PIPE O))
+ ((PIPE O) (IDOC MEM))
"st $src1,@-$src2"
(+ OP1_2 OP2_7 src1 src2)
; This is the original way. It doesn't work for parallel execution
)
)
-(dnmi push "push" ()
+(dnmi push "push" ((IDOC MEM))
"push $src1"
(emit st-minus src1 (src2 15)) ; "st %0,@-sp"
)
(dni sub "sub"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"sub $dr,$sr"
(+ OP1_0 OP2_2 dr sr)
(set dr (sub dr sr))
)
(dni subv "sub:rv"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"subv $dr,$sr"
(+ OP1_0 OP2_0 dr sr)
(parallel ()
)
(dni subx "sub:rx"
- ((PIPE OS))
+ ((PIPE OS) (IDOC ALU))
"subx $dr,$sr"
(+ OP1_0 OP2_1 dr sr)
(parallel ()
)
(dni trap "trap"
- (UNCOND-CTI FILL-SLOT (PIPE O))
+ (UNCOND-CTI FILL-SLOT (PIPE O) (IDOC MISC))
"trap $uimm4"
(+ OP1_1 OP2_15 (f-r1 0) uimm4)
(sequence ()
)
(dni unlock "unlock"
- ((PIPE O))
+ ((PIPE O) (IDOC MISC))
"unlock $src1,@$src2"
(+ OP1_2 OP2_5 src1 src2)
(sequence ()
; Saturate into byte.
(dni satb "satb"
- ((MACH m32rx))
+ ((MACH m32rx) (IDOC ALU))
"satb $dr,$sr"
(+ OP1_8 dr OP2_6 sr (f-uimm16 #x0300))
(set dr
; Saturate into half word.
(dni sath "sath"
- ((MACH m32rx))
+ ((MACH m32rx) (IDOC ALU))
"sath $dr,$sr"
(+ OP1_8 dr OP2_6 sr (f-uimm16 #x0200))
(set dr
; Saturate word.
(dni sat "sat"
- ((MACH m32rx) SPECIAL)
+ ((MACH m32rx) SPECIAL (IDOC ALU))
"sat $dr,$sr"
(+ OP1_8 dr OP2_6 sr (f-uimm16 0))
(set dr
; Parallel compare byte zeros.
; Set C bit in condition register if any byte in source register is zero.
(dni pcmpbz "pcmpbz"
- ((MACH m32rx) (PIPE OS) SPECIAL)
+ ((MACH m32rx) (PIPE OS) SPECIAL (IDOC ALU))
"pcmpbz $src2"
(+ OP1_0 (f-r1 3) OP2_7 src2)
(set condbit
; Add accumulators
(dni sadd "sadd"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC ACCUM))
"sadd"
(+ OP1_5 (f-r1 0) OP2_14 (f-r2 4))
(set (reg h-accums 0)
; Multiply and add into accumulator 1
(dni macwu1 "macwu1"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"macwu1 $src1,$src2"
(+ OP1_5 src1 OP2_11 src2)
(set (reg h-accums 1)
; Multiply and subtract from accumulator 0
(dni msblo "msblo"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"msblo $src1,$src2"
(+ OP1_5 src1 OP2_13 src2)
(set accum
; Multiply into accumulator 1
(dni mulwu1 "mulwu1"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"mulwu1 $src1,$src2"
(+ OP1_5 src1 OP2_10 src2)
(set (reg h-accums 1)
; Multiply and add into accumulator 1
(dni maclh1 "maclh1"
- ((MACH m32rx) (PIPE S))
+ ((MACH m32rx) (PIPE S) (IDOC MAC))
"maclh1 $src1,$src2"
(+ OP1_5 src1 OP2_12 src2)
(set (reg h-accums 1)
; skip instruction if C
(dni sc "sc"
- ((MACH m32rx) (PIPE O) SPECIAL)
+ ((MACH m32rx) (PIPE O) SPECIAL (IDOC BR))
"sc"
(+ OP1_7 (f-r1 4) OP2_0 (f-r2 1))
(skip (zext INT condbit))
; skip instruction if not C
(dni snc "snc"
- ((MACH m32rx) (PIPE O) SPECIAL)
+ ((MACH m32rx) (PIPE O) SPECIAL (IDOC BR))
"snc"
(+ OP1_7 (f-r1 5) OP2_0 (f-r2 1))
(skip (zext INT (not condbit)))
(comment "insn can't go in delay slot")
)
+; IDOC attribute for instruction documentation.
+
+(define-attr
+ (for insn)
+ (type enum)
+ (name IDOC)
+ (comment "insn kind for documentation")
+ (attrs META)
+ (values
+ (MEM - () "Memory")
+ (ALU - () "ALU")
+ (FPU - () "FPU")
+ (BR - () "Branch")
+ (PRIV - () "Priviledged")
+ (MISC - () "Miscellaneous")
+ )
+)
+
; Enum for exception vectors.
(define-enum
(name e-exception)
() () () ())
)
+; IDOC attribute for instruction documentation.
+
+(define-attr
+ (for insn)
+ (type enum)
+ (name IDOC)
+ (comment "insn kind for documentation")
+ (attrs META)
+ (values
+ (MEM - () "Memory")
+ (ALU - () "ALU")
+ (FPU - () "FPU")
+ (BR - () "Branch")
+ (PRIV - () "Priviledged")
+ (MISC - () "Miscellaneous")
+ )
+)
+\f
; Hardware elements.
(dsh h-pc "program counter" (PC) (pc))
(load "desc")
(load "desc-cpu")
(load "html")
+ ; ??? Necessary for the following case, dunno why.
+ ; bash$ guile -l dev.scm
+ ; guile> (load-doc)
+ ; guile> (cload #:arch "m32r")
+ (set! APPLICATION 'DOC)
)
(define (load-opc)
The operand contains negative values (not used yet so definition is
still nebulous.
-@item RELAX
+@item RELAXABLE
This operand contains the changeable field (usually a branch address) of
a relaxable instruction.
; Parse a list of enum name/value entries.
; PREFIX is prepended to each name.
; Elements are any of: symbol, (symbol), (symbol value)
-; (symbol - attrs), (symbol value attrs).
-; The `-' means use the next value.
+; (symbol - attrs), (symbol value attrs), (symbol - attrs comment),
+; (symbol value attrs comment).
+; The - or #f means "use the next value".
+; SYMBOL may be - which means "skip this value".
; The result is the same list, except values are filled in where missing,
; and each symbol is prepended with `prefix'.
-(define (parse-enum-vals prefix vals)
- ; Scan the value list, building up RES-VALS as we go.
+(define (parse-enum-vals errtxt prefix vals)
+ ; Scan the value list, building up RESULT as we go.
; Each element's value is 1+ the previous, unless there's an explicit value.
(let loop ((result nil) (last -1) (remaining vals))
(if (null? remaining)
(+ last 1))))
(if (eq? (car remaining) '-)
(loop result val (cdr remaining))
- (loop (cons (cons (symbol-append prefix
- (if (pair? (car remaining))
- (caar remaining)
- (car remaining)))
- (cons val
- ; Pass any attributes through unchanged.
- (if (and (pair? (car remaining))
- (pair? (cdar remaining)))
- (cddar remaining)
- nil)))
- result)
- val
- (cdr remaining))))))
+ (let ((name (symbol-append prefix
+ (if (pair? (car remaining))
+ (caar remaining)
+ (car remaining))))
+ (attrs (if (and (pair? (car remaining))
+ (pair? (cdar remaining))
+ (pair? (cddar remaining)))
+ (caddar remaining)
+ nil))
+ (comment (if (and (pair? (car remaining))
+ (pair? (cdar remaining))
+ (pair? (cddar remaining))
+ (pair? (cdddar remaining)))
+ (car (cdddar remaining))
+ "")))
+ (loop (cons (list name val attrs comment) result)
+ val
+ (cdr remaining)))))))
)
+; Accessors for the various elements of an enum val.
+
+(define (enum-val-name ev) (list-ref ev 0))
+(define (enum-val-value ev) (list-ref ev 1))
+(define (enum-val-attrs ev) (list-ref ev 2))
+(define (enum-val-comment ev) (list-ref ev 3))
+
; Convert the names in the result of parse-enum-vals to uppercase.
(define (enum-vals-upcase vals)
prefix
)
-; This is the main routine for building an ifield object from a
+; This is the main routine for building an enum object from a
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
(parse-comment comment errtxt)
(atlist-parse attrs "enum" errtxt)
(-enum-parse-prefix errtxt prefix)
- (parse-enum-vals prefix vals)))
+ (parse-enum-vals errtxt prefix vals)))
)
; Read an enum description
; Enums support code.
; Return #t if VALS is a sequential list of enum values.
-; VALS is a list of enums. e.g. ((sym1) (sym2 3) (sym3 '- attr1 (attr2 4)))
+; VALS is a list of enums. e.g. ((sym1) (sym2 3) (sym3 - attr1 (attr2 4)))
; FIXME: Doesn't handle gaps in specified values.
; e.g. (sym1 val1) sym2 (sym3 val3)
", ")
(gen-c-symbol prefix)
(gen-c-symbol (car e))
- (if (or sequential? (null? (cdr e)) (eq? '- (cadr e)))
+ (if (or sequential?
+ (null? (cdr e))
+ (eq? '- (cadr e)))
""
(string-append " = "
(if (number? (cadr e))
(atlist-parse attrs "insn-enum" errtxt)
(-enum-parse-prefix errtxt prefix)
fld-obj
- (parse-enum-vals prefix vals))))
+ (parse-enum-vals errtxt prefix vals))))
(current-enum-add! e)
e))))
)
for a in $archs
do
- make html ARCH=$a
+ case $a in
+ arm)
+ make html ARCH=$a ISAS=arm INSN_FILE_NAME=arm-arm-insn.html
+ mv arm.html arm-arm.html
+ mv arm-insn.html arm-arm-insn.html
+ make html ARCH=$a ISAS=thumb INSN_FILE_NAME=arm-thumb-insn.html
+ mv arm.html arm-thumb.html
+ mv arm-insn.html arm-thumb-insn.html
+ ;;
+ frv)
+ make html ARCH=$a MACHS="frv,simple,tomcat,fr400" INSN_FILE_NAME=frv-1-insn.html
+ mv frv.html frv-1.html
+ mv frv-insn.html frv-1-insn.html
+ make html ARCH=$a MACHS="fr500" INSN_FILE_NAME=frv-2-insn.html
+ mv frv.html frv-2.html
+ mv frv-insn.html frv-2-insn.html
+ ;;
+ *)
+ make html ARCH=$a
+ ;;
+ esac
done
)
; - for insn formats, consider printing them better,
; e.g. maybe generate image and include that instead
; - need ability to specify more prose for each architecture
-; - frv-doc.html is massive, default plan is to split it up by machine
-; but is that the way to go here?
-; --> split up output into several files anyway (for all archs)
; - assembler support
; - need to add docs to website that can be linked to here, rather than
; including generic cgen documentation here
"\n>\n\n")
)
+; KIND is one of "Architecture" or "Instruction".
; TODO: Add author arg so all replies for this arch go to right person.
-(define (gen-html-header)
+(define (gen-html-header kind)
(let ((arch (current-arch-name))
(ARCH (string-upcase (current-arch-name))))
(string-list
"<html>\n"
"<head>\n"
" <meta http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\">\n"
- " <meta name=\"description\" content=\"" ARCH " Architecture Documentation\">\n"
+ " <meta name=\"description\" content=\"" ARCH " " kind " Documentation\">\n"
" <meta name=\"language\" content=\"en-us\">\n"
" <meta name=\"owner\" content=\"dje@sebabeach.org (Doug Evans)\">\n"
" <meta name=\"reply-to\" content=\"dje@sebabeach.org (Doug Evans)\">\n"
- " <title>" ARCH " Architecture Documentation</title>\n"
+ " <title>" ARCH " " kind " Documentation</title>\n"
"</head>\n"
"<body bgcolor=\"#F0F0F0\" TEXT=\"#003333\" LINK=\"#FF0000\" VLINK=\"#444444\" alink=\"#000000\">\n"
)
)
)
-(define (gen-table-of-contents)
+; INSN-FILE is the name of the .html file containing instruction definitions.
+
+(define (gen-table-of-contents insn-file)
(let ((ARCH (string-upcase (current-arch-name))))
(string-list
"<h1>\n"
"<li><a href=\"#machines\">Machine variants</a></li>\n"
"<li><a href=\"#models\">Model variants</a></li>\n"
"<li><a href=\"#registers\">Registers</a></li>\n"
- "<li><a href=\"#insns\">Instructions</a></li>\n"
- "<li><a href=\"#macro-insns\">Macro instructions</a></li>\n"
+ "<li><a href=\"" insn-file "#insns\">Instructions</a></li>\n"
+ "<li><a href=\"" insn-file "#macro-insns\">Macro instructions</a></li>\n"
"<li><a href=\"#assembler\">Assembler supplemental</a></li>\n"
"</ul>\n"
"<br>\n"
))
)
-; Utility to print a list entry for object O of kind KIND
-; which is a link to the description of O.
+; Utility to print a list entry for NAME/COMMENT, kind KIND
+; which is a link to the entry's description.
; KIND is one of "mach", "model", etc.
-(define (gen-obj-list-entry o kind)
+(define (gen-list-entry name comment kind)
(string-append "<li>"
- "<a href=\"#" kind "-" (obj:name o) "\">"
- (obj:name o)
+ "<a href=\"#" kind "-" name "\">"
+ name
" - "
- (obj:comment o)
+ comment
"</a>\n"
"</li>\n")
)
-; Utility to print the header for the description of object O of kind KIND.
-; KIND is one of "mach", "model", etc.
+; Cover-fn to gen-list-entry for use with objects.
-(define (gen-obj-doc-header o kind)
+(define (gen-obj-list-entry o kind)
+ (gen-list-entry (obj:name o) (obj:comment o) kind)
+)
+
+; Utility to print the header for the description of TEXT.
+
+(define (gen-doc-header text anchor-name)
(string-list
- "<a name=\"" kind "-" (obj:name o) "\"></a>\n"
- "<h3>" (obj:name o) " - " (obj:comment o) "</h3>\n"
+ "<a name=\"" anchor-name "\"></a>\n"
+ "<h3>" text "</h3>\n"
)
)
+
+; Cover-fn to gen-doc-header for use with objects.
+; KIND is one of "mach", "model", etc.
+
+(define (gen-obj-doc-header o kind)
+ (gen-doc-header (string-append (obj:name o) " - " (obj:comment o))
+ (string-append kind "-" (obj:name o)))
+)
\f
; Architecture page.
-(define (-gen-cpu-intro cpu)
+(define (gen-cpu-intro cpu)
(string-list
"<li>\n"
(obj:name cpu) " - " (obj:comment cpu) "\n"
"<br>\n"
"Machines:\n"
"<ul>\n"
- (string-list-map -gen-mach-intro
+ (string-list-map gen-mach-intro
(alpha-sort-obj-list (machs-for-cpu cpu)))
"</ul>\n"
"</li>\n"
)
)
-(define (-gen-mach-intro mach)
+(define (gen-mach-intro mach)
(string-list
"<li>\n"
(obj:name mach) " - " (obj:comment mach) "\n"
"<br>\n"
"Models:\n"
"<ul>\n"
- (string-list-map -gen-model-intro
+ (string-list-map gen-model-intro
(alpha-sort-obj-list (models-for-mach mach)))
"</ul>\n"
"</li>\n"
)
)
-(define (-gen-model-intro model)
+(define (gen-model-intro model)
(string-list
"<li>\n"
(obj:name model) " - " (obj:comment model) "\n"
)
)
-(define (-gen-isa-intro isa)
+(define (gen-isa-intro isa)
(string-list
"<li>\n"
(obj:name isa) " - " (obj:comment isa) "\n"
; a list is excessive. Later.
"<p>\n"
"<ul>\n"
- (string-list-map -gen-isa-intro
+ (string-list-map gen-isa-intro
(alpha-sort-obj-list isas))
"</ul>\n"
"<p>\n"
"<h3>CPU Families</h3>\n"
"<ul>\n"
- (string-list-map -gen-cpu-intro
+ (string-list-map gen-cpu-intro
(alpha-sort-obj-list cpus))
"</ul>\n"
))
(list-drop (car widths) bitnums)))))
)
-; Return ordered list of operands for each field in NAMES.
-; The result is an acceptable arg to gen-iformat-table-1.
-
-(define (get-operands insn)
- (let ((ifields (ifmt-ifields (insn-ifmt insn))))
- (map (lambda (f)
- (if (ifld-constant? f)
- (ifld-get-value f)
- (obj:name (ifld-get-value f))))
- ifields))
-)
-
; Generate a diagram typically used to display instruction fields.
-; NAMES is a list of field names,
-; WIDTHS is a list of their widths.
(define (gen-iformat-table insn)
- (let* ((widths (map ifld-length
- (ifmt-ifields (insn-ifmt insn))))
- (names (map obj:name
- (ifmt-ifields (insn-ifmt insn))))
- (operands (get-operands insn))
- (lsb0? (current-arch-insn-lsb0?)))
- (gen-iformat-table-1 (get-ifield-bitnums widths lsb0?) names operands))
+ (let* ((lsb0? (current-arch-insn-lsb0?))
+ (sorted-iflds (sort-ifield-list (insn-iflds insn) (not lsb0?))))
+ (let ((widths (map ifld-length sorted-iflds))
+ (names (map obj:name sorted-iflds))
+ (operands (map (lambda (f)
+ (if (ifld-constant? f)
+ (ifld-get-value f)
+ (obj:name (ifld-get-value f))))
+ sorted-iflds)))
+ (gen-iformat-table-1 (get-ifield-bitnums widths lsb0?) names operands)))
)
(define (gen-insn-doc-1 insn)
"<plaintext>" ; no trailing newline here on purpose
(with-output-to-string
(lambda ()
- (pretty-print (insn-semantics insn))))
+ ; Print the const-folded semantics, computed in `tmp'.
+ (pretty-print (rtx-trim-for-doc (insn-tmp insn)))))
"</plaintext></font>\n"
"</li>\n"
; "<br>\n" ; not present on purpose
(timing:units (cdr t)))
"\n"
"</li>\n"))
- (insn-timing insn))
+ ; ignore timings for discarded
+ (find (lambda (t) (not (null? (cdr t))))
+ (insn-timing insn)))
"</ul>\n"
"</li>\n"
"<br>\n")
)
)
-(define (gen-insn-doc-list mach)
- (let ((insns (find (lambda (insn)
- (mach-supports? mach insn))
- (current-insn-list))))
- (string-list
- (gen-obj-doc-header mach "mach-insns")
- "<ul>\n"
- (string-map (lambda (o)
- (gen-obj-list-entry o "insn"))
- insns)
- "</ul>\n"
- ))
+(define (gen-insn-doc-list mach name comment insns)
+ (string-list
+ "<hr>\n"
+ (gen-doc-header (string-append (obj:name mach)
+ " "
+ name
+ (if (string=? comment "")
+ ""
+ (string-append " - " comment)))
+ (string-append "mach-insns-"
+ (obj:name mach)
+ "-"
+ name))
+ "<ul>\n"
+ (string-list-map (lambda (o)
+ (gen-obj-list-entry o "insn"))
+ insns)
+ "</ul>\n"
+ )
+)
+
+; Return boolean indicating if INSN sets the pc.
+
+(define (insn-sets-pc? insn)
+ (or (obj-has-attr? insn 'COND-CTI)
+ (obj-has-attr? insn 'UNCOND-CTI)
+ (obj-has-attr? insn 'SKIP-CTI))
+)
+
+; Traverse the semantics of INSN and return a list of symbols
+; indicating various interesting properties we find.
+; This is taken from `semantic-attrs' which does the same thing to find the
+; CTI attributes.
+; The result is list of properties computed from the semantics.
+; The possibilities are: MEM, FPU.
+
+(define (get-insn-properties insn)
+ (let*
+ ((context #f) ; ??? do we need a better context?
+
+ ; String for error messages.
+ (errtxt "semantic attribute computation for html")
+
+ ; List of attributes computed from SEM-CODE-LIST.
+ ; The first element is just a dummy so that append! always works.
+ (sem-attrs (list #f))
+
+ ; Called for expressions encountered in SEM-CODE-LIST.
+ (process-expr!
+ (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (case (car expr)
+
+ ((operand) (if (memory? (op:type (rtx-operand-obj expr)))
+ ; Don't change to '(MEM), since we use append!.
+ (append! sem-attrs (list 'MEM)))
+ (if (mode-float? (op:mode (rtx-operand-obj expr)))
+ ; Don't change to '(FPU), since we use append!.
+ (append! sem-attrs (list 'FPU)))
+ )
+
+ ((mem) (append! sem-attrs (list 'MEM)))
+
+ ; If this is a syntax expression, the operands won't have been
+ ; processed, so tell our caller we want it to by returning #f.
+ ; We do the same for non-syntax expressions to keep things
+ ; simple. This requires collaboration with the traversal
+ ; handlers which are defined to do what we want if we return #f.
+ (else #f))))
+ )
+
+ ; Traverse the expression recording the attributes.
+ ; We just want the side-effects of computing various properties
+ ; so we discard the result.
+
+ (rtx-traverse context
+ insn
+ ; Simplified semantics recorded in the `tmp' field.
+ (insn-tmp insn)
+ process-expr!
+ #f)
+
+ ; Drop dummy first arg and remove duplicates.
+ (nub (cdr sem-attrs) identity))
)
+; Return boolean indicating if PROPS indicates INSN references memory.
+
+(define (insn-refs-mem? insn props)
+ (->bool (memq 'MEM props))
+)
+
+; Return boolean indicating if PROPS indicates INSN uses the fpu.
+
+(define (insn-uses-fpu? insn props)
+ (->bool (memq 'FPU props))
+)
+
+; Ensure INSN has attribute IDOC.
+; If not specified, guess(?).
+
+(define (guess-insn-idoc-attr! insn)
+ (if (not (obj-attr-present? insn 'IDOC))
+ (let ((attr #f)
+ (props (get-insn-properties insn)))
+ ; Try various heuristics.
+ (if (and (not attr)
+ (insn-sets-pc? insn))
+ (set! attr 'BR))
+ (if (and (not attr)
+ (insn-refs-mem? insn props))
+ (set! attr 'MEM))
+ (if (and (not attr)
+ (insn-uses-fpu? insn props))
+ (set! attr 'FPU))
+ ; If nothing else works, assume ALU.
+ (if (not attr)
+ (set! attr 'ALU))
+ (obj-cons-attr! insn (enum-attr-make 'IDOC attr))))
+ *UNSPECIFIED*
+)
+
+; Return subset of insns in IDOC category CAT-NAME.
+
+(define (get-insns-for-category insns cat-name)
+ (find (lambda (insn)
+ (obj-has-attr-value-no-default? insn 'IDOC cat-name))
+ insns)
+)
+
+; CATEGORIES is a list of "enum value" elements for each category.
+; See <enum-attribute> for the definition.
+; INSNS is already alphabetically sorted and selected for just MACH.
+
+(define (gen-categories-insn-lists mach categories insns)
+ (string-list
+ ; generate a table of insns for each category
+ (string-list-map (lambda (c)
+ (let ((cat-insns (get-insns-for-category insns (enum-val-name c)))
+ (comment (enum-val-comment c)))
+ (if (null? cat-insns)
+ ""
+ (gen-insn-doc-list mach (enum-val-name c) comment cat-insns))))
+ categories)
+ ; lastly, the alphabetical list
+ (gen-insn-doc-list mach (obj:name mach) (obj:comment mach) insns)
+ )
+)
+
+; CATEGORIES is a list of "enum value" elements for each category.
+; See <enum-attribute> for the definition.
+; INSNS is already alphabetically sorted and selected for just MACH.
+
+(define (gen-insn-categories mach categories insns)
+ (string-list
+ "<ul>\n"
+ (string-list-map (lambda (c)
+ (let ((cat-insns (get-insns-for-category insns (enum-val-name c)))
+ (comment (enum-val-comment c)))
+ (if (null? cat-insns)
+ ""
+ (string-list
+ "<li><a href=\"#mach-insns-"
+ (obj:name mach)
+ "-"
+ (enum-val-name c)
+ "\">"
+ (enum-val-name c)
+ (if (string=? comment "")
+ ""
+ (string-append " - " comment))
+ "</a></li>\n"
+ ))))
+ categories)
+ "<li><a href=\"#mach-insns-"
+ (obj:name mach)
+ "-"
+ (obj:name mach)
+ "\">alphabetically</a></li>\n"
+ "</ul>\n"
+ )
+)
+
+; ??? There's an inefficiency here, we compute insns for each mach for each
+; category twice. Left for later if warranted.
+
(define (gen-insn-docs)
+ ; First simplify the semantics, e.g. do constant folding.
+ ; For insns built up from macros, often this will remove a lot of clutter.
+ (for-each (lambda (insn)
+ (insn-set-tmp! insn (rtx-simplify #f insn
+ (insn-semantics insn)
+ (insn-build-known-values insn))))
+ (current-insn-list))
+
(let ((machs (current-mach-list))
- (insns (alpha-sort-obj-list (current-insn-list))))
+ (insns (alpha-sort-obj-list (current-insn-list)))
+ (categories (attr-values (current-attr-lookup 'IDOC))))
+ ; First, install IDOC attributes for insns that don't specify one.
+ (for-each guess-insn-idoc-attr! insns)
(string-list
"\n"
"<hr>\n"
"<h2>Instructions</h2>\n"
"Instructions for each machine:\n"
"<ul>\n"
- (string-map (lambda (o)
- (gen-obj-list-entry o "mach-insns"))
- machs)
+; (string-map (lambda (o)
+; (gen-obj-list-entry o "mach-insns"))
+; machs)
+ (string-list-map (lambda (m)
+ (let ((mach-insns (find (lambda (insn)
+ (mach-supports? m insn))
+ insns)))
+ (string-list "<li>"
+ (obj:name m)
+ " - "
+ (obj:comment m)
+ "</li>\n"
+ (gen-insn-categories m categories mach-insns)
+ )))
+ machs)
"</ul>\n"
- (string-list-map gen-insn-doc-list machs)
- "<p>\n"
+; (string-list-map (lambda (m)
+; (gen-insn-doc-list m insns))
+; machs)
+ (string-list-map (lambda (m)
+ (let ((mach-insns (find (lambda (insn)
+ (mach-supports? m insn))
+ insns)))
+ (gen-categories-insn-lists m categories mach-insns)))
+ machs)
+ "<hr>\n"
"<h2>Individual instructions descriptions</h2>\n"
"<br>\n"
(string-list-map gen-insn-doc-1 insns)
)
\f
; Top level C code generators
-;
-; TODO: Will eventually want to split .html output into several files to
-; speed up loading into browsers.
-(define (cgen-doc.html)
- (logit 1 "Generating " (current-arch-name) "-doc.html ...\n")
+; Set by the -N argument.
+(define *insn-html-file-name* "unspecified.html")
+
+(define (cgen.html)
+ (logit 1 "Generating " (current-arch-name) ".html ...\n")
(string-write
(gen-html-copyright (string-append "Architecture documentation for "
(current-arch-name)
".")
CURRENT-COPYRIGHT CURRENT-PACKAGE)
- gen-html-header
- gen-table-of-contents
+ (gen-html-header "Architecture")
+ (gen-table-of-contents *insn-html-file-name*)
gen-arch-intro
gen-machine-docs
gen-model-docs
gen-register-docs
+ gen-asm-docs
+ gen-html-trailer
+ )
+)
+
+(define (cgen-insn.html)
+ (logit 1 "Generating " (current-arch-name) "-insn.html ...\n")
+ (string-write
+ (gen-html-copyright (string-append "Instruction documentation for "
+ (current-arch-name)
+ ".")
+ CURRENT-COPYRIGHT CURRENT-PACKAGE)
+ (gen-html-header "Instruction")
gen-insn-docs
gen-macro-insn-docs
- gen-asm-docs
gen-html-trailer
)
)
-\f
+
; For debugging.
(define (cgen-all)
(string-write
- cgen-doc.html
+ cgen.html
+ cgen-insn.html
)
)
sfmt
; Temp slot for use by applications.
- ; ??? Will go away in time.
tmp
; Instruction semantics.
)
(define-setters <insn> insn
- (fmt-desc ifmt sfmt ifield-assertion compiled-semantics)
+ (fmt-desc ifmt sfmt tmp ifield-assertion compiled-semantics)
)
; Return a boolean indicating if X is an <insn>.
; them together.
; FIXME: This is a case where we need one attribute with several values.
; Presently each RELAX_FOO will use up a bit.
- (define-attr '(for insn) '(type boolean) '(name RELAXABLE) '(comment "insn is relaxable"))
+ ; NOTE: Defined in operand.scm because we can't define it twice.
+ ;(define-attr '(for insn) '(type boolean) '(name RELAXABLE)
+ ; '(comment "insn is relaxable"))
; RELAX: Large relaxable variant. Avoided by assembler in first pass.
; FIXME: Rename this to RELAXED.
insns-analyzed? semantics-analyzed? aliases-analyzed?
)
)
+
(define-setters <arch> arch
(data
attr-list enum-list kw-list
; Could use a hash table except that there currently aren't that many.
(define (current-attr-list) (car (arch-attr-list CURRENT-ARCH)))
+
(define (current-attr-add! a)
+ ; NOTE: While putting this test in define-attr feels better, having it here
+ ; is more robust, internal calls get checked too. Thus it's here.
+ ; Ditto for all the other such tests in this file.
+ (if (current-attr-lookup (obj:name a))
+ (parse-error "define-attr" "attribute already defined" (obj:name a)))
(let ((adata (arch-attr-list CURRENT-ARCH)))
; Build list in normal order so we don't have to reverse it at the end
; (since our format is non-trivial).
(append! (cdr adata) (acons (obj:name a) a nil)))))
*UNSPECIFIED*
)
+
(define (current-attr-lookup attr-name)
(assq-ref (cdr (arch-attr-list CURRENT-ARCH)) attr-name)
)
; Enums.
(define (current-enum-list) (arch-enum-list CURRENT-ARCH))
+
(define (current-enum-add! e)
+ (if (current-enum-lookup (obj:name e))
+ (parse-error "define-enum" "enum already defined" (obj:name e)))
(arch-set-enum-list! CURRENT-ARCH (cons e (arch-enum-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-enum-lookup enum-name)
(object-assq enum-name (current-enum-list))
)
; Keywords.
(define (current-kw-list) (arch-kw-list CURRENT-ARCH))
+
(define (current-kw-add! kw)
+ (if (current-kw-lookup (obj:name kw))
+ (parse-error "define-keyword" "keyword already defined" (obj:name kw)))
(arch-set-kw-list! CURRENT-ARCH (cons kw (arch-kw-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-kw-lookup kw-name)
(object-assq kw-name (current-kw-list))
)
; Instruction sets.
(define (current-isa-list) (arch-isa-list CURRENT-ARCH))
+
(define (current-isa-add! i)
+ (if (current-isa-lookup (obj:name i))
+ (parse-error "define-isa" "isa already defined" (obj:name i)))
(arch-set-isa-list! CURRENT-ARCH (cons i (arch-isa-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-isa-lookup isa-name)
(object-assq isa-name (current-isa-list))
)
; Cpu families.
(define (current-cpu-list) (arch-cpu-list CURRENT-ARCH))
+
(define (current-cpu-add! c)
+ (if (current-cpu-lookup (obj:name c))
+ (parse-error "define-cpu" "cpu already defined" (obj:name c)))
(arch-set-cpu-list! CURRENT-ARCH (cons c (arch-cpu-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-cpu-lookup cpu-name)
(object-assq cpu-name (current-cpu-list))
)
; Machines.
(define (current-mach-list) (arch-mach-list CURRENT-ARCH))
+
(define (current-mach-add! m)
+ (if (current-mach-lookup (obj:name m))
+ (parse-error "define-mach" "mach already defined" (obj:name m)))
(arch-set-mach-list! CURRENT-ARCH (cons m (arch-mach-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-mach-lookup mach-name)
(object-assq mach-name (current-mach-list))
)
; Models.
(define (current-model-list) (arch-model-list CURRENT-ARCH))
+
(define (current-model-add! m)
+ (if (current-model-lookup (obj:name m))
+ (parse-error "define-model" "model already defined" (obj:name m)))
(arch-set-model-list! CURRENT-ARCH (cons m (arch-model-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-model-lookup model-name)
(object-assq model-name (current-model-list))
)
; Hardware elements.
(define (current-hw-list) (arch-hw-list CURRENT-ARCH))
+
(define (current-hw-add! hw)
+ (if (current-hw-lookup (obj:name hw))
+ (parse-error "define-hardware" "hardware already defined" (obj:name hw)))
(arch-set-hw-list! CURRENT-ARCH (cons hw (arch-hw-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-hw-lookup hw)
(if (object? hw)
hw
; Instruction fields.
(define (current-ifld-list) (map cdr (arch-ifld-list CURRENT-ARCH)))
+
(define (current-ifld-add! f)
+ (if (current-ifld-lookup (obj:name f))
+ (parse-error "define-ifield" "ifield already defined" (obj:name f)))
(arch-set-ifld-list! CURRENT-ARCH
(acons (obj:name f) f (arch-ifld-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-ifld-lookup x)
(if (ifield? x)
x
; Operands.
(define (current-op-list) (map cdr (arch-op-list CURRENT-ARCH)))
+
(define (current-op-add! op)
+ (if (current-op-lookup (obj:name op))
+ (parse-error "define-operand" "operand already defined" (obj:name op)))
(arch-set-op-list! CURRENT-ARCH
(acons (obj:name op) op (arch-op-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-op-lookup name)
(assq-ref (arch-op-list CURRENT-ARCH) name)
)
; Instructions.
(define (current-raw-insn-list) (arch-insn-list CURRENT-ARCH))
+
(define (current-insn-list) (map cdr (arch-insn-list CURRENT-ARCH)))
+
(define (current-insn-add! i)
+ (if (current-insn-lookup (obj:name i))
+ (parse-error "define-insn" "insn already defined" (obj:name i)))
(arch-set-insn-list! CURRENT-ARCH
(acons (obj:name i) i (arch-insn-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-insn-lookup name)
(assq-ref (arch-insn-list CURRENT-ARCH) name)
)
; Macro instructions.
(define (current-minsn-list) (map cdr (arch-minsn-list CURRENT-ARCH)))
+
(define (current-minsn-add! m)
+ (if (current-minsn-lookup (obj:name m))
+ (parse-error "define-minsn" "macro-insn already defined" (obj:name m)))
(arch-set-minsn-list! CURRENT-ARCH
(acons (obj:name m) m (arch-minsn-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-minsn-lookup name)
(assq-ref (arch-minsn-list CURRENT-ARCH) name)
)
; rtx subroutines.
(define (current-subr-list) (map cdr (arch-subr-list CURRENT-ARCH)))
-(define (current-subr-add! m)
+
+(define (current-subr-add! s)
+ (if (current-subr-lookup (obj:name s))
+ (parse-error "define-subr" "subroutine already defined" (obj:name s)))
(arch-set-subr-list! CURRENT-ARCH
- (acons (obj:name m) m (arch-subr-list CURRENT-ARCH)))
+ (acons (obj:name s) s (arch-subr-list CURRENT-ARCH)))
+ *UNSPECIFIED*
)
+
(define (current-subr-lookup name)
(assq-ref (arch-subr-list CURRENT-ARCH) name)
)
(define (insn-handlers insn)
(string-append
- (number->string (lookup-index 'insn-normal opc-parse-handlers 0))
+ (number->string (assq-lookup-index 'insn-normal opc-parse-handlers 0))
", "
- (number->string (lookup-index 'insn-normal opc-insert-handlers 0))
+ (number->string (assq-lookup-index 'insn-normal opc-insert-handlers 0))
", "
- (number->string (lookup-index 'insn-normal opc-extract-handlers 0))
+ (number->string (assq-lookup-index 'insn-normal opc-extract-handlers 0))
", "
- (number->string (lookup-index 'insn-normal opc-print-handlers 0))
+ (number->string (assq-lookup-index 'insn-normal opc-print-handlers 0))
)
)
(define-attr '(for operand) '(type boolean) '(name NEGATIVE)
'(comment "value is negative"))
- (define-attr '(for operand) '(type boolean) '(name RELAX)
- '(comment "operand is relaxable"))
+
+ ; Also used for insns, and we can't define it twice, so we specify
+ ; for insn here.
+ (define-attr '(for operand insn) '(type boolean) '(name RELAXABLE)
+ '(comment "operand/insn is relaxable"))
; ??? Might be able to make SEM-ONLY go away (or machine compute it)
; by scanning which operands are refered to by the insn syntax strings.
(maybe-load "minsn" #f '<macro-insn>)
(maybe-load "decode" #f 'decode-build-table)
(maybe-load "rtl" "rtl" '<rtx-func>)
+(maybe-load "rtl-traverse" "rtl_traverse" 'rtx-traverse)
(maybe-load "rtx-funcs" "rtx_funcs" 'def-rtx-funcs)
(maybe-load "rtl-c" "rtl_c" '<c-expr>)
(maybe-load "semantics" #f 'semantic-compile)
--- /dev/null
+; RTL traversing support.
+; Copyright (C) 2000, 2001 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; 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).
+
+; Set to #t to debug rtx traversal.
+
+(define -rtx-traverse-debug? #f)
+
+; Container to record the current state of traversal.
+; This is initialized before traversal, and modified (in a copy) as the
+; traversal state changes.
+; This doesn't record all traversal state, just the more static elements.
+; There's no point in recording things like the parent expression and operand
+; position as they change for every sub-traversal.
+; The main raison d'etre for this class is so we can add more state without
+; having to modify all the traversal handlers.
+; ??? At present it's not a proper "class" as there's no real need.
+;
+; CONTEXT is a <context> object or #f if there is none.
+; It is used for error messages.
+;
+; EXPR-FN is a dual-purpose beast. The first purpose is to just process
+; the current expression and return the result. The second purpose is to
+; lookup the function which will then 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) ...).
+; If the result of EXPR-FN is a lambda, it is applied to
+; (cons TSTATE (cdr 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)).
+; 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.
+;
+; ENV is the current environment. This is a stack of sequence locals.
+;
+; COND? is a boolean indicating if the current expression is on a conditional
+; execution path. This is for optimization purposes only and it is always ok
+; to pass #t, except for the top-level caller which must pass #f (since the top
+; level expression obviously isn't subject to any condition).
+; It is used, for example, to speed up the simulator: there's no need to keep
+; 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.
+;
+; KNOWN is an alist of known values. This is used by rtx-simplify.
+; Each element is (name . value) where
+; NAME is either an ifield or operand name (in the future it might be a
+; sequence local name), and
+; VALUE is either (const mode value) or (numlist mode value1 value2 ...).
+;
+; 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-context state) (vector-ref state 0))
+(define (tstate-set-context! state newval) (vector-set! state 0 newval))
+(define (tstate-owner state) (vector-ref state 1))
+(define (tstate-set-owner! state newval) (vector-set! state 1 newval))
+(define (tstate-expr-fn state) (vector-ref state 2))
+(define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval))
+(define (tstate-env state) (vector-ref state 3))
+(define (tstate-set-env! state newval) (vector-set! state 3 newval))
+(define (tstate-cond? state) (vector-ref state 4))
+(define (tstate-set-cond?! state newval) (vector-set! state 4 newval))
+(define (tstate-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))
+
+; Create a copy of STATE.
+
+(define (tstate-copy state)
+ ; A fast vector-copy would be nice, but this is simple and portable.
+ (list->vector (vector->list state))
+)
+
+; Create a copy of STATE with a new environment ENV.
+
+(define (tstate-new-env state env)
+ (let ((result (tstate-copy state)))
+ (tstate-set-env! result env)
+ result)
+)
+
+; Create a copy of STATE with environment ENV pushed onto the existing
+; environment list.
+; There's no routine to pop the environment list as there's no current
+; need for it: we make a copy of the state when we push.
+
+(define (tstate-push-env state env)
+ (let ((result (tstate-copy state)))
+ (tstate-set-env! result (cons env (tstate-env result)))
+ result)
+)
+
+; Create a copy of STATE with a new COND? value.
+
+(define (tstate-new-cond? state cond?)
+ (let ((result (tstate-copy state)))
+ (tstate-set-cond?! result cond?)
+ 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.
+
+(define (tstate-known-lookup tstate name)
+ (let ((known (tstate-known tstate)))
+ (assq-ref known name))
+)
+
+; Increment the recorded traversal depth of TSTATE.
+
+(define (tstate-incr-depth! tstate)
+ (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
+)
+
+; Decrement the recorded traversal depth of TSTATE.
+
+(define (tstate-decr-depth! tstate)
+ (tstate-set-depth! tstate (1- (tstate-depth tstate)))
+)
+\f
+; Traversal/compilation support.
+
+; Return a boolean indicating if X is a mode.
+
+(define (-rtx-any-mode? x)
+ (->bool (mode:lookup x))
+)
+
+; Return a boolean indicating if X is a symbol or rtx.
+
+(define (-rtx-symornum? x)
+ (or (symbol? x) (number? x))
+)
+
+; Traverse a list of rtx's.
+
+(define (-rtx-traverse-rtx-list rtx-list mode 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-list)
+)
+
+; Cover-fn to context-error for signalling an error during rtx traversal.
+
+(define (-rtx-traverse-error tstate errmsg expr op-num)
+; (parse-error context (string-append errmsg ", operand number "
+; (number->string op-num))
+; (rtx-dump expr))
+ (context-error (tstate-context tstate)
+ (string-append errmsg ", operand #" (number->string op-num))
+ (rtx-strdump expr))
+)
+
+; 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))
+ #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)
+ 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)
+ 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)
+ (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))
+ (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
+ ; ??? Entries after the first are conditional.
+ (-rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff)
+ (-rtx-traverse-rtx-list
+ (cdr val) mode 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))
+ (cons (cons (car val)
+ (-rtx-traverse-rtx-list
+ (cdr val) mode 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)
+ (let ((env (rtx-env-make-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))
+ (cons val (tstate-new-env tstate val))
+)
+
+(define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
+; (cons val ; (atlist-source-form (atlist-parse val "" "with-attr"))
+; 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
+; for rtx-arg-types.
+
+(define -rtx-traverser-table #f)
+
+; Return a hash table of standard operand traversers.
+; The result of each traverser is a pair of the compiled form of `val' and
+; a possibly new traversal state or #f if there is no change.
+
+(define (-rtx-make-traverser-table)
+ (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 '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))
+ )))
+
+ (for-each (lambda (traverser)
+ (hashq-set! hash-tab (car traverser) (cdr traverser)))
+ traversers)
+
+ hash-tab)
+)
+
+; 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.
+
+(define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
+ (if -rtx-traverse-debug?
+ (begin
+ (display (spaces (* 4 (tstate-depth tstate))))
+ (display "Traversing operands of: ")
+ (display (rtx-dump expr))
+ (newline)
+ (rtx-env-dump (tstate-env tstate))
+ (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)
+ )
+
+ (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
+
+ (if -rtx-traverse-debug?
+ (begin
+ (display (spaces (* 4 (tstate-depth tstate))))
+ (if (null? operands)
+ (display "end of operands")
+ (begin
+ (display "op-num ") (display op-num) (display ": ")
+ (display (rtx-dump (car operands)))
+ (display ", ")
+ (display (if varargs? (car arg-types) (caar arg-types)))
+ (display ", ")
+ (display (if varargs? arg-modes (car arg-modes)))
+ ))
+ (newline)
+ (force-output)
+ ))
+
+ (cond ((null? operands)
+ ; Out of operands, check if we have the expected number.
+ (if (or (null? arg-types)
+ varargs?)
+ (reverse! result)
+ (context-error (tstate-context tstate)
+ "missing operands" (rtx-strdump expr))))
+
+ ((null? arg-types)
+ (context-error (tstate-context tstate)
+ "too many operands" (rtx-strdump 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 ((traverser (cdr type)))
+ (let ((traversed-val (fastcall6 traverser val mode 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.
+ (loop (cdr operands)
+ (+ op-num 1)
+ (if varargs? arg-types (cdr arg-types))
+ (if varargs? arg-modes (cdr arg-modes))
+ (cons val result)))))))
+)
+
+; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
+; need to call it.
+
+(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 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)))
+)
+
+; Traverse an expression.
+; For syntax expressions arguments are not pre-evaluated before calling the
+; user's expression handler. Otherwise they are.
+; If EXPR-FN wants to just scan the operands, rather than evaluating them,
+; one thing it can do is call back to rtx-traverse-operands.
+; If EXPR-FN returns #f, traverse the operands normally and return
+; (rtx's-name traversed-operand1 ...).
+; This is for semantic-compile's sake and all traversal handlers are
+; required to do this if 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)))
+ (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)))
+ (apply fn (cons tstate operands))))
+ fn)
+ (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
+ (cons (car expr2) operands))))
+)
+
+; Main entry point for expression traversal.
+; (Actually rtx-traverse is, but it's just a cover function for this.)
+;
+; The result is the result of the lambda EXPR-FN looks up in the case of
+; expressions or an operand object (usually <operand>) in the case of operands.
+;
+; EXPR is the expression to be traversed.
+;
+; 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.
+;
+; OP-POS is the position EXPR appears in PARENT-EXPR. The
+; top-level caller must pass 0 for it.
+;
+; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
+; or #f if it doesn't matter.
+;
+; TSTATE is the current traversal state.
+;
+; APPSTUFF is for application specific use.
+;
+; All macros are expanded here. User code never sees them.
+; All operand shortcuts are also expand here. User code never sees them.
+; These are:
+; - operands, ifields, and numbers appearing where an rtx is expected are
+; converted to use `operand', `ifield', or `const'.
+
+(define (-rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
+ (if -rtx-traverse-debug?
+ (begin
+ (display (spaces (* 4 (tstate-depth tstate))))
+ (display "Traversing expr: ")
+ (display expr)
+ (newline)
+ (display (spaces (* 4 (tstate-depth tstate))))
+ (display "-expected: ")
+ (display expected)
+ (newline)
+ (display (spaces (* 4 (tstate-depth tstate))))
+ (display "-mode: ")
+ (display mode)
+ (newline)
+ (force-output)
+ ))
+
+ (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)
+ (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)
+ (context-error (tstate-context tstate) "unknown rtx function"
+ expr))))))
+ (tstate-decr-depth! tstate)
+ result))
+
+ ; 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)
+ (-rtx-traverse
+ (rtx-make-operand expr) ; (current-op-lookup expr))
+ expected mode 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))
+ ((current-ifld-lookup expr)
+ (-rtx-traverse
+ (rtx-make-ifield expr)
+ expected mode parent-expr op-pos tstate appstuff))
+ ((enum-lookup-val expr)
+ (-rtx-traverse
+ (rtx-make-enum 'INT expr)
+ expected mode parent-expr op-pos tstate appstuff))
+ (else
+ (context-error (tstate-context tstate)
+ "unknown operand" expr))))
+ ((integer? expr)
+ (-rtx-traverse (rtx-make-const 'INT expr)
+ expected mode parent-expr op-pos tstate appstuff))
+ (else
+ (context-error (tstate-context tstate)
+ "unexpected operand"
+ expr)))
+
+ ; Not expecting RTX or SETRTX.
+ (context-error (tstate-context tstate)
+ "unexpected operand"
+ expr)))
+)
+
+; User visible procedures to traverse an rtl expression.
+; These calls -rtx-traverse to do most of the work.
+; See tstate-make for an explanation of EXPR-FN.
+; CONTEXT is a <context> object or #f if there is none.
+; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
+; APPSTUFF is for application specific use.
+
+(define (rtx-traverse context owner expr expr-fn appstuff)
+ (-rtx-traverse expr #f 'DFLT #f 0
+ (tstate-make context owner expr-fn (rtx-env-empty-stack)
+ #f #f nil 0)
+ appstuff)
+)
+
+(define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
+ (-rtx-traverse expr #f 'DFLT #f 0
+ (tstate-make context owner expr-fn
+ (rtx-env-push (rtx-env-empty-stack)
+ (rtx-env-make-locals locals))
+ #f #f nil 0)
+ appstuff)
+)
+
+; Traverser debugger.
+
+(define (rtx-traverse-debug expr)
+ (rtx-traverse
+ #f #f expr
+ (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+ (display "-expr: ")
+ (display (string-append "rtx=" (obj:name rtx-obj)))
+ (display " expr=")
+ (display expr)
+ (display " mode=")
+ (display mode)
+ (display " parent=")
+ (display parent-expr)
+ (display " op-pos=")
+ (display op-pos)
+ (display " cond?=")
+ (display (tstate-cond? tstate))
+ (newline)
+ #f)
+ #f
+ )
+)
+
+; 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 (-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))
+)
+
+(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)
+)
+\f
+; RTL evaluation state.
+; Applications may subclass <eval-state> if they need to add things.
+;
+; This is initialized before evaluation, and modified (in a copy) as the
+; evaluation state changes.
+; This doesn't record all evaluation state, just the less dynamic elements.
+; There's no point in recording things like the parent expression and operand
+; position as they change for every sub-eval.
+; The main raison d'etre for this class is so we can add more state without
+; having to modify all the eval handlers.
+
+(define <eval-state>
+ (class-make '<eval-state> nil
+ '(
+ ; <context> object or #f if there is none
+ (context . #f)
+
+ ; Current object rtl is being evaluated for.
+ ; We need to be able to access the current instruction while
+ ; generating semantic code. However, the semantic description
+ ; doesn't specify it as an argument to anything (and we don't
+ ; want it to). So we record the value here.
+ (owner . #f)
+
+ ; EXPR-FN is a dual-purpose beast. The first purpose is to
+ ; just process the current expression and return the result.
+ ; The second purpose is to lookup the function which will then
+ ; process the expression. It is applied recursively to the
+ ; expression and each sub-expression. It must be defined as
+ ; (lambda (rtx-obj expr mode estate) ...).
+ ; If the result of EXPR-FN is a lambda, it is applied to
+ ; (cons ESTATE (cdr EXPR)). ESTATE is prepended to the
+ ; arguments.
+ ; For syntax expressions if the result of EXPR-FN is #f,
+ ; the operands are processed using the builtin evaluator.
+ ; FIXME: This special handling of syntax expressions is
+ ; not currently done.
+ ; 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 estate).
+ ; The arguments to the result of EXPR-FN are
+ ; (cons ESTATE (cdr EXPR)).
+ ; The reason for the duality is mostly history.
+ ; In time things should be simplified.
+ (expr-fn . #f)
+
+ ; Current environment. This is a stack of sequence locals.
+ (env . ())
+
+ ; Current evaluation depth. This is used, for example, to
+ ; control indentation in generated output.
+ (depth . 0)
+
+ ; Associative list of modifiers.
+ ; This is here to support things like `delay'.
+ (modifiers . ())
+ )
+ nil)
+)
+
+; Create an <eval-state> object using a list of keyword/value elements.
+; ARGS is a list of #:keyword/value elements.
+; The result is a list of the unrecognized elements.
+; Subclasses should override this method and send-next it first, then
+; see if they recognize anything in the result, returning what isn't
+; recognized.
+
+(method-make!
+ <eval-state> 'vmake!
+ (lambda (self args)
+ (let loop ((args args) (unrecognized nil))
+ (if (null? args)
+ (reverse! unrecognized) ; ??? Could invoke method to initialize here.
+ (begin
+ (case (car args)
+ ((#:context)
+ (elm-set! self 'context (cadr args)))
+ ((#:owner)
+ (elm-set! self 'owner (cadr args)))
+ ((#:expr-fn)
+ (elm-set! self 'expr-fn (cadr args)))
+ ((#:env)
+ (elm-set! self 'env (cadr args)))
+ ((#:depth)
+ (elm-set! self 'depth (cadr args)))
+ ((#:modifiers)
+ (elm-set! self 'modifiers (cadr args)))
+ (else
+ ; Build in reverse order, as we reverse it back when we're done.
+ (set! unrecognized
+ (cons (cadr args) (cons (car args) unrecognized)))))
+ (loop (cddr args) unrecognized)))))
+)
+
+; Accessors.
+
+(define-getters <eval-state> estate
+ (context owner expr-fn env depth modifiers)
+)
+(define-setters <eval-state> estate
+ (context owner expr-fn env depth modifiers)
+)
+
+; Build an estate for use in producing a value from rtl.
+; CONTEXT is a <context> object or #f if there is none.
+; OWNER is the owner of the expression or #f if there is none.
+
+(define (estate-make-for-eval context owner)
+ (vmake <eval-state>
+ #:context context
+ #:owner owner
+ #:expr-fn (lambda (rtx-obj expr mode estate)
+ (rtx-evaluator rtx-obj)))
+)
+
+; Create a copy of ESTATE.
+
+(define (estate-copy estate)
+ (object-copy-top estate)
+)
+
+; Create a copy of STATE with a new environment ENV.
+
+(define (estate-new-env state env)
+ (let ((result (estate-copy state)))
+ (estate-set-env! result env)
+ result)
+)
+
+; Create a copy of STATE with environment ENV pushed onto the existing
+; environment list.
+; There's no routine to pop the environment list as there's no current
+; need for it: we make a copy of the state when we push.
+
+(define (estate-push-env state env)
+ (let ((result (estate-copy state)))
+ (estate-set-env! result (cons env (estate-env result)))
+ result)
+)
+
+; Create a copy of STATE with modifiers MODS.
+
+(define (estate-with-modifiers state mods)
+ (let ((result (estate-copy state)))
+ (estate-set-modifiers! result (append mods (estate-modifiers result)))
+ result)
+)
+
+; Convert a tstate to an estate.
+
+(define (tstate->estate t)
+ (vmake <eval-state>
+ #:context (tstate-context t)
+ #:env (tstate-env t))
+)
+\f
+; RTL expression evaluation.
+;
+; ??? These used eval2 at one point. Not sure which is faster but I suspect
+; eval2 is by far. On the otherhand this has yet to be compiled. And this way
+; is more portable, more flexible, and works with guile 1.2 (which has
+; problems with eval'ing self referential vectors, though that's one reason to
+; use smobs).
+
+; Set to #t to debug rtx evaluation.
+
+(define -rtx-eval-debug? #f)
+
+; 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 or its name.
+; ESTATE is the current evaluation state.
+
+(define (rtx-eval-with-estate expr mode estate)
+ (if -rtx-eval-debug?
+ (begin
+ (display "Traversing ")
+ (display expr)
+ (newline)
+ (rtx-env-dump (estate-env estate))
+ ))
+
+ (if (pair? expr) ; pair? -> cheap non-null-list?
+
+ (let* ((rtx-obj (rtx-lookup (car expr)))
+ (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
+ (if fn
+ (if (procedure? fn)
+ (apply fn (cons estate (cdr expr)))
+; ; Don't eval operands for syntax expressions.
+; (if (rtx-style-syntax? rtx-obj)
+; (apply fn (cons estate (cdr expr)))
+; (let ((operands
+; (-rtx-eval-operands rtx-obj expr estate)))
+; (apply fn (cons estate operands))))
+ fn)
+ ; Leave expr unchanged.
+ expr))
+; (let ((operands
+; (-rtx-traverse-operands rtx-obj expr estate)))
+; (cons rtx-obj operands))))
+
+ ; EXPR is not a list
+ (error "argument to rtx-eval-with-estate is not a list" expr))
+)
+
+; Evaluate rtx expression EXPR and return the computed value.
+; EXPR must already be in compiled form (the result of rtx-compile).
+; 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
+; 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.
+
+(define (-rtx-trim-args name args)
+ (let* ((rtx-obj (rtx-lookup name))
+ (arg-types (rtx-arg-types rtx-obj)))
+
+ (let loop ((args args)
+ (types (cddr arg-types)) ; skip options, mode
+ (result nil))
+
+ (if (null? args)
+
+ (reverse! result)
+
+ (let ((arg (car args))
+ ; Remember, types may be an improper list.
+ (type (if (pair? types) (car types) types))
+ (new-arg (car args)))
+
+ ;(display arg (current-error-port)) (newline (current-error-port))
+ ;(display type (current-error-port)) (newline (current-error-port))
+
+ (case type
+ ((OPTIONS)
+ (assert #f)) ; shouldn't get here
+
+ ((ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE)
+ #f) ; leave arg untouched
+
+ ((RTX SETRTX TESTRTX)
+ (set! new-arg (-rtx-trim-for-doc arg)))
+
+ ((CONDRTX)
+ (assert (= (length arg) 2))
+ (if (eq? (car arg) 'else)
+ (set! new-arg (cons 'else (-rtx-trim-for-doc (cadr arg))))
+ (set! new-arg (list (-rtx-trim-for-doc (car arg))
+ (-rtx-trim-for-doc (cadr arg)))))
+ )
+
+ ((CASERTX)
+ (assert (= (length arg) 2))
+ (set! new-arg (list (car arg) (-rtx-trim-for-doc (cadr arg))))
+ )
+
+ ((LOCALS)
+ #f) ; leave arg untouched
+
+ ((ENV)
+ #f) ; leave arg untouched for now
+
+ ((ATTRS)
+ #f) ; leave arg untouched for now
+
+ ((SYMBOL STRING NUMBER SYMORNUM)
+ #f) ; leave arg untouched
+
+ ((OBJECT)
+ (assert #f)) ; hopefully(wip!) shouldn't get here
+
+ (else
+ (assert #f))) ; unknown arg type
+
+ (loop (cdr args)
+ (if (pair? types) (cdr types) types)
+ (cons new-arg result))))))
+)
+
+; Given a fully specified rtx 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.
+;
+; 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"
+; and trimming the clutter from "(const () BI 0)" yielding "0".
+
+(define (-rtx-trim-for-doc rtx)
+ (if (pair? rtx) ; ??? cheap rtx?
+ (let ((name (car rtx))
+ (options (cadr rtx))
+ (mode (caddr rtx))
+ (rest (cdddr rtx)))
+
+ (case name
+
+ ((const) (car rest))
+
+ ((ifield operand local)
+ (if (null? options)
+ (if (eq? mode 'DFLT)
+ (car rest)
+ (cons name (cons mode rest)))
+ rtx))
+
+ ((sequence parallel)
+ ; No special support is needed, except it's nice to remove nop
+ ; statements. These can be created when an `if' get simplified.
+ (let ((trimmed-args (-rtx-trim-args name rest))
+ (result nil))
+ (for-each (lambda (rtx)
+ (if (equal? rtx '(nop))
+ #f ; ignore
+ (set! result (cons rtx result))))
+ trimmed-args)
+ (if (null? options)
+ (if (eq? mode 'DFLT)
+ (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)
+ (cons name trimmed-args)
+ (cons name (cons mode trimmed-args)))
+ (cons name (cons options (cons mode trimmed-args))))))))
+
+ ; Not an rtx expression, must be number, symbol, string.
+ rtx)
+)
+
+(define (rtx-trim-for-doc rtx)
+ (-rtx-trim-for-doc rtx)
+)
(method-make! <rtx-func> 'get-name (lambda (self) (elm-get self 'name)))
+; List of mode types for arg-types.
+
+(define -rtx-valid-mode-types
+ '(
+ ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
+ )
+)
+
; List of valid values for arg-types, not including mode names.
(define -rtx-valid-types
- '(OPTIONS
- ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
- RTX TESTRTX CONDRTX CASERTX
- LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT)
+ (append
+ '(OPTIONS)
+ -rtx-valid-mode-types
+ '(RTX SETRTX TESTRTX CONDRTX CASERTX)
+ '(LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT)
+ )
)
; List of valid mode matchers, excluding mode names.
(stringize rtx "-"))
)
\f
-; 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).
-
-; Set to #t to debug rtx traversal.
-
-(define -rtx-traverse-debug? #f)
-
-; Container to record the current state of traversal.
-; This is initialized before traversal, and modified (in a copy) as the
-; traversal state changes.
-; This doesn't record all traversal state, just the more static elements.
-; There's no point in recording things like the parent expression and operand
-; position as they change for every sub-traversal.
-; The main raison d'etre for this class is so we can add more state without
-; having to modify all the traversal handlers.
-; ??? At present it's not a proper "class" as there's no real need.
-;
-; CONTEXT is a <context> object or #f if there is none.
-; It is used for error messages.
-;
-; EXPR-FN is a dual-purpose beast. The first purpose is to just process
-; the current expression and return the result. The second purpose is to
-; lookup the function which will then 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) ...).
-; If the result of EXPR-FN is a lambda, it is applied to
-; (cons TSTATE (cdr 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)).
-; 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.
-;
-; ENV is the current environment. This is a stack of sequence locals.
-;
-; COND? is a boolean indicating if the current expression is on a conditional
-; execution path. This is for optimization purposes only and it is always ok
-; to pass #t, except for the top-level caller which must pass #f (since the top
-; level expression obviously isn't subject to any condition).
-; It is used, for example, to speed up the simulator: there's no need to keep
-; 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.
-;
-; KNOWN is an alist of known values. This is used by rtx-simplify.
-; Each element is (name . value) where
-; NAME is either an ifield or operand name (in the future it might be a
-; sequence local name), and
-; VALUE is either (const mode value) or (numlist mode value1 value2 ...).
-;
-; 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-context state) (vector-ref state 0))
-(define (tstate-set-context! state newval) (vector-set! state 0 newval))
-(define (tstate-owner state) (vector-ref state 1))
-(define (tstate-set-owner! state newval) (vector-set! state 1 newval))
-(define (tstate-expr-fn state) (vector-ref state 2))
-(define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval))
-(define (tstate-env state) (vector-ref state 3))
-(define (tstate-set-env! state newval) (vector-set! state 3 newval))
-(define (tstate-cond? state) (vector-ref state 4))
-(define (tstate-set-cond?! state newval) (vector-set! state 4 newval))
-(define (tstate-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))
-
-; Create a copy of STATE.
-
-(define (tstate-copy state)
- ; A fast vector-copy would be nice, but this is simple and portable.
- (list->vector (vector->list state))
-)
-
-; Create a copy of STATE with a new environment ENV.
-
-(define (tstate-new-env state env)
- (let ((result (tstate-copy state)))
- (tstate-set-env! result env)
- result)
-)
-
-; Create a copy of STATE with environment ENV pushed onto the existing
-; environment list.
-; There's no routine to pop the environment list as there's no current
-; need for it: we make a copy of the state when we push.
-
-(define (tstate-push-env state env)
- (let ((result (tstate-copy state)))
- (tstate-set-env! result (cons env (tstate-env result)))
- result)
-)
-
-; Create a copy of STATE with a new COND? value.
-
-(define (tstate-new-cond? state cond?)
- (let ((result (tstate-copy state)))
- (tstate-set-cond?! result cond?)
- 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.
-
-(define (tstate-known-lookup tstate name)
- (let ((known (tstate-known tstate)))
- (assq-ref known name))
-)
-
-; Increment the recorded traversal depth of TSTATE.
-
-(define (tstate-incr-depth! tstate)
- (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
-)
-
-; Decrement the recorded traversal depth of TSTATE.
-
-(define (tstate-decr-depth! tstate)
- (tstate-set-depth! tstate (1- (tstate-depth tstate)))
-)
-\f
-; Traversal/compilation support.
-
-; Return a boolean indicating if X is a mode.
-
-(define (-rtx-any-mode? x)
- (->bool (mode:lookup x))
-)
-
-; Return a boolean indicating if X is a symbol or rtx.
-
-(define (-rtx-symornum? x)
- (or (symbol? x) (number? x))
-)
-
-; Traverse a list of rtx's.
-
-(define (-rtx-traverse-rtx-list rtx-list mode 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-list)
-)
-
-; Cover-fn to context-error for signalling an error during rtx traversal.
-
-(define (-rtx-traverse-error tstate errmsg expr op-num)
-; (parse-error context (string-append errmsg ", operand number "
-; (number->string op-num))
-; (rtx-dump expr))
- (context-error (tstate-context tstate)
- (string-append errmsg ", operand #" (number->string op-num))
- (rtx-strdump expr))
-)
-
-; 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))
- #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)
- 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)
- 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)
- (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))
- (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
- ; ??? Entries after the first are conditional.
- (-rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff)
- (-rtx-traverse-rtx-list
- (cdr val) mode 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))
- (cons (cons (car val)
- (-rtx-traverse-rtx-list
- (cdr val) mode 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)
- (let ((env (rtx-env-make-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))
- (cons val (tstate-new-env tstate val))
-)
-
-(define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
-; (cons val ; (atlist-source-form (atlist-parse val "" "with-attr"))
-; 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
-; for rtx-arg-types.
-
-(define -rtx-traverser-table #f)
-
-; Return a hash table of standard operand traversers.
-; The result of each traverser is a pair of the compiled form of `val' and
-; a possibly new traversal state or #f if there is no change.
-
-(define (-rtx-make-traverser-table)
- (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 'NONVOIDFLTODE (/fastcall-make -rtx-traverse-nonvoidmode))
- (cons 'VOIDFLTODE (/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 '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))
- )))
-
- (for-each (lambda (traverser)
- (hashq-set! hash-tab (car traverser) (cdr traverser)))
- traversers)
-
- hash-tab)
-)
-
-; 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.
-
-(define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
- (if -rtx-traverse-debug?
- (begin
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "Traversing operands of: ")
- (display (rtx-dump expr))
- (newline)
- (rtx-env-dump (tstate-env tstate))
- (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)
- )
-
- (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
-
- (if -rtx-traverse-debug?
- (begin
- (display (spaces (* 4 (tstate-depth tstate))))
- (if (null? operands)
- (display "end of operands")
- (begin
- (display "op-num ") (display op-num) (display ": ")
- (display (rtx-dump (car operands)))
- (display ", ")
- (display (if varargs? (car arg-types) (caar arg-types)))
- (display ", ")
- (display (if varargs? arg-modes (car arg-modes)))
- ))
- (newline)
- (force-output)
- ))
-
- (cond ((null? operands)
- ; Out of operands, check if we have the expected number.
- (if (or (null? arg-types)
- varargs?)
- (reverse! result)
- (context-error (tstate-context tstate)
- "missing operands" (rtx-strdump expr))))
-
- ((null? arg-types)
- (context-error (tstate-context tstate)
- "too many operands" (rtx-strdump 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 ((traverser (cdr type)))
- (let ((traversed-val (fastcall6 traverser val mode 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.
- (loop (cdr operands)
- (+ op-num 1)
- (if varargs? arg-types (cdr arg-types))
- (if varargs? arg-modes (cdr arg-modes))
- (cons val result)))))))
-)
-
-; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
-; need to call it.
-
-(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 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)))
-)
-
-; Traverse an expression.
-; For syntax expressions arguments are not pre-evaluated before calling the
-; user's expression handler. Otherwise they are.
-; If EXPR-FN wants to just scan the operands, rather than evaluating them,
-; one thing it can do is call back to rtx-traverse-operands.
-; If EXPR-FN returns #f, traverse the operands normally and return
-; (rtx's-name traversed-operand1 ...).
-; This is for semantic-compile's sake and all traversal handlers are
-; required to do this if 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)))
- (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)))
- (apply fn (cons tstate operands))))
- fn)
- (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
- (cons (car expr2) operands))))
-)
-
-; Main entry point for expression traversal.
-; (Actually rtx-traverse is, but it's just a cover function for this.)
-;
-; The result is the result of the lambda EXPR-FN looks up in the case of
-; expressions or an operand object (usually <operand>) in the case of operands.
-;
-; EXPR is the expression to be traversed.
-;
-; 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.
-;
-; OP-POS is the position EXPR appears in PARENT-EXPR. The
-; top-level caller must pass 0 for it.
-;
-; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
-; or #f if it doesn't matter.
-;
-; TSTATE is the current traversal state.
-;
-; APPSTUFF is for application specific use.
-;
-; All macros are expanded here. User code never sees them.
-; All operand shortcuts are also expand here. User code never sees them.
-; These are:
-; - operands, ifields, and numbers appearing where an rtx is expected are
-; converted to use `operand', `ifield', or `const'.
-
-(define (-rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
- (if -rtx-traverse-debug?
- (begin
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "Traversing expr: ")
- (display expr)
- (newline)
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "-expected: ")
- (display expected)
- (newline)
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "-mode: ")
- (display mode)
- (newline)
- (force-output)
- ))
-
- (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)
- (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)
- (context-error (tstate-context tstate) "unknown rtx function"
- expr))))))
- (tstate-decr-depth! tstate)
- result))
-
- ; 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)
- (-rtx-traverse
- (rtx-make-operand expr) ; (current-op-lookup expr))
- expected mode 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))
- ((current-ifld-lookup expr)
- (-rtx-traverse
- (rtx-make-ifield expr)
- expected mode parent-expr op-pos tstate appstuff))
- ((enum-lookup-val expr)
- (-rtx-traverse
- (rtx-make-enum 'INT expr)
- expected mode parent-expr op-pos tstate appstuff))
- (else
- (context-error (tstate-context tstate)
- "unknown operand" expr))))
- ((integer? expr)
- (-rtx-traverse (rtx-make-const 'INT expr)
- expected mode parent-expr op-pos tstate appstuff))
- (else
- (context-error (tstate-context tstate)
- "unexpected operand"
- expr)))
-
- ; Not expecting RTX or SETRTX.
- (context-error (tstate-context tstate)
- "unexpected operand"
- expr)))
-)
-
-; User visible procedures to traverse an rtl expression.
-; These calls -rtx-traverse to do most of the work.
-; See tstate-make for an explanation of EXPR-FN.
-; CONTEXT is a <context> object or #f if there is none.
-; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
-; APPSTUFF is for application specific use.
-
-(define (rtx-traverse context owner expr expr-fn appstuff)
- (-rtx-traverse expr #f 'DFLT #f 0
- (tstate-make context owner expr-fn (rtx-env-empty-stack)
- #f #f nil 0)
- appstuff)
-)
-
-(define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
- (-rtx-traverse expr #f 'DFLT #f 0
- (tstate-make context owner expr-fn
- (rtx-env-push (rtx-env-empty-stack)
- (rtx-env-make-locals locals))
- #f #f nil 0)
- appstuff)
-)
-
-; Traverser debugger.
-
-(define (rtx-traverse-debug expr)
- (rtx-traverse
- #f #f expr
- (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
- (display "-expr: ")
- (display (string-append "rtx=" (obj:name rtx-obj)))
- (display " expr=")
- (display expr)
- (display " mode=")
- (display mode)
- (display " parent=")
- (display parent-expr)
- (display " op-pos=")
- (display op-pos)
- (display " cond?=")
- (display (tstate-cond? tstate))
- (newline)
- #f)
- #f
- )
-)
-
-; 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 (-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))
-)
-
-(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)
-)
-\f
; Various rtx utilities.
; Dump an rtx expression.
(hashq-ref -rtx-macro-table (car x)))))
)
\f
-; RTL evaluation state.
-; Applications may subclass <eval-state> if they need to add things.
-;
-; This is initialized before evaluation, and modified (in a copy) as the
-; evaluation state changes.
-; This doesn't record all evaluation state, just the less dynamic elements.
-; There's no point in recording things like the parent expression and operand
-; position as they change for every sub-eval.
-; The main raison d'etre for this class is so we can add more state without
-; having to modify all the eval handlers.
-
-(define <eval-state>
- (class-make '<eval-state> nil
- '(
- ; <context> object or #f if there is none
- (context . #f)
-
- ; Current object rtl is being evaluated for.
- ; We need to be able to access the current instruction while
- ; generating semantic code. However, the semantic description
- ; doesn't specify it as an argument to anything (and we don't
- ; want it to). So we record the value here.
- (owner . #f)
-
- ; EXPR-FN is a dual-purpose beast. The first purpose is to
- ; just process the current expression and return the result.
- ; The second purpose is to lookup the function which will then
- ; process the expression. It is applied recursively to the
- ; expression and each sub-expression. It must be defined as
- ; (lambda (rtx-obj expr mode estate) ...).
- ; If the result of EXPR-FN is a lambda, it is applied to
- ; (cons ESTATE (cdr EXPR)). ESTATE is prepended to the
- ; arguments.
- ; For syntax expressions if the result of EXPR-FN is #f,
- ; the operands are processed using the builtin evaluator.
- ; FIXME: This special handling of syntax expressions is
- ; not currently done.
- ; 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 estate).
- ; The arguments to the result of EXPR-FN are
- ; (cons ESTATE (cdr EXPR)).
- ; The reason for the duality is mostly history.
- ; In time things should be simplified.
- (expr-fn . #f)
-
- ; Current environment. This is a stack of sequence locals.
- (env . ())
-
- ; Current evaluation depth. This is used, for example, to
- ; control indentation in generated output.
- (depth . 0)
-
- ; Associative list of modifiers.
- ; This is here to support things like `delay'.
- (modifiers . ())
- )
- nil)
-)
-
-; Create an <eval-state> object using a list of keyword/value elements.
-; ARGS is a list of #:keyword/value elements.
-; The result is a list of the unrecognized elements.
-; Subclasses should override this method and send-next it first, then
-; see if they recognize anything in the result, returning what isn't
-; recognized.
-
-(method-make!
- <eval-state> 'vmake!
- (lambda (self args)
- (let loop ((args args) (unrecognized nil))
- (if (null? args)
- (reverse! unrecognized) ; ??? Could invoke method to initialize here.
- (begin
- (case (car args)
- ((#:context)
- (elm-set! self 'context (cadr args)))
- ((#:owner)
- (elm-set! self 'owner (cadr args)))
- ((#:expr-fn)
- (elm-set! self 'expr-fn (cadr args)))
- ((#:env)
- (elm-set! self 'env (cadr args)))
- ((#:depth)
- (elm-set! self 'depth (cadr args)))
- ((#:modifiers)
- (elm-set! self 'modifiers (cadr args)))
- (else
- ; Build in reverse order, as we reverse it back when we're done.
- (set! unrecognized
- (cons (cadr args) (cons (car args) unrecognized)))))
- (loop (cddr args) unrecognized)))))
-)
-
-; Accessors.
-
-(define-getters <eval-state> estate
- (context owner expr-fn env depth modifiers)
-)
-(define-setters <eval-state> estate
- (context owner expr-fn env depth modifiers)
-)
-
-; Build an estate for use in producing a value from rtl.
-; CONTEXT is a <context> object or #f if there is none.
-; OWNER is the owner of the expression or #f if there is none.
-
-(define (estate-make-for-eval context owner)
- (vmake <eval-state>
- #:context context
- #:owner owner
- #:expr-fn (lambda (rtx-obj expr mode estate)
- (rtx-evaluator rtx-obj)))
-)
-
-; Create a copy of ESTATE.
-
-(define (estate-copy estate)
- (object-copy-top estate)
-)
-
-; Create a copy of STATE with a new environment ENV.
-
-(define (estate-new-env state env)
- (let ((result (estate-copy state)))
- (estate-set-env! result env)
- result)
-)
-
-; Create a copy of STATE with environment ENV pushed onto the existing
-; environment list.
-; There's no routine to pop the environment list as there's no current
-; need for it: we make a copy of the state when we push.
-
-(define (estate-push-env state env)
- (let ((result (estate-copy state)))
- (estate-set-env! result (cons env (estate-env result)))
- result)
-)
-
-; Create a copy of STATE with modifiers MODS.
-
-(define (estate-with-modifiers state mods)
- (let ((result (estate-copy state)))
- (estate-set-modifiers! result (append mods (estate-modifiers result)))
- result)
-)
-
-; Convert a tstate to an estate.
-
-(define (tstate->estate t)
- (vmake <eval-state>
- #:context (tstate-context t)
- #:env (tstate-env t))
-)
-\f
-; RTL expression evaluation.
-;
-; ??? These used eval2 at one point. Not sure which is faster but I suspect
-; eval2 is by far. On the otherhand this has yet to be compiled. And this way
-; is more portable, more flexible, and works with guile 1.2 (which has
-; problems with eval'ing self referential vectors, though that's one reason to
-; use smobs).
-
-; Set to #t to debug rtx evaluation.
-
-(define -rtx-eval-debug? #f)
-
-; 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 or its name.
-; ESTATE is the current evaluation state.
-
-(define (rtx-eval-with-estate expr mode estate)
- (if -rtx-eval-debug?
- (begin
- (display "Traversing ")
- (display expr)
- (newline)
- (rtx-env-dump (estate-env estate))
- ))
-
- (if (pair? expr) ; pair? -> cheap non-null-list?
-
- (let* ((rtx-obj (rtx-lookup (car expr)))
- (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
- (if fn
- (if (procedure? fn)
- (apply fn (cons estate (cdr expr)))
-; ; Don't eval operands for syntax expressions.
-; (if (rtx-style-syntax? rtx-obj)
-; (apply fn (cons estate (cdr expr)))
-; (let ((operands
-; (-rtx-eval-operands rtx-obj expr estate)))
-; (apply fn (cons estate operands))))
- fn)
- ; Leave expr unchanged.
- expr))
-; (let ((operands
-; (-rtx-traverse-operands rtx-obj expr estate)))
-; (cons rtx-obj operands))))
-
- ; EXPR is not a list
- (error "argument to rtx-eval-with-estate is not a list" expr))
-)
-
-; Evaluate rtx expression EXPR and return the computed value.
-; EXPR must already be in compiled form (the result of rtx-compile).
-; 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
; Instruction field support.
; Return list of ifield names refered to in EXPR.
(set! -rtx-macro-table (make-hash-table 127))
(set! -rtx-num-next 0)
(def-rtx-funcs)
+
+ ; Sanity checks.
+ ; All rtx take options for the first arg and a mode for the second.
+ (for-each (lambda (rtx-name)
+ (let ((rtx (rtx-lookup rtx-name)))
+ (if rtx
+ (begin
+ (if (null? (rtx-arg-types rtx))
+ #f ; pc is the one exception, blech
+ (begin
+ (assert (eq? (car (rtx-arg-types rtx)) 'OPTIONS))
+ (assert (memq (cadr (rtx-arg-types rtx)) -rtx-valid-mode-types)))))
+ #f) ; else a macro
+ ))
+ -rtx-name-list)
+
(reader-add-command! 'define-subr
"\
Define an rtx subroutine, name/value pair list version.
; Set/get/miscellaneous
(drn (nop &options &mode)
- (OPTIONS VOIDFLTODE) (NA NA)
+ (OPTIONS VOIDMODE) (NA NA)
MISC
#f
)
; ??? There's no real need for mode either.
(drsn (parallel &options &mode ignore expr . exprs)
- (OPTIONS VOIDFLTODE LOCALS RTX . RTX) (NA NA NA VOID . VOID)
+ (OPTIONS VOIDMODE LOCALS RTX . RTX) (NA NA NA VOID . VOID)
SEQUENCE
#f
)
(map (lambda (insn)
; Must pass canonicalized and macro-expanded rtl.
(rtx-simplify #f insn (insn-semantics insn)
- (-build-known-values insn)))
+ (insn-build-known-values insn)))
insn-list))
insn-list)
)
(map (lambda (insn)
; Must pass canonicalized and macro-expanded rtl.
(rtx-simplify #f insn (insn-semantics insn)
- (-build-known-values insn)))
+ (insn-build-known-values insn)))
(non-multi-insns (non-alias-insns (current-insn-list))))
(non-multi-insns (non-alias-insns (current-insn-list))))
)
; Build the tstate known value list for INSN.
; This built from the ifield-assertion list.
-(define (-build-known-values insn)
+(define (insn-build-known-values insn)
(let ((expr (insn-ifield-assertion insn)))
(if expr
(case (rtx-name expr)
; ??? This calls rtx-simplify which calls rtx-traverse as it's simpler to
; simplify EXPR first, and then compile it. On the other hand it's slower
; (two calls to rtx-traverse!).
+;
+; FIXME: There's no need for sem-code-list to be a list.
+; The caller always passes (list (insn-semantics insn)).
(define (semantic-compile context insn sem-code-list)
(for-each (lambda (rtx) (assert (rtx? rtx)))
context
insn
(rtx-simplify context insn expr
- (-build-known-values insn))
+ (insn-build-known-values insn))
process-expr!
#f))
sem-code-list))
;
; CONTEXT is a <context> object or #f if there is none.
; INSN is the <insn> object.
+;
+; FIXME: There's no need for sem-code-list to be a list.
+; The caller always passes (list (insn-semantics insn)).
(define (semantic-attrs context insn sem-code-list)
(for-each (lambda (rtx) (assert (rtx? rtx)))
context
insn
(rtx-simplify context insn expr
- (-build-known-values insn))
+ (insn-build-known-values insn))
process-expr!
#f))
sem-code-list))
; Remove duplicate elements from sorted list L.
; Currently supported elements are symbols (a b c) and lists ((a) (b) (c)).
+; NOTE: Uses equal? for comparisons.
(define (remove-duplicates l)
(let loop ((l l) (result nil))
; This is not intended to be applied to large lists with an expected large
; result (where sorting the list first would be faster), though one could
; add such support later.
+;
+; ??? Rename to follow memq/memv/member naming convention.
(define (nub l key-generator)
(let loop ((l l) (keys (map key-generator l)) (result nil))
(else (find-apply fn pred (cdr l))))
)
-; Given a list of lists L such that the first element in each list names the
-; entry, look up symbol S in that and return its index. If not found,
-; return #f.
+; Given a list L, look up element ELM and return its index.
+; If not found, return #f.
+; I is added to the result.
+; (Yes, in one sense I is present to simplify the implementation. Sue me.)
+
+(define (eqv-lookup-index elm l i)
+ (cond ((null? l) #f)
+ ((eqv? elm (car l)) i)
+ (else (eqv-lookup-index elm (cdr l) (1+ i))))
+)
+
+; Given an associative list L, look up entry for symbol S and return its index.
+; If not found, return #f.
; Eg: (lookup 'element2 '((element1 1) (element2 2)))
-; Granted, linear searching isn't efficient. If it ever becomes a problem we
-; can do something about it then.
; I is added to the result.
+; (Yes, in one sense I is present to simplify the implementation. Sue me.)
+; NOTE: Uses eq? for comparisons.
-(define (lookup-index s l i)
+(define (assq-lookup-index s l i)
(cond ((null? l) #f)
((eqv? s (caar l)) i)
- (else (lookup-index s (cdr l) (1+ i))))
+ (else (assq-lookup-index s (cdr l) (1+ i))))
)
; Return the index of element ELM in list L or #f if not found.
; If found, I is added to the result.
; (Yes, in one sense I is present to simplify the implementation. Sue me.)
+; NOTE: Uses equal? for comparisons.
(define (element-lookup-index elm l i)
(cond ((null? l) #f)
)
; Return #t if ELM is in ELM-LIST.
+; NOTE: Uses equal? for comparisons (via `member').
(define (element? elm elm-list)
(->bool (member elm elm-list))
OSDN Git Service
