[Guile-commits] 13/24: Instruction explosion for char->integer

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 21d5897b4c232b83f8bb35496001804a9148e881
Author: Andy Wingo <address@hidden>
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