From 8fba497dd350ff85356c61588a65f6539719d286 Mon Sep 17 00:00:00 2001 From: devans Date: Wed, 23 Sep 2009 22:30:19 +0000 Subject: [PATCH] * xc16x.cpu (h-cr): New hardware. (muls): Comment out parts that won't compile, add fixme. (mulu, divl, divlu, jmpabs, jmpa-, jmprel, jbc, jnbs, callr): Ditto. (scxti, scxtmg, scxtm, bclear, bclr18, bset19, bitset, bmov): Ditto. (bmovn, band, bor, bxor, bcmp, bfldl, bfldh): Ditto. Rewrite rtl processing to require it to be "canonicalized" first, and write a full canonicalizer / expression checker. Remove all appearances of DFLT in canonical rtl. * attr.scm (/attr-eval atval owner): Call rtx-canonicalize, then rtx-simplify. * iformat.scm (ifmt-analyze) Use canonical semantics. * insn (): New member canonical-semantics. * mach.scm (): New member multi-insns-instantiated?. (/instantiate-multi-insns!): New function. (/canonicalize-insns!): New function. (arch-analyze-insns!): Canonicalize insn semantics before processing them. * mode.scm (/mode-set-word-params!): New function. (mode-void?): New function. (mode-compatible?): VOID is compatible with VOID. (/mode-word-sizes-defined?): New global. (mode-set-word-modes!): Use/set it. (mode-ensure-word-sizes-defined): Update. (mode-builtin!): New builtin "modes" SYM, INSN, MACH. Redo WI/UWI/AI/IAI handling. (op:new-mode): No longer accept DFLT. ( constructor): Ensure all fields are initialized. ( constructor): Ditto. (/derived-parse-ifield-assertion): Delete arg `args'. All callers updated. * rtl-c.scm (): New member `for-insn?'. (rtl-c): Call rtx-canonicalize instead of rtx-compile. (rtl-c-expr, rtl-c++): Ditto. (/rtl-c-get): Use mode of operand, not containing expression. (rtl-c-set-quiet, rtl-c-set-trace): Remove DFLT support. (/rtx-use-sem-fn?): Don't check for (insn? owner), check estate-for-insn? instead. (s-unop): Use mode of expression, not first operand. (s-binop, s-binop-with-bit, s-shop, s-cmpop): Ditto. (s-sequence): Remove DFLT support. (ifield): Use mode of expression, not UINT. (pc): Comment out, unused. (int-attr): New rtx kind. (attr): Deprecate. (set, set-quiet): Pass src to rtl-c-set-{trace,quiet} for expansion. * rtl-traverse.scm (/rtx-canon-debug?): New global. (/make-cstate): New function. (/cstate-context, /cstate-outer-expr): New functions. (/rtx-canon-error): New function. (/rtx-lookup-hw, /rtx-pick-mode, /rtx-pick-mode3, /rtx-pick-op-mode, /rtx-get-last-cond-case-rtx): New functions. (/rtx-canon-*): New functions. (/rtx-canner-table, /rtx-operand-canoners): New globals. (/rtx-make-canon-table, /rtx-special-expr-canoners): New functions. (/rtx-option, /rtx-option-list?): Rewrite. (rtx-munge-mode&options): Replaces /rtx-munge-mode&options. Rewritten, all callers updated. (/rtx-canon-expr, /rtx-canon): New functions. (rtx-canonicalize): Move here from rtl-xform.scm and rewrite. (rtx-canonicalize-stmt): New function. (tstate-make): Remove arg `set?'. All callers updated. (tstate-new-set?): Delete. (/rtx-traverse-options, /rtx-traverse-*mode): Delete, moved to /rtx-canon-*. (/rtx-traverse-normal-operand): New function. (/rtx-traverse-rtx-list): Delete arg `mode', all callers updated. (/rtx-traverse-rtx, /rtx-traverse-setrtx,, /rtx-traverse-testrtx, /rtx-traverse-condrtx, /rtx-traverse-casertx, /rtx-traverse-locals, /rtx-traverse-iteration, /rtx-traverse-env, /rtx-traverse-attrs): Ditto. (/rtx-traverse-symbol, /rtx-traverse-string, /rtx-traverse-number, /rtx-traverse-symornum, /rtx-traverse-object): Delete. (/rtx-make-traverser-table): Update. (/rtx-traverse-operands): Remove mode processing, now done during canonicalization. (/rtx-traverse-expr): Delete arg `mode', all callers updated. (/rtx-traverse): Ditto. (rtx-init-traverser-tables!): New function. * rtl-xform (/rtx-verify-no-dflt-modes-expr-fn): New function. (rtx-verify-no-dflt-modes): New function. (/rtx-simplify-expr-fn): Update, `arg' mode deleted. (rtx-simplify-insn): Use insn-canonical-semantics. (rtx-canonicalize): Moved to rtl-traverse.scm. (/compile-expr-fn, rtx-compile): Delete. (/rtx-trim-rtx-list): New function. (/rtx-trim-for-doc): Handle set, if. * rtl.scm (): New members result-mode, matchexpr-index. (/rtx-valid-mode-types): Update. (/rtx-valid-matches): Update. (/rtx-find-matchexpr-index): New function. (rtx-lookup): Require rtx-kind to be the rtx name. (def-rtx-node): New arg result-mode, all callers updated. (def-rtx-syntax-node, def-rtx-operand-node): Ditto. (rtx-lazy-sem-mode): Delete. (/rtx-closure-make): New arg `mode', all callers updated. (rtx-make-ifield, rtx-make-operand, rtx-make-local): Ditto. (rtx-operand-obj): Rewrite. (rtx-make-xop): New functions. (/hw): Renamed from `hw', all callers updated. Use the correct mode instead of DFLT for the index. (rtl-builtin!): Call rtx-init-traversal-tables!. (rtl-finish!): Update. * rtx-funcs.scm (all rtx functions): New parameter: result-mode. Update mode arg-type. (pc): Comment out. (int-attr): New rtx kind. (attr): Deprecate. * sem-frags.scm (/frag-hash-compute!): Update, mode arg deleted. (/frag-cost-compute!): Ditto. * semantics.scm (/build-operand!): Delete args op-name, op. New arg op-expr. All callers updated. (/build-mem-operand!): Remove DFLT support. (semantic-compile): Update process-expr!, mode arg deleted. * sid-cpu.scm (gen-semantic-code): Specify #:for-insn? in rtl-c++ calls. (/gen-sem-case, /gen-sfrag-code): Ditto. * sid.scm (/op-gen-set-trace1): Renamed from /op-gen-set-trace. (/op-gen-set-trace): New function. If not doing profiling, call /op-gen-set-quiet. * sim-cpu.scm (gen-semantic-code): Specify #:for-insn? in rtl-c calls. * utils-gen.scm (/gen-ifld-extract-base): Update call to rtl-c. (/gen-ifld-extract-beyond, gen-multi-ifld-extract): Ditto. * utils.scm (find-first-index): New function. * doc/rtl.texi: Delete docs for `attr'. Add `int-attr'. --- cgen/ChangeLog | 126 ++++ cgen/attr.scm | 2 +- cgen/cpu/xc16x.cpu | 132 ++-- cgen/doc/rtl.texi | 23 +- cgen/html.scm | 9 +- cgen/iformat.scm | 17 +- cgen/insn.scm | 22 +- cgen/mach.scm | 141 ++-- cgen/mode.scm | 91 ++- cgen/operand.scm | 71 +- cgen/rtl-c.scm | 181 ++--- cgen/rtl-traverse.scm | 1838 ++++++++++++++++++++++++++++++++++++++----------- cgen/rtl-xform.scm | 204 ++---- cgen/rtl.scm | 247 ++++--- cgen/rtx-funcs.scm | 324 ++++++--- cgen/sem-frags.scm | 6 +- cgen/semantics.scm | 59 +- cgen/sid-cpu.scm | 37 +- cgen/sid.scm | 16 +- cgen/sim-cpu.scm | 26 +- cgen/utils-gen.scm | 10 +- cgen/utils.scm | 12 +- 22 files changed, 2549 insertions(+), 1045 deletions(-) diff --git a/cgen/ChangeLog b/cgen/ChangeLog index c3605e7345..a5fc9e9945 100644 --- a/cgen/ChangeLog +++ b/cgen/ChangeLog @@ -1,5 +1,131 @@ 2009-09-23 Doug Evans + * xc16x.cpu (h-cr): New hardware. + (muls): Comment out parts that won't compile, add fixme. + (mulu, divl, divlu, jmpabs, jmpa-, jmprel, jbc, jnbs, callr): Ditto. + (scxti, scxtmg, scxtm, bclear, bclr18, bset19, bitset, bmov): Ditto. + (bmovn, band, bor, bxor, bcmp, bfldl, bfldh): Ditto. + + Rewrite rtl processing to require it to be "canonicalized" first, + and write a full canonicalizer / expression checker. + Remove all appearances of DFLT in canonical rtl. + * attr.scm (/attr-eval atval owner): Call rtx-canonicalize, + then rtx-simplify. + * iformat.scm (ifmt-analyze) Use canonical semantics. + * insn (): New member canonical-semantics. + * mach.scm (): New member multi-insns-instantiated?. + (/instantiate-multi-insns!): New function. + (/canonicalize-insns!): New function. + (arch-analyze-insns!): Canonicalize insn semantics before processing + them. + * mode.scm (/mode-set-word-params!): New function. + (mode-void?): New function. + (mode-compatible?): VOID is compatible with VOID. + (/mode-word-sizes-defined?): New global. + (mode-set-word-modes!): Use/set it. + (mode-ensure-word-sizes-defined): Update. + (mode-builtin!): New builtin "modes" SYM, INSN, MACH. + Redo WI/UWI/AI/IAI handling. + (op:new-mode): No longer accept DFLT. + ( constructor): Ensure all fields are initialized. + ( constructor): Ditto. + (/derived-parse-ifield-assertion): Delete arg `args'. + All callers updated. + * rtl-c.scm (): New member `for-insn?'. + (rtl-c): Call rtx-canonicalize instead of rtx-compile. + (rtl-c-expr, rtl-c++): Ditto. + (/rtl-c-get): Use mode of operand, not containing expression. + (rtl-c-set-quiet, rtl-c-set-trace): Remove DFLT support. + (/rtx-use-sem-fn?): Don't check for (insn? owner), check + estate-for-insn? instead. + (s-unop): Use mode of expression, not first operand. + (s-binop, s-binop-with-bit, s-shop, s-cmpop): Ditto. + (s-sequence): Remove DFLT support. + (ifield): Use mode of expression, not UINT. + (pc): Comment out, unused. + (int-attr): New rtx kind. + (attr): Deprecate. + (set, set-quiet): Pass src to rtl-c-set-{trace,quiet} for expansion. + * rtl-traverse.scm (/rtx-canon-debug?): New global. + (/make-cstate): New function. + (/cstate-context, /cstate-outer-expr): New functions. + (/rtx-canon-error): New function. + (/rtx-lookup-hw, /rtx-pick-mode, /rtx-pick-mode3, /rtx-pick-op-mode, + /rtx-get-last-cond-case-rtx): New functions. + (/rtx-canon-*): New functions. + (/rtx-canner-table, /rtx-operand-canoners): New globals. + (/rtx-make-canon-table, /rtx-special-expr-canoners): New functions. + (/rtx-option, /rtx-option-list?): Rewrite. + (rtx-munge-mode&options): Replaces /rtx-munge-mode&options. + Rewritten, all callers updated. + (/rtx-canon-expr, /rtx-canon): New functions. + (rtx-canonicalize): Move here from rtl-xform.scm and rewrite. + (rtx-canonicalize-stmt): New function. + (tstate-make): Remove arg `set?'. All callers updated. + (tstate-new-set?): Delete. + (/rtx-traverse-options, /rtx-traverse-*mode): Delete, + moved to /rtx-canon-*. + (/rtx-traverse-normal-operand): New function. + (/rtx-traverse-rtx-list): Delete arg `mode', all callers updated. + (/rtx-traverse-rtx, /rtx-traverse-setrtx,, /rtx-traverse-testrtx, + /rtx-traverse-condrtx, /rtx-traverse-casertx, /rtx-traverse-locals, + /rtx-traverse-iteration, /rtx-traverse-env, /rtx-traverse-attrs): + Ditto. + (/rtx-traverse-symbol, /rtx-traverse-string, /rtx-traverse-number, + /rtx-traverse-symornum, /rtx-traverse-object): Delete. + (/rtx-make-traverser-table): Update. + (/rtx-traverse-operands): Remove mode processing, now done during + canonicalization. + (/rtx-traverse-expr): Delete arg `mode', all callers updated. + (/rtx-traverse): Ditto. + (rtx-init-traverser-tables!): New function. + * rtl-xform (/rtx-verify-no-dflt-modes-expr-fn): New function. + (rtx-verify-no-dflt-modes): New function. + (/rtx-simplify-expr-fn): Update, `arg' mode deleted. + (rtx-simplify-insn): Use insn-canonical-semantics. + (rtx-canonicalize): Moved to rtl-traverse.scm. + (/compile-expr-fn, rtx-compile): Delete. + (/rtx-trim-rtx-list): New function. + (/rtx-trim-for-doc): Handle set, if. + * rtl.scm (): New members result-mode, matchexpr-index. + (/rtx-valid-mode-types): Update. + (/rtx-valid-matches): Update. + (/rtx-find-matchexpr-index): New function. + (rtx-lookup): Require rtx-kind to be the rtx name. + (def-rtx-node): New arg result-mode, all callers updated. + (def-rtx-syntax-node, def-rtx-operand-node): Ditto. + (rtx-lazy-sem-mode): Delete. + (/rtx-closure-make): New arg `mode', all callers updated. + (rtx-make-ifield, rtx-make-operand, rtx-make-local): Ditto. + (rtx-operand-obj): Rewrite. + (rtx-make-xop): New functions. + (/hw): Renamed from `hw', all callers updated. + Use the correct mode instead of DFLT for the index. + (rtl-builtin!): Call rtx-init-traversal-tables!. + (rtl-finish!): Update. + * rtx-funcs.scm (all rtx functions): New parameter: result-mode. + Update mode arg-type. + (pc): Comment out. + (int-attr): New rtx kind. + (attr): Deprecate. + * sem-frags.scm (/frag-hash-compute!): Update, mode arg deleted. + (/frag-cost-compute!): Ditto. + * semantics.scm (/build-operand!): Delete args op-name, op. + New arg op-expr. All callers updated. + (/build-mem-operand!): Remove DFLT support. + (semantic-compile): Update process-expr!, mode arg deleted. + * sid-cpu.scm (gen-semantic-code): Specify #:for-insn? in + rtl-c++ calls. + (/gen-sem-case, /gen-sfrag-code): Ditto. + * sid.scm (/op-gen-set-trace1): Renamed from /op-gen-set-trace. + (/op-gen-set-trace): New function. If not doing profiling, + call /op-gen-set-quiet. + * sim-cpu.scm (gen-semantic-code): Specify #:for-insn? in rtl-c calls. + * utils-gen.scm (/gen-ifld-extract-base): Update call to rtl-c. + (/gen-ifld-extract-beyond, gen-multi-ifld-extract): Ditto. + * utils.scm (find-first-index): New function. + * doc/rtl.texi: Delete docs for `attr'. Add `int-attr'. + * rtx-funcs.scm (eq,ne,lt,gt,le,ge,ltu,leu,gtu,geu): Change class to COMPARE. * sem-frags.scm (/frag-cost-compute!): Add COMPARE. diff --git a/cgen/attr.scm b/cgen/attr.scm index 43f6c10f10..dab76339f2 100644 --- a/cgen/attr.scm +++ b/cgen/attr.scm @@ -495,7 +495,7 @@ (define (/attr-eval atval owner) (let* ((estate (estate-make-for-eval #f owner)) - (expr (rtx-compile #f (rtx-simplify #f owner atval nil) nil)) + (expr (rtx-simplify #f owner (rtx-canonicalize #f 'DFLT atval nil) nil)) (value (rtx-eval-with-estate expr DFLT estate))) (cond ((symbol? value) value) ((number? value) value) diff --git a/cgen/cpu/xc16x.cpu b/cgen/cpu/xc16x.cpu index db5f9ba38b..efa687d2b9 100644 --- a/cgen/cpu/xc16x.cpu +++ b/cgen/cpu/xc16x.cpu @@ -1,6 +1,6 @@ ; Infineon XC16X CPU description. -*- Scheme -*- ; -; Copyright 2006, 2009 Free Software Foundation, Inc. +; Copyright 2006, 2007, 2009 Free Software Foundation, Inc. ; ; Contributed by KPIT Cummins Infosystems Ltd.; developed under contract ; from Infineon Systems, GMBH , Germany. @@ -9,7 +9,7 @@ ; ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by -; the Free Software Foundation; either version 2 of the License, or +; the Free Software Foundation; either version 3 of the License, or ; (at your option) any later version. ; ; This program is distributed in the hope that it will be useful, @@ -241,6 +241,16 @@ (indices extern-keyword gr-names) ) +;; HACK: Various semantics refer to h-cr. +;; This is here to keep things working. +(define-hardware + (name h-cr) + (comment "cr registers") + (attrs PROFILE CACHE-ADDR) + (type register HI (16)) + (indices extern-keyword gr-names) +) + (define-keyword (name ext-names) (enum-prefix H-EXT-) @@ -1095,7 +1105,7 @@ ((PIPE OS) (IDOC ALU)) "mul $src1,$src2" (+ OP1_0 OP2_11 src1 src2) - (reg SI h-md 0) + (nop) ;; FIXME: (reg SI h-md 0) () ) ; MULU Rwn,Rwm @@ -1103,7 +1113,7 @@ ((PIPE OS) (IDOC ALU)) "mulu $src1,$src2" (+ OP1_1 OP2_11 src1 src2) - (reg SI h-md 0) + (nop) ;; FIXME: (reg SI h-md 0) () ) ; DIV Rwn @@ -1123,8 +1133,8 @@ "divl $srdiv" (+ OP1_6 OP2_11 srdiv ) (sequence () - (set HI (reg HI h-cr 6) (div SI (reg SI h-md 0) srdiv)) - (set HI (reg HI h-cr 7) (mod SI (reg SI h-md 0) srdiv)) + (set HI (reg HI h-cr 6) 0) ;; FIXME: (div SI (reg SI h-md 0) srdiv)) + (set HI (reg HI h-cr 7) 0) ;; FIXME: (mod SI (reg SI h-md 0) srdiv)) ) () ) @@ -1134,8 +1144,8 @@ "divlu $srdiv" (+ OP1_7 OP2_11 srdiv ) (sequence () - (set HI (reg HI h-cr 6) (udiv SI (reg SI h-md 0) srdiv)) - (set HI (reg HI h-cr 7) (umod SI (reg SI h-md 0) srdiv)) + (set HI (reg HI h-cr 6) 0) ;; FIXME: (udiv SI (reg SI h-md 0) srdiv)) + (set HI (reg HI h-cr 7) 0) ;; FIXME: (umod SI (reg SI h-md 0) srdiv)) ) () ) @@ -1829,14 +1839,14 @@ (sequence ((HI tmp1) (HI tmp2)) (set tmp1 (mem HI caddr)) (set tmp2 (sub HI pc (mem HI caddr))) - (if (gt tmp2 (const 0)) (lt tmp2 (const 32)) (eq tmp2 (const 32)) + (if (gt tmp2 (const 0)) ;; FIXME: (lt tmp2 (const 32)) (eq tmp2 (const 32)) (set bitone (const 1))) - (if (lt tmp2 (const 0)) (eq tmp2 (const 0)) (gt tmp2 (const 32)) + (if (lt tmp2 (const 0)) ;; FIXME: (eq tmp2 (const 0)) (gt tmp2 (const 32)) (set bitone (const 0))) - (if (eq extcond (const 1) (ne extcond cc_Z)) + (if (eq extcond (const 1)) ;; FIXME: (ne extcond cc_Z)) (set bit01 (const 0)) (set HI pc (mem HI caddr))) - (if (ne extcond (const 1) (eq extcond cc_Z)) + (if (ne extcond (const 1)) ;; FIXME: (eq extcond cc_Z)) (set bit01 (const 1)) (set HI pc (add HI pc (const 2)))) ) @@ -1855,9 +1865,9 @@ (sequence ((HI tmp1) (HI tmp2)) (set tmp1 (mem HI caddr)) (set tmp2 (sub HI pc (mem HI caddr))) - (if (gt tmp2 (const 0)) (lt tmp2 (const 32)) (eq tmp2 (const 32)) + (if (gt tmp2 (const 0)) ;; FIXME: (lt tmp2 (const 32)) (eq tmp2 (const 32)) (set bitone (const 1))) - (if (lt tmp2 (const 0)) (eq tmp2 (const 0)) (gt tmp2 (const 32)) + (if (lt tmp2 (const 0)) ;; FIXME: (eq tmp2 (const 0)) (gt tmp2 (const 32)) (set bitone (const 0))) (set HI pc (add HI pc (const 2))) ) @@ -1888,9 +1898,9 @@ (sequence () (if QI (lt QI rel (const 0)) (sequence () - (neg QI rel) - (add QI rel (const 1)) - (mul QI rel (const 2)) + ;; FIXME: (neg QI rel) + ;; FIXME: (add QI rel (const 1)) + ;; FIXME: (mul QI rel (const 2)) (set HI pc (sub HI pc rel)) )) (set HI pc (add HI pc (mul QI rel (const 2)))) @@ -1992,8 +2002,8 @@ (if QI (lt QI relhi (const 0)) (set tmp2 (const 1)) (set tmp1 genreg) - (sll tmp2 qlobit) - (inv tmp2) + ;; FIXME: (sll tmp2 qlobit) + ;; FIXME: (inv tmp2) (set HI tmp1(and tmp1 tmp2)) (set HI genreg tmp1) (set HI pc (add HI pc (mul QI relhi (const 2))))) @@ -2040,7 +2050,7 @@ (if QI (lt QI relhi (const 0)) (set tmp2 (const 1)) (set tmp1 reg8) - (sll tmp2 qbit) + ;; FIXME: (sll tmp2 qbit) (set BI tmp1(or tmp1 tmp2)) (set HI reg8 tmp1) (set HI pc (add HI pc (mul QI relhi (const 2))))) @@ -2119,9 +2129,9 @@ (sequence () (if QI (lt QI rel (const 0)) (sequence () - (neg QI rel) - (add QI rel (const 1)) - (mul QI rel (const 2)) + ;; FIXME: (neg QI rel) + ;; FIXME: (add QI rel (const 1)) + ;; FIXME: (mul QI rel (const 2)) (set HI pc (sub HI pc rel)) )) (set HI pc (add HI pc (mul QI rel (const 2)))) @@ -2307,7 +2317,7 @@ (sequence ((HI tmp1) (HI tmp2)) (set HI tmp1 reg8) (set HI tmp2 uimm16) - (sub HI (reg HI h-cr 9) (const 2)) + ;; FIXME: (sub HI (reg HI h-cr 9) (const 2)) (set HI (reg HI h-cr 9) tmp1) (set HI reg8 tmp2) ) @@ -2331,7 +2341,7 @@ (sequence ((HI tmp1) (HI tmp2)) (set HI tmp1 regmem8) (set HI tmp2 memgr8) - (sub HI (reg HI h-cr 9) (const 2)) + ;; FIXME: (sub HI (reg HI h-cr 9) (const 2)) (set HI (reg HI h-cr 9) tmp1) (set HI regmem8 tmp2) ) @@ -2346,7 +2356,7 @@ (sequence ((HI tmp1) (HI tmp2)) (set HI tmp1 reg8) (set HI tmp2 memory) - (sub HI (reg HI h-cr 9) (const 2)) + ;; FIXME: (sub HI (reg HI h-cr 9) (const 2)) (set HI (reg HI h-cr 9) tmp1) (set HI reg8 tmp2) ) @@ -2647,8 +2657,8 @@ (sequence ((HI tmp1) (HI tmp2)) (set tmp2 (const 1)) (set tmp1 reg8) - (sll tmp2 qbit) - (inv tmp2) + ;; FIXME: (sll tmp2 qbit) + ;; FIXME: (inv tmp2) (set BI tmp1(and tmp1 tmp2)) (set HI reg8 tmp1)) () @@ -2663,8 +2673,8 @@ (sequence ((HI tmp1) (HI tmp2)) (set tmp2 (const 1)) (set tmp1 reg8) - (sll tmp2 qbit) - (inv tmp2) + ;; FIXME: (sll tmp2 qbit) + ;; FIXME: (inv tmp2) (set BI tmp1(and tmp1 tmp2)) (set HI reg8 tmp1)) () @@ -2696,7 +2706,7 @@ (sequence ((HI tmp1) (HI tmp2)) (set tmp2 (const 1)) (set tmp1 reg8) - (sll tmp2 qbit) + ;; FIXME: (sll tmp2 qbit) (set BI tmp1(or tmp1 tmp2)) (set HI reg8 tmp1)) () @@ -2712,7 +2722,7 @@ (sequence ((HI tmp1) (HI tmp2)) (set tmp2 (const 1)) (set tmp1 reg8) - (sll tmp2 qbit) + ;; FIXME: (sll tmp2 qbit) (set BI tmp1(or tmp1 tmp2)) (set HI reg8 tmp1)) () @@ -2748,10 +2758,10 @@ (set HI tmp2 reg8) (set tmp3 (const 1)) (set tmp4 (const 1)) - (sll tmp3 qlobit) - (sll tmp4 qhibit) - (and tmp1 tmp3) - (and tmp2 tmp4) + ;; FIXME: (sll tmp3 qlobit) + ;; FIXME: (sll tmp4 qhibit) + ;; FIXME: (and tmp1 tmp3) + ;; FIXME: (and tmp2 tmp4) (set BI tmp1 tmp2) (set HI reghi8 tmp1) (set HI reg8 tmp2)) @@ -2769,11 +2779,11 @@ (set HI tmp2 reg8) (set tmp3 (const 1)) (set tmp4 (const 1)) - (sll tmp3 qlobit) - (sll tmp4 qhibit) - (and tmp1 tmp3) - (and tmp2 tmp4) - (inv HI tmp2) + ;; FIXME: (sll tmp3 qlobit) + ;; FIXME: (sll tmp4 qhibit) + ;; FIXME: (and tmp1 tmp3) + ;; FIXME: (and tmp2 tmp4) + ;; FIXME: (inv HI tmp2) (set BI tmp1 tmp2) (set HI reghi8 tmp1) (set HI reg8 tmp2)) @@ -2791,10 +2801,10 @@ (set HI tmp2 reg8) (set tmp3 (const 1)) (set tmp4 (const 1)) - (sll tmp3 qlobit) - (sll tmp4 qhibit) - (and tmp1 tmp3) - (and tmp2 tmp4) + ;; FIXME: (sll tmp3 qlobit) + ;; FIXME: (sll tmp4 qhibit) + ;; FIXME: (and tmp1 tmp3) + ;; FIXME: (and tmp2 tmp4) (set BI tmp1(and tmp1 tmp2)) (set HI reghi8 tmp1) (set HI reg8 tmp2)) @@ -2812,10 +2822,10 @@ (set HI tmp2 reg8) (set tmp3 (const 1)) (set tmp4 (const 1)) - (sll tmp3 qlobit) - (sll tmp4 qhibit) - (and tmp1 tmp3) - (and tmp2 tmp4) + ;; FIXME: (sll tmp3 qlobit) + ;; FIXME: (sll tmp4 qhibit) + ;; FIXME: (and tmp1 tmp3) + ;; FIXME: (and tmp2 tmp4) (set BI tmp1(or tmp1 tmp2)) (set HI reghi8 tmp1) (set HI reg8 tmp2)) @@ -2833,10 +2843,10 @@ (set HI tmp2 reg8) (set tmp3 (const 1)) (set tmp4 (const 1)) - (sll tmp3 qlobit) - (sll tmp4 qhibit) - (and tmp1 tmp3) - (and tmp2 tmp4) + ;; FIXME: (sll tmp3 qlobit) + ;; FIXME: (sll tmp4 qhibit) + ;; FIXME: (and tmp1 tmp3) + ;; FIXME: (and tmp2 tmp4) (set BI tmp1(xor tmp1 tmp2)) (set HI reghi8 tmp1) (set HI reg8 tmp2)) @@ -2854,10 +2864,10 @@ (set HI tmp2 reg8) (set tmp3 (const 1)) (set tmp4 (const 1)) - (sll tmp3 qlobit) - (sll tmp4 qhibit) - (and tmp1 tmp3) - (and tmp2 tmp4) + ;; FIXME: (sll tmp3 qlobit) + ;; FIXME: (sll tmp4 qhibit) + ;; FIXME: (and tmp1 tmp3) + ;; FIXME: (and tmp2 tmp4) (set BI tmp1(xor tmp1 tmp2)) (set HI reghi8 tmp1) (set HI reg8 tmp2)) @@ -2874,7 +2884,7 @@ (set HI tmp1 reg8) (set QI tmp2 mask8) (set QI tmp3 datahi8) - (inv QI tmp2) + ;; FIXME: (inv QI tmp2) (set HI tmp1 (and tmp1 tmp2)) (set HI tmp1 (or tmp1 tmp3)) (set HI reg8 tmp1) @@ -2892,9 +2902,9 @@ (set HI tmp1 reg8) (set QI tmp2 masklo8) (set HI tmp3 data8) - (sll tmp2 (const 8)) - (inv HI tmp2) - (sll tmp3 (const 8)) + ;; FIXME: (sll tmp2 (const 8)) + ;; FIXME: (inv HI tmp2) + ;; FIXME: (sll tmp3 (const 8)) (set HI tmp1 (and tmp1 tmp2)) (set HI tmp1 (or tmp1 tmp3)) (set HI reg8 tmp1) diff --git a/cgen/doc/rtl.texi b/cgen/doc/rtl.texi index 6ec30ad36e..c316fe71c9 100644 --- a/cgen/doc/rtl.texi +++ b/cgen/doc/rtl.texi @@ -2853,20 +2853,25 @@ an experiment and will probably change. Skip the next instruction if @samp{yes?} is non-zero. This rtx is an experiment and will probably change. -@item (attr mode kind attr-name) -Return the value of attribute @samp{attr-name} in mode -@samp{mode}. @samp{kind} must currently be @samp{insn}: the current -instruction. - @item (symbol name) Return a symbol with value @samp{name}, for use in attribute processing. This is equivalent to @samp{quote} in Scheme but @samp{quote} sounds too jargonish. -@item (eq-attr mode attr-name value) -Return non-zero if the value of attribute @samp{attr-name} is -@samp{value}. If @samp{value} is a list return ``true'' if -@samp{attr-name} is any of the listed values. +@item (int-attr mode object attr-name) +Return the value of attribute @samp{attr-name} in mode @samp{mode}. +@samp{object} must currently be @samp{(current-insn)}, the current instruction, +or @samp{(current-mach)}, the current machine. +The attribute's value must be representable as an integer. + +@item (eq-attr mode object attr-name value) +Return non-zero if the value of attribute @samp{attr-name} of +object @samp{object} is @samp{value}. + +@emph{NOTE:} List values of @samp{value} may be changed to allow use the +@samp{number-list} rtx function. +If @samp{value} is a list return ``true'' if the attribute is any of +the listed values. But this is not implemented yet. @item (index-of operand) Return the index of @samp{operand}. For registers this is the register number. diff --git a/cgen/html.scm b/cgen/html.scm index ba5e4d89cd..fee303bfa3 100644 --- a/cgen/html.scm +++ b/cgen/html.scm @@ -679,6 +679,8 @@ See the input .cpu file(s) for copyright information. ; The possibilities are: MEM, FPU. (define (get-insn-properties insn) + (logit 2 "Collecting properties of insn " (obj:name insn) " ...\n") + (let* ((context #f) ; ??? do we need a better context? @@ -687,15 +689,14 @@ See the input .cpu file(s) for copyright information. (sem-attrs (list #f)) ; Called for expressions encountered in SEM-CODE-LIST. - ; MODE is the name of the mode. (process-expr! - (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) + (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) (case (car expr) - ((operand) (if (memory? (op:type (rtx-operand-obj expr))) + ((operand) (if (memory? (op:type (current-op-lookup (rtx-arg1 expr)))) ; Don't change to '(MEM), since we use append!. (append! sem-attrs (list 'MEM))) - (if (mode-float? (op:mode (rtx-operand-obj expr))) + (if (mode-float? (mode:lookup (rtx-mode expr))) ; Don't change to '(FPU), since we use append!. (append! sem-attrs (list 'FPU))) ) diff --git a/cgen/iformat.scm b/cgen/iformat.scm index bb91660901..82ba13fd2a 100644 --- a/cgen/iformat.scm +++ b/cgen/iformat.scm @@ -384,17 +384,18 @@ ; Compute an iformat descriptor used to build an object for INSN. ; -; If COMPUTE-SFORMAT? is #t compile the semantics and compute the semantic -; format (same as instruction format except that operands are used to +; If COMPUTE-SFORMAT? is #t compute the semantic format +; (same as instruction format except that operands are used to ; distinguish insns). ; Attributes derivable from the semantics are also computed. ; This is all done at the same time to minimize the number of times the ; semantic code is traversed. +; The semantics of INSN must already be compiled and stored in +; compiled-semantics. ; -; The result is (descriptor compiled-semantics attrs). +; The result is (descriptor attrs). ; `descriptor' is #f for insns with an empty field list ; (this happens for virtual insns). -; `compiled-semantics' is #f if COMPUTE-SFORMAT? is #f. ; `attrs' is an object of attributes derived from the semantics. ; ; ??? We never traverse the semantics of virtual insns. @@ -415,8 +416,7 @@ ; Field list is unspecified. (list #f #f atlist-empty) - ; FIXME: error checking (e.g. missing or overlapping bits) - (let* ((sem (insn-semantics insn)) + (let* ((sem (insn-canonical-semantics insn)) ; Compute list of input and output operands if asked for. (sem-ops (if compute-sformat? (semantic-compile #f ; FIXME: context @@ -425,14 +425,15 @@ (if sem (semantic-attrs #f ; FIXME: context insn sem) - atlist-empty)))) - ) + atlist-empty))))) + (let ((compiled-sem (csem-code sem-ops)) (in-ops (csem-inputs sem-ops)) (out-ops (csem-outputs sem-ops)) (attrs (csem-attrs sem-ops)) (cti? (or (atlist-cti? (csem-attrs sem-ops)) (insn-cti? insn)))) + (list (make cti? sorted-ifields in-ops out-ops (if (and in-ops out-ops) diff --git a/cgen/insn.scm b/cgen/insn.scm index 984425d156..e2066c44a7 100644 --- a/cgen/insn.scm +++ b/cgen/insn.scm @@ -44,7 +44,8 @@ tmp ; Instruction semantics. - ; This is the rtl in source form or #f if there is none. + ; This is the rtl in source form, as provided in the + ; description file, or #f if there is none. ; ; There are a few issues (ick, I hate that word) to consider ; here: @@ -62,9 +63,13 @@ ; separate class. ; ??? Contents of trap expressions is wip. It will probably ; be a sequence with an #:errchk modifier or some such. - (semantics . #f) + semantics + + ; The processed form of the semantics. + ; This remains #f for virtual insns (FIXME: keep?). + (canonical-semantics . #f) - ; The processed form of the above. + ; The processed form of the semantics. ; This remains #f for virtual insns (FIXME: keep?). (compiled-semantics . #f) @@ -73,7 +78,7 @@ ; Another thing that will be needed is [in some cases] a more ; simplified version of the RTL for use by apps like compilers. ; Perhaps that's what this will become. - host-semantics + ;host-semantics ; The function unit usage of the instruction. timing @@ -90,11 +95,12 @@ (define-getters insn (syntax iflds ifield-assertion fmt-desc ifmt sfmt tmp - semantics compiled-semantics host-semantics timing) + semantics canonical-semantics compiled-semantics timing) ) (define-setters insn - (fmt-desc ifmt sfmt tmp ifield-assertion compiled-semantics) + (fmt-desc ifmt sfmt tmp ifield-assertion + canonical-semantics compiled-semantics) ) ; Return a boolean indicating if X is an . @@ -401,7 +407,8 @@ (let ((ifield-assertion (if (and ifield-assertion (not (null? ifield-assertion))) - (rtx-canonicalize context ifield-assertion) + (rtx-canonicalize context 'DFLT ;; BI? + ifield-assertion nil) #f)) (semantics (if (not (null? semantics)) semantics @@ -700,6 +707,7 @@ ;; With derived ifields this is really hard, so only do the base insn ;; for now. Do the simple test for now, it doesn't catch everything, ;; but it should catch a lot. + ;; ??? One thing we don't catch yet is overlapping bits. (let* ((base-iflds (find (lambda (f) (not (ifld-beyond-base? f))) diff --git a/cgen/mach.scm b/cgen/mach.scm index 10e378b518..4df5c33344 100644 --- a/cgen/mach.scm +++ b/cgen/mach.scm @@ -37,6 +37,8 @@ ; standard values derived from the input data derived + ; #t if multi-insns have been instantiated + (multi-insns-instantiated? . #f) ; #t if instructions have been analyzed (insns-analyzed? . #f) ; #t if semantics were included in the analysis @@ -61,6 +63,7 @@ ifld-table hw-list op-table ifmt-list sfmt-list insn-table minsn-table subr-list derived + multi-insns-instantiated? insns-analyzed? semantics-analyzed? aliases-analyzed? next-ordinal ) @@ -73,6 +76,7 @@ ifld-table hw-list op-table ifmt-list sfmt-list insn-table minsn-table subr-list derived + multi-insns-instantiated? insns-analyzed? semantics-analyzed? aliases-analyzed? next-ordinal ) @@ -1809,6 +1813,67 @@ *UNSPECIFIED* ) +;; Instantiate the multi-insns of ARCH (if there are any). + +(define (/instantiate-multi-insns! arch) + ;; Skip if already done, we don't want to create duplicates. + + (if (not (arch-multi-insns-instantiated? arch)) + (begin + + (if (any-true? (map multi-insn? (arch-insn-list arch))) + + (begin + ; Instantiate sub-insns of all multi-insns. + (logit 1 "Instantiating multi-insns ...\n") + + ;; FIXME: Hack to remove differences in generated code when we + ;; switched to recording insns in hash tables. + ;; Multi-insn got instantiated after the list of insns had been + ;; reversed and they got added to the front of the list, in + ;; reverse order. Blech! + ;; Eventually remove this, have a flag day, and check in the + ;; updated files. + ;; NOTE: This causes major diffs to opcodes/m32c-*.[ch]. + (let ((orig-ord (arch-next-ordinal arch))) + (arch-set-next-ordinal! arch (- MAX-VIRTUAL-INSNS)) + (for-each (lambda (insn) + (multi-insn-instantiate! insn)) + (multi-insns (arch-insn-list arch))) + (arch-set-next-ordinal! arch orig-ord)) + + (logit 1 "Done instantiating multi-insns.\n") + )) + + (arch-set-multi-insns-instantiated?! arch #t) + )) +) + +;; Subroutine of arch-analyze-insns! to simplify it. +;; Canonicalize INSNS of ARCH. + +(define (/canonicalize-insns! arch insn-list) + (logit 1 "Canonicalizing instruction semantics ...\n") + + (for-each (lambda (insn) + (cond ((insn-canonical-semantics insn) + #t) ;; already done + ((insn-semantics insn) + (logit 2 "Canonicalizing semantics for " (obj:name insn) " ...\n") + (let ((canon-sem + (rtx-canonicalize + (make-obj-context insn + (string-append "canonicalizing semantics of " + (obj:str-name insn))) + 'VOID (insn-semantics insn) nil))) + (insn-set-canonical-semantics! insn canon-sem))) + (else + (logit 2 "Skipping instruction " (obj:name insn) ", no semantics ...\n")))) + insn-list) + + (logit 1 "Done canonicalization.\n") +) + ; Analyze the instruction set. ; The name is explicitly vague because it's intended that all insn analysis ; would be controlled here. @@ -1831,55 +1896,37 @@ (begin - ;; FIXME: This shouldn't be calling current-insn-list, - ;; it should use (arch-insn-list arch). - ;; Then again various subroutines assume arch == CURRENT-ARCH. - ;; Still, something needs to be cleaned up. - (if (any-true? (map multi-insn? (current-insn-list))) - (begin - ; Instantiate sub-insns of all multi-insns. - (logit 1 "Instantiating multi-insns ...\n") + (/instantiate-multi-insns! arch) - ;; FIXME: Hack to remove differences in generated code when we - ;; switched to recording insns in hash tables. - ;; Multi-insn got instantiated after the list of insns had been - ;; reversed and they got added to the front of the list, in - ;; reverse order. Blech! - ;; Eventually remove this, have a flag day, and check in the - ;; updated files. - ;; NOTE: This causes major diffs to opcodes/m32c-*.[ch]. - (let ((orig-ord (arch-next-ordinal arch))) - (arch-set-next-ordinal! arch (- MAX-VIRTUAL-INSNS)) - (for-each (lambda (insn) - (multi-insn-instantiate! insn)) - (multi-insns (current-insn-list))) - (arch-set-next-ordinal! arch orig-ord)) - )) + (let ((insn-list (non-multi-insns + (if include-aliases? + (arch-insn-list arch) + (non-alias-insns (arch-insn-list arch)))))) - ; This is expensive so indicate start/finish. - (logit 1 "Analyzing instruction set ...\n") - - (let ((fmt-lists - (ifmt-compute! (non-multi-insns - (if include-aliases? - (arch-insn-list arch) - (non-alias-insns (arch-insn-list arch)))) - analyze-semantics?))) - - (arch-set-ifmt-list! arch (car fmt-lists)) - (arch-set-sfmt-list! arch (cadr fmt-lists)) - (arch-set-insns-analyzed?! arch #t) - (arch-set-semantics-analyzed?! arch analyze-semantics?) - (arch-set-aliases-analyzed?! arch include-aliases?) - - ;; Now that the instruction formats are computed, - ;; do some sanity checks. - (logit 1 "Performing sanity checks ...\n") - (/sanity-check-insns arch) - - (logit 1 "Done analysis.\n") - )) - ) + ;; Compile each insns semantics, traversers/evaluators require it. + (/canonicalize-insns! arch insn-list) + + ;; This is expensive so indicate start/finish. + (logit 1 "Analyzing instruction set ...\n") + + (let ((fmt-lists + (ifmt-compute! insn-list + analyze-semantics?))) + + (arch-set-ifmt-list! arch (car fmt-lists)) + (arch-set-sfmt-list! arch (cadr fmt-lists)) + (arch-set-insns-analyzed?! arch #t) + (arch-set-semantics-analyzed?! arch analyze-semantics?) + (arch-set-aliases-analyzed?! arch include-aliases?) + + ;; Now that the instruction formats are computed, + ;; do some sanity checks. + (logit 1 "Performing sanity checks ...\n") + (/sanity-check-insns arch) + + (logit 1 "Done analysis.\n") + )) + )) *UNSPECIFIED* ) diff --git a/cgen/mode.scm b/cgen/mode.scm index 8772b10745..3240e69fd5 100644 --- a/cgen/mode.scm +++ b/cgen/mode.scm @@ -78,6 +78,19 @@ ; ptr-to is currently private so there is no accessor. (define mode:host? (elm-make-getter 'host?)) +;; Utility to set the parameters of WI/UWI/AI/IAI modes. + +(define (/mode-set-word-params! dst src) + (assert (mode? dst)) + (assert (mode? src)) + (elm-xset! dst 'bits (elm-xget src 'bits)) + (elm-xset! dst 'bytes (elm-xget src 'bytes)) + (elm-xset! dst 'non-mode-c-type (elm-xget src 'non-mode-c-type)) + (elm-xset! dst 'printf-type (elm-xget src 'printf-type)) + (elm-xset! dst 'sem-mode (elm-xget src 'sem-mode)) + *UNSPECIFIED* +) + ; Return string C type to use for values of mode M. (define (mode:c-type m) @@ -156,28 +169,35 @@ (define (mode-class-numeric? class) (memq class '(INT UINT FLOAT))) -; Return a boolean indicating if MODE has an integral mode class. +; Return a boolean indicating if MODE has an integral mode class. ; Similarily for signed/unsigned. (define (mode-integral? mode) (mode-class-integral? (mode:class mode))) (define (mode-signed? mode) (mode-class-signed? (mode:class mode))) (define (mode-unsigned? mode) (mode-class-unsigned? (mode:class mode))) -; Return a boolean indicating if MODE has a floating point mode class. +; Return a boolean indicating if MODE has a floating point mode class. (define (mode-float? mode) (mode-class-float? (mode:class mode))) -; Return a boolean indicating if MODE has a numeric mode class. +; Return a boolean indicating if MODE has a numeric mode class. (define (mode-numeric? mode) (mode-class-numeric? (mode:class mode))) +;; Return a boolean indicating if MODE is VOID. + +(define (mode-void? mode) + (eq? mode VOID) +) + ; Return a boolean indicating if MODE1 is compatible with MODE2. ; MODE[12] are either names or objects. ; HOW is a symbol indicating how the test is performed: ; strict: modes must have same name -; samesize: modes must be both float or both integer (int or uint) and have -; same size -; sameclass: modes must be both float or both integer (int or uint) +; samesize: modes must be both float, or both integer (int or uint), +; or both VOID and have same size +; sameclass: modes must be both float, or both integer (int or uint), +; or both VOID ; numeric: modes must be both numeric (define (mode-compatible? how mode1 mode2) @@ -193,10 +213,13 @@ ((mode-float? m1) (and (mode-float? m2) (= (mode:bits m1) (mode:bits m2)))) + ((mode-void? m1) + (mode-void? m2)) (else #f))) ((sameclass) (cond ((mode-integral? m1) (mode-integral? m2)) ((mode-float? m1) (mode-float? m2)) + ((mode-void? m1) (mode-void? m2)) (else #f))) ((numeric) (and (mode-numeric? m1) (mode-numeric? m2))) @@ -409,6 +432,9 @@ ; IDENTICAL: all word sizes must be identical (define /mode-word-sizes-kind #f) +;; Set to true if mode-set-word-modes! has been called. +(define /mode-word-sizes-defined? #f) + ; Called when a cpu-family is read in to set the word sizes. (define (mode-set-word-modes! bitsize) @@ -422,8 +448,7 @@ (error "unable to find precise mode to match cpu word-bitsize" bitsize)) ; Enforce word size kind. - (if (!= current-word-bitsize 0) - ; word size already set + (if /mode-word-sizes-defined? (case /mode-word-sizes-kind ((IDENTICAL) (if (!= current-word-bitsize (mode:bits word-mode)) @@ -436,16 +461,14 @@ (if (not ignore?) (begin - (set! WI word-mode) - (set! UWI uword-mode) - (set! AI uword-mode) - (set! IAI uword-mode) - (hashq-set! /mode-table 'WI word-mode) - (hashq-set! /mode-table 'UWI uword-mode) - (hashq-set! /mode-table 'AI uword-mode) - (hashq-set! /mode-table 'IAI uword-mode) + (/mode-set-word-params! WI word-mode) + (/mode-set-word-params! UWI uword-mode) + (/mode-set-word-params! AI uword-mode) + (/mode-set-word-params! IAI uword-mode) )) ) + + (set! /mode-word-sizes-defined? #t) ) ; Called by apps to indicate cpu:word-bitsize always has one value. @@ -468,9 +491,10 @@ ; Ensure word sizes have been defined. ; This must be called after all cpu families have been defined ; and before any ifields, hardware, operand or insns have been read. +; FIXME: sparc.cpu breaks this (define (mode-ensure-word-sizes-defined) - (if (eq? (obj:name WI) 'VOID) + (if (not /mode-word-sizes-defined?) (error "word sizes must be defined")) ) @@ -504,6 +528,7 @@ (define (mode-init!) (set! /mode-word-sizes-kind 'IDENTICAL) + (set! /mode-word-sizes-defined? #f) (reader-add-command! 'define-full-mode "\ @@ -533,13 +558,22 @@ Define a mode, all arguments specified. (let ((dfm define-full-mode)) ; This list must be defined in order of increasing size among each type. + ; FIXME: still true? (dfm 'VOID "void" '() 'RANDOM 0 0 "void" "" #f #f #f) ; VOIDmode ; Special marker to indicate "use the default mode". - ; ??? Not yet used everywhere it should be. (dfm 'DFLT "default mode" '() 'RANDOM 0 0 "" "" #f #f #f) + ; Mode used in `symbol' rtxs. + (dfm 'SYM "symbol" '() 'RANDOM 0 0 "" "" #f #f #f) + + ; Mode used in `current-insn' rtxs. + (dfm 'INSN "insn" '() 'RANDOM 0 0 "" "" #f #f #f) + + ; Mode used in `current-mach' rtxs. + (dfm 'MACH "mach" '() 'RANDOM 0 0 "" "" #f #f #f) + ; Not UINT on purpose. (dfm 'BI "one bit (0,1 not 0,-1)" '() 'INT 1 1 "int" "'x'" #f #f #f) @@ -593,16 +627,17 @@ Define a mode, all arguments specified. (set! INT (mode:lookup 'INT)) (set! UINT (mode:lookup 'UINT)) - ; While setting the real values of WI/UWI/AI/IAI is defered to - ; mode-set-word-modes!, create entries in the table. - (set! WI VOID) - (set! UWI VOID) - (set! AI VOID) - (set! IAI VOID) - (mode:add! 'WI VOID) - (mode:add! 'UWI VOID) - (mode:add! 'AI VOID) - (mode:add! 'IAI VOID) + ;; While setting the real values of WI/UWI/AI/IAI is defered to + ;; mode-set-word-modes!, create usable entries in the table. + ;; The entries must be usable as h/w elements may be defined that use them. + (set! WI (object-copy-top (mode:lookup 'SI))) + (set! UWI (object-copy-top (mode:lookup 'USI))) + (set! AI (object-copy-top (mode:lookup 'USI))) + (set! IAI (object-copy-top (mode:lookup 'USI))) + (mode:add! 'WI WI) + (mode:add! 'UWI UWI) + (mode:add! 'AI AI) + (mode:add! 'IAI IAI) ;; Need to have usable mode classes at this point as define-cpu ;; calls mode-set-word-modes!. diff --git a/cgen/operand.scm b/cgen/operand.scm index f9a84b0e1d..144afbdccb 100644 --- a/cgen/operand.scm +++ b/cgen/operand.scm @@ -40,6 +40,8 @@ ; that require a unique hardware element to be refered to are ; required to ensure duplicates are discarded (usually done ; by keeping the appropriate machs). + ; All h/w elements with the same semantic name are required + ; to be the same kind (register, immediate, etc.). ; FIXME: Rename to hw. (type . #f) @@ -276,6 +278,7 @@ ; NOTE: Even if the mode isn't changing this creates a copy. ; If OP has been subclassed the result must contain the complete class ; (e.g. the behaviour of `object-copy-top'). +; NEW-MODE-NAME must be a valid numeric mode. (define (op:new-mode op new-mode-name) (let ((result (object-copy-top op))) @@ -284,11 +287,12 @@ ; " hw-name=" (op:hw-name op) ; " mode=" (op:mode op) ; " newmode=" new-mode-name) - (if (or (eq? new-mode-name 'DFLT) - (eq? new-mode-name 'VOID) ; temporary: for upward compatibility - (mode:eq? new-mode-name (op:mode op))) - ; Mode isn't changing. - result +; (if (or (eq? new-mode-name 'DFLT) +; (eq? new-mode-name 'VOID) ; temporary: for upward compatibility +; (mode:eq? new-mode-name (op:mode op))) +; ; Mode isn't changing. +; result + (if #t ;; FIXME ; See if new mode is supported by the hardware. (if (hw-mode-ok? (op:type op) new-mode-name (op:index op)) (let ((new-mode (mode:lookup new-mode-name))) @@ -733,10 +737,31 @@ '()) ) -(method-make-make! - '(name comment attrs mode - args syntax base-ifield encoding ifield-assertion - getter setter) +;; constructor. +;; MODE is a object. + +(method-make! + 'make! + (lambda (self name comment attrs mode + args syntax base-ifield encoding ifield-assertion + getter setter) + (elm-set! self 'name name) + (elm-set! self 'comment comment) + (elm-set! self 'attrs attrs) + (elm-set! self 'sem-name name) + (elm-set! self 'pretty-sem-name #f) ;; FIXME + (elm-set! self 'hw-name #f) ;; FIXME + (elm-set! self 'mode mode) + (elm-set! self 'mode-name (obj:name mode)) + (elm-set! self 'getter getter) + (elm-set! self 'setter setter) + ;; These are the additional fields in . + (elm-set! self 'args args) + (elm-set! self 'syntax syntax) + (elm-set! self 'base-ifield base-ifield) + (elm-set! self 'encoding encoding) + (elm-set! self 'ifield-assertion ifield-assertion) + self) ) (define (derived-operand? x) (class-instance? x)) @@ -767,11 +792,14 @@ (method-make! 'make! - (lambda (self name comment attrs mode base-ifield choices) + (lambda (self name comment attrs mode-name base-ifield choices) (elm-set! self 'name name) (elm-set! self 'comment comment) (elm-set! self 'attrs attrs) - (elm-set! self 'mode-name mode) + (elm-set! self 'sem-name name) + (elm-set! self 'pretty-sem-name #f) ;; FIXME + (elm-set! self 'hw-name #f) ;; FIXME + (elm-set! self 'mode-name mode-name) (elm-set! self 'base-ifield base-ifield) (elm-set! self 'choices choices) ; Set index to a special marker value. @@ -806,17 +834,15 @@ )) ) -; Subroutine of /derived-operand-parse to parse the ifield assertion. -; The ifield assertion is either () or an RTL expression asserting something -; about the ifield values of the containing insn. -; Operands are specified by name, but what is used is their indices (there's -; an implicit `index-of' going on). +;; Subroutine of /derived-operand-parse to parse the ifield assertion. +;; The ifield assertion is either () or a (restricted) RTL expression +;; asserting something about the ifield values of the containing insn. +;; The result is #f if the assertion is (), or the canonical rtl. -(define (/derived-parse-ifield-assertion context args ifield-assertion) - ; FIXME: for now +(define (/derived-parse-ifield-assertion context ifield-assertion) (if (null? ifield-assertion) #f - ifield-assertion) + (rtx-canonicalize context 'INT ifield-assertion nil)) ) ; Parse a derived operand definition. @@ -864,18 +890,19 @@ syntax base-ifield ; FIXME: validate parsed-encoding - (/derived-parse-ifield-assertion context args ifield-assertion) + (/derived-parse-ifield-assertion context ifield-assertion) (if (null? getter) #f (/operand-parse-getter context (list args - (rtx-canonicalize context getter)) + (rtx-canonicalize context mode getter nil)) (length args))) (if (null? setter) #f (/operand-parse-setter context (list (append args '(newval)) - (rtx-canonicalize context setter)) + (rtx-canonicalize context 'VOID setter + (list (list 'newval mode #f)))) (length args))) ))) (elm-set! result 'hw-name (obj:name (hardware-for-mode mode-obj))) diff --git a/cgen/rtl-c.scm b/cgen/rtl-c.scm index 5eec677e4d..83837cf599 100644 --- a/cgen/rtl-c.scm +++ b/cgen/rtl-c.scm @@ -10,13 +10,12 @@ ; (rtl-c mode '(func mode ...) nil) ; ; E.g. -; (rtl-c DFLT '(add SI (const SI 1) (const SI 2)) nil) +; (rtl-c SI '(add () SI (const () SI 1) (const () SI 2)) nil) ; --> ; "ADDSI (1, 2)" -; Mode `DFLT' (DEFAULTmode) means "use the default/natural mode". ; -; The expression is in source form or may be already compiled (with -; rtx-compile). +; The expression is in source form and must be already canonicalized (with +; rtx-canonicalize). ; ; The `set' rtx needs to be handled a little carefully. ; Both the dest and src are processed first, and then code to perform the @@ -33,7 +32,6 @@ ; - gen-set-trace - return string of C code to set operand's value ; ; Instruction fields are refered to by name. -; (estate-owner estate) must be an instruction that has the field. ; Instruction ifields must have these methods: ; - get-mode ; - cxmake-get @@ -124,7 +122,7 @@ ) ; Main routine to create a node object. -; MODE is either the mode's symbol (e.g. 'QI) or a mode object. +; MODE is either the mode's symbol (e.g. 'QI) or a object. ; CODE is a string of C code. (define (cx:make mode code) @@ -216,6 +214,11 @@ ; Each newline is then preceeded with '\\'. (macro? . #f) + ; Boolean indicating if evaluation is for an instruction. + ; It's not always possible to look at OWNER, e.g. when we're + ; processing semantic fragments. + (for-insn? . #f) + ; #f -> reference ifield values using FLD macro. ; #t -> use C variables. ; ??? This is only needed to get correct ifield references @@ -231,7 +234,7 @@ ; FIXME: involves upcasting. (define-getters estate - (rtl-cover-fns? output-language macro? ifield-var?) + (rtl-cover-fns? output-language macro? for-insn? ifield-var?) ) ; Return booleans indicating if output language is C/C++. @@ -258,6 +261,8 @@ (elm-set! self 'output-language (cadr args))) ((#:macro?) (elm-set! self 'macro? (cadr args))) + ((#:for-insn?) + (elm-set! self 'for-insn? (cadr args))) ((#:ifield-var?) (elm-set! self 'ifield-var? (cadr args))) (else @@ -309,14 +314,13 @@ ) ; Translate parsed RTL expression X to a string of C code. -; X must have already been fed through rtx-parse/rtx-compile. +; X must have already been fed through rtx-canonicalize. ; MODE is the desired mode of the value or DFLT for "natural mode". ; MODE is a object. ; EXTRA-VARS-ALIST is an association list of extra ; (symbol -or-mode-name value) elements to be used during value lookup. ; OVERRIDES is a #:keyword/value list of arguments to build the eval state ; with. -; ??? Maybe EXTRA-VARS-ALIST should be handled this way. (define (rtl-c-parsed mode x extra-vars-alist . overrides) (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) @@ -327,10 +331,9 @@ ; MODE is a object. (define (rtl-c mode x extra-vars-alist . overrides) - ; ??? rtx-compile could return a closure, then we wouldn't have to - ; pass EXTRA-VARS-ALIST to two routines here. (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) - (rtl-c-with-estate estate mode (rtx-compile #f x extra-vars-alist))) + (rtl-c-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x + extra-vars-alist))) ) ; Same as rtl-c-with-estate except return a object. @@ -352,10 +355,9 @@ ; MODE is a object. (define (rtl-c-expr mode x extra-vars-alist . overrides) - ; ??? rtx-compile could return a closure, then we wouldn't have to - ; pass EXTRA-VARS-ALIST to two routines here. (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides))) - (rtl-c-expr-with-estate estate mode (rtx-compile #f x extra-vars-alist))) + (rtl-c-expr-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x + extra-vars-alist))) ) ; C++ versions of rtl-c routines. @@ -376,28 +378,26 @@ ) ; Translate parsed RTL expression X to a string of C++ code. -; X must have already been fed through rtx-parse/rtx-compile. +; X must have already been fed through rtx-canonicalize. ; MODE is the desired mode of the value or DFLT for "natural mode". ; MODE is a object. ; EXTRA-VARS-ALIST is an association list of extra (symbol value) ; elements to be used during value lookup. ; OVERRIDES is a #:keyword/value list of arguments to build the eval state ; with. -; ??? Maybe EXTRA-VARS-ALIST should be handled this way. (define (rtl-c++-parsed mode x extra-vars-alist . overrides) (let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides))) (rtl-c-with-estate estate mode x)) ) -; Same as rtl-c-parsed but X is unparsed. +; Same as rtl-c++-parsed but X is unparsed. ; MODE is a object. (define (rtl-c++ mode x extra-vars-alist . overrides) - ; ??? rtx-compile could return a closure, then we wouldn't have to - ; pass EXTRA-VARS-ALIST to two routines here. (let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides))) - (rtl-c-with-estate estate mode (rtx-compile #f x extra-vars-alist))) + (rtl-c-with-estate estate mode (rtx-canonicalize #f (obj:name mode) x + extra-vars-alist))) ) ; Top level routines for getting/setting values. @@ -412,11 +412,11 @@ ; - sequence's local variable object ; - operand name ; - operand object +; - an integer ; - a string of C code ; FIXME: Reduce acceptable values of SRC. ; The result has mode MODE, unless MODE is the "default mode indicator" ; (DFLT) in which case the mode of the result is derived from SRC. -; If SRC is a string, MODE can't be VOID or DFLT. ; ; ??? mode compatibility checks are wip @@ -441,31 +441,36 @@ ; The recursive call to /rtl-c-get is in case the result of rtx-eval ; is a hardware object, rtx-func object, or another rtl expression. + ; FIXME: simplify ((rtx? src) (let ((evald-src (rtx-eval-with-estate src mode estate))) ; There must have been some change, otherwise we'll loop forever. (assert (not (eq? src evald-src))) (/rtl-c-get estate mode evald-src))) + ;; FIXME: Can we ever get a symbol here? ((or (and (symbol? src) (current-op-lookup src)) (operand? src)) (begin (if (symbol? src) (set! src (current-op-lookup src))) (cond ((mode:eq? 'DFLT mode) + ; FIXME: Can we get called with 'DFLT anymore? ; FIXME: If we fetch the mode here, operands can assume ; they never get called with "default mode". (send src 'cxmake-get estate mode #f #f)) ((rtx-mode-compatible? mode (op:mode src)) - (let ((mode (rtx-lazy-sem-mode mode))) + (let ((mode (op:mode src))) ;; FIXME: (rtx-sem-mode mode))) (send src 'cxmake-get estate mode #f #f))) (else + ;; FIXME: canonicalization should have already caught this (estate-error estate (string-append "operand " (obj:str-name src) " referenced in incompatible mode") (obj:name mode)))))) + ;; FIXME: Can we ever get a symbol here? ((or (and (symbol? src) (rtx-temp-lookup (estate-env estate) src)) (rtx-temp? src)) (begin @@ -474,16 +479,18 @@ (cond ((mode:eq? 'DFLT mode) (send src 'cxmake-get estate (rtx-temp-mode src) #f #f)) ((rtx-mode-compatible? mode (rtx-temp-mode src)) - (let ((mode (rtx-lazy-sem-mode mode))) + (let ((mode (rtx-temp-mode src))) ;; FIXME: (rtx-sem-mode mode))) (send src 'cxmake-get estate mode #f #f))) - (else (estate-error - estate - (string-append "sequence temp " (rtx-temp-name src) - " referenced in incompatible mode") - (obj:name mode)))))) + (else + ;; FIXME: canonicalization should have already caught this + (estate-error + estate + (string-append "sequence temp " (rtx-temp-name src) + " referenced in incompatible mode") + (obj:name mode)))))) ((integer? src) - ; Default mode of string argument is INT. + ; Default mode of integer argument is INT. (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode)) (cx:make INT (number->string src)) (cx:make mode (number->string src)))) @@ -512,12 +519,19 @@ ; Return a object to set the value of DEST to SRC. ; ESTATE is the current rtl evaluation state. +; MODE is the mode of DEST or DFLT which means fetch the real mode from DEST. ; MODE is either a object or the mode name. ; DEST is one of: ; - node ; - rtl expression (e.g. '(mem QI dr)) -; SRC is a object. +; SRC is an RTX expression. It is important that we evaluate it, instead of +; our caller, because only we know the mode of DEST (which we need to pass +; when evaluating SRC if MODE is DFLT). ??? Can no longer get DFLT, but +; it feels right to continue to evaluate SRC here. ; The mode of the result is always VOID (void). +; +; ??? One possible optimization is to pass the address of the result +; to the computation of SRC. Seems dodgey though. (define (rtl-c-set-quiet estate mode dest src) ;(display (list 'rtl-c-set-quiet mode dest src)) (newline) @@ -530,15 +544,12 @@ (estate-error estate "rtl-c-set-quiet: invalid dest" dest))))) + (assert (mode? mode)) (if (not (object? xdest)) (estate-error estate "rtl-c-set-quiet: invalid dest" dest)) - (let ((mode (if (mode:eq? 'DFLT mode) - (rtx-obj-mode xdest) - (rtx-lazy-sem-mode mode)))) - (assert (mode? mode)) - (cx:make VOID (send xdest 'gen-set-quiet + (cx:make VOID (send xdest 'gen-set-quiet estate mode #f #f - (rtl-c-get estate mode src))))) + (rtl-c-get estate mode src)))) ) ; Same as rtl-c-set-quiet except also print TRACE_RESULT message. @@ -559,15 +570,12 @@ (estate-error estate "rtl-c-set-trace: invalid dest" dest))))) + (assert (mode? mode)) (if (not (object? xdest)) (estate-error estate "rtl-c-set-trace: invalid dest" dest)) - (let ((mode (if (mode:eq? 'DFLT mode) - (rtx-obj-mode xdest) - (rtx-lazy-sem-mode mode)))) - (assert (mode? mode)) - (cx:make VOID (send xdest 'gen-set-trace + (cx:make VOID (send xdest 'gen-set-trace estate mode #f #f - (rtl-c-get estate mode src))))) + (rtl-c-get estate mode src)))) ) ; Emit C code for each rtx function. @@ -610,7 +618,7 @@ ; ??? Bad assumption! VOID expressions may be used ; within sequences without local vars, which are translated ; to comma-expressions. - (if (or (mode:eq? 'DFLT mode) + (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore (mode:eq? 'VOID mode)) ");\n" ")") @@ -636,7 +644,7 @@ ; ??? Bad assumption! VOID expressions may be used ; within sequences without local vars, which are translated ; to comma-expressions. - (if (or (mode:eq? 'DFLT mode) + (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore (mode:eq? 'VOID mode)) ");\n" ")") @@ -661,7 +669,9 @@ (and (not (obj-has-attr? mode 'FORCE-C)) (or (not c-op) (and (estate-rtl-cover-fns? estate) - (or (insn? (estate-owner estate)) + ;; NOTE: We can't check (insn? (estate-owner estate)) here. + ;; It's not necessarily present for semantic fragments. + (or (estate-for-insn? estate) (not (mode:host? mode)))))) ) @@ -671,7 +681,7 @@ (define (s-unop estate name c-op mode src) (let* ((val (rtl-c-get estate mode src)) ; Refetch mode in case it was DFLT and ensure unsigned->signed. - (mode (cx:mode val)) + (mode (mode:lookup mode)) ;;(cx:mode val)) ;; FIXME: can't get DFLT anymore (sem-mode (rtx-sem-mode mode))) ; FIXME: Argument checking. @@ -693,7 +703,6 @@ ; Two operands referenced in the same mode producing a result in the same mode. ; MODE is the mode name. -; If MODE is DFLT, use the mode of SRC1. ; ; ??? Will eventually want to handle floating point modes specially. Since ; bigger modes may get clumsily passed (there is no pass by reference in C) and @@ -704,9 +713,10 @@ ; rather then complicating cxmake-get. Ditto for rtl-c-get-ref/rtl-c-get. (define (s-binop estate name c-op mode src1 src2) + ;(display (list "binop " name ", mode " mode)) (newline) (let* ((val1 (rtl-c-get estate mode src1)) ; Refetch mode in case it was DFLT and ensure unsigned->signed. - (mode (cx:mode val1)) + (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore (sem-mode (rtx-sem-mode mode)) (val2 (rtl-c-get estate mode src2))) ; FIXME: Argument checking. @@ -738,12 +748,14 @@ (define (s-binop-with-bit estate name mode src1 src2 src3) (let* ((val1 (rtl-c-get estate mode src1)) ; Refetch mode in case it was DFLT and ensure unsigned->signed. - (mode (rtx-sem-mode (cx:mode val1))) + (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore + (sem-mode (rtx-sem-mode mode)) (val2 (rtl-c-get estate mode src2)) (val3 (rtl-c-get estate 'BI src3))) ; FIXME: Argument checking. + (cx:make mode - (string-append name (obj:str-name mode) + (string-append name (obj:str-name sem-mode) " (" (cx:c val1) ", " (cx:c val2) ", " @@ -758,10 +770,11 @@ ; different from a logical one. May need to create `sla' some day. Later. (define (s-shop estate name c-op mode src1 src2) + ;(display (list "shop " name ", mode " mode)) (newline) (let* ((val1 (rtl-c-get estate mode src1)) ; Refetch mode in case it was DFLT and ensure unsigned->signed ; [sign of operation is determined from operation name, not mode]. - (mode (cx:mode val1)) + (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore (sem-mode (rtx-sem-mode mode)) (val2 (rtl-c-get estate mode src2))) ; FIXME: Argument checking. @@ -802,6 +815,7 @@ (let* ((val1 (rtl-c-get estate DFLT src1)) (val2 (rtl-c-get estate DFLT src2))) ; FIXME: Argument checking. + ; If this is the simulator and MODE is not a host mode, use a macro. ; ??? MODE here being the mode of SRC1. Maybe later. (if (estate-rtl-cover-fns? estate) @@ -856,7 +870,7 @@ (define (s-cmpop estate name c-op mode src1 src2) (let* ((val1 (rtl-c-get estate mode src1)) ; Refetch mode in case it was DFLT. - (mode (cx:mode val1)) + (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore (val2 (rtl-c-get estate mode src2))) ; FIXME: Argument checking. @@ -900,7 +914,7 @@ (if (> (length else) 1) (estate-error estate "if: too many elements in `else' part" else)) (let () - (if (or (mode:eq? 'DFLT mode) + (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore (mode:eq? 'VOID mode)) (cx:make mode (string-append "if (" (cx:c (rtl-c-get estate DFLT cond)) ")" @@ -936,6 +950,7 @@ ; FIXME: Need more error checking of arguments. (define (s-cond estate mode . cond-code-list) + ;; FIXME: can't get DFLT anymore (let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode)))) (if (null? cond-code-list) (estate-error estate "empty `cond'")) @@ -1101,6 +1116,7 @@ ; FIXME: What to allow for case choices is wip. (define (s-case estate mode test . case-list) + ;; FIXME: can't get DFLT anymore (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode)) (s-case-vm estate test case-list) (s-case-non-vm estate mode test case-list)) @@ -1154,10 +1170,12 @@ ; One can still put a parallel inside an `if' however. (define (/par-replace-set-dests estate exprs) + ;(display exprs) (newline) (let ((sets (list 'set 'set-quiet (rtx-lookup 'set) (rtx-lookup 'set-quiet)))) (letrec ((replace (lambda (expr) + ;(display expr) (newline) (let ((name (car expr)) (options (rtx-options expr)) (mode (rtx-mode expr))) @@ -1166,7 +1184,7 @@ options mode (/par-new-temp! ; replace dest with temp - (if (mode:eq? 'DFLT mode) + (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore (rtx-lvalue-mode-name estate (rtx-set-dest expr)) mode)) (rtx-set-src expr)) @@ -1235,9 +1253,9 @@ (define (s-sequence estate mode env . exprs) (let* ((env (rtx-env-make-locals env)) ; compile env (estate (estate-push-env estate env))) - (if (or (mode:eq? 'DFLT mode) + (if (or (mode:eq? 'DFLT mode) ;; FIXME: DFLT can't appear anymore (mode:eq? 'VOID mode)) - (cx:make mode + (cx:make VOID (string-append ; FIXME: do {} while (0); doesn't get "optimized out" ; internally by gcc, meaning two labels and a loop are @@ -1247,7 +1265,7 @@ "{\n" (gen-temp-defs estate env) (string-map (lambda (e) - (rtl-c-with-estate estate DFLT e)) + (rtl-c-with-estate estate VOID e)) exprs) "}\n")) (cx:make mode @@ -1294,7 +1312,7 @@ " ++" c-iter-var ")\n" " {\n" (string-map (lambda (e) - (rtl-c-with-estate estate DFLT e)) + (rtl-c-with-estate estate VOID e)) exprs) " }\n" "}\n")) @@ -1332,7 +1350,7 @@ (string-append "\"" (backslash "\"" message) "\"")))) - (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode)) + (if (mode:eq? mode VOID) c-call (cx:make mode (string-append "(" (cx:c c-call) ", 0)")))) ) @@ -1346,12 +1364,11 @@ ; Instruction field support. ; ??? This should build an operand object like -build-ifield-operand! does ; in semantics.scm. -; ??? Mode support is wip. (define-fn ifield (*estate* options mode ifld-name) (if (estate-ifield-var? *estate*) - (cx:make 'UINT (gen-c-symbol ifld-name)) - (cx:make 'UINT (string-append "FLD (" (gen-c-symbol ifld-name) ")"))) + (cx:make mode (gen-c-symbol ifld-name)) + (cx:make mode (string-append "FLD (" (gen-c-symbol ifld-name) ")"))) ; (let ((f (current-ifld-lookup ifld-name))) ; (make (obj-location f) ifld-name ifld-name ; (atlist-cons (bool-attr-make 'SEM-ONLY #t) @@ -1367,11 +1384,13 @@ (define-fn operand (*estate* options mode object-or-name) (cond ((operand? object-or-name) + ;; mode checking to be done during canonicalization object-or-name) ((symbol? object-or-name) (let ((object (current-op-lookup object-or-name))) (if (not object) (estate-error *estate* "undefined operand" object-or-name)) + ;; mode checking to be done during canonicalization object)) (else (estate-error *estate* "bad arg to `operand'" object-or-name))) @@ -1426,9 +1445,11 @@ (if (pair? sel) (car sel) hw-selector-default)) ) -(define-fn pc (*estate* options mode) - s-pc -) +; ??? Hmmm... needed? The pc is usually specified as `pc' which is shorthand +; for (operand pc). +;(define-fn pc (*estate* options mode) +; s-pc +;) (define-fn ref (*estate* options mode name) (if (not (insn? (estate-owner *estate*))) @@ -1444,7 +1465,8 @@ ; ??? Maybe this should return an operand object. (define-fn index-of (*estate* options mode op) - (send (op:index (rtx-eval-with-estate op DFLT *estate*)) 'cxmake-get *estate* 'DFLT) + (send (op:index (rtx-eval-with-estate op DFLT *estate*)) + 'cxmake-get *estate* (mode:lookup mode)) ) (define-fn clobber (*estate* options mode object) @@ -1462,7 +1484,7 @@ (begin ;; check for proper usage (if (let* ((hw (case (car rtx) - ((operand) (op:type (rtx-operand-obj rtx))) + ((operand) (op:type (current-op-lookup (rtx-arg1 rtx)))) ((xop) (op:type (rtx-xop-obj rtx))) (else #f)))) (not (and hw (or (pc? hw) (memory? hw) (register? hw))))) @@ -1503,8 +1525,9 @@ ")")) ) -(define-fn attr (*estate* options mode owner attr-name) - (cond ((equal? owner '(current-insn () DFLT)) +(define-fn int-attr (*estate* options mode owner attr-name) + (cond ((or (equal? owner '(current-insn () DFLT)) ;; FIXME: delete in time + (equal? owner '(current-insn () INSN))) (s-c-raw-call *estate* 'INT "GET_ATTR" (string-upcase (gen-c-symbol attr-name)))) (else @@ -1513,7 +1536,7 @@ (define-fn const (*estate* options mode c) (assert (not (mode:eq? 'VOID mode))) - (if (mode:eq? 'DFLT mode) + (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore (set! mode 'INT)) (let ((mode (mode:lookup mode))) (cx:make mode @@ -1550,7 +1573,6 @@ (define-fn subword (*estate* options mode value word-num) (let* ((mode (mode:lookup mode)) (val (rtl-c-get *estate* DFLT value)) - ; Refetch mode in case it was DFLT. (val-mode (cx:mode val))) (cx:make mode (string-append "SUBWORD" @@ -1583,13 +1605,13 @@ ) (define-fn set (*estate* options mode dst src) - (if (insn? (estate-owner *estate*)) - (rtl-c-set-trace *estate* mode dst (rtl-c-get *estate* mode src)) - (rtl-c-set-quiet *estate* mode dst (rtl-c-get *estate* mode src))) + (if (estate-for-insn? *estate*) + (rtl-c-set-trace *estate* mode dst src) + (rtl-c-set-quiet *estate* mode dst src)) ) (define-fn set-quiet (*estate* options mode dst src) - (rtl-c-set-quiet *estate* mode dst (rtl-c-get *estate* mode src)) + (rtl-c-set-quiet *estate* mode dst src) ) (define-fn neg (*estate* options mode s1) @@ -1793,8 +1815,9 @@ ) (define-fn member (*estate* options mode value set) - ; FIXME: Multiple evalutions of VALUE. - (let ((c-value (rtl-c-get *estate* 'DFLT value)) + ;; NOTE: There are multiple evalutions of VALUE in the generated code. + ;; It's probably ok, this comment is more for completeness sake. + (let ((c-value (rtl-c-get *estate* mode value)) (set (rtx-number-list-values set))) (let loop ((set (cdr set)) (code (string-append "(" (cx:c c-value) @@ -1840,7 +1863,7 @@ (define-fn closure (*estate* options mode expr env) ; ??? estate-push-env? - (rtl-c-with-estate (estate-new-env *estate* env) DFLT expr) + (rtl-c-with-estate (estate-new-env *estate* env) (mode:lookup mode) expr) ) ;; The result is the rtl->c generator table. diff --git a/cgen/rtl-traverse.scm b/cgen/rtl-traverse.scm index 8045d45b25..11268accd4 100644 --- a/cgen/rtl-traverse.scm +++ b/cgen/rtl-traverse.scm @@ -1,14 +1,1295 @@ -; RTL traversing support. -; Copyright (C) 2000, 2001, 2009 Red Hat, Inc. -; This file is part of CGEN. -; See file COPYING.CGEN for details. +;; RTL traversing support. +;; Copyright (C) 2000, 2001, 2009 Red Hat, Inc. +;; This file is part of CGEN. +;; See file COPYING.CGEN for details. + +;; Canonicalization support. +;; Canonicalizing an rtl expression involves adding possibly missing options +;; and mode, and converting occurrences of DFLT into usable modes. +;; Various error checks are done as well. +;; This is done differently than traversal support because it has a more +;; specific purpose, it doesn't need to support arbitrary "expr-fns". +;; ??? At present the internal form is also the source form (easier debugging). + +(define /rtx-canon-debug? #f) + +;; Canonicalization state. +;; This carries the immutable elements only! +;; OUTER-EXPR is the EXPR argument to rtx-canonicalize. + +(define (/make-cstate context outer-expr) + (vector context outer-expr) +) + +(define (/cstate-context cstate) (vector-ref cstate 0)) +(define (/cstate-outer-expr cstate) (vector-ref cstate 1)) + +;; Flag an error while canonicalizing rtl. + +(define (/rtx-canon-error cstate errmsg expr parent-expr op-num) + (let* ((pretty-parent-expr + (with-output-to-string + (lambda () + (pretty-print (rtx-dump (/cstate-outer-expr cstate)))))) + (intro (if parent-expr + (string-append "While canonicalizing " + (rtx-strdump parent-expr) + (if op-num + (string-append ", operand #" + (number->string op-num)) + "") + " of:\n" + pretty-parent-expr) + (string-append "While canonicalizing:\n" pretty-parent-expr)))) + (context-error (/cstate-context cstate) intro errmsg (rtx-dump expr))) +) + +;; Lookup h/w object HW-NAME and return it (as a object). +;; If multiple h/w objects with the same name are defined, require +;; all to have the same mode. +;; CHECK-KIND is a function of one argument to verify the h/w objects +;; are valid and if not flag an error. + +(define (/rtx-lookup-hw cstate hw-name parent-expr check-kind) + (let ((hw-objs (current-hw-sem-lookup hw-name))) + + (if (null? hw-objs) + (/rtx-canon-error cstate "unknown h/w object" + hw-name parent-expr #f)) + + ;; Just check the first one with CHECK-KIND. + (check-kind (car hw-objs)) + + (let* ((hw1 (car hw-objs)) + (hw1-mode (hw-mode hw1)) + (hw1-mode-name (obj:name hw1-mode))) + + ;; Allow multiple h/w objects with the same name + ;; as long has they have the same mode. + (if (> (length hw-objs) 1) + (let ((other-hw-mode-names (map (lambda (hw) + (obj:name (hw-mode hw))) + (cdr hw-objs)))) + (if (not (all-true? (map (lambda (mode-name) + (eq? mode-name hw1-mode-name)) + other-hw-mode-names))) + (/rtx-canon-error cstate "multiple h/w objects with different modes selected" + hw-name parent-expr #f)))) + + hw1)) +) + +;; Return the mode name to use in an expression given the requested mode +;; and the mode used in the expression. +;; If both are DFLT, leave it alone and hope the expression provides +;; enough info to pick a usable mode. +;; If both are provided, prefer the mode used in the expression. +;; If the modes are incompatible, return #f. + +(define (/rtx-pick-mode cstate requested-mode-name expr-mode-name) + (cond ((eq? requested-mode-name 'DFLT) + expr-mode-name) + ((eq? expr-mode-name 'DFLT) + requested-mode-name) + (else + (let ((requested-mode (mode:lookup requested-mode-name)) + (expr-mode (mode:lookup expr-mode-name))) + (if (not requested-mode) + (/rtx-canon-error cstate "invalid mode" requested-mode-name #f #f)) + (if (not expr-mode) + (/rtx-canon-error cstate "invalid mode" expr-mode-name #f #f)) + ;; FIXME: 'would prefer samesize or "no precision lost", sigh + (if (mode-compatible? 'sameclass requested-mode expr-mode) + expr-mode-name + expr-mode-name)))) ;; FIXME: should be #f, disabled pending completion of rtl mode handling rewrite +) + +;; Return the mode name (as a symbol) to use in an object's rtl given +;; the requested mode, the mode used in the expression, and the object's +;; real mode. +;; If both requested mode and expr mode are DFLT, use the real mode. +;; If requested mode is DFLT, prefer expr mode. +;; If expr mode is DFLT, prefer the real mode. +;; If both requested mode and expr mode are specified, prefer expr-mode. +;; If there's an error the result is the error message (as a string). +;; +;; E.g. in (set SI dest (ifield DFLT f-r1)), the mode of the ifield's +;; expression is DFLT, the requested mode is SI, and the real mode of f-r1 +;; may be INT. +;; +;; REAL-MODE is a object. + +(define (/rtx-pick-mode3 requested-mode-name expr-mode-name real-mode) + ;; Leave checking for (symbol? requested-mode-name) to caller (or higher). + (let ((expr-mode (mode:lookup expr-mode-name))) + (cond ((not expr-mode) + "unknown mode") + ((eq? requested-mode-name 'DFLT) + (if (eq? expr-mode-name 'DFLT) + (obj:name real-mode) + (if (rtx-mode-compatible? expr-mode real-mode) + expr-mode-name + (string-append "expression mode " + (symbol->string expr-mode-name) + " is incompatible with real mode " + (obj:str-name real-mode))))) + ((eq? expr-mode-name 'DFLT) + (if (rtx-mode-compatible? (mode:lookup requested-mode-name) + real-mode) + (obj:name real-mode) + (string-append "mode of containing expression " + (symbol->string requested-mode-name) + " is incompatible with real mode " + (obj:str-name real-mode)))) + (else + (let ((requested-mode (mode:lookup requested-mode-name))) + (cond ((not (rtx-mode-compatible? requested-mode expr-mode)) + (string-append "mode of containing expression " + (symbol->string requested-mode-name) + " is incompatible with expression mode " + (symbol->string expr-mode-name))) + ((not (rtx-mode-compatible? expr-mode real-mode)) + (string-append "expression mode " + (symbol->string expr-mode-name) + " is incompatible with real mode " + (obj:str-name real-mode))) + (else + expr-mode-name)))))) +) + +;; Return the mode name (as a symbol) to use in an operand's rtl given +;; the requested mode, the mode used in the expression, and the operand's +;; real mode. +;; If both requested mode and expr mode are DFLT, use the real mode. +;; If requested mode is DFLT, prefer expr mode. +;; If expr mode is DFLT, prefer the real mode. +;; If both requested mode and expr mode are specified, prefer expr-mode. +;; If the modes are incompatible an error is signalled. +;; +;; E.g. in (set QI (mem QI src2) src1), the mode to set is QI, but if src1 +;; is a 32-bit (SI) register we want QI. +;; OTOH, in (set QI (mem QI src2) uimm8), the mode to set is QI, but we want +;; the real mode of uimm8. +;; +;; ??? This is different from /rtx-pick-mode3 for compatibility with +;; pre-full-canonicalization versions. +; It's currently a toss-up on whether it improves things. +;; +;; OP is an object. +;; +;; Things are complicated because multiple versions of a h/w object can be +;; defined, and the operand refers to the h/w by name. +;; op:type, which op:mode calls, will flag an error if multiple versions of +;; a h/w object are defined - only one should have been kept during .cpu +;; file loading. This is for semantic code generation, but for generating +;; files covering the entire architecture we need to keep all the versions. +;; Things are ok, as far as canonicalization is concerned, if all h/w versions +;; have the same mode (which could be WI for 32/64 arches). + +(define (/rtx-pick-op-mode cstate requested-mode-name expr-mode-name op + parent-expr) + ;; Leave checking for (symbol? requested-mode-name) to caller (or higher). + (let* ((op-mode-name (op:mode-name op)) + (hw (/rtx-lookup-hw cstate (op:hw-name op) parent-expr + (lambda (hw) *UNSPECIFIED*))) + (op-mode (if (eq? op-mode-name 'DFLT) + (hw-mode hw) + (mode:lookup op-mode-name))) + (expr-mode (mode:lookup expr-mode-name))) + (cond ((not expr-mode) + (/rtx-canon-error cstate "unknown mode" expr-mode-name + parent-expr #f)) + ((eq? requested-mode-name 'DFLT) + (if (eq? expr-mode-name 'DFLT) + (obj:name op-mode) + (if (rtx-mode-compatible? expr-mode op-mode) + expr-mode-name + (/rtx-canon-error cstate + (string-append + "expression mode " + (symbol->string expr-mode-name) + " is incompatible with operand mode " + (obj:str-name op-mode)) + expr-mode-name parent-expr #f)))) + ((eq? expr-mode-name 'DFLT) + (if (rtx-mode-compatible? (mode:lookup requested-mode-name) + op-mode) +; FIXME: Experiment. It's currently a toss-up on whether it improves things. +; (cond ((pc? op) +; (obj:name op-mode)) +; ((register? hw) +; requested-mode-name) +; (else +; (obj:name op-mode))) + (obj:name op-mode) + (/rtx-canon-error cstate + (string-append + "mode of containing expression " + (symbol->string requested-mode-name) + " is incompatible with operand mode " + (obj:str-name op-mode)) + requested-mode-name parent-expr #f))) + (else + (let ((requested-mode (mode:lookup requested-mode-name))) + (cond ((not (rtx-mode-compatible? requested-mode expr-mode)) + (/rtx-canon-error cstate + (string-append + "mode of containing expression " + (symbol->string requested-mode-name) + " is incompatible with expression mode " + (symbol->string expr-mode-name)) + requested-mode-name parent-expr #f)) + ((not (rtx-mode-compatible? expr-mode op-mode)) + (/rtx-canon-error cstate + (string-append + "expression mode " + (symbol->string expr-mode-name) + " is incompatible with operand mode " + (obj:str-name op-mode)) + expr-mode-name parent-expr #f)) + (else + expr-mode-name)))))) +) + +;; Return the last rtx in cond or case expression EXPR. -; RTL expression traversal support. -; Traversal (and compilation) involves validating the source form and -; converting it to internal form. -; ??? At present the internal form is also the source form (easier debugging). +(define (/rtx-get-last-cond-case-rtx expr) + (let ((len (length expr))) + (list-ref expr (- len 1))) +) + +;; Canonicalize a list of rtx's. +;; The mode of rtxes prior to the last one must be VOID. + +(define (/rtx-canon-rtx-list rtx-list mode parent-expr op-num cstate env depth) + (let* ((nr-rtxes (length rtx-list)) + (last-op-num (- nr-rtxes 1))) + (map (lambda (rtx op-num) + (/rtx-canon rtx 'RTX + (if (= op-num last-op-num) mode 'VOID) + parent-expr op-num cstate env depth)) + rtx-list (iota nr-rtxes))) +) + +;; Rtx canonicalizers. +;; These are defined as individual functions that are then built into a table +;; mostly for simplicity. +; +;; The result is either a pair of the parsed VAL and new environment, +;; or #f meaning there is no change (saves lots of unnecessarying cons'ing). + +(define (/rtx-canon-options val mode parent-expr op-num cstate env depth) + #f +) + +(define (/rtx-canon-anyintmode val mode parent-expr op-num cstate env depth) + (let ((val-obj (mode:lookup val))) + (if (and val-obj + (or (memq (mode:class val-obj) '(INT UINT)) + (eq? val 'DFLT))) + #f + (/rtx-canon-error cstate "expecting an integer mode" + val parent-expr op-num))) +) + +(define (/rtx-canon-anyfloatmode val mode parent-expr op-num cstate env depth) + (let ((val-obj (mode:lookup val))) + (if (and val-obj + (or (memq (mode:class val-obj) '(FLOAT)) + (eq? val 'DFLT))) + #f + (/rtx-canon-error cstate "expecting a float mode" + val parent-expr op-num))) +) + +(define (/rtx-canon-anynummode val mode parent-expr op-num cstate env depth) + (let ((val-obj (mode:lookup val))) + (if (and val-obj + (or (memq (mode:class val-obj) '(INT UINT FLOAT)) + (eq? val 'DFLT))) + #f + (/rtx-canon-error cstate "expecting a numeric mode" + val parent-expr op-num))) +) + +(define (/rtx-canon-anyexprmode val mode parent-expr op-num cstate env depth) + (let ((val-obj (mode:lookup val))) + (if (and val-obj + (or (memq (mode:class val-obj) '(INT UINT FLOAT)) + (memq val '(DFLT PTR VOID)))) + #f + (/rtx-canon-error cstate "expecting a numeric mode, PTR, or VOID" + val parent-expr op-num))) +) + +(define (/rtx-canon-explnummode val mode parent-expr op-num cstate env depth) + (let ((val-obj (mode:lookup val))) + (if (and val-obj + (memq (mode:class val-obj) '(INT UINT FLOAT))) + #f + (/rtx-canon-error cstate "expecting an explicit numeric mode" + val parent-expr op-num))) +) + +(define (/rtx-canon-voidornummode val mode parent-expr op-num cstate env depth) + (let ((val-obj (mode:lookup val))) + (if (and val-obj + (or (memq (mode:class val-obj) '(INT UINT FLOAT)) + (memq val '(DFLT VOID)))) + #f + (/rtx-canon-error cstate "expecting void or a numeric mode" + val parent-expr op-num))) +) + +(define (/rtx-canon-voidmode val mode parent-expr op-num cstate env depth) + (if (memq val '(DFLT VOID)) + (cons 'VOID env) + (/rtx-canon-error cstate "expecting VOID mode" + val parent-expr op-num)) +) + +(define (/rtx-canon-bimode val mode parent-expr op-num cstate env depth) + (if (memq val '(DFLT BI)) + (cons 'BI env) + (/rtx-canon-error cstate "expecting BI mode" + val parent-expr op-num)) +) + +(define (/rtx-canon-intmode val mode parent-expr op-num cstate env depth) + (if (memq val '(DFLT INT)) + (cons 'INT env) + (/rtx-canon-error cstate "expecting INT mode" + val parent-expr op-num)) +) + +(define (/rtx-canon-symmode val mode parent-expr op-num cstate env depth) + (if (memq val '(DFLT SYM)) + (cons 'SYM env) + (/rtx-canon-error cstate "expecting SYM mode" + val parent-expr op-num)) +) + +(define (/rtx-canon-insnmode val mode parent-expr op-num cstate env depth) + (if (memq val '(DFLT INSN)) + (cons 'INSN env) + (/rtx-canon-error cstate "expecting INSN mode" + val parent-expr op-num)) +) + +(define (/rtx-canon-machmode val mode parent-expr op-num cstate env depth) + (if (memq val '(DFLT MACH)) + (cons 'MACH env) + (/rtx-canon-error cstate "expecting MACH mode" + val parent-expr op-num)) +) + +(define (/rtx-canon-rtx val mode parent-expr op-num cstate env depth) +; Commented out 'cus it doesn't quite work yet. +; (if (not (rtx? val)) +; (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num)) + (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth) + env) +) + +(define (/rtx-canon-setrtx val mode parent-expr op-num cstate env depth) +; Commented out 'cus it doesn't quite work yet. +; (if (not (rtx? val)) +; (/rtx-canon-error cstate "expecting an rtx" val parent-expr op-num)) + (let ((dest (/rtx-canon val 'SETRTX mode parent-expr op-num cstate env depth))) + (cons dest env)) +) + +;; This is the test of an `if'. + +(define (/rtx-canon-testrtx val mode parent-expr op-num cstate env depth) +; Commented out 'cus it doesn't quite work yet. +; (if (not (rtx? val)) +; (/rtx-canon-error cstate "expecting an rtx" +; val parent-expr op-num)) + (cons (/rtx-canon val 'RTX mode parent-expr op-num cstate env depth) + env) +) + +(define (/rtx-canon-condrtx val mode parent-expr op-num cstate env depth) + (if (not (pair? val)) + (/rtx-canon-error cstate "expecting an expression" + val parent-expr op-num)) + (if (eq? (car val) 'else) + (begin + (if (!= (+ op-num 2) (length parent-expr)) + (/rtx-canon-error cstate "`else' clause not last" + val parent-expr op-num)) + (cons (cons 'else + (/rtx-canon-rtx-list + (cdr val) mode parent-expr op-num cstate env depth)) + env)) + (cons (cons + ;; ??? Entries after the first are conditional. + (/rtx-canon (car val) 'RTX 'INT parent-expr op-num cstate env depth) + (/rtx-canon-rtx-list + (cdr val) mode parent-expr op-num cstate env depth)) + env)) +) + +(define (/rtx-canon-casertx val mode parent-expr op-num cstate env depth) + (if (or (not (list? val)) + (< (length val) 2)) + (/rtx-canon-error cstate "invalid `case' expression" + val parent-expr op-num)) + ;; car is either 'else or list of symbols/numbers + (if (not (or (eq? (car val) 'else) + (and (list? (car val)) + (not (null? (car val))) + (all-true? (map /rtx-symornum? + (car val)))))) + (/rtx-canon-error cstate "invalid `case' choice" + val parent-expr op-num)) + (if (and (eq? (car val) 'else) + (!= (+ op-num 2) (length parent-expr))) + (/rtx-canon-error cstate "`else' clause not last" + val parent-expr op-num)) + (cons (cons (car val) + (/rtx-canon-rtx-list + (cdr val) mode parent-expr op-num cstate env depth)) + env) +) + +(define (/rtx-canon-locals val mode parent-expr op-num cstate env depth) + (if (not (list? val)) + (/rtx-canon-error cstate "bad locals list" + val parent-expr op-num)) + (for-each (lambda (var) + (if (or (not (list? var)) + (!= (length var) 2) + (not (/rtx-any-mode? (car var))) + (not (symbol? (cadr var)))) + (/rtx-canon-error cstate "bad locals list" + val parent-expr op-num))) + val) + (let ((new-env (rtx-env-make-locals val))) + (cons val (cons new-env env))) +) + +(define (/rtx-canon-iteration val mode parent-expr op-num cstate env depth) + (if (not (symbol? val)) + (/rtx-canon-error cstate "bad iteration variable name" + val parent-expr op-num)) + (let ((new-env (rtx-env-make-iteration-locals val))) + (cons val (cons new-env env))) +) + +(define (/rtx-canon-env val mode parent-expr op-num cstate env depth) + ;; VAL is an environment stack. + (if (not (list? val)) + (/rtx-canon-error cstate "environment not a list" + val parent-expr op-num)) + ;; FIXME: Shouldn't this push VAL onto ENV? + (cons val env) +) + +(define (/rtx-canon-attrs val mode parent-expr op-num cstate env depth) +; (cons val ; (atlist-source-form (atlist-parse (make-prefix-cstate "with-attr") val "")) +; env) + #f +) + +(define (/rtx-canon-symbol val mode parent-expr op-num cstate env depth) + (if (not (symbol? val)) + (/rtx-canon-error cstate "expecting a symbol" + val parent-expr op-num)) + #f +) + +(define (/rtx-canon-string val mode parent-expr op-num cstate env depth) + (if (not (string? val)) + (/rtx-canon-error cstate "expecting a string" + val parent-expr op-num)) + #f +) + +(define (/rtx-canon-number val mode parent-expr op-num cstate env depth) + (if (not (number? val)) + (/rtx-canon-error cstate "expecting a number" + val parent-expr op-num)) + #f +) + +(define (/rtx-canon-symornum val mode parent-expr op-num cstate env depth) + (if (not (or (symbol? val) (number? val))) + (/rtx-canon-error cstate "expecting a symbol or number" + val parent-expr op-num)) + #f +) + +(define (/rtx-canon-object val mode parent-expr op-num cstate env depth) + #f +) + +;; Table of rtx canonicalizers. +;; This is a vector of size rtx-max-num. +;; Each entry is a list of (arg-type-name . canonicalizer) elements +;; for rtx-arg-types. +;; FIXME: Initialized in rtl.scm (i.e. outside this file). + +(define /rtx-canoner-table #f) + +;; Return a hash table of standard operand canonicalizers. +;; The result of each canonicalizer is a pair of the canonical form +;; of `val' and a possibly new environment or #f if there is no change. + +(define (/rtx-make-canon-table) + (let ((hash-tab (make-hash-table 31)) + (canoners + (list + (cons 'OPTIONS /rtx-canon-options) + (cons 'ANYINTMODE /rtx-canon-anyintmode) + (cons 'ANYFLOATMODE /rtx-canon-anyfloatmode) + (cons 'ANYNUMMODE /rtx-canon-anynummode) + (cons 'ANYEXPRMODE /rtx-canon-anyexprmode) + (cons 'EXPLNUMMODE /rtx-canon-explnummode) + (cons 'VOIDORNUMMODE /rtx-canon-voidornummode) + (cons 'VOIDMODE /rtx-canon-voidmode) + (cons 'BIMODE /rtx-canon-bimode) + (cons 'INTMODE /rtx-canon-intmode) + (cons 'SYMMODE /rtx-canon-symmode) + (cons 'INSNMODE /rtx-canon-insnmode) + (cons 'MACHMODE /rtx-canon-machmode) + (cons 'RTX /rtx-canon-rtx) + (cons 'SETRTX /rtx-canon-setrtx) + (cons 'TESTRTX /rtx-canon-testrtx) + (cons 'CONDRTX /rtx-canon-condrtx) + (cons 'CASERTX /rtx-canon-casertx) + (cons 'LOCALS /rtx-canon-locals) + (cons 'ITERATION /rtx-canon-iteration) + (cons 'ENV /rtx-canon-env) + (cons 'ATTRS /rtx-canon-attrs) + (cons 'SYMBOL /rtx-canon-symbol) + (cons 'STRING /rtx-canon-string) + (cons 'NUMBER /rtx-canon-number) + (cons 'SYMORNUM /rtx-canon-symornum) + (cons 'OBJECT /rtx-canon-object) + ))) + + (for-each (lambda (canoner) + (hashq-set! hash-tab (car canoner) (cdr canoner))) + canoners) + + hash-tab) +) + +;; Standard expression operand canonicalizer. +;; Loop over the operands, verifying them according to the argument type +;; and mode matcher, and replace DFLT with a usable mode. + +(define (/rtx-canon-operands rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + ;; ??? Might want to just leave operands as a list. + (let* ((operands (list->vector args)) + (nr-operands (vector-length operands)) + (this-expr (cons func args)) ;; For error messages. + (expr-mode + ;; For sets, the requested mode is DFLT or VOID (the mode of the + ;; result), but the mode we want is the mode of the set destination. + (if (rtx-result-mode rtx-obj) + (cadr args) ;; mode of arg2 doesn't come from containing expr + (/rtx-pick-mode cstate requested-mode-name (cadr args)))) + (all-arg-types (vector-ref /rtx-canoner-table (rtx-num rtx-obj)))) + + (if (not expr-mode) + (/rtx-canon-error cstate + (string-append "requested mode " + (symbol->string requested-mode-name) + " is incompatible with expression mode " + (symbol->string (cadr args))) + this-expr parent-expr #f)) + + (let loop ((env env) + (op-num 0) + (arg-types all-arg-types) + (arg-modes (rtx-arg-modes rtx-obj))) + + (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types))))) + + (if /rtx-canon-debug? + (begin + (display (spaces (* 4 depth))) + (if (= op-num nr-operands) + (display "end of operands") + (begin + (display "op-num ") (display op-num) (display ": ") + (display (rtx-dump (vector-ref operands op-num))) + (display ", ") + (display (if varargs? (car arg-types) (caar arg-types))) + (display ", ") + (display (if varargs? arg-modes (car arg-modes))) + )) + (newline) + (force-output))) + + (cond ((= op-num nr-operands) + + ;; Out of operands, check if we have the expected number. + (if (or (null? arg-types) + varargs?) + + ;; We're theoretically done. + (let ((set-mode-from-arg! + (lambda (arg-num) + (if /rtx-canon-debug? + (begin + (display (spaces (* 4 depth))) + (display "Computing expr mode from arguments.") + (newline))) + (let* ((expr-to-match + (case func + ((cond case) + (/rtx-get-last-cond-case-rtx (vector-ref operands arg-num))) + (else + (vector-ref operands arg-num)))) + (expr-to-match-obj (rtx-lookup (rtx-name expr-to-match))) + (result-mode (or (rtx-result-mode expr-to-match-obj) + (let ((expr-mode (rtx-mode expr-to-match))) + (if (eq? expr-mode 'DFLT) + (if (eq? requested-mode-name 'DFLT) + (/rtx-canon-error cstate + "unable to determine mode of expression from arguments, please specify a mode" + this-expr parent-expr #f) + requested-mode-name) + expr-mode))))) + (vector-set! operands 1 result-mode))))) + ;; The expression's mode might still be DFLT. + ;; If it is, fetch the mode of the MATCHEXPR operand, + ;; or MATCHSEQ operand, or containing expression. + ;; If it's still DFLT, flag an error. + (if (eq? (vector-ref operands 1) 'DFLT) + (cond ((rtx-matchexpr-index rtx-obj) + => (lambda (matchexpr-index) + (set-mode-from-arg! matchexpr-index))) + ((eq? func 'sequence) + (set-mode-from-arg! (- nr-operands 1))) + (else + (if /rtx-canon-debug? + (begin + (display (spaces (* 4 depth))) + (display "Computing expr mode from containing expression.") + (newline))) + (if (or (eq? requested-mode-name 'DFLT) + (rtx-result-mode rtx-obj)) + (/rtx-canon-error cstate + "unable to determine mode of expression, please specify a mode" + this-expr parent-expr #f) + (vector-set! operands 1 requested-mode-name))))) + (vector->list operands)) + + (/rtx-canon-error cstate "missing operands" + this-expr parent-expr #f))) + + ((null? arg-types) + (/rtx-canon-error cstate "too many operands" + this-expr parent-expr #f)) + + (else + (let ((type (if varargs? arg-types (car arg-types))) + (mode (let ((mode-spec (if varargs? + arg-modes + (car arg-modes)))) + ;; We don't necessarily have enough information + ;; at this point. Just propagate what we do know, + ;; and leave it for final processing to fix up what + ;; we missed. + ;; This is small enough that case is fast enough, + ;; and the number of entries should be stable. + (case mode-spec + ((ANY) 'DFLT) + ((ANYINT) 'DFLT) ;; FIXME + ((NA) #f) + ((MATCHEXPR) expr-mode) + ((MATCHSEQ) + (if (= (+ op-num 1) nr-operands) ;; last one? + expr-mode + 'VOID)) + ((MATCH2) + ;; This is complicated by the fact that some + ;; rtx have a different result mode than what + ;; is specified in the rtl (e.g. set, eq). + ;; ??? Make these rtx specify both modes? + (let* ((op2 (vector-ref operands 2)) + (op2-obj (rtx-lookup (rtx-name op2)))) + (or (rtx-result-mode op2-obj) + (rtx-mode op2)))) + ((MATCH3) + ;; This is complicated by the fact that some + ;; rtx have a different result mode than what + ;; is specified in the rtl (e.g. set, eq). + ;; ??? Make these rtx specify both modes? + (let* ((op2 (vector-ref operands 3)) + (op2-obj (rtx-lookup (rtx-name op2)))) + (or (rtx-result-mode op2-obj) + (rtx-mode op2)))) + ;; Otherwise mode-spec is the mode to use. + (else mode-spec)))) + (val (vector-ref operands op-num)) + ) + + ;; Look up the canoner for this operand and perform it. + ;; FIXME: This would benefit from returning multiple values. + (let ((canoner (cdr type))) + (let ((canon-val (canoner val mode this-expr op-num + cstate env depth))) + (if canon-val + (begin + (set! val (car canon-val)) + (set! env (cdr canon-val)))))) + + (vector-set! operands op-num val) + + ;; Done with this operand, proceed to the next. + (loop env + (+ op-num 1) + (if varargs? arg-types (cdr arg-types)) + (if varargs? arg-modes (cdr arg-modes))))))))) +) + +(define (/rtx-canon-rtx-enum rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to enum, expecting 3" + (cons func args) parent-expr #f)) + + (let ((mode-name (cadr args)) + (enum-name (caddr args))) + (let ((mode-obj (mode:lookup mode-name)) + (enum-obj (enum-lookup-val enum-name))) + + (if (not enum-obj) + (/rtx-canon-error cstate "unknown enum value" + enum-name parent-expr #f)) + + (let ((expr-mode-or-errmsg (/rtx-pick-mode3 requested-mode-name mode-name INT))) + (if (symbol? expr-mode-or-errmsg) + (list (car args) expr-mode-or-errmsg enum-name) + (/rtx-canon-error cstate expr-mode-or-errmsg + enum-name parent-expr #f))))) +) + +(define (/rtx-canon-rtx-ifield rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to ifield, expecting 3" + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (ifld-name (caddr args))) + (let ((ifld-obj (current-ifld-lookup ifld-name))) + + (if ifld-obj + + (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name + expr-mode-name + (ifld-mode ifld-obj)))) + (if (symbol? mode-or-errmsg) + (list (car args) mode-or-errmsg ifld-name) + (/rtx-canon-error cstate mode-or-errmsg expr-mode-name + parent-expr parent-op-num))) + + (/rtx-canon-error cstate "unknown ifield" + ifld-name parent-expr #f)))) +) + +(define (/rtx-canon-rtx-operand rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to operand, expecting 3" + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (op-name (caddr args))) + (let ((op-obj (current-op-lookup op-name))) + + (if op-obj + + (let ((mode (/rtx-pick-op-mode cstate requested-mode-name + expr-mode-name op-obj parent-expr))) + (list (car args) mode op-name)) + + (/rtx-canon-error cstate "unknown operand" + op-name parent-expr #f)))) +) + +(define (/rtx-canon-rtx-xop rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to xop, expecting 3" + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (xop-obj (caddr args))) + + (if (operand? xop-obj) + + (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name + expr-mode-name + (op:mode xop-obj)))) + (if (symbol? mode-or-errmsg) + (list (car args) mode-or-errmsg xop-obj) + (/rtx-canon-error cstate mode-or-errmsg expr-mode-name + parent-expr parent-op-num))) + + (/rtx-canon-error cstate "xop operand #2 not an operand" + (obj:name xop-obj) parent-expr #f))) +) + +(define (/rtx-canon-rtx-local rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to local, expecting 3" + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (local-name (caddr args))) + (let ((local-obj (rtx-temp-lookup env local-name))) + + (if local-obj + + (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name + expr-mode-name + (rtx-temp-mode local-obj)))) + (if (symbol? mode-or-errmsg) + (list (car args) mode-or-errmsg local-name) + (/rtx-canon-error cstate mode-or-errmsg expr-mode-name + parent-expr parent-op-num))) + + (/rtx-canon-error cstate "unknown local" + local-name parent-expr #f)))) +) + +(define (/rtx-canon-rtx-ref rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to ref, expecting 3" + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (ref-name (caddr args))) + ;; FIXME: Will current-op-lookup find named operands? + (let ((op-obj (current-op-lookup env ref-name))) + + (if op-obj + + ;; The result of "ref" is canonically an INT. + (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name + expr-mode-name + INT))) + (if (symbol? mode-or-errmsg) + (list (car args) mode-or-errmsg ref-name) + (/rtx-canon-error cstate mode-or-errmsg expr-mode-name + parent-expr parent-op-num))) + + (/rtx-canon-error cstate "unknown operand" + ref-name parent-expr #f)))) +) + +(define (/rtx-canon-rtx-reg rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (let ((len (length args))) + (if (or (< len 3) (> len 5)) + (/rtx-canon-error cstate + ;; TODO: be more firm on expected number of args + (string-append + "wrong number of operands to " + (symbol->string func) + ", expecting 3 (or possibly 4,5)") + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (hw-name (caddr args)) + (this-expr (cons func args))) + (let* ((hw (/rtx-lookup-hw cstate hw-name parent-expr + (lambda (hw) + (if (not (register? hw)) + (/rtx-canon-error cstate "not a register" hw-name + parent-expr parent-op-num)) + *UNSPECIFIED*))) + (hw-mode-obj (hw-mode hw))) + + (let ((mode-or-errmsg (/rtx-pick-mode3 requested-mode-name + expr-mode-name + hw-mode-obj))) + + (if (symbol? mode-or-errmsg) + + ;; Canonicalizing optional index/selector. + (let ((index (if (>= len 4) + (let ((canon (/rtx-canon-rtx + (list-ref args 3) 'INT + this-expr 3 cstate env depth))) + (car canon)) ;; discard env + #f)) + (sel (if (= len 5) + (let ((canon (/rtx-canon-rtx + (list-ref args 4) 'INT + this-expr 4 cstate env depth))) + (car canon)) ;; discard env + #f))) + (if sel + (begin + (assert index) + (list (car args) mode-or-errmsg hw-name index sel)) + (if index + (list (car args) mode-or-errmsg hw-name index) + (list (car args) mode-or-errmsg hw-name)))) + + (/rtx-canon-error cstate mode-or-errmsg expr-mode-name + parent-expr parent-op-num)))))) +) + +(define (/rtx-canon-rtx-mem rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (let ((len (length args))) + (if (or (< len 3) (> len 4)) + (/rtx-canon-error cstate + "wrong number of operands to mem, expecting 3 (or possibly 4)" + (cons func args) parent-expr #f)) + + (let ((expr-mode-name (cadr args)) + (addr-expr (caddr args)) + (this-expr (cons func args))) + + ;; Call /rtx-canon-explnummode just for the error checking. + (/rtx-canon-explnummode expr-mode-name #f this-expr 1 cstate env depth) + + (if (and (not (eq? requested-mode-name 'DFLT)) + ;; FIXME: 'would prefer samesize or "no precision lost", sigh + (not (mode-compatible? 'sameclass + requested-mode-name expr-mode-name))) + (/rtx-canon-error cstate + (string-append "requested mode " + (symbol->string requested-mode-name) + " is incompatible with expression mode " + (symbol->string expr-mode-name)) + this-expr parent-expr #f)) + + (let ((addr (car ;; discard env + (/rtx-canon-rtx (list-ref args 2) 'AI + this-expr 2 cstate env depth))) + (sel (if (= len 4) + (let ((canon (/rtx-canon-rtx (list-ref args 3) 'INT + this-expr 3 cstate env depth))) + (car canon)) ;; discard env + #f))) + (if sel + (list (car args) expr-mode-name addr sel) + (list (car args) expr-mode-name addr))))) +) + +(define (/rtx-canon-rtx-const rtx-obj requested-mode-name + func args parent-expr parent-op-num + cstate env depth) + (if (!= (length args) 3) + (/rtx-canon-error cstate "wrong number of operands to const, expecting 3" + (cons func args) parent-expr #f)) + + ;; ??? floating point support is wip + ;; NOTE: (integer? 1.0) == #t, but (inexact? 1.0) ==> #t too. + + (let ((expr-mode-name1 (if (and (eq? requested-mode-name 'DFLT) + (eq? (cadr args) 'DFLT)) + 'INT + (cadr args))) + (value (caddr args)) + (this-expr (cons func args))) + + (let ((expr-mode-name (/rtx-pick-mode cstate requested-mode-name + expr-mode-name1))) + + (if (not expr-mode-name) + (/rtx-canon-error cstate + (string-append "requested mode " + (symbol->string requested-mode-name) + " is incompatible with expression mode " + (symbol->string expr-mode-name1)) + this-expr parent-expr #f)) + + (let ((expr-mode (mode:lookup expr-mode-name))) + + (cond ((integer? value) + (if (not (memq (mode:class expr-mode) '(INT UINT FLOAT))) + (/rtx-canon-error cstate "integer value incompatible with mode" + value this-expr 2))) + ((inexact? value) + (if (not (memq (mode:class expr-mode) '(FLOAT))) + (/rtx-canon-error cstate "floating point value incompatible with mode" + value this-expr 2))) + (else + (/rtx-canon-error cstate + (string-append "expecting a" + (if (eq? (mode:class expr-mode) 'FLOAT) + " floating point" + "n integer") + " constant") + value this-expr 2))) + + (list (car args) expr-mode-name value)))) +) + +;; Table of operand canonicalizers. +;; The main one is /rtx-traverse-operands, but a few rtx functions are simple +;; and special-purpose enough that it's simpler to have specific traversers. + +(define /rtx-operand-canoners #f) + +;; Return list of rtx functions that have special purpose canoners. + +(define (/rtx-special-expr-canoners) + (list + (cons 'enum /rtx-canon-rtx-enum) + (cons 'ifield /rtx-canon-rtx-ifield) + (cons 'operand /rtx-canon-rtx-operand) + ;;(cons 'name /rtx-canon-rtx-name) ;; ??? needed? + (cons 'xop /rtx-canon-rtx-xop) ;; yes, it can appear + (cons 'local /rtx-canon-rtx-local) + (cons 'ref /rtx-canon-rtx-ref) + ;;(cons 'index-of /rtx-canon-rtx-index-of) ;; ??? needed? + (cons 'reg /rtx-canon-rtx-reg) + (cons 'raw-reg /rtx-canon-rtx-reg) + (cons 'mem /rtx-canon-rtx-mem) + (cons 'const /rtx-canon-rtx-const) + ) +) + +;; Subroutine of rtx-munge-mode&options. +;; Return boolean indicating if X is an rtx option. + +(define (/rtx-option? x) + (keyword? x) +) -; Set to #t to debug rtx traversal. +;; Subroutine of rtx-munge-mode&options. +;; Return boolean indicating if X is an rtx option list. + +(define (/rtx-option-list? x) + (or (null? x) + (and (pair? x) + (/rtx-option? (car x)))) +) + +;; Subroutine of /rtx-canon-expr to fill in the options and mode if absent. +;; The result is the canonical form of ARGS. +;; +;; "munge" is an awkward name to use here, but I like it for now because +;; it's easy to grep for. +;; An empty option list requires a mode to be present so that the empty +;; list in `(sequence () foo bar)' is unambiguously recognized as the locals +;; list. Icky, sure, but less icky than the alternatives thus far. + +(define (rtx-munge-mode&options rtx-obj requested-mode-name func args) + (let ((orig-args args) + (options #f) + (mode-name #f) + ;; The mode in a `set' is the mode of the destination, + ;; whereas the mode of the result is VOID. + ;; The mode in a compare (e.g. `eq') is the mode of the operands, + ;; but the mode of the result is BI. + (requested-mode-name (if (rtx-result-mode rtx-obj) + 'DFLT ;; mode of args doesn't come from containing expr + 'DFLT))) ;; FIXME: requested-mode-name))) + + ;; Pick off the option list if present. + (if (and (pair? args) + (/rtx-option-list? (car args)) + ;; Handle `(sequence () foo bar)'. If empty list isn't followed + ;; by a mode, it is not an option list. + (or (not (null? (car args))) + (and (pair? (cdr args)) + (mode-name? (cadr args))))) + (begin + (set! options (car args)) + (set! args (cdr args)))) + + ;; Pick off the mode if present. + (if (and (pair? args) + (mode-name? (car args))) + (begin + (set! mode-name (car args)) + (set! args (cdr args)))) + + ;; Now put option list and mode back. + ;; But don't do unnecessary consing. + (if options + (if (and mode-name (not (eq? mode-name 'DFLT))) + orig-args ;; can return ARGS unchanged + (cons options (cons requested-mode-name args))) + (if (and mode-name (not (eq? mode-name 'DFLT))) + (cons nil orig-args) ;; just need to insert options + (cons nil (cons requested-mode-name args))))) +) + +;; Subroutine of /rtx-canon to simplify it. + +(define (/rtx-canon-expr rtx-obj requested-mode-name + func args parent-expr op-num cstate env depth) + (let ((args2 (rtx-munge-mode&options rtx-obj requested-mode-name func args))) + + (if /rtx-canon-debug? + (begin + (display (spaces (* 4 depth))) + (display "Traversing operands of: ") + (display (rtx-dump (cons func args))) + (newline) + (display (spaces (* 4 depth))) + (display "Requested mode: ") + (display requested-mode-name) + (newline) + (display (spaces (* 4 depth))) + (rtx-env-dump env) + (force-output))) + + (let* ((canoner (vector-ref /rtx-operand-canoners (rtx-num rtx-obj))) + (operands (canoner rtx-obj requested-mode-name + func args2 parent-expr op-num + cstate env (+ depth 1)))) + (cons func operands))) +) + +;; Convert rtl expression EXPR from source form to canonical form. +;; The expression is validated and rtx macros are expanded as well. +;; Plus DFLT mode is converted to a useful mode. +;; The result is EXPR in canonical form. +;; +;; CSTATE is a object or #f if there is none. +;; It is used in error messages. + +(define (/rtx-canon expr expected mode parent-expr op-num cstate env depth) + (if /rtx-canon-debug? + (begin + (display (spaces (* 4 depth))) + (display "Canonicalizing (") + (display mode) + (display "): ") + (display (rtx-dump expr)) + (newline) + (display (spaces (* 4 depth))) + (rtx-env-dump env) + (force-output) + )) + + (let ((result + (if (pair? expr) ;; pair? -> cheap non-null-list? + + (let ((rtx-obj (rtx-lookup (car expr)))) + (if rtx-obj + (/rtx-canon-expr rtx-obj mode (car expr) (cdr expr) + parent-expr op-num cstate env depth) + (let ((rtx-obj (/rtx-macro-lookup (car expr)))) + (if rtx-obj + (/rtx-canon (/rtx-macro-expand expr rtx-evaluator) + expected mode parent-expr op-num cstate env (+ depth 1)) + (/rtx-canon-error cstate "unknown rtx function" + expr parent-expr op-num))))) + + ;; EXPR is not a list. + ;; See if it's an operand shortcut. + (if (memq expected '(RTX SETRTX)) + + (cond ((symbol? expr) + (cond ((current-op-lookup expr) + => (lambda (op) + ;; NOTE: We can't simply call + ;; op:mode-name here, we need the real + ;; mode, not (potentially) DFLT. + ;; See /rtx-pick-op-mode. + (rtx-make-operand (/rtx-pick-op-mode cstate mode 'DFLT op parent-expr) + expr))) + ((rtx-temp-lookup env expr) + => (lambda (tmp) + (rtx-make-local (obj:name (rtx-temp-mode tmp)) expr))) + ((current-ifld-lookup expr) + => (lambda (f) + (rtx-make-ifield (obj:name (ifld-mode f)) expr))) + ((enum-lookup-val expr) + ;; ??? If enums could have modes other than INT, + ;; we'd want to propagate that mode here. + (rtx-make-enum 'INT expr)) + (else + (/rtx-canon-error cstate "unknown operand" + expr parent-expr op-num)))) + ((integer? expr) + (rtx-make-const 'INT expr)) + (else + (/rtx-canon-error cstate "unexpected operand" + expr parent-expr op-num))) + + ;; Not expecting RTX or SETRTX. + (/rtx-canon-error cstate "unexpected operand" + expr parent-expr op-num))))) + + (if /rtx-canon-debug? + (begin + (display (spaces (* 4 depth))) + (display "Result: ") + (display (rtx-dump result)) + (newline) + (force-output) + )) + + result) +) + +;; Public entry point. +;; Convert rtl expression EXPR from source form to canonical form. +;; The expression is validated and rtx macros are expanded as well. +;; Plus operand shortcuts are expanded: +;; - numbers -> (const number) +;; - operand-name -> (operand operand-name) +;; - ifield-name -> (ifield ifield-name) +;; Plus an absent option list is replaced with (). +;; Plus DFLT mode is converted to a useful mode. +;; +;; The result is EXPR in canonical form. +;; +;; CONTEXT is a object or #f if there is none. +;; It is used in error messages. +;; +;; MODE-NAME is the requested mode of the result, or DFLT. +;; +;; EXTRA-VARS-ALIST is an association list of extra (symbol value) +;; elements to be used during value lookup. +;; VALUE can be #f which means "unknown". +;; +;; ??? If EXTRA-VARS-ALIST is non-null, it might be nice to return a closure. +;; It might simplify subsequent uses of the canonicalized code. + +(define (rtx-canonicalize context mode-name expr extra-vars-alist) + (let ((result + (/rtx-canon expr 'RTX mode-name #f 0 + (/make-cstate context expr) + (rtx-env-init-stack1 extra-vars-alist) 0))) + (rtx-verify-no-dflt-modes context result) + result) +) + +;; Utility for a common case. +;; Canonicalize rtl expression STMT which has a VOID result, +;; and no external environment. + +(define (rtx-canonicalize-stmt context stmt) + (rtx-canonicalize context 'VOID stmt nil) +) + +;; RTL expression traversal support. +;; This is for analyzing the semantics in some way. +;; The rtl must already be in canonical form. + +;; Set to #t to debug rtx traversal. (define /rtx-traverse-debug? #f) @@ -30,16 +1311,15 @@ ; lookup the function which will then process the expression. ; It is applied recursively to the expression and each sub-expression. ; It must be defined as -; (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) ...). -; MODE is the name of the mode. +; (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) ...). ; If the result of EXPR-FN is a lambda, it is applied to -; (cons TSTATE (cdr EXPR)). TSTATE is prepended to the arguments. +; (cons TSTATE EXPR), TSTATE is prepended to the arguments. ; For syntax expressions if the result of EXPR-FN is #f, the operands are ; processed using the builtin traverser. ; So to repeat: EXPR-FN can process the expression, and if its result is a ; lambda then it also processes the expression. The arguments to EXPR-FN -; are (rtx-obj expr mode parent-expr op-pos tstate appstuff). The format -; of the result of EXPR-FN are (cons TSTATE (cdr EXPR)). +; are (rtx-obj expr parent-expr op-pos tstate appstuff). The format +; of the result of EXPR-FN are (cons TSTATE EXPR). ; The reason for the duality is that when trying to understand EXPR (e.g. when ; computing the insn format) EXPR-FN processes the expression itself, and ; when evaluating EXPR it's the result of EXPR-FN that computes the value. @@ -54,9 +1334,6 @@ ; 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 object. ; @@ -71,8 +1348,8 @@ ; ; DEPTH is the current traversal depth. -(define (tstate-make context owner expr-fn env cond? set? known depth) - (vector context owner expr-fn env cond? set? known depth) +(define (tstate-make context owner expr-fn env cond? known depth) + (vector context owner expr-fn env cond? known depth) ) (define (tstate-context state) (vector-ref state 0)) @@ -85,12 +1362,10 @@ (define (tstate-set-env! state newval) (vector-set! state 3 newval)) (define (tstate-cond? state) (vector-ref state 4)) (define (tstate-set-cond?! state newval) (vector-set! state 4 newval)) -(define (tstate-set? state) (vector-ref state 5)) -(define (tstate-set-set?! state newval) (vector-set! state 5 newval)) -(define (tstate-known state) (vector-ref state 6)) -(define (tstate-set-known! state newval) (vector-set! state 6 newval)) -(define (tstate-depth state) (vector-ref state 7)) -(define (tstate-set-depth! state newval) (vector-set! state 7 newval)) +(define (tstate-known state) (vector-ref state 5)) +(define (tstate-set-known! state newval) (vector-set! state 5 newval)) +(define (tstate-depth state) (vector-ref state 6)) +(define (tstate-set-depth! state newval) (vector-set! state 6 newval)) ; Create a copy of STATE. @@ -126,14 +1401,6 @@ result) ) -; Create a copy of STATE with a new SET? value. - -(define (tstate-new-set? state set?) - (let ((result (tstate-copy state))) - (tstate-set-set?! result set?) - result) -) - ; Lookup NAME in the known value table. ; Returns the value or #f if not found. ; The value is either a const rtx or a number-list rtx. @@ -165,7 +1432,7 @@ (cons errmsg expr))))) ) -; Traversal/compilation support. +; Traversal support. ; Return a boolean indicating if X is a mode. @@ -181,10 +1448,10 @@ ; Traverse a list of rtx's. -(define (/rtx-traverse-rtx-list rtx-list mode expr op-num tstate appstuff) +(define (/rtx-traverse-rtx-list rtx-list expr op-num tstate appstuff) (map (lambda (rtx) ; ??? Shouldn't OP-NUM change for each element? - (/rtx-traverse rtx 'RTX mode expr op-num tstate appstuff)) + (/rtx-traverse rtx 'RTX expr op-num tstate appstuff)) rtx-list) ) @@ -195,250 +1462,85 @@ (define (/rtx-traverse-error tstate errmsg rtl-expr op-num) (tstate-error tstate (string-append errmsg ", operand #" (number->string op-num)) - (rtx-strdump rtl-expr)) + (rtx-dump rtl-expr)) ) ; Rtx traversers. -; These are defined as individual functions that are then built into a table -; so that we can use Hobbit's "fastcall" support. ; ; The result is either a pair of the parsed VAL and new TSTATE, ; or #f meaning there is no change (saves lots of unnecessarying cons'ing). -(define (/rtx-traverse-options val mode expr op-num tstate appstuff) - #f -) - -(define (/rtx-traverse-anymode val mode expr op-num tstate appstuff) - (let ((val-obj (mode:lookup val))) - (if (not val-obj) - (/rtx-traverse-error tstate "expecting a mode" - expr op-num)) - #f) -) - -(define (/rtx-traverse-intmode val mode expr op-num tstate appstuff) - (let ((val-obj (mode:lookup val))) - (if (and val-obj - (or (memq (mode:class val-obj) '(INT UINT)) - (eq? val 'DFLT))) - #f - (/rtx-traverse-error tstate "expecting an integer mode" - expr op-num))) -) - -(define (/rtx-traverse-floatmode val mode expr op-num tstate appstuff) - (let ((val-obj (mode:lookup val))) - (if (and val-obj - (or (memq (mode:class val-obj) '(FLOAT)) - (eq? val 'DFLT))) - #f - (/rtx-traverse-error tstate "expecting a float mode" - expr op-num))) -) - -(define (/rtx-traverse-nummode val mode expr op-num tstate appstuff) - (let ((val-obj (mode:lookup val))) - (if (and val-obj - (or (memq (mode:class val-obj) '(INT UINT FLOAT)) - (eq? val 'DFLT))) - #f - (/rtx-traverse-error tstate "expecting a numeric mode" - expr op-num))) -) - -(define (/rtx-traverse-explnummode val mode expr op-num tstate appstuff) - (let ((val-obj (mode:lookup val))) - (if (not val-obj) - (/rtx-traverse-error tstate "expecting a mode" - expr op-num)) - (if (memq val '(DFLT VOID)) - (/rtx-traverse-error tstate "DFLT and VOID not allowed here" - expr op-num)) - #f) -) - -(define (/rtx-traverse-nonvoidmode val mode expr op-num tstate appstuff) - (if (eq? val 'VOID) - (/rtx-traverse-error tstate "mode can't be VOID" - expr op-num)) +(define (/rtx-traverse-normal-operand val expr op-num tstate appstuff) #f ) -(define (/rtx-traverse-voidmode val mode expr op-num tstate appstuff) - (if (memq val '(DFLT VOID)) - #f - (/rtx-traverse-error tstate "expecting mode VOID" - expr op-num)) -) - -(define (/rtx-traverse-dfltmode val mode expr op-num tstate appstuff) - (if (eq? val 'DFLT) - #f - (/rtx-traverse-error tstate "expecting mode DFLT" - expr op-num)) -) - -(define (/rtx-traverse-rtx val mode expr op-num tstate appstuff) -; Commented out 'cus it doesn't quite work yet. -; (if (not (rtx? val)) -; (/rtx-traverse-error tstate "expecting an rtx" -; expr op-num)) - (cons (/rtx-traverse val 'RTX mode expr op-num tstate appstuff) +(define (/rtx-traverse-rtx val expr op-num tstate appstuff) + (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff) tstate) ) -(define (/rtx-traverse-setrtx val mode expr op-num tstate appstuff) - ; FIXME: Still need to turn it off for sub-exprs. - ; e.g. (mem (reg ...)) -; Commented out 'cus it doesn't quite work yet. -; (if (not (rtx? val)) -; (/rtx-traverse-error tstate "expecting an rtx" -; expr op-num)) - (cons (/rtx-traverse val 'SETRTX mode expr op-num - (tstate-new-set? tstate #t) - appstuff) +(define (/rtx-traverse-setrtx val expr op-num tstate appstuff) + (cons (/rtx-traverse val 'SETRTX expr op-num tstate appstuff) tstate) ) ; This is the test of an `if'. -(define (/rtx-traverse-testrtx val mode expr op-num tstate appstuff) -; Commented out 'cus it doesn't quite work yet. -; (if (not (rtx? val)) -; (/rtx-traverse-error tstate "expecting an rtx" -; expr op-num)) - (cons (/rtx-traverse val 'RTX mode expr op-num tstate appstuff) +(define (/rtx-traverse-testrtx val expr op-num tstate appstuff) + (cons (/rtx-traverse val 'RTX expr op-num tstate appstuff) (tstate-new-cond? tstate (not (rtx-compile-time-constant? val)))) ) -(define (/rtx-traverse-condrtx val mode expr op-num tstate appstuff) - (if (not (pair? val)) - (/rtx-traverse-error tstate "expecting an expression" - expr op-num)) +(define (/rtx-traverse-condrtx val expr op-num tstate appstuff) (if (eq? (car val) 'else) - (begin - (if (!= (+ op-num 2) (length expr)) - (/rtx-traverse-error tstate - "`else' clause not last" - expr op-num)) - (cons (cons 'else - (/rtx-traverse-rtx-list - (cdr val) mode expr op-num - (tstate-new-cond? tstate #t) - appstuff)) - (tstate-new-cond? tstate #t))) + (cons (cons 'else + (/rtx-traverse-rtx-list + (cdr val) expr op-num + (tstate-new-cond? tstate #t) + appstuff)) + (tstate-new-cond? tstate #t)) (cons (cons ; ??? Entries after the first are conditional. - (/rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff) + (/rtx-traverse (car val) 'RTX expr op-num tstate appstuff) (/rtx-traverse-rtx-list - (cdr val) mode expr op-num + (cdr val) expr op-num (tstate-new-cond? tstate #t) appstuff)) (tstate-new-cond? tstate #t))) ) -(define (/rtx-traverse-casertx val mode expr op-num tstate appstuff) - (if (or (not (list? val)) - (< (length val) 2)) - (/rtx-traverse-error tstate - "invalid `case' expression" - expr op-num)) - ; car is either 'else or list of symbols/numbers - (if (not (or (eq? (car val) 'else) - (and (list? (car val)) - (not (null? (car val))) - (all-true? (map /rtx-symornum? - (car val)))))) - (/rtx-traverse-error tstate - "invalid `case' choice" - expr op-num)) - (if (and (eq? (car val) 'else) - (!= (+ op-num 2) (length expr))) - (/rtx-traverse-error tstate "`else' clause not last" - expr op-num)) +(define (/rtx-traverse-casertx val expr op-num tstate appstuff) (cons (cons (car val) (/rtx-traverse-rtx-list - (cdr val) mode expr op-num + (cdr val) expr op-num (tstate-new-cond? tstate #t) appstuff)) (tstate-new-cond? tstate #t)) ) -(define (/rtx-traverse-locals val mode expr op-num tstate appstuff) - (if (not (list? val)) - (/rtx-traverse-error tstate "bad locals list" - expr op-num)) - (for-each (lambda (var) - (if (or (not (list? var)) - (!= (length var) 2) - (not (/rtx-any-mode? (car var))) - (not (symbol? (cadr var)))) - (/rtx-traverse-error tstate - "bad locals list" - expr op-num))) - val) +(define (/rtx-traverse-locals val expr op-num tstate appstuff) (let ((env (rtx-env-make-locals val))) (cons val (tstate-push-env tstate env))) ) -(define (/rtx-traverse-iteration val mode expr op-num tstate appstuff) - (if (not (symbol? val)) - (/rtx-traverse-error tstate "bad iteration variable name" - expr op-num)) +(define (/rtx-traverse-iteration val expr op-num tstate appstuff) (let ((env (rtx-env-make-iteration-locals val))) (cons val (tstate-push-env tstate env))) ) -(define (/rtx-traverse-env val mode expr op-num tstate appstuff) - ; VAL is an environment stack. - (if (not (list? val)) - (/rtx-traverse-error tstate "environment not a list" - expr op-num)) +(define (/rtx-traverse-env val expr op-num tstate appstuff) + ;; VAL is an environment stack. (cons val (tstate-new-env tstate val)) ) -(define (/rtx-traverse-attrs val mode expr op-num tstate appstuff) +(define (/rtx-traverse-attrs val expr op-num tstate appstuff) ; (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val "")) ; tstate) #f ) -(define (/rtx-traverse-symbol val mode expr op-num tstate appstuff) - (if (not (symbol? val)) - (/rtx-traverse-error tstate "expecting a symbol" - expr op-num)) - #f -) - -(define (/rtx-traverse-string val mode expr op-num tstate appstuff) - (if (not (string? val)) - (/rtx-traverse-error tstate "expecting a string" - expr op-num)) - #f -) - -(define (/rtx-traverse-number val mode expr op-num tstate appstuff) - (if (not (number? val)) - (/rtx-traverse-error tstate "expecting a number" - expr op-num)) - #f -) - -(define (/rtx-traverse-symornum val mode expr op-num tstate appstuff) - (if (not (or (symbol? val) (number? val))) - (/rtx-traverse-error tstate - "expecting a symbol or number" - expr op-num)) - #f -) - -(define (/rtx-traverse-object val mode expr op-num tstate appstuff) - #f -) - ; Table of rtx traversers. ; This is a vector of size rtx-max-num. ; Each entry is a list of (arg-type-name . traverser) elements @@ -455,31 +1557,33 @@ (let ((hash-tab (make-hash-table 31)) (traversers (list - ; /fastcall-make is recognized by Hobbit and handled specially. - ; When not using Hobbit it is a macro that returns its argument. - (cons 'OPTIONS (/fastcall-make /rtx-traverse-options)) - (cons 'ANYMODE (/fastcall-make /rtx-traverse-anymode)) - (cons 'INTMODE (/fastcall-make /rtx-traverse-intmode)) - (cons 'FLOATMODE (/fastcall-make /rtx-traverse-floatmode)) - (cons 'NUMMODE (/fastcall-make /rtx-traverse-nummode)) - (cons 'EXPLNUMMODE (/fastcall-make /rtx-traverse-explnummode)) - (cons 'NONVOIDMODE (/fastcall-make /rtx-traverse-nonvoidmode)) - (cons 'VOIDMODE (/fastcall-make /rtx-traverse-voidmode)) - (cons 'DFLTMODE (/fastcall-make /rtx-traverse-dfltmode)) - (cons 'RTX (/fastcall-make /rtx-traverse-rtx)) - (cons 'SETRTX (/fastcall-make /rtx-traverse-setrtx)) - (cons 'TESTRTX (/fastcall-make /rtx-traverse-testrtx)) - (cons 'CONDRTX (/fastcall-make /rtx-traverse-condrtx)) - (cons 'CASERTX (/fastcall-make /rtx-traverse-casertx)) - (cons 'LOCALS (/fastcall-make /rtx-traverse-locals)) - (cons 'ITERATION (/fastcall-make /rtx-traverse-iteration)) - (cons 'ENV (/fastcall-make /rtx-traverse-env)) - (cons 'ATTRS (/fastcall-make /rtx-traverse-attrs)) - (cons 'SYMBOL (/fastcall-make /rtx-traverse-symbol)) - (cons 'STRING (/fastcall-make /rtx-traverse-string)) - (cons 'NUMBER (/fastcall-make /rtx-traverse-number)) - (cons 'SYMORNUM (/fastcall-make /rtx-traverse-symornum)) - (cons 'OBJECT (/fastcall-make /rtx-traverse-object)) + (cons 'OPTIONS /rtx-traverse-normal-operand) + (cons 'ANYINTMODE /rtx-traverse-normal-operand) + (cons 'ANYFLOATMODE /rtx-traverse-normal-operand) + (cons 'ANYNUMMODE /rtx-traverse-normal-operand) + (cons 'ANYEXPRMODE /rtx-traverse-normal-operand) + (cons 'EXPLNUMMODE /rtx-traverse-normal-operand) + (cons 'VOIDORNUMMODE /rtx-traverse-normal-operand) + (cons 'VOIDMODE /rtx-traverse-normal-operand) + (cons 'BIMODE /rtx-traverse-normal-operand) + (cons 'INTMODE /rtx-traverse-normal-operand) + (cons 'SYMMODE /rtx-traverse-normal-operand) + (cons 'INSNMODE /rtx-traverse-normal-operand) + (cons 'MACHMODE /rtx-traverse-normal-operand) + (cons 'RTX /rtx-traverse-rtx) + (cons 'SETRTX /rtx-traverse-setrtx) + (cons 'TESTRTX /rtx-traverse-testrtx) + (cons 'CONDRTX /rtx-traverse-condrtx) + (cons 'CASERTX /rtx-traverse-casertx) + (cons 'LOCALS /rtx-traverse-locals) + (cons 'ITERATION /rtx-traverse-iteration) + (cons 'ENV /rtx-traverse-env) + (cons 'ATTRS /rtx-traverse-attrs) + (cons 'SYMBOL /rtx-traverse-normal-operand) + (cons 'STRING /rtx-traverse-normal-operand) + (cons 'NUMBER /rtx-traverse-normal-operand) + (cons 'SYMORNUM /rtx-traverse-normal-operand) + (cons 'OBJECT /rtx-traverse-normal-operand) ))) (for-each (lambda (traverser) @@ -490,9 +1594,7 @@ ) ; Traverse the operands of EXPR, a canonicalized RTL expression. -; Here "canonicalized" means that /rtx-munge-mode&options has been called to -; insert an option list and mode if they were absent in the original -; expression. +; Here "canonicalized" means that EXPR has been run through rtx-canonicalize. ; Note that this means that, yes, the options and mode are "traversed" too. (define (/rtx-traverse-operands rtx-obj expr tstate appstuff) @@ -503,15 +1605,13 @@ (display (rtx-dump expr)) (newline) (rtx-env-dump (tstate-env tstate)) - (force-output) - )) + (force-output))) (let loop ((operands (cdr expr)) (op-num 0) (arg-types (vector-ref /rtx-traverser-table (rtx-num rtx-obj))) (arg-modes (rtx-arg-modes rtx-obj)) - (result nil) - ) + (result nil)) (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types))))) @@ -529,56 +1629,32 @@ (display (if varargs? arg-modes (car arg-modes))) )) (newline) - (force-output) - )) + (force-output))) (cond ((null? operands) - ; Out of operands, check if we have the expected number. + ;; Out of operands, check if we have the expected number. (if (or (null? arg-types) varargs?) (reverse! result) - (tstate-error tstate "missing operands" (rtx-strdump expr)))) + (tstate-error tstate "missing operands" (rtx-dump expr)))) ((null? arg-types) - (tstate-error tstate "too many operands" (rtx-strdump expr))) + (tstate-error tstate "too many operands" (rtx-dump expr))) (else - (let ((type (if varargs? arg-types (car arg-types))) - (mode (let ((mode-spec (if varargs? - arg-modes - (car arg-modes)))) - ; This is small enough that this is fast enough, - ; and the number of entries should be stable. - ; FIXME: for now - (case mode-spec - ((ANY) 'DFLT) - ((NA) #f) - ((OP0) (rtx-mode expr)) - ((MATCH1) - ; If there is an explicit mode, use it. - ; Otherwise we have to look at operand 1. - (if (eq? (rtx-mode expr) 'DFLT) - 'DFLT - (rtx-mode expr))) - ((MATCH2) - ; If there is an explicit mode, use it. - ; Otherwise we have to look at operand 2. - (if (eq? (rtx-mode expr) 'DFLT) - 'DFLT - (rtx-mode expr))) - (else mode-spec)))) - (val (car operands)) - ) - - ; Look up the traverser for this kind of operand and perform it. + (let* ((val (car operands)) + (type (if varargs? arg-types (car arg-types)))) + + ;; Look up the traverser for this kind of operand and perform it. + ;; FIXME: This would benefit from returning multiple values. (let ((traverser (cdr type))) - (let ((traversed-val (fastcall6 traverser val mode expr op-num tstate appstuff))) + (let ((traversed-val (traverser val expr op-num tstate appstuff))) (if traversed-val (begin (set! val (car traversed-val)) (set! tstate (cdr traversed-val)))))) - ; Done with this operand, proceed to the next. + ;; Done with this operand, proceed to the next. (loop (cdr operands) (+ op-num 1) (if varargs? arg-types (cdr arg-types)) @@ -591,65 +1667,12 @@ (define rtx-traverse-operands /rtx-traverse-operands) -; Subroutine of /rtx-munge-mode&options. -; Return boolean indicating if X is an rtx option. - -(define (/rtx-option? x) - (and (symbol? x) - (char=? (string-ref (symbol->string x) 0) #\:)) -) - -; Subroutine of /rtx-munge-mode&options. -; Return boolean indicating if X is an rtx option list. - -(define (/rtx-option-list? x) - (or (null? x) - (and (pair? x) - (/rtx-option? (car x)))) -) - -; Subroutine of /rtx-traverse-expr to fill in the mode if absent and to -; collect the options into one list. -; -; ARGS is the list of arguments to the rtx function -; (e.g. (1 2) in (add 1 2)). -; ??? "munge" is an awkward name to use here, but I like it for now because -; it's easy to grep for. -; ??? An empty option list requires a mode to be present so that the empty -; list in `(sequence () foo bar)' is unambiguously recognized as the locals -; list. Icky, sure, but less icky than the alternatives thus far. - -(define (/rtx-munge-mode&options args) - (let ((options nil) - (mode-name 'DFLT)) - ; Pick off the option list if present. - (if (and (pair? args) - (/rtx-option-list? (car args)) - ; Handle `(sequence () foo bar)'. If empty list isn't followed - ; by a mode, it is not an option list. - (or (not (null? (car args))) - (and (pair? (cdr args)) - (mode-name? (cadr args))))) - (begin - (set! options (car args)) - (set! args (cdr args)))) - ; Pick off the mode if present. - (if (and (pair? args) - (mode-name? (car args))) - (begin - (set! mode-name (car args)) - (set! args (cdr args)))) - ; Now put option list and mode back. - (cons options (cons mode-name args))) -) - ; Subroutine of /rtx-traverse to traverse an expression. ; ; RTX-OBJ is the object of the (outer) expression being traversed. ; ; EXPR is the expression to be traversed. -; -; MODE is the name of the mode of EXPR. +; It must be fully canonical. ; ; PARENT-EXPR is the expression EXPR is contained in. The top-level ; caller must pass #f for it. @@ -672,21 +1695,19 @@ ; This is for semantic-compile's sake and all traversal handlers are ; required to do this if the expr-fn returns #f. -(define (/rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff) - (let* ((expr2 (cons (car expr) - (/rtx-munge-mode&options (cdr expr)))) - (fn (fastcall7 (tstate-expr-fn tstate) - rtx-obj expr2 mode parent-expr op-pos tstate appstuff))) +(define (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff) + (let ((fn ((tstate-expr-fn tstate) + rtx-obj expr parent-expr op-pos tstate appstuff))) (if fn (if (procedure? fn) ; Don't traverse operands for syntax expressions. - (if (rtx-style-syntax? rtx-obj) - (apply fn (cons tstate (cdr expr2))) - (let ((operands (/rtx-traverse-operands rtx-obj expr2 tstate appstuff))) + (if (eq? (rtx-style rtx-obj) 'SYNTAX) + (apply fn (cons tstate cdr expr)) + (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff))) (apply fn (cons tstate operands)))) fn) - (let ((operands (/rtx-traverse-operands rtx-obj expr2 tstate appstuff))) - (cons (car expr2) operands)))) + (let ((operands (/rtx-traverse-operands rtx-obj expr tstate appstuff))) + (cons (car expr) operands)))) ) ; Main entry point for expression traversal. @@ -697,12 +1718,11 @@ ; in the case of operands. ; ; EXPR is the expression to be traversed. +; It must be fully canonical. ; ; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type ; or #f if it doesn't matter. ; -; MODE is the name of the mode of EXPR. -; ; PARENT-EXPR is the expression EXPR is contained in. The top-level ; caller must pass #f for it. ; @@ -719,7 +1739,7 @@ ; - operands, ifields, and numbers appearing where an rtx is expected are ; converted to use `operand', `ifield', or `const'. -(define (/rtx-traverse expr expected mode parent-expr op-pos tstate appstuff) +(define (/rtx-traverse expr expected parent-expr op-pos tstate appstuff) (if /rtx-traverse-debug? (begin (display (spaces (* 4 (tstate-depth tstate)))) @@ -730,24 +1750,22 @@ (display "-expected: ") (display expected) (newline) - (display (spaces (* 4 (tstate-depth tstate)))) - (display "-mode: ") - (display mode) - (newline) (force-output) )) + ;; FIXME: error checking here should be deleteable. + (if (pair? expr) ; pair? -> cheap non-null-list? (let ((rtx-obj (rtx-lookup (car expr)))) (tstate-incr-depth! tstate) (let ((result (if rtx-obj - (/rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff) + (/rtx-traverse-expr rtx-obj expr parent-expr op-pos tstate appstuff) (let ((rtx-obj (/rtx-macro-lookup (car expr)))) (if rtx-obj (/rtx-traverse (/rtx-macro-expand expr rtx-evaluator) - expected mode parent-expr op-pos tstate appstuff) + expected parent-expr op-pos tstate appstuff) (tstate-error tstate "unknown rtx function" expr)))))) (tstate-decr-depth! tstate) result)) @@ -758,28 +1776,33 @@ (cond ((symbol? expr) (cond ((current-op-lookup expr) - (/rtx-traverse - (rtx-make-operand expr) ; (current-op-lookup expr)) - expected mode parent-expr op-pos tstate appstuff)) + => (lambda (op) + (/rtx-traverse + ;; NOTE: Can't call op:mode-name here, we need + ;; the real mode, not (potentially) DFLT. + (rtx-make-operand (obj:name (op:mode op)) expr) + expected parent-expr op-pos tstate appstuff))) ((rtx-temp-lookup (tstate-env tstate) expr) - (/rtx-traverse - (rtx-make-local expr) ; (rtx-temp-lookup (tstate-env tstate) expr)) - expected mode parent-expr op-pos tstate appstuff)) + => (lambda (tmp) + (/rtx-traverse + (rtx-make-local (rtx-temp-mode tmp) expr) + expected parent-expr op-pos tstate appstuff))) ((current-ifld-lookup expr) - (/rtx-traverse - (rtx-make-ifield expr) - expected mode parent-expr op-pos tstate appstuff)) + => (lambda (f) + (/rtx-traverse + (rtx-make-ifield (obj:name (ifld-mode f)) expr) + expected parent-expr op-pos tstate appstuff))) ((enum-lookup-val expr) ;; ??? If enums could have modes other than INT, ;; we'd want to propagate that mode here. (/rtx-traverse (rtx-make-enum 'INT expr) - expected mode parent-expr op-pos tstate appstuff)) + expected parent-expr op-pos tstate appstuff)) (else (tstate-error tstate "unknown operand" expr)))) ((integer? expr) (/rtx-traverse (rtx-make-const 'INT expr) - expected mode parent-expr op-pos tstate appstuff)) + expected parent-expr op-pos tstate appstuff)) (else (tstate-error tstate "unexpected operand" expr))) @@ -788,6 +1811,7 @@ ) ; User visible procedures to traverse an rtl expression. +; EXPR must be fully canonical (i.e. compiled). ; These calls /rtx-traverse to do most of the work. ; See tstate-make for explanations of OWNER, EXPR-FN. ; CONTEXT is a object or #f if there is none. @@ -795,33 +1819,32 @@ ; APPSTUFF is for application specific use. (define (rtx-traverse context owner expr expr-fn appstuff) - (/rtx-traverse expr #f 'DFLT #f 0 + (/rtx-traverse expr #f #f 0 (tstate-make context owner expr-fn (rtx-env-empty-stack) - #f #f nil 0) + #f nil 0) appstuff) ) (define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff) - (/rtx-traverse expr #f 'DFLT #f 0 + (/rtx-traverse expr #f #f 0 (tstate-make context owner expr-fn (rtx-env-push (rtx-env-empty-stack) (rtx-env-make-locals locals)) - #f #f nil 0) + #f nil 0) appstuff) ) ; Traverser debugger. +; This just traverses EXPR printing everything it sees. (define (rtx-traverse-debug expr) (rtx-traverse #f #f expr - (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) + (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) (display "-expr: ") (display (string-append "rtx=" (obj:str-name rtx-obj))) (display " expr=") (display expr) - (display " mode=") - (display mode) (display " parent=") (display parent-expr) (display " op-pos=") @@ -1023,15 +2046,17 @@ ; RTX expression evaluator. ; -; EXPR is the expression to be eval'd. It must be in compiled form. -; MODE is the mode of EXPR, a object. +; EXPR is the expression to be eval'd. It must be in compiled(canonical) form. +; MODE is the desired mode of EXPR, a object. ; ESTATE is the current evaluation state. (define (rtx-eval-with-estate expr mode estate) (if /rtx-eval-debug? (begin - (display "Traversing ") - (display expr) + (display "Evaluating expr with mode ") + (display (if (symbol? mode) mode (obj:name mode))) + (newline) + (display (rtx-dump expr)) (newline) (rtx-env-dump (estate-env estate)) )) @@ -1044,7 +2069,7 @@ (if (procedure? fn) (apply fn (cons estate (cdr expr))) ; ; Don't eval operands for syntax expressions. -; (if (rtx-style-syntax? rtx-obj) +; (if (eq? (rtx-style rtx-obj) 'SYNTAX) ; (apply fn (cons estate (cdr expr))) ; (let ((operands ; (/rtx-eval-operands rtx-obj expr estate))) @@ -1061,7 +2086,7 @@ ) ; Evaluate rtx expression EXPR and return the computed value. -; EXPR must already be in compiled form (the result of rtx-compile). +; EXPR must already be in canonical form (the result of rtx-canonicalize). ; OWNER is the owner of the value, used for attribute computation, ; or #f if there isn't one. ; FIXME: context? @@ -1069,3 +2094,38 @@ (define (rtx-value expr owner) (rtx-eval-with-estate expr DFLT (estate-make-for-eval #f owner)) ) + +;; Initialize the tables. + +(define (rtx-init-traversal-tables!) + (let ((compiler-hash-table (/rtx-make-canon-table)) + (traverser-hash-table (/rtx-make-traverser-table))) + + (set! /rtx-canoner-table (make-vector (rtx-max-num) #f)) + (set! /rtx-traverser-table (make-vector (rtx-max-num) #f)) + + (for-each (lambda (rtx-name) + (let ((rtx (rtx-lookup rtx-name))) + (if rtx + (let ((num (rtx-num rtx)) + (arg-types (rtx-arg-types rtx))) + (vector-set! /rtx-canoner-table num + (map1-improper + (lambda (arg-type) + (cons arg-type + (hashq-ref compiler-hash-table arg-type))) + arg-types)) + (vector-set! /rtx-traverser-table num + (map1-improper + (lambda (arg-type) + (cons arg-type + (hashq-ref traverser-hash-table arg-type))) + arg-types)))))) + (rtx-name-list))) + + (set! /rtx-operand-canoners (make-vector (rtx-max-num) /rtx-canon-operands)) + (for-each (lambda (rtx-canoner) + (let ((rtx-obj (rtx-lookup (car rtx-canoner)))) + (vector-set! /rtx-operand-canoners (rtx-num rtx-obj) (cdr rtx-canoner)))) + (/rtx-special-expr-canoners)) +) diff --git a/cgen/rtl-xform.scm b/cgen/rtl-xform.scm index d207a1dade..3ddabd1fb4 100644 --- a/cgen/rtl-xform.scm +++ b/cgen/rtl-xform.scm @@ -7,10 +7,28 @@ ;; In particular: ;; rtx-simplify ;; rtx-solve -;; rtx-canonicalize -;; rtx-compile ;; rtx-trim-for-doc +;; Utility to verify there are no DFLT modes present in EXPR + +;; Subroutine of rtx-verify-no-dflt-modes to simplify it. +;; This is the EXPR-FN argument to rtl-traverse. + +(define (/rtx-verify-no-dflt-modes-expr-fn rtx-obj expr parent-expr op-pos + tstate appstuff) + (if (eq? (rtx-mode expr) 'DFLT) + (tstate-error tstate "DFLT mode present" expr)) + + ;; Leave EXPR unchanged and continue. + #f +) + +;; Entry point. Verify there are no DFLT modes in EXPR. + +(define (rtx-verify-no-dflt-modes context expr) + (rtx-traverse context #f expr /rtx-verify-no-dflt-modes-expr-fn #f) +) + ;; rtx-simplify (and supporting cast) ; Subroutine of /rtx-simplify-expr-fn to compare two values for equality. @@ -116,9 +134,8 @@ ; Subroutine of rtx-simplify. ; This is the EXPR-FN argument to rtx-traverse. -; MODE is the name of the mode. -(define (/rtx-simplify-expr-fn rtx-obj expr mode parent-expr op-pos +(define (/rtx-simplify-expr-fn rtx-obj expr parent-expr op-pos tstate appstuff) ;(display "Processing ") (display (rtx-dump expr)) (newline) @@ -127,9 +144,7 @@ ((not) (let* ((arg (/rtx-traverse (rtx-alu-op-arg expr 0) - 'RTX - (rtx-alu-op-mode expr) - expr 1 tstate appstuff)) + 'RTX expr 1 tstate appstuff)) (no-side-effects? (not (rtx-side-effects? arg)))) (cond ((and no-side-effects? (rtx-false? arg)) (rtx-true)) @@ -139,9 +154,9 @@ ((orif) (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0) - 'RTX 'DFLT expr 0 tstate appstuff)) + 'RTX expr 0 tstate appstuff)) (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1) - 'RTX 'DFLT expr 1 tstate appstuff))) + 'RTX expr 1 tstate appstuff))) (let ((no-side-effects-0? (not (rtx-side-effects? arg0))) (no-side-effects-1? (not (rtx-side-effects? arg1)))) (cond ((and no-side-effects-0? (rtx-true? arg0)) @@ -160,9 +175,9 @@ ((andif) (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0) - 'RTX 'DFLT expr 0 tstate appstuff)) + 'RTX expr 0 tstate appstuff)) (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1) - 'RTX 'DFLT expr 1 tstate appstuff))) + 'RTX expr 1 tstate appstuff))) (let ((no-side-effects-0? (not (rtx-side-effects? arg0))) (no-side-effects-1? (not (rtx-side-effects? arg1)))) (cond ((and no-side-effects-0? (rtx-false? arg0)) @@ -186,16 +201,17 @@ ; ??? Was this but that calls rtx-traverse again which ; resets the temp stack! ; (rtx-simplify context (caddr expr)))) - (/rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff))) + (/rtx-traverse (rtx-if-test expr) 'RTX expr 1 tstate appstuff))) (cond ((rtx-true? test) - (/rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff)) + (/rtx-traverse (rtx-if-then expr) 'RTX expr 2 tstate appstuff)) ((rtx-false? test) (if (rtx-if-else expr) - (/rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff) + (/rtx-traverse (rtx-if-else expr) 'RTX expr 3 tstate appstuff) ; Sanity check, mode must be VOID. + ; FIXME: DFLT can no longer appear (if (or (mode:eq? 'DFLT (rtx-mode expr)) (mode:eq? 'VOID (rtx-mode expr))) - (rtx-make 'nop) + (rtx-make 'nop 'VOID) (error "rtx-simplify: non-void-mode `if' missing `else' part" expr)))) ; Can't simplify. ; We could traverse the then/else clauses here, but it's simpler @@ -207,10 +223,8 @@ (let ((name (rtx-name expr)) (cmp-mode (rtx-cmp-op-mode expr)) (arg0 (/rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX - (rtx-cmp-op-mode expr) expr 1 tstate appstuff)) (arg1 (/rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX - (rtx-cmp-op-mode expr) expr 2 tstate appstuff))) (if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1)) (rtx-make name cmp-mode arg0 arg1) @@ -277,7 +291,7 @@ ; Simplify an rtl expression. ; -; EXPR must be in source form. +; EXPR must be in canonical source form. ; The result is a possibly simplified EXPR, still in source form. ; ; CONTEXT is a object or #f, used for error messages. @@ -298,11 +312,11 @@ ; ??? Will become more intelligent as needed. (define (rtx-simplify context owner expr known) - (/rtx-traverse expr #f 'DFLT #f 0 + (/rtx-traverse expr #f #f 0 (tstate-make context owner - (/fastcall-make /rtx-simplify-expr-fn) + /rtx-simplify-expr-fn (rtx-env-empty-stack) - #f #f known 0) + #f known 0) #f) ) @@ -310,7 +324,7 @@ ;; CONTEXT is a object or #f, used for error messages. (define (rtx-simplify-insn context insn) - (rtx-simplify context insn (insn-semantics insn) + (rtx-simplify context insn (insn-canonical-semantics insn) (insn-build-known-values insn)) ) @@ -325,9 +339,8 @@ ; Subroutine of rtx-solve. ; This is the EXPR-FN argument to rtx-traverse. -; MODE is the name of the mode. -(define (/solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff) +(define (/solve-expr-fn rtx-obj expr parent-expr op-pos tstate appstuff) #f ; wip ) @@ -352,11 +365,11 @@ (let* ((simplified-expr (rtx-simplify context owner expr known)) (maybe-solved-expr simplified-expr) ; FIXME: for now -; (/rtx-traverse simplified-expr #f 'DFLT #f 0 +; (/rtx-traverse simplified-expr #f #f 0 ; (tstate-make context owner -; (/fastcall-make /solve-expr-fn) +; /solve-expr-fn ; (rtx-env-empty-stack) -; #f #f known 0) +; #f known 0) ; #f)) ) (cond ((rtx-true? maybe-solved-expr) #t) @@ -364,101 +377,15 @@ (else '?))) ) -;; rtx-canonicalize (and supporting cast) - -; RTX canonicalization. -; ??? wip - -; Subroutine of rtx-canonicalize. -; Return canonical form of rtx expression EXPR. -; CONTEXT is a object or #f if there is none. -; It is used for error message. -; RTX-OBJ is the object of (car expr). - -(define (/rtx-canonicalize-expr context rtx-obj expr) - #f -) +;; rtx-trim-for-doc (and supporting cast) +;; RTX trimming (removing fluff not normally needed for the human viewer). -; Return canonical form of EXPR. -; CONTEXT is a object or #f if there is none. -; It is used for error message. -; -; Does: -; - operand shortcuts expanded -; - numbers -> (const number) -; - operand-name -> (operand operand-name) -; - ifield-name -> (ifield ifield-name) -; - no options -> null option list -; - absent result mode of those that require a mode -> DFLT -; - rtx macros are expanded -; -; EXPR is returned in source form. We could speed up future processing by -; transforming it into a more compiled form, but that makes debugging more -; difficult, so for now we don't. - -(define (rtx-canonicalize context expr) - ; FIXME: wip - (cond ((integer? expr) - (rtx-make-const 'INT expr)) - ((symbol? expr) - (let ((op (current-op-lookup expr))) - (if op - (rtx-make-operand expr) - (context-error context - "While canonicalizing rtl" - "can't canonicalize, unknown symbol" - expr)))) - ((pair? expr) - expr) - (else - (context-error context - "While canonicalizing rtl" - "can't canonicalize, syntax error" - expr))) -) - -;; rtx-compile (and supporting cast) - -;; Subroutine of rtx-compile. -;; This is the tstate-expr-fn. -;; MODE is the name of the mode. - -(define (/compile-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff) -; (cond -; The intent of this is to handle sequences/closures, but is it needed? -; ((rtx-style-syntax? rtx-obj) -; ((rtx-evaluator rtx-obj) rtx-obj expr mode -; parent-expr op-pos tstate)) -; (else - (cons (car expr) ; rtx-obj - (/rtx-traverse-operands rtx-obj expr tstate appstuff)) -) +;; Subroutine of /rtx-trim-args to simplify it. +;; Trim a list of rtxes. -; Convert rtl expression EXPR from source form to compiled form. -; The expression is validated and rtx macros are expanded as well. -; CONTEXT is a object or #f if there is none. -; It is used in error messages. -; EXTRA-VARS-ALIST is an association list of extra (symbol value) -; elements to be used during value lookup. -; -; This does the same operation that rtx-traverse does, except that it provides -; a standard value for EXPR-FN. -; -; ??? In the future the compiled form may be the same as the source form -; except that all elements would be converted to their respective objects. - -(define (rtx-compile context expr extra-vars-alist) - (/rtx-traverse expr #f 'DFLT #f 0 - (tstate-make context #f - (/fastcall-make /compile-expr-fn) - (rtx-env-init-stack1 extra-vars-alist) - #f #f nil 0) - #f) +(define (/rtx-trim-rtx-list rtx-list) + (map /rtx-rtim-for-doc rtx-list) ) - -;; rtx-trim-for-doc (and supporting cast) - -; RTX trimming (removing fluff not normally needed for the human viewer). ; Subroutine of /rtx-trim-for-doc to simplify it. ; Trim all the arguments of rtx NAME. @@ -487,7 +414,9 @@ ((OPTIONS) (assert #f)) ; shouldn't get here - ((ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE) + ((ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE + VOIDORNUMMODE VOIDMODE BIMODE INTMODE + SYMMODE INSNMODE MACHMODE) #f) ; leave arg untouched ((RTX SETRTX TESTRTX) @@ -529,11 +458,12 @@ (cons new-arg result)))))) ) -; Given a fully specified rtx expression, usually the result of rtx-simplify, +; Given a canonical rtl expression, usually the result of rtx-simplify, ; remove bits unnecessary for documentation purposes. -; rtx-simplify adds a lot of verbosity because in the process of -; simplifying the rtl it produces fully-specified rtl. -; Examples of things to remove: empty options list, DFLT mode. +; Canonical rtl too verbose for docs. +; Examples of things to remove: +; - empty options list +; - ifield/operand/local/const wrappers ; ; NOTE: While having to trim the result of rtx-simplify may seem ironical, ; it isn't. You need to keep separate the notions of simplifying "1+1" to "2" @@ -548,15 +478,25 @@ (case name - ((const) (car rest)) - - ((ifield operand local) + ((const ifield operand local) (if (null? options) - (if (eq? mode 'DFLT) - (car rest) - (cons name (cons mode rest))) + (car rest) rtx)) + ((set) + (let ((trimmed-args (/rtx-trim-args name rest))) + (if (null? options) + (cons name trimmed-args) + (cons name (cons options (cons mode trimmed-args)))))) + + ((if) + (let ((trimmed-args (/rtx-trim-args name rest))) + (if (null? options) + (if (eq? mode 'VOID) + (cons name trimmed-args) + (cons name (cons mode trimmed-args))) + (cons name (cons options (cons mode trimmed-args)))))) + ((sequence parallel) ; No special support is needed, except it's nice to remove nop ; statements. These can be created when an `if' get simplified. @@ -568,7 +508,7 @@ (set! result (cons rtx result)))) trimmed-args) (if (null? options) - (if (eq? mode 'DFLT) + (if (eq? mode 'VOID) (cons name (reverse result)) (cons name (cons mode (reverse result)))) (cons name (cons options (cons mode (reverse result))))))) @@ -576,7 +516,7 @@ (else (let ((trimmed-args (/rtx-trim-args name rest))) (if (null? options) - (if (eq? mode 'DFLT) + (if (eq? mode 'DFLT) ;; FIXME: DFLT can no longer appear (cons name trimmed-args) (cons name (cons mode trimmed-args))) (cons name (cons options (cons mode trimmed-args)))))))) diff --git a/cgen/rtl.scm b/cgen/rtl.scm index 703fb7584d..bb99ef7b57 100644 --- a/cgen/rtl.scm +++ b/cgen/rtl.scm @@ -32,23 +32,33 @@ (class-make ' nil '( ; name as it appears in RTL + ; must be accessed via obj:name name ; argument list + ; ??? Not used I think, but keep. args + ; result mode, or #f if from arg 2 + ; (or the containing expression when canonicalizing) + result-mode + ; types of each argument, as symbols ; This is #f for macros. ; Possible values: - ; OPTIONS - optional list of :-prefixed options. - ; ANYMODE - any mode - ; INTMODE - any integer mode - ; FLOATMODE - any floating point mode - ; NUMMODE - any numeric mode + ; OPTIONS - optional list of keyword-prefixed options + ; ANYINTMODE - any integer mode + ; ANYFLOATMODE - any floating point mode + ; ANYNUMMODE - any numeric mode + ; ANYEXPRMODE - VOID, PTR, or any numeric mode ; EXPLNUMMODE - explicit numeric mode, can't be DFLT or VOID - ; NONVOIDMODE - can't be `VOID' + ; VOIDORNUMMODE - VOID or any numeric mode ; VOIDMODE - must be `VOID' - ; DFLTMODE - must be `DFLT', used when any mode is inappropriate + ; BIMODE - BI (boolean or bit int) + ; INTMODE - must be `INT' + ; SYMMODE - must be SYM + ; INSNMODE - must be INSN + ; MACHMODE - must be MACH ; RTX - any rtx ; SETRTX - any rtx allowed to be `set' ; TESTRTX - the test of an `if' @@ -57,32 +67,42 @@ ; LOCALS - the locals list of a sequence ; ENV - environment stack ; ATTRS - attribute list - ; SYMBOL - operand must be a symbol - ; STRING - operand must be a string - ; NUMBER - operand must be a number - ; SYMORNUM - operand must be a symbol or number - ; OBJECT - operand is an object + ; SYMBOL - arg must be a symbol + ; STRING - arg must be a string + ; NUMBER - arg must be a number + ; SYMORNUM - arg must be a symbol or number + ; OBJECT - arg is an object (FIXME: restrict to ?) arg-types ; required mode of each argument ; This is #f for macros. ; Possible values include any mode name and: ; ANY - any mode + ; ANYINT - any integer mode ; NA - not applicable - ; OP0 - mode is specified in operand 0 - ; unless it is DFLT in which case use the default mode - ; of the operand - ; MATCH1 - must match mode of operand 1 - ; which will have OP0 for its mode spec - ; MATCH2 - must match mode of operand 2 - ; which will have OP0 for its mode spec + ; MATCHEXPR - mode has to match the mode specified in the + ; containing expression + ; NOTE: This isn't necessarily the mode of the + ; result of the expression. E.g. in `set', the + ; result always has mode VOID, but the mode + ; specified in the expression is the mode of the + ; set destination. + ; MATCHSEQ - for sequences + ; last expression has to match mode of sequence, + ; preceding expressions must be VOID + ; MATCH2 - must match mode of arg 2 + ; MATCH3 - must match mode of arg 3 ; - must match specified mode arg-modes + ; arg number of the MATCHEXPR arg, + ; or #f if there is none + matchexpr-index + ; The class of rtx. ; This is #f for macros. ; ARG - operand, local, const - ; SET - set + ; SET - set, set-quiet ; UNARY - not, inv, etc. ; BINARY - add, sub, etc. ; TRINARY - addc, subc, etc. @@ -95,10 +115,10 @@ class ; A symbol indicating the flavour of rtx node this is. - ; function - normal function - ; syntax - don't pre-eval arguments - ; operand - result is an operand - ; macro - converts one rtx expression to another + ; FUNCTION - normal function + ; SYNTAX - don't pre-eval arguments + ; OPERAND - result is an operand + ; MACRO - converts one rtx expression to another ; The word "style" was chosen to be sufficiently different ; from "type", "kind", and "class". style @@ -119,7 +139,7 @@ ; Accessor fns (define-getters rtx - (name args arg-types arg-modes class style evaluator num) + (result-mode arg-types arg-modes matchexpr-index class style evaluator num) ) (define (rtx-style-syntax? rtx) (eq? (rtx-style rtx) 'syntax)) @@ -132,7 +152,8 @@ (define /rtx-valid-mode-types '( - ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE + ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE VOIDORNUMMODE + VOIDMODE BIMODE INTMODE SYMMODE INSNMODE MACHMODE ) ) @@ -150,7 +171,23 @@ ; List of valid mode matchers, excluding mode names. (define /rtx-valid-matches - '(ANY NA OP0 MATCH1 MATCH2) + '(ANY ANYINT NA MATCHEXPR MATCHSEQ MATCH2 MATCH3) +) + +;; Return arg number of MATCHEXPR in ARG-MODES or #f if not present. + +(define (/rtx-find-matchexpr-index arg-modes) + ;; We can't use find-first-index here because arg-modes can be an + ;; improper list (a b c . d). + ;;(find-first-index 0 (lambda (t) (eq? t 'MATCHEXPR)) arg-modes) + (define (improper-find-first-index i pred l) + (cond ((null? l) #f) + ((pair? l) + (cond ((pred (car l)) i) + (else (improper-find-first-index (+ 1 i) pred (cdr l))))) + ((pred l) i) + (else #f))) + (improper-find-first-index 0 (lambda (t) (eq? t 'MATCHEXPR)) arg-modes) ) ; List of all defined rtx names. This can be map'd over without having @@ -166,14 +203,11 @@ ; Look up the object for RTX-KIND. ; Returns the object or #f if not found. -; RTX-KIND may already be an object. FIXME: delete? +; RTX-KIND is the name of the rtx function. (define (rtx-lookup rtx-kind) - (cond ((symbol? rtx-kind) - (hashq-ref /rtx-func-table rtx-kind)) - ((rtx-func? rtx-kind) - rtx-kind) - (else #f)) + (assert (symbol? rtx-kind)) + (hashq-ref /rtx-func-table rtx-kind) ) ; Table of rtx macro objects. @@ -209,15 +243,33 @@ ; ; ??? Note that we can support variables. Not sure it should be done. -(define (def-rtx-node name-args arg-types arg-modes class action) - (let ((name (car name-args)) - (args (cdr name-args))) +(define (def-rtx-node name-args result-mode arg-types arg-modes class action) + (let* ((name (car name-args)) + (args (cdr name-args)) + (context (make-prefix-context (string-append "defining rtx " + (symbol->string name)))) + (matchexpr-index (/rtx-find-matchexpr-index arg-modes))) + +; (map1-improper (lambda (arg-type) +; (if (not (memq arg-type /rtx-valid-types)) +; (context-error context "While defining rtx functions" +; "invalid arg type" arg-type))) +; arg-types) +; (map1-improper (lambda (arg-mode) +; (if (and (not (memq arg-mode /rtx-valid-matches)) +; (not (symbol? arg-mode))) ;; FIXME: mode-name? +; (context-error context "While defining rtx functions" +; "invalid arg mode match" arg-mode))) +; arg-modes) + (let ((rtx (make name args - arg-types arg-modes + result-mode arg-types arg-modes matchexpr-index class 'function (if action - (eval1 (list 'lambda (cons '*estate* args) action)) + (eval1 (list 'lambda + (cons '*estate* args) + action)) #f) /rtx-num-next))) ; Add it to the table of rtx handlers. @@ -237,15 +289,18 @@ ; Same as define-rtx-node but don't pre-evaluate the arguments. ; Remember that `mode' must be the first argument. -(define (def-rtx-syntax-node name-args arg-types arg-modes class action) +(define (def-rtx-syntax-node name-args result-mode arg-types arg-modes class action) (let ((name (car name-args)) - (args (cdr name-args))) + (args (cdr name-args)) + (matchexpr-index (/rtx-find-matchexpr-index arg-modes))) (let ((rtx (make name args - arg-types arg-modes + result-mode arg-types arg-modes matchexpr-index class 'syntax (if action - (eval1 (list 'lambda (cons '*estate* args) action)) + (eval1 (list 'lambda + (cons '*estate* args) + action)) #f) /rtx-num-next))) ; Add it to the table of rtx handlers. @@ -265,16 +320,19 @@ ; Same as define-rtx-node but return an operand (usually an object). ; ??? `mode' must be the first argument? -(define (def-rtx-operand-node name-args arg-types arg-modes class action) +(define (def-rtx-operand-node name-args result-mode arg-types arg-modes class action) ; Operand nodes must specify an action. (assert action) (let ((name (car name-args)) - (args (cdr name-args))) + (args (cdr name-args)) + (matchexpr-index (/rtx-find-matchexpr-index arg-modes))) (let ((rtx (make name args - arg-types arg-modes + result-mode arg-types arg-modes matchexpr-index class 'operand - (eval1 (list 'lambda (cons '*estate* args) action)) + (eval1 (list 'lambda + (cons '*estate* args) + action)) /rtx-num-next))) ; Add it to the table of rtx handlers. (hashq-set! /rtx-func-table name rtx) @@ -300,7 +358,7 @@ (assert action) (let ((name (car name-args)) (args (cdr name-args))) - (let ((rtx (make name args #f #f + (let ((rtx (make name args #f #f #f #f #f ; class 'macro (eval1 (list 'lambda args action)) @@ -406,10 +464,6 @@ (define (rtx-sem-mode mode) (or (mode:sem-mode mode) mode)) -; MODE is a object. - -(define (rtx-lazy-sem-mode mode) (rtx-sem-mode mode)) - ; Return the mode of object OBJ. (define (rtx-obj-mode obj) (send obj 'get-mode)) @@ -418,10 +472,10 @@ ; M1,M2 are objects. (define (rtx-mode-compatible? m1 m2) - (let ((mode1 (rtx-lazy-sem-mode m1)) - (mode2 (rtx-lazy-sem-mode m2))) - ;(eq? (obj:name mode1) (obj:name mode2))) - ; ??? This is more permissive than is perhaps proper. + ;; ??? This is more permissive than is perhaps proper. + (let ((mode1 (rtx-sem-mode m1)) + (mode2 (rtx-sem-mode m2))) + ;;(eq? (obj:name mode1) (obj:name mode2))) (mode-compatible? 'sameclass mode1 mode2)) ) @@ -429,6 +483,7 @@ ; Temporaries are created within a sequence. ; MODE is a object. +; VALUE is #f if not set yet. ; e.g. (sequence ((WI tmp)) (set tmp reg0) ...) ; ??? Perhaps what we want here is `let' but for now I prefer `sequence'. ; This isn't exactly `let' either as no initial value is specified. @@ -537,7 +592,6 @@ ; ??? Should environments only have rtx-temps? (define (rtx-temp-lookup env name) - ;(display "looking up:") (display name) (newline) (let loop ((stack (rtx-env-var-list env))) (if (null? stack) #f @@ -549,8 +603,8 @@ ; Create a "closure" of EXPR using the current temp stack. -(define (/rtx-closure-make estate expr) - (rtx-make 'closure expr (estate-env estate)) +(define (/rtx-closure-make estate mode expr) + (rtx-make 'closure mode expr (estate-env estate)) ) (define (rtx-env-dump env) @@ -579,7 +633,7 @@ ; that much. (define (rtx-make kind . args) - (cons kind (/rtx-munge-mode&options args)) + (cons kind (rtx-munge-mode&options (rtx-lookup kind) 'DFLT kind args)) ) (define rtx-name car) @@ -641,7 +695,9 @@ ; Return argument to `symbol' rtx. (define rtx-symbol-name rtx-arg1) -(define (rtx-make-ifield ifield-name) (rtx-make 'ifield ifield-name)) +(define (rtx-make-ifield mode-name ifield-name) + (rtx-make 'ifield mode-name ifield-name) +) (define (rtx-ifield? rtx) (eq? 'ifield (rtx-name rtx))) (define (rtx-ifield-name rtx) (let ((ifield (rtx-arg1 rtx))) @@ -656,22 +712,37 @@ ifield)) ) -(define (rtx-make-operand op-name) (rtx-make 'operand op-name)) +(define (rtx-make-operand mode-name op-name) + (rtx-make 'operand mode-name op-name) +) (define (rtx-operand? rtx) (eq? 'operand (rtx-name rtx))) +;; FIXME: This should just fetch rtx-arg1, +;; operand rtxes shouldn't have objects, that's what xop is for. (define (rtx-operand-name rtx) (let ((operand (rtx-arg1 rtx))) (if (symbol? operand) operand (obj:name operand))) ) + +;; Given an operand rtx, construct the object. +;; RTX must be canonical rtl. + (define (rtx-operand-obj rtx) - (let ((operand (rtx-arg1 rtx))) - (if (symbol? operand) - (current-op-lookup operand) - operand)) + (let ((op (current-op-lookup (rtx-arg1 rtx))) + (mode (rtx-mode rtx))) + (assert op) + (assert (not (eq? mode 'DFLT))) + ;; NOTE: op:mode-name can be DFLT, which means use the mode of the type. + ;; But we can't propagate DFLT here, in canonical rtl DFLT is not allowed. + (if (mode:eq? (op:mode-name op) mode) + op + (op:new-mode op mode))) ) -(define (rtx-make-local local-name) (rtx-make 'local local-name)) +(define (rtx-make-local mode-name local-name) + (rtx-make 'local mode-name local-name) +) (define (rtx-local? rtx) (eq? 'local (rtx-name rtx))) (define (rtx-local-name rtx) (let ((local (rtx-arg1 rtx))) @@ -686,6 +757,10 @@ local)) ) +(define (rtx-make-xop op) + (rtx-make 'xop (op:mode-name op) op) +) + (define rtx-xop-obj rtx-arg1) ;(define (rtx-opspec? rtx) (eq? 'opspec (rtx-name rtx))) @@ -744,7 +819,7 @@ (if (pair? rtx) (case (car rtx) ((const) (number->string (rtx-const-value rtx))) - ((operand) (symbol->string (obj:name (rtx-operand-obj rtx)))) + ((operand) (symbol->string (rtx-operand-name rtx))) ((local) (symbol->string (rtx-local-name rtx))) ((xop) (symbol->string (obj:name (rtx-xop-obj rtx)))) (else @@ -927,7 +1002,7 @@ ; Maybe in the future allow arrays although there's significant utility in ; allowing only at most a scalar index. -(define (hw estate mode-name hw-name index-arg selector) +(define (/hw estate mode-name hw-name index-arg selector) ; Enforce some rules to keep things in line with the current design. (if (not (symbol? mode-name)) (parse-error (estate-context estate) "invalid mode name" mode-name)) @@ -946,6 +1021,7 @@ (let* ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name))) (hw-name-with-mode (symbol-append hw-name '- (obj:name mode))) + (index-mode (if (eq? hw-name 'h-memory) 'AI 'INT)) (result (new ))) ; ??? lookup-for-new? (if (not mode) @@ -970,8 +1046,8 @@ (if (rtx-constant? index-arg) (make 'anonymous 'constant UINT (rtx-constant-value index-arg)) - (make 'anonymous 'rtx DFLT - (/rtx-closure-make estate index-arg)))) + (make 'anonymous 'rtx (mode:lookup index-mode) + (/rtx-closure-make estate index-mode index-arg)))) (else (parse-error (estate-context estate) "invalid index" index-arg)))) @@ -1004,9 +1080,9 @@ ; ESTATE is the current rtx evaluation state. ; INDX-SEL is an optional register number and possible selector. ; The register number, if present, is (car indx-sel) and must be a number or -; unevaluated RTX expression. +; unevaluated canonical RTX expression. ; The selector, if present, is (cadr indx-sel) and must be a number or -; unevaluated RTX expression. +; unevaluated canonical RTX expression. ; ??? A register selector isn't supported yet. It's just an idea that's ; been put down on paper for future reference. @@ -1019,8 +1095,9 @@ ) ; This is shorthand for (hw estate mode-name h-memory addr selector). -; ADDR must be an unevaluated RTX expression. -; If present (car sel) must be a number or unevaluated RTX expression. +; ADDR must be an unevaluated canonical RTX expression. +; If present (car sel) must be a number or unevaluated canonical +; RTX expression. (define (mem estate mode-name addr . sel) (s-hw estate mode-name 'h-memory addr @@ -1029,7 +1106,7 @@ ; For the rtx nodes to use. -(define s-hw hw) +(define s-hw /hw) ; The program counter. ; When this code is loaded, global `pc' is nil, it hasn't been set to the @@ -1076,6 +1153,7 @@ ; The argument to drn,drmn,drsn must be Scheme code (or a fixed subset ; thereof). .str/.sym are used in pmacros so it makes sense to include them ; in the subset. +; FIXME: Huh? (define .str string-append) (define .sym symbol-append) @@ -1123,12 +1201,15 @@ Define an rtx subroutine, name/value pair list version. " nil 'arg-list define-subr) + *UNSPECIFIED* ) -; Install builtins +;; Install builtins (define (rtl-builtin!) + (rtx-init-traversal-tables!) + *UNSPECIFIED* ) @@ -1143,20 +1224,6 @@ Define an rtx subroutine, name/value pair list version. ; Update s-pc, must be called after operand-init!. (set! s-pc pc) - ; Table of traversers for the various rtx elements. - (let ((hash-table (/rtx-make-traverser-table))) - (set! /rtx-traverser-table (make-vector (rtx-max-num) #f)) - (for-each (lambda (rtx-name) - (let ((rtx (rtx-lookup rtx-name))) - (if rtx - (vector-set! /rtx-traverser-table (rtx-num rtx) - (map1-improper - (lambda (arg-type) - (cons arg-type - (hashq-ref hash-table arg-type))) - (rtx-arg-types rtx)))))) - (rtx-name-list))) - ; Initialize the operand hash table. (set! /rtx-operand-table (make-hash-table 127)) diff --git a/cgen/rtx-funcs.scm b/cgen/rtx-funcs.scm index be1268b6fc..991bf6be04 100644 --- a/cgen/rtx-funcs.scm +++ b/cgen/rtx-funcs.scm @@ -32,9 +32,12 @@ ; Error reporting. ; MODE is present for use in situations like non-VOID mode cond's. +; The code will expect the mode to be compatible even though `error' +; "doesn't return". A small concession for simpler code. (drn (error &options &mode message) - (OPTIONS ANYMODE STRING) (NA NA NA) + #f + (OPTIONS VOIDORNUMMODE STRING) (NA NA NA) MISC (estate-error *estate* "error in rtl" message) ) @@ -43,7 +46,8 @@ ; Default mode is INT. (drn (enum &options &mode enum-name) - (OPTIONS NUMMODE SYMBOL) (NA NA NA) + #f + (OPTIONS ANYINTMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/ENUM-NAME/ ? ARG ; When computing a value, return the enum's value. (enum-lookup-val enum-name) @@ -56,7 +60,8 @@ ; in this. (dron (ifield &options &mode ifld-name) - (OPTIONS DFLTMODE SYMBOL) (NA NA NA) + #f + (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/IFIELD-NAME/ ? ARG (let ((f (current-ifld-lookup ifld-name))) (make (obj-location f) @@ -74,7 +79,8 @@ ; in this. (dron (operand &options &mode op-name) - (OPTIONS DFLTMODE SYMBOL) (NA NA NA) + #f + (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/OPERAND-NAME/ ? ARG (current-op-lookup op-name) ) @@ -104,8 +110,10 @@ ; ??? Might also support numbering by allowing NEW-NAME to be a number. (drsn (name &options &mode new-name value) - (OPTIONS DFLTMODE SYMBOL RTX) (NA NA NA ANY) + #f + (OPTIONS ANYNUMMODE SYMBOL RTX) (NA NA NA ANY) ARG + ;; FIXME: s/DFLT/&mode/ ? (let ((result (object-copy (rtx-get 'DFLT value)))) (op:set-sem-name! result new-name) result) @@ -118,13 +126,14 @@ ; Compiled operands are wrapped in this so that they still look like rtx. (dron (xop &options &mode object) - (OPTIONS DFLTMODE OBJECT) (NA NA NA) + #f + (OPTIONS ANYNUMMODE OBJECT) (NA NA NA) ;; FIXME: s/OBJECT/OPERAND/ ? ARG object ) ;(dron (opspec: &options &mode op-name op-num hw-ref attrs) -; (OPTIONS ANYMODE SYMBOL NUMBER RTX ATTRS) (NA NA NA NA ANY NA) +; (OPTIONS ANYNUMMODE SYMBOL NUMBER RTX ATTRS) (NA NA NA NA ANY NA) ; ARG ; (let ((opval (rtx-eval-with-estate hw-ref (mode:lookup &mode) *estate*))) ; (assert (operand? opval)) @@ -143,7 +152,8 @@ ; wrapped in this. (dron (local &options &mode local-name) - (OPTIONS DFLTMODE SYMBOL) (NA NA NA) + #f + (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/LOCAL-NAME/ ? ARG (rtx-temp-lookup (tstate-env *tstate*) local-name) ) @@ -159,7 +169,8 @@ ; ??? Since operands are given names and not numbers this isn't currently used. ; ;(drsn (dup &options &mode op-name) -; (OPTIONS DFLTMODE SYMBOL) (NA NA NA) +; #f +; (OPTIONS ANYNUMMODE SYMBOL) (NA NA NA) ; ;(s-dup *estate* op-name) ; (begin ; (if (not (insn? (estate-owner *estate*))) @@ -174,18 +185,22 @@ ; ??? What about input/output operands. (drsn (ref &options &mode name) - (OPTIONS DFLTMODE SYMBOL) (NA NA NA) + BI + (OPTIONS BIMODE SYMBOL) (NA NA NA) ;; FIXME: s/SYMBOL/OPERAND-NAME/ ? ARG #f ) ; Return the index of an operand. ; For registers this is the register number. -; ??? Mode handling incomplete. +; ??? Mode handling incomplete, this doesn't handle mem, which it could. +; Until then we fix the mode of the result to INT. (dron (index-of &options &mode op-rtx) - (OPTIONS DFLTMODE RTX) (NA NA ANY) + INT + (OPTIONS INTMODE RTX) (NA NA ANY) ARG + ;; FIXME: s/DFLT/&mode/ ? (let* ((operand (rtx-eval-with-estate op-rtx DFLT *estate*)) (f (hw-index:value (op:index operand))) (f-name (obj:name f))) @@ -220,7 +235,7 @@ ; unevaluated. ; ??? Not currently supported. Not sure whether it should be. ;(drsn (hw &options &mode hw-elm . indx-sel) -; (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT) +; (OPTIONS ANYNUMMODE SYMBOL . RTX) (NA NA NA . INT) ; ARG ; (let ((indx (if (pair? indx-sel) (car indx-sel) 0)) ; (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel))) @@ -232,7 +247,8 @@ ; Register accesses. ; INDX-SEL is an optional index and possible selector. (dron (reg &options &mode hw-elm . indx-sel) - (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT) + #f + (OPTIONS ANYNUMMODE SYMBOL . RTX) (NA NA NA . INT) ;; FIXME: s/SYMBOL/HW-NAME/ ? ARG (let ((indx (if (pair? indx-sel) (car indx-sel) 0)) (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel))) @@ -245,7 +261,8 @@ ; getter/setter definitions. (dron (raw-reg &options &mode hw-elm . indx-sel) - (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT) + #f + (OPTIONS ANYNUMMODE SYMBOL . RTX) (NA NA NA . INT) ;; FIXME: s/SYMBOL/HW-NAME/ ? ARG (let ((indx (if (pair? indx-sel) (car indx-sel) 0)) (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel))) @@ -258,6 +275,7 @@ ; Memory accesses. (dron (mem &options &mode addr . sel) + #f (OPTIONS EXPLNUMMODE RTX . RTX) (NA NA AI . INT) ARG (s-hw *estate* mode 'h-memory addr @@ -270,7 +288,7 @@ ; The program counter. ; ??? Hmmm... needed? The pc is usually specified as `pc' which is shorthand ; for (operand pc). -(dron (pc) () () ARG s-pc) +;(dron (pc) () () ARG s-pc) ; Fetch bytes from the instruction stream of size MODE. ; FIXME: Later need to augment this by passing an indicator to the mem-fetch @@ -303,10 +321,12 @@ ; Indicate there are N delay slots in the processing of RTX. ; N is a `const' node. +; The mode of the result is the mode of RTX. ; ??? wip! (drn (delay &options &mode n rtx) - (OPTIONS DFLTMODE RTX RTX) (NA NA INT ANY) + #f + (OPTIONS VOIDORNUMMODE RTX RTX) (NA NA INT MATCHEXPR) MISC #f ; (s-sequence *estate* VOID '() rtx) ; wip! ) @@ -328,7 +348,8 @@ ; ??? wip! (drn (skip &options &mode yes?) - (OPTIONS DFLTMODE RTX) (NA NA INT) + VOID + (OPTIONS VOIDMODE RTX) (NA NA INT) MISC #f ) @@ -341,7 +362,7 @@ ; OWNER is the result of either (current-insn) or (current-mach) ; [note that canonicalization will turn them into ; (current-{insn,mach} () DFLT)]. -; The result is always of mode INT. +; The result is always of mode BI. ; FIXME: wip ; ; This is a syntax node so the args are not pre-evaluated. @@ -349,7 +370,8 @@ ; FIXME: Hmmm... it currently isn't a syntax node. (drn (eq-attr &options &mode owner attr value) - (OPTIONS DFLTMODE RTX SYMBOL SYMORNUM) (NA NA ANY NA NA) + BI + (OPTIONS BIMODE RTX SYMBOL SYMORNUM) (NA NA ANY NA NA) MISC (let ((atval (if owner (obj-attr-value owner attr) @@ -359,23 +381,33 @@ (eq? atval value))) ) -; Get the value of attribute ATTR-NAME. -; OBJ is the result of either (current-insn) or (current-mach) -; [note that canonicalization will turn them into -; (current-{insn,mach} () DFLT)]. +; Get the value of attribute ATTR-NAME, expressable as an integer. +; OBJ is the result of either (current-insn) or (current-mach). +; Note that canonicalization will turn them into +; (current-{insn,mach} () {INSN,MACH}MODE). ; FIXME:wip +; This uses INTMODE because we can't otherwise determine the +; mode of the result (if elided). -(drn (attr &options &mode obj attr-name) - (OPTIONS DFLTMODE RTX SYMBOL) (NA NA NA NA) +(drn (int-attr &options &mode obj attr-name) + #f + (OPTIONS INTMODE RTX SYMBOL) (NA NA ANY NA) MISC #f ) +;; Deprecated alias for int-attr. + +(drmn (attr arg1 . rest) + (cons 'int-attr (cons arg1 rest)) +) + ; Same as `quote', for use in attributes cus "quote" sounds too jargonish. ; [Ok, not a strong argument for using "symbol", but so what?] (drsn (symbol &options &mode name) - (OPTIONS DFLTMODE SYMBOL) (NA NA NA) + SYM + (OPTIONS SYMMODE SYMBOL) (NA NA NA) ARG name ) @@ -383,7 +415,8 @@ ; Return the current instruction. (drn (current-insn &options &mode) - (OPTIONS DFLTMODE) (NA NA) + INSN + (OPTIONS INSNMODE) (NA NA) MISC (let ((obj (estate-owner *estate*))) (if (not (insn? obj)) @@ -395,7 +428,8 @@ ; This can either be a compile-time or run-time value. (drn (current-mach &options &mode) - (OPTIONS DFLTMODE) (NA NA) + MACH + (OPTIONS MACHMODE) (NA NA) MISC -rtx-current-mach ) @@ -404,7 +438,8 @@ ; FIXME: Need to consider 64 bit hosts. (drn (const &options &mode c) - (OPTIONS NUMMODE NUMBER) (NA NA NA) + #f + (OPTIONS ANYNUMMODE NUMBER) (NA NA NA) ARG ; When computing a value, just return the constant unchanged. c @@ -419,7 +454,8 @@ ; ??? Not all of the combinations are supported in the simulator. ; They'll get added as necessary. (drn (join &options &out-mode in-mode arg1 . arg-rest) - (OPTIONS NUMMODE NUMMODE RTX . RTX) (NA NA NA ANY . ANY) + #f + (OPTIONS ANYNUMMODE ANYNUMMODE RTX . RTX) (NA NA NA ANY . ANY) MISC ; FIXME: Ensure correct number of args for in/out modes. ; FIXME: Ensure compatible modes. @@ -434,13 +470,14 @@ ; ??? GCC plans to switch to SUBREG_BYTE. Keep an eye out for the switch ; (which is extensive so probably won't happen anytime soon). ; -; The mode spec of operand0 use to be OP0, but subword is not a normal rtx. +; The mode spec of operand0 use to be MATCHEXPR, but subword is not a normal rtx. ; The mode of operand0 is not necessarily the same as the mode of the result, ; and code which analyzes it would otherwise use the result mode (specified by ; `&mode') for the mode of operand0. (drn (subword &options &mode value word-num) - (OPTIONS NUMMODE RTX RTX) (NA NA ANY INT) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA ANY INT) ARG #f ) @@ -466,7 +503,8 @@ ; independent name. (drn (c-code &options &mode text) - (OPTIONS ANYMODE STRING) (NA NA NA) + #f + (OPTIONS ANYEXPRMODE STRING) (NA NA NA) UNSPEC #f ) @@ -482,7 +520,8 @@ ; Otherwise it is part of an expression. (drn (c-call &options &mode name . args) - (OPTIONS ANYMODE STRING . RTX) (NA NA NA . ANY) + #f + (OPTIONS ANYEXPRMODE STRING . RTX) (NA NA NA . ANY) UNSPEC #f ) @@ -490,7 +529,8 @@ ; Same as c-call but without implicit first arg of `current_cpu'. (drn (c-raw-call &options &mode name . args) - (OPTIONS ANYMODE STRING . RTX) (NA NA NA . ANY) + #f + (OPTIONS ANYEXPRMODE STRING . RTX) (NA NA NA . ANY) UNSPEC #f ) @@ -498,6 +538,7 @@ ; Set/get/miscellaneous (drn (nop &options &mode) + VOID (OPTIONS VOIDMODE) (NA NA) MISC #f @@ -506,7 +547,8 @@ ; Clobber - mark an object as modified without explaining why or how. (drn (clobber &options &mode object) - (OPTIONS ANYMODE RTX) (NA NA OP0) + VOID + (OPTIONS VOIDORNUMMODE RTX) (NA NA MATCHEXPR) MISC #f ) @@ -531,13 +573,15 @@ ; Scheme too closely. (drn (set &options &mode dst src) - (OPTIONS ANYMODE SETRTX RTX) (NA NA OP0 MATCH1) + VOID + (OPTIONS ANYNUMMODE SETRTX RTX) (NA NA MATCHEXPR MATCH2) SET #f ) (drn (set-quiet &options &mode dst src) - (OPTIONS ANYMODE SETRTX RTX) (NA NA OP0 MATCH1) + VOID + (OPTIONS ANYNUMMODE SETRTX RTX) (NA NA MATCHEXPR MATCH2) SET #f ) @@ -571,13 +615,15 @@ ; - ??? (drn (neg &options &mode s1) - (OPTIONS ANYMODE RTX) (NA NA OP0) + #f + (OPTIONS ANYNUMMODE RTX) (NA NA MATCHEXPR) UNARY #f ) (drn (abs &options &mode s1) - (OPTIONS ANYMODE RTX) (NA NA OP0) + #f + (OPTIONS ANYNUMMODE RTX) (NA NA MATCHEXPR) UNARY #f ) @@ -586,7 +632,8 @@ ; For floating point values this produces 1/x. ; ??? Might want different names. (drn (inv &options &mode s1) - (OPTIONS ANYMODE RTX) (NA NA OP0) + #f + (OPTIONS ANYINTMODE RTX) (NA NA MATCHEXPR) UNARY #f ) @@ -595,18 +642,21 @@ ; MODE is the mode of S1. The result always has mode BI. ; ??? Perhaps `mode' shouldn't be here. (drn (not &options &mode s1) - (OPTIONS ANYMODE RTX) (NA NA OP0) + BI + (OPTIONS ANYINTMODE RTX) (NA NA MATCHEXPR) UNARY #f ) (drn (add &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (sub &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) @@ -616,54 +666,64 @@ ; For the *flag rtx's, MODE is the mode of S1,S2; the result always has ; mode BI. (drn (addc &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + #f + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (addc-cflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (addc-oflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (subc &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + #f + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (subc-cflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (subc-oflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) ;; ??? These are deprecated. Delete in time. (drn (add-cflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (add-oflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (sub-cflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) (drn (sub-oflag &options &mode s1 s2 s3) - (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI) + BI + (OPTIONS ANYINTMODE RTX RTX RTX) (NA NA MATCHEXPR MATCH2 BI) TRINARY #f ) @@ -690,7 +750,8 @@ ; Multiply/divide. (drn (mul &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) @@ -699,22 +760,26 @@ ; [both host and target], and one that specifies implementation defined ; situations [target]. (drn (div &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (udiv &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (mod &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (umod &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) @@ -724,19 +789,22 @@ ; various floating point routines (drn (sqrt &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA OP0) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA MATCHEXPR) UNARY #f ) (drn (cos &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA OP0) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA MATCHEXPR) UNARY #f ) (drn (sin &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA OP0) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA MATCHEXPR) UNARY #f ) @@ -744,42 +812,49 @@ ; min/max (drn (min &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (max &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (umin &options &mode s1 s2) - (OPTIONS INTMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (umax &options &mode s1 s2) - (OPTIONS INTMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) ; These are bitwise operations. (drn (and &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (or &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) (drn (xor &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR MATCH2) BINARY #f ) @@ -787,29 +862,34 @@ ; Shift operations. (drn (sll &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT) BINARY #f ) (drn (srl &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT) BINARY #f ) ; ??? In non-sim case, ensure s1 is in right C type for right result. (drn (sra &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT) BINARY #f ) ; Rotates don't really have a sign, so doesn't matter what we say. (drn (ror &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT) BINARY #f ) (drn (rol &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT) + #f + (OPTIONS ANYINTMODE RTX RTX) (NA NA MATCHEXPR INT) BINARY #f ) @@ -822,12 +902,14 @@ ; On the other hand, handling an arbitrary number of args isn't supported by ; ISA's, which the main goal of what we're trying to represent. (drn (andif &options &mode s1 s2) - (OPTIONS DFLTMODE RTX RTX) (NA NA ANY ANY) + BI + (OPTIONS BIMODE RTX RTX) (NA NA ANYINT ANYINT) BINARY ; IF? #f ) (drn (orif &options &mode s1 s2) - (OPTIONS DFLTMODE RTX RTX) (NA NA ANY ANY) + BI + (OPTIONS BIMODE RTX RTX) (NA NA ANYINT ANYINT) BINARY ; IF? #f ) @@ -843,47 +925,56 @@ ; Conversions. (drn (ext &options &mode s1) - (OPTIONS INTMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYINTMODE RTX) (NA NA ANY) UNARY #f ) (drn (zext &options &mode s1) - (OPTIONS INTMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYINTMODE RTX) (NA NA ANY) UNARY #f ) (drn (trunc &options &mode s1) - (OPTIONS INTMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYINTMODE RTX) (NA NA ANY) UNARY #f ) (drn (fext &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA ANY) UNARY #f ) (drn (ftrunc &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA ANY) UNARY #f ) (drn (float &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA ANY) UNARY #f ) (drn (ufloat &options &mode s1) - (OPTIONS FLOATMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYFLOATMODE RTX) (NA NA ANY) UNARY #f ) (drn (fix &options &mode s1) - (OPTIONS INTMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYINTMODE RTX) (NA NA ANY) UNARY #f ) (drn (ufix &options &mode s1) - (OPTIONS INTMODE RTX) (NA NA ANY) + #f + (OPTIONS ANYINTMODE RTX) (NA NA ANY) UNARY #f ) @@ -892,54 +983,64 @@ ; MODE is the mode of S1,S2. The result always has mode BI. (drn (eq &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (ne &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) ; ??? In non-sim case, ensure s1,s2 is in right C type for right result. (drn (lt &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (le &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (gt &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (ge &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) ; ??? In non-sim case, ensure s1,s2 is in right C type for right result. (drn (ltu &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (leu &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (gtu &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) (drn (geu &options &mode s1 s2) - (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1) + BI + (OPTIONS ANYNUMMODE RTX RTX) (NA NA MATCHEXPR MATCH2) COMPARE #f ) @@ -951,7 +1052,8 @@ ; VALUE is any constant rtx. SET is a `number-list' rtx. (drn (member &options &mode value set) - (OPTIONS DFLTMODE RTX RTX) (NA NA INT INT) + #f + (OPTIONS BIMODE RTX RTX) (NA NA INT INT) MISC (begin (if (not (rtx-constant? value)) @@ -965,7 +1067,11 @@ (rtx-false))) ) +;; FIXME: "number" in "number-list" implies floats are ok. +;; Rename to integer-list, int-list, or some such. + (drn (number-list &options &mode value-list) + #f (OPTIONS INTMODE NUMBER . NUMBER) (NA NA NA . NA) MISC #f @@ -975,30 +1081,36 @@ ; FIXME: make syntax node? (drn (if &options &mode cond then . else) - (OPTIONS ANYMODE TESTRTX RTX . RTX) (NA NA ANY OP0 . MATCH2) + #f + ;; ??? It would be cleaner if TESTRTX had to have BI mode. + (OPTIONS VOIDORNUMMODE TESTRTX RTX . RTX) (NA NA ANYINT MATCHEXPR . MATCH3) IF (apply e-if (append! (list *estate* mode cond then) else)) ) ; ??? The syntax here isn't quite that of Scheme. A condition must be ; followed by a result expression. +; ??? The syntax here isn't quite right, there must be at least one cond rtx. ; ??? Intermediate expressions (the ones before the last one) needn't have ; the same mode as the result. (drsn (cond &options &mode . cond-code-list) - (OPTIONS ANYMODE . CONDRTX) (NA NA . OP0) + #f + (OPTIONS VOIDORNUMMODE . CONDRTX) (NA NA . MATCHEXPR) COND #f ) +; ??? The syntax here isn't quite right, there must be at least one case. ; ??? Intermediate expressions (the ones before the last one) needn't have ; the same mode as the result. (drn (case &options &mode test . case-list) - (OPTIONS ANYMODE RTX . CASERTX) (NA NA ANY . OP0) + #f + (OPTIONS VOIDORNUMMODE RTX . CASERTX) (NA NA ANY . MATCHEXPR) COND #f ) -; parallel, sequence, do-count +; parallel, sequence, do-count, closure ; This has to be a syntax node as we don't want EXPRS to be pre-evaluated. ; All semantic ops must have a mode, though here it must be VOID. @@ -1006,6 +1118,7 @@ ; ??? There's no real need for mode either, but convention requires it. (drsn (parallel &options &mode ignore expr . exprs) + #f (OPTIONS VOIDMODE LOCALS RTX . RTX) (NA NA NA VOID . VOID) SEQUENCE #f @@ -1016,7 +1129,8 @@ ; ??? This should create a closure. (drsn (sequence &options &mode locals expr . exprs) - (OPTIONS ANYMODE LOCALS RTX . RTX) (NA NA NA OP0 . OP0) + #f + (OPTIONS VOIDORNUMMODE LOCALS RTX . RTX) (NA NA NA MATCHSEQ . MATCHSEQ) SEQUENCE #f ) @@ -1025,16 +1139,18 @@ ; yet and thus pre-evaluating the expressions doesn't work. (drsn (do-count &options &mode iter-var nr-times expr . exprs) + #f (OPTIONS VOIDMODE ITERATION RTX RTX . RTX) (NA NA NA INT VOID . VOID) SEQUENCE #f ) - + ; Internal rtx to create a closure. ; Internal, so it does not appear in rtl.texi. (drsn (closure &options &mode expr env) - (OPTIONS DFLTMODE RTX ENV) (NA NA NA NA) + #f + (OPTIONS VOIDORNUMMODE RTX ENV) (NA NA MATCHEXPR NA) MISC #f ) diff --git a/cgen/sem-frags.scm b/cgen/sem-frags.scm index f34d60e461..bd03cd259a 100644 --- a/cgen/sem-frags.scm +++ b/cgen/sem-frags.scm @@ -174,7 +174,7 @@ ;; MODE is the name of the mode. -(define (/frag-hash-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff) +(define (/frag-hash-compute! rtx-obj expr parent-expr op-pos tstate appstuff) (let ((h 0)) (case (rtx-name expr) ((operand) @@ -211,7 +211,7 @@ ;; MODE is the name of the mode. -(define (/frag-cost-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff) +(define (/frag-cost-compute! rtx-obj expr parent-expr op-pos tstate appstuff) ; FIXME: wip (let ((speed 0) (size 0)) @@ -990,7 +990,7 @@ (define (sem-find-common-frags insn-list) (/sem-find-common-frags-1 (begin - (logit 2 "Simplifying/canonicalizing rtl ...\n") + (logit 2 "Simplifying rtl ...\n") (map (lambda (insn) (rtx-simplify-insn #f insn)) insn-list)) diff --git a/cgen/semantics.scm b/cgen/semantics.scm index ed7abf40c6..306c43126e 100644 --- a/cgen/semantics.scm +++ b/cgen/semantics.scm @@ -71,19 +71,18 @@ ; Subroutine of semantic-compile:process-expr!, to simplify it. ; Looks up the operand in the current set, returns it if found, ; otherwise adds it. -; MODE is the mode name. ; REF-TYPE is one of 'use, 'set, 'set-quiet. ; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc. -(define (/build-operand! op-name op mode tstate ref-type op-list sem-attrs) - ;(display (list op-name mode ref-type)) (newline) (force-output) - (let* ((mode (mode-real-name (if (eq? mode 'DFLT) - (op:mode op) - (mode:lookup mode)))) - ; The first #f is a placeholder for the object. - (try (list '-op- #f mode op-name #f)) +(define (/build-operand! op-expr tstate ref-type op-list sem-attrs) + (let* ((op (rtx-operand-obj op-expr)) + (mode (rtx-mode op-expr)) + ;; The first #f is a placeholder for the object. + (try (list '-op- #f mode (rtx-arg1 op-expr) #f)) (existing-op (/rtx-find-op try op-list))) + (assert (not (eq? (op:mode-name op) 'DFLT))) + (if (and (pc? op) (memq ref-type '(set set-quiet))) (append! sem-attrs @@ -99,10 +98,10 @@ ; operands. This is done by creating shared rtx (a la gcc) - the ; operand number then need only be updated in one place. - (let ((xop (op:new-mode op mode))) - (op:set-cond?! xop (tstate-cond? tstate)) + (begin + (op:set-cond?! op (tstate-cond? tstate)) ; Set the object rtx in `try', now that we have it. - (set-car! (cdr try) (rtx-make 'xop xop)) + (set-car! (cdr try) (rtx-make-xop op)) ; Add the operand to in/out-ops. (append! op-list (list try)) (cadr try)))) @@ -116,10 +115,7 @@ (if hw - ; If the mode is DFLT, use the object's natural mode. - (let* ((mode (mode-real-name (if (eq? (rtx-mode expr) 'DFLT) - (hw-mode hw) - (mode:lookup (rtx-mode expr))))) + (let* ((mode (rtx-mode expr)) (indx-sel (rtx-reg-index-sel expr)) ; #f is a place-holder for the object (filled in later) (try (list 'reg #f mode hw-name indx-sel)) @@ -135,7 +131,7 @@ (cons hw-name indx-sel)))))) (op:set-cond?! xop (tstate-cond? tstate)) ; Set the object rtx in `try', now that we have it. - (set-car! (cdr try) (rtx-make 'xop xop)) + (set-car! (cdr try) (rtx-make-xop xop)) ; Add the operand to in/out-ops. (append! op-list (list try)) (cadr try)))) @@ -146,13 +142,9 @@ ; Subroutine of semantic-compile:process-expr!, to simplify it. (define (/build-mem-operand! expr tstate op-list) - (let ((mode (mode-real-name (mode:lookup (rtx-mode expr)))) + (let ((mode (rtx-mode expr)) (indx-sel (rtx-mem-index-sel expr))) - (if (memq mode '(DFLT VOID)) - (parse-error (tstate-context tstate) - "memory must have explicit mode" expr)) - (let* ((try (list 'mem #f mode 'h-memory indx-sel)) (existing-op (/rtx-find-op try op-list))) @@ -165,7 +157,7 @@ (cons mode indx-sel))))) (op:set-cond?! xop (tstate-cond? tstate)) ; Set the object in `try', now that we have it. - (set-car! (cdr try) (rtx-make 'xop xop)) + (set-car! (cdr try) (rtx-make-xop xop)) ; Add the operand to in/out-ops. (append! op-list (list try)) (cadr try))))) @@ -198,7 +190,7 @@ (make 'anonymous 'ifield (ifld-mode f) f) nil #f #f))) - (set-car! (cdr try) (rtx-make 'xop xop)) + (set-car! (cdr try) (rtx-make-xop xop)) (append! op-list (list try)) (cadr try))))) ) @@ -246,7 +238,7 @@ ; (send (op:type op) 'get-index-mode) f) nil #f #f))) - (set-car! (cdr try) (rtx-make 'xop xop)) + (set-car! (cdr try) (rtx-make-xop xop)) (append! op-list (list try)) (cadr try))))))) ) @@ -337,12 +329,14 @@ (sem-attrs (list #f)) ; Called for expressions encountered in SEM-CODE. - ; MODE is the name of the mode. ; Don't waste cpu here, this is part of the slowest piece in CGEN. (process-expr! - (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) + (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) (case (car expr) + ;; NOTE: Despite the ! in, e.g., /build-reg-operand!, + ;; it does return a result. + ; Registers. ((reg) (let ((ref-type (/rtx-ref-type parent-expr op-pos)) ; ??? could verify reg is a scalar @@ -373,16 +367,15 @@ out-ops)))) ; Operands. - ((operand) (let ((op (rtx-operand-obj expr)) - (ref-type (/rtx-ref-type parent-expr op-pos))) - (/build-operand! (obj:name op) op mode tstate ref-type + ((operand) (let ((ref-type (/rtx-ref-type parent-expr op-pos))) + (/build-operand! expr tstate ref-type (if (eq? ref-type 'use) in-ops out-ops) sem-attrs))) ; Give operand new name. - ((name) (let ((result (/rtx-traverse (caddr expr) 'RTX mode + ((name) (let ((result (/rtx-traverse (caddr expr) 'RTX parent-expr op-pos tstate appstuff))) (if (not (operand? result)) (error "name: invalid argument:" expr result)) @@ -509,12 +502,12 @@ (sem-attrs (list #f)) ; Called for expressions encountered in SEM-CODE. - ; MODE is the name of the mode. (process-expr! - (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) + (lambda (rtx-obj expr parent-expr op-pos tstate appstuff) (case (car expr) - ((operand) (if (and (eq? 'pc (obj:name (rtx-operand-obj expr))) + ;; FIXME: What's the result for the operand case? + ((operand) (if (and (eq? 'pc (rtx-operand-name expr)) (memq (/rtx-ref-type parent-expr op-pos) '(set set-quiet))) (append! sem-attrs diff --git a/cgen/sid-cpu.scm b/cgen/sid-cpu.scm index d401343cfe..6fec50302b 100644 --- a/cgen/sid-cpu.scm +++ b/cgen/sid-cpu.scm @@ -705,18 +705,25 @@ using namespace cgen; (define (gen-semantic-code insn) ; Indicate generating code for INSN. - ; Use the compiled form if available. - ; The case when they're not available is for virtual insns. - (let ((sem-c-code - (if (insn-compiled-semantics insn) - (rtl-c++-parsed VOID (insn-compiled-semantics insn) nil - #:rtl-cover-fns? #t - #:owner insn) - (rtl-c++ VOID (insn-semantics insn) nil - #:rtl-cover-fns? #t - #:owner insn))) - ) - sem-c-code) + ; Use the canonical form if available. + ; The case when they're not available is for virtual insns. (??? Still true?) + (cond ((insn-compiled-semantics insn) + => (lambda (sem) + (rtl-c++-parsed VOID sem nil + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner insn))) + ((insn-canonical-semantics insn) + => (lambda (sem) + (rtl-c++-parsed VOID sem nil + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner insn))) + (else + (rtl-c++ VOID (insn-semantics insn) nil + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner insn))) ) ; Return definition of C function to perform INSN. @@ -887,6 +894,7 @@ using namespace @prefix@; // FIXME: namespace organization still wip\n")) (string-append " " (rtl-c++ VOID (isa-setup-semantics (current-isa)) nil + #:for-insn? #t #:rtl-cover-fns? #t #:owner insn)) "") @@ -1112,16 +1120,19 @@ struct @prefix@_pbb_label { (let ((sem (sfrag-compiled-semantics frag)) ; If the frag has one owner, use it. Otherwise indicate the owner is ; unknown. In cases where the owner is needed by the semantics, the - ; frag should have only one owner. + ; frag should have only one owner. In practice this means that frags + ; with the ref,current-insn rtx cannot be used by multiple insns. (owner (if (= (length (sfrag-users frag)) 1) (car (sfrag-users frag)) #f)) ) (if sem (rtl-c++-parsed VOID sem locals + #:for-insn? #t #:rtl-cover-fns? #t #:owner owner) (rtl-c++ VOID (sfrag-semantics frag) locals + #:for-insn? #t #:rtl-cover-fns? #t #:owner owner))) ) diff --git a/cgen/sid.scm b/cgen/sid.scm index dffeb964fb..4e43fa44ad 100644 --- a/cgen/sid.scm +++ b/cgen/sid.scm @@ -640,7 +640,7 @@ (method-make! 'cxmake-get (lambda (self estate mode index selector) - (let ((mode (if (mode:eq? 'DFLT mode) + (let ((mode (if (mode:eq? 'DFLT mode) ;; FIXME: delete, DFLT (hw-mode self) mode)) (default-selector? (hw-selector-default? selector))) @@ -1021,7 +1021,7 @@ (/op-gen-delayed-set-maybe-trace op estate mode index selector newval #f)) -(define (/op-gen-set-trace op estate mode index selector newval) +(define (/op-gen-set-trace1 op estate mode index selector newval) (string-append " {\n" " " (mode:c-type mode) " opval = " (cx:c newval) ";\n" @@ -1083,6 +1083,18 @@ " }\n") ) +(define (/op-gen-set-trace op estate mode index selector newval) + ;; If tracing hasn't been enabled, use gen-set-quiet, mostly to reduce + ;; diffs in the generated source from pre-full-canonicalization cgen. + (if (or (and (with-profile?) + (op:cond? op)) + (not (current-pbb-engine?)) + ;; FIXME: Why doesn't gen-set-quiet check op:setter? + (op:setter op)) + (/op-gen-set-trace1 op estate mode index selector newval) + (/op-gen-set-quiet op estate mode index selector newval)) +) + (define (/op-gen-delayed-set-trace op estate mode index selector newval) (/op-gen-delayed-set-maybe-trace op estate mode index selector newval #t)) diff --git a/cgen/sim-cpu.scm b/cgen/sim-cpu.scm index d4b3fb601f..cdb9c20d6a 100644 --- a/cgen/sim-cpu.scm +++ b/cgen/sim-cpu.scm @@ -535,6 +535,7 @@ SEM_FN_NAME (@prefix@,init_idesc_table) (SIM_CPU *current_cpu) (string-append " " (rtl-c VOID (isa-setup-semantics (current-isa)) nil + #:for-insn? #t #:rtl-cover-fns? #t #:owner insn) "\n") @@ -542,13 +543,24 @@ SEM_FN_NAME (@prefix@,init_idesc_table) (SIM_CPU *current_cpu) ; Indicate generating code for INSN. ; Use the compiled form if available. - ; The case when they're not available is for virtual insns. - (let ((sem (insn-compiled-semantics insn))) - (if sem - (rtl-c-parsed VOID sem nil - #:rtl-cover-fns? #t #:owner insn) - (rtl-c VOID (insn-semantics insn) nil - #:rtl-cover-fns? #t #:owner insn)))) + ; The case when they're not available is for virtual insns. (??? Still true?) + (cond ((insn-compiled-semantics insn) + => (lambda (sem) + (rtl-c-parsed VOID sem nil + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner insn))) + ((insn-canonical-semantics insn) + => (lambda (sem) + (rtl-c-parsed VOID sem nil + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner insn))) + (else + (rtl-c VOID (insn-semantics insn) nil + #:for-insn? #t + #:rtl-cover-fns? #t + #:owner insn)))) ) ; Return definition of C function to perform INSN. diff --git a/cgen/utils-gen.scm b/cgen/utils-gen.scm index 550c2bd5ee..0ae30061a0 100644 --- a/cgen/utils-gen.scm +++ b/cgen/utils-gen.scm @@ -107,7 +107,7 @@ ; cadr: fetches expression to be evaluated ; caar: fetches symbol in arglist ; cadar: fetches `pc' symbol in arglist - (rtl-c VOID (cadr decode) + (rtl-c DFLT (cadr decode) (list (list (caar decode) 'UINT extraction) (list (cadar decode) 'IAI "pc")) #:rtl-cover-fns? #f #:ifield-var? #t))) @@ -223,7 +223,7 @@ ; cadr: fetches expression to be evaluated ; caar: fetches symbol in arglist ; cadar: fetches `pc' symbol in arglist - (rtl-c VOID (cadr decode) + (rtl-c DFLT (cadr decode) (list (list (caar decode) 'UINT extraction) (list (cadar decode) 'IAI "pc")) #:rtl-cover-fns? #f #:ifield-var? #t))) @@ -255,14 +255,14 @@ (let* ((decode-proc (ifld-decode f)) (varname (gen-sym f)) (decode (string-list - ;; First, the block that extract the multi-ifield into the ifld variable + ;; First, the block that extract the multi-ifield into the ifld variable. (rtl-c VOID (multi-ifld-extract f) nil #:rtl-cover-fns? #f #:ifield-var? #t) - ;; Next, the decode routine that modifies it + ;; Next, the decode routine that modifies it. (if decode-proc (string-append " " varname " = " - (rtl-c VOID (cadr decode-proc) + (rtl-c DFLT (cadr decode-proc) (list (list (caar decode-proc) 'UINT varname) (list (cadar decode-proc) 'IAI "pc")) #:rtl-cover-fns? #f #:ifield-var? #t) diff --git a/cgen/utils.scm b/cgen/utils.scm index e69ee5ee77..70232d9b40 100644 --- a/cgen/utils.scm +++ b/cgen/utils.scm @@ -1151,7 +1151,7 @@ ) ; Return list of index numbers of elements in list L that satisfy PRED. -; I is usually 0. +; I is added to each index, it's usually 0. (define (find-index i pred l) (define (find1 i pred l result) @@ -1161,6 +1161,16 @@ (reverse! (find1 i pred l nil)) ) +; Return index number of first element in list L that satisfy PRED. +; Returns #f if not present. +; I is added to the result, it's usually 0. + +(define (find-first-index i pred l) + (cond ((null? l) #f) + ((pred (car l)) i) + (else (find-first-index (+ 1 i) pred (cdr l)))) +) + ; Return list of elements of L that satisfy PRED. (define (find pred l) -- 2.11.0