wingo pushed a commit to branch master in repository guile. commit 21d5897b4c232b83f8bb35496001804a9148e881 Author: Andy Wingo <wi...@pobox.com> Date: Tue Apr 10 13:45:33 2018 +0200
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. --- module/language/cps/compile-bytecode.scm | 2 -- module/language/cps/effects-analysis.scm | 3 +-- module/language/cps/slot-allocation.scm | 2 +- module/language/cps/types.scm | 4 ---- module/language/tree-il/compile-cps.scm | 23 +++++++++++++++++++---- module/system/vm/assembler.scm | 1 - 6 files changed, 21 insertions(+), 14 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index aa8c120..bcd535f 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 7b65671..b19027d 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 6f19f7d..d3f7ce3 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 1f24e02..9fb0df9 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 8afb7cf..4724375 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 cd12f2c..6bb1475 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