summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-04-10 13:45:33 +0200
committerAndy Wingo <wingo@pobox.com>2018-04-10 13:45:33 +0200
commit21d5897b4c232b83f8bb35496001804a9148e881 (patch)
tree53af0906f654b48f2b11ecee58e1799fc6b6dd86
parent935598515407376a42c7e3f6a28437ed62c660f8 (diff)
Instruction explosion for char->integer
* module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/types.scm: * module/language/cps/compile-bytecode.scm (compile-function): Remove char->integer cases. * module/system/vm/assembler.scm: Remove emit-char->integer export. * module/language/tree-il/compile-cps.scm (char->integer): Define instruction exploder.
-rw-r--r--module/language/cps/compile-bytecode.scm2
-rw-r--r--module/language/cps/effects-analysis.scm3
-rw-r--r--module/language/cps/slot-allocation.scm2
-rw-r--r--module/language/cps/types.scm4
-rw-r--r--module/language/tree-il/compile-cps.scm23
-rw-r--r--module/system/vm/assembler.scm1
6 files changed, 21 insertions, 14 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index aa8c1206c..bcd535f0c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -175,8 +175,6 @@
(($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
(emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj))
idx))
- (($ $primcall 'char->integer #f (src))
- (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'add/immediate y (x))
(emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'sub/immediate y (x))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 7b6567167..b19027df9 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -544,8 +544,7 @@ the LABELS that are clobbered by the effects of LABEL."
;; Characters.
(define-primitive-effects
((untag-char _))
- ((tag-char _))
- ((char->integer _) &type-check))
+ ((tag-char _)))
;; Atomics are a memory and a compiler barrier; they cause all effects
;; so no need to have a case for them here. (Though, see
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 6f19f7d14..d3f7ce3de 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -751,7 +751,7 @@ are comparable with eqv?. A tmp slot may be used."
'fadd 'fsub 'fmul 'fdiv))
(intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
- 'char->integer 's64->u64
+ 's64->u64
'assume-u64
'uadd 'usub 'umul
'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 1f24e023f..9fb0df966 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1605,10 +1605,6 @@ minimum, and maximum."
(define-type-inferrer (tag-char u64 result)
(define! result &char 0 (min (&max u64) *max-codepoint*)))
-(define-type-inferrer (char->integer c result)
- (restrict! c &char 0 *max-codepoint*)
- (define! result &u64 (&min/0 c) (min (&max c) *max-codepoint*)))
-
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 8afb7cf84..472437507 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1300,8 +1300,6 @@
(define-primcall-converter integer->char
(lambda (cps k src op param i)
- ;; Precondition: SLEN is a non-negative S64 that is representable as a
- ;; fixnum.
(define not-fixnum
#(wrong-type-arg
"integer->char"
@@ -1340,9 +1338,26 @@
($continue kbound0 src ($primcall 'untag-fixnum #f (i)))))
(build-term ($branch knot-fixnum kuntag src 'fixnum? #f (i))))))
-(define-primcall-converters
- (char->integer scm >u64)
+(define-primcall-converter char->integer
+ (lambda (cps k src op param ch)
+ (define not-char
+ #(wrong-type-arg
+ "char->integer"
+ "Wrong type argument in position 1 (expecting char): ~S"))
+ (with-cps cps
+ (letv ui si)
+ (letk knot-char
+ ($kargs () () ($throw src 'throw/value+data not-char (ch))))
+ (letk ktag ($kargs ('si) (si)
+ ($continue k src ($primcall 'tag-fixnum #f (si)))))
+ (letk kcvt ($kargs ('ui) (ui)
+ ($continue ktag src ($primcall 'u64->s64 #f (ui)))))
+ (letk kuntag ($kargs () ()
+ ($continue kcvt src ($primcall 'untag-char #f (ch)))))
+ (build-term
+ ($branch knot-char kuntag src 'char? #f (ch))))))
+(define-primcall-converters
(rsh scm u64 >scm)
(lsh scm u64 >scm))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index cd12f2cdc..6bb1475cb 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -259,7 +259,6 @@
emit-ursh/immediate
emit-srsh/immediate
emit-ulsh/immediate
- emit-char->integer
emit-class-of
emit-make-array
emit-scm->f64