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