[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/12: Add tag-fixnum instruction
From: |
Andy Wingo |
Subject: |
[Guile-commits] 07/12: Add tag-fixnum instruction |
Date: |
Sat, 11 Nov 2017 16:12:25 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 8b5f9648ff806157f90489b1f5eb26fb1e05a8cf
Author: Andy Wingo <address@hidden>
Date: Thu Nov 9 14:18:01 2017 +0100
Add tag-fixnum instruction
* libguile/vm-engine.c (tag-fixnum): New instruction.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/cse.scm (compute-equivalent-subexpressions):
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm (&min/fixnum, &max/fixnum, tag-fixnum):
* module/system/vm/assembler.scm: Add support for the new instruction.
---
libguile/vm-engine.c | 12 +++++++++++-
module/language/cps/compile-bytecode.scm | 2 ++
module/language/cps/cse.scm | 5 +++++
module/language/cps/effects-analysis.scm | 3 ++-
module/language/cps/types.scm | 6 ++++++
module/system/vm/assembler.scm | 1 +
6 files changed, 27 insertions(+), 2 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4c4d9eb..c2b0156 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -4057,7 +4057,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (215, unused_215, NULL, NOP)
+ VM_DEFINE_OP (215, tag_fixnum, "tag-fixnum", OP1 (X8_S12_S12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+
+ UNPACK_12_12 (op, dst, src);
+
+ SP_SET (dst, SCM_I_MAKINUM (SP_REF_S64 (src)));
+
+ NEXT (1);
+ }
+
VM_DEFINE_OP (216, unused_216, NULL, NOP)
VM_DEFINE_OP (217, unused_217, NULL, NOP)
VM_DEFINE_OP (218, unused_218, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index ed25148..2e3697b 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -271,6 +271,8 @@
(from-sp (slot expected)) (from-sp (slot desired))))
(($ $primcall 'untag-fixnum #f (src))
(emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
+ (($ $primcall 'tag-fixnum #f (src))
+ (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src))))
(($ $primcall name #f args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index a074c7b..b4b23ed 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -329,6 +329,11 @@ false. It could be that both true and false proofs are
available."
(match defs
((scm)
(add-def! `(primcall scm->s64 #f ,scm) s64))))
+ (('primcall 'untag-fixnum #f scm)
+ (match defs
+ ((s64)
+ (add-def! `(primcall s64->scm #f ,s64) scm)
+ (add-def! `(primcall tag-fixnum #f ,s64) scm))))
(_ #t))))
(define (visit-label label equiv-labels var-substs)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 9a7f70d..3131366 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -374,7 +374,8 @@ is or might be a read or a write to the same location as A."
((load-s64))
((s64->scm _))
((s64->scm/unlikely _))
- ((untag-fixnum _)))
+ ((untag-fixnum _))
+ ((tag-fixnum _)))
;; Bytevectors.
(define-primitive-effects
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 267e9ef..c40a807 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -398,6 +398,8 @@ minimum, and maximum."
(define-syntax-rule (&max/u64 x) (min (&max x) &u64-max))
(define-syntax-rule (&min/s64 x) (max (&min x) &s64-min))
(define-syntax-rule (&max/s64 x) (min (&max x) &s64-max))
+(define-syntax-rule (&min/fixnum x) (max (&min x) most-negative-fixnum))
+(define-syntax-rule (&max/fixnum x) (min (&max x) most-positive-fixnum))
(define-syntax-rule (&max/size x) (min (&max x) (target-max-size-t)))
(define-syntax-rule (&max/scm-size x) (min (&max x) (target-max-size-t/scm)))
@@ -901,6 +903,10 @@ minimum, and maximum."
(define-type-inferrer (untag-fixnum scm result)
(define! result &s64 (&min/s64 scm) (&max/s64 scm)))
+(define-simple-type-checker (tag-fixnum (logior &s64 &u64)))
+(define-type-inferrer (tag-fixnum s64 result)
+ (define! result &fixnum (&min/fixnum s64) (&max/fixnum s64)))
+
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 5fccd86..dbbe812 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -98,6 +98,7 @@
emit-eof-object?
emit-untag-fixnum
+ emit-tag-fixnum
emit-throw
(emit-throw/value* . emit-throw/value)
- [Guile-commits] branch master updated (f96a670 -> 83a03a3), Andy Wingo, 2017/11/11
- [Guile-commits] 01/12: Fix effects analysis bug introduced with primcall param, Andy Wingo, 2017/11/11
- [Guile-commits] 02/12: Refactor numeric comparison bytecode emission, Andy Wingo, 2017/11/11
- [Guile-commits] 05/12: Closure conversion uses immediate variants of vector instructions, Andy Wingo, 2017/11/11
- [Guile-commits] 06/12: Use immediate primcalls when unfolding constructors, Andy Wingo, 2017/11/11
- [Guile-commits] 09/12: Convert "ash" to "lsh"/"rsh" when lowering to CPS, Andy Wingo, 2017/11/11
- [Guile-commits] 12/12: Specialize rsh/lsh, not ash, Andy Wingo, 2017/11/11
- [Guile-commits] 07/12: Add tag-fixnum instruction,
Andy Wingo <=
- [Guile-commits] 08/12: Compiler uses target fixnum range, Andy Wingo, 2017/11/11
- [Guile-commits] 03/12: Canonicalize <=, >=, and > primcalls to <, Andy Wingo, 2017/11/11
- [Guile-commits] 11/12: Add missing lsh/immediate, rsh/immediate type inferrers, Andy Wingo, 2017/11/11
- [Guile-commits] 04/12: Specialize comparisons to SCM as s64, Andy Wingo, 2017/11/11
- [Guile-commits] 10/12: Type folding has "macro reduction" phase, Andy Wingo, 2017/11/11