diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-26 19:53:20 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-26 19:53:20 -0700 |
| commit | fd906cb17c6b51bcc61d6aea134d3857a294b627 (patch) | |
| tree | c0f64658c23371b5bf66570c24985241e901cf45 /share | |
| parent | 5f107b22b84b603d6bf4a554a4be729883fd6d7c (diff) | |
| download | txr-fd906cb17c6b51bcc61d6aea134d3857a294b627.tar.gz txr-fd906cb17c6b51bcc61d6aea134d3857a294b627.tar.bz2 txr-fd906cb17c6b51bcc61d6aea134d3857a294b627.zip | |
vm/asm: new swtch instruction.
* share/txr/stdlib/asm.tl (backpatch-low16, backpatch-high16):
New struct types.
(%backpatch-low16%, %backpatch-high16%): New global variables.
(swtch): New opcode.
(op-swtch): New opcode class.
* vm.c (vm_swtch): New static function.
(vm_execute): Handle SWTCH opcode via vm_swtch.
* vmop.h: Regenerated.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/asm.tl | 40 |
1 files changed, 40 insertions, 0 deletions
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl index 88c801e2..bba50b39 100644 --- a/share/txr/stdlib/asm.tl +++ b/share/txr/stdlib/asm.tl @@ -279,6 +279,21 @@ (2 (chr-int val)) (t (error "assembler: bad immediate operand: ~s" bits))))) +(defstruct backpatch-low16 nil + (:method backpatch (me asm at offs) + (tree-bind (hi lo) asm.(get-pair) + asm.(set-pos at) + asm.(put-pair hi offs)))) + +(defstruct backpatch-high16 nil + (:method backpatch (me asm at offs) + (tree-bind (hi lo) asm.(get-pair) + asm.(set-pos at) + asm.(put-pair offs lo)))) + +(defvarl %backpatch-low16% (new backpatch-low16)) +(defvarl %backpatch-high16% (new backpatch-high16)) + (defmacro defopcode (class symbol code . slot-defs) ^(symacrolet ((auto (pinc %oc-code%))) (defstruct ,class oc-base @@ -512,6 +527,31 @@ (defopcode-derived op-ifql ifql auto op-ifq) +(defopcode op-swtch swtch auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 1 syntax) + (let* ((args asm.(parse-args me syntax '(r))) + (lbls (cddr syntax)) + (tblsz (len lbls))) + asm.(put-insn me.code tblsz (car args)) + (while lbls + (let ((x asm.(lookup-label (pop lbls) %backpatch-low16%)) + (y (if lbls + asm.(lookup-label (pop lbls) %backpatch-high16%) + 0))) + asm.(put-pair y x))))) + + (:method dis (me asm tblsz switch-val) + (build + (add me.symbol) + (add (operand-to-sym switch-val)) + (while (> tblsz 0) + (dec tblsz 2) + (tree-bind (y x) asm.(get-pair) + (add x) + (unless (minusp tblsz) + (add y))))))) + (defopcode-derived op-uwprot uwprot auto op-jmp) (defopcode op-block block auto |