[Guile-commits] 01/13: Instruction explosion for struct-vtable

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit c7b3379a4c2111a872992202895a7fa700fb252d
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 10 19:47:58 2018 +0100

    Instruction explosion for struct-vtable
    
    * module/language/tree-il/compile-cps.scm (ensure-struct): New helper.xo
      (struct-vtable): New lowering procedure.
    * module/language/cps/types.scm (annotation->type): Add struct.
      (scm-ref/tag, scm-set!/tag): Fix to get type from annotation.
    * module/language/cps/effects-analysis.scm (annotation->memory-kind):
      Add struct.
---
 module/language/cps/effects-analysis.scm |  3 ++-
 module/language/cps/types.scm            | 10 +++++++---
 module/language/tree-il/compile-cps.scm  | 26 ++++++++++++++++++++++++++
 3 files changed, 35 insertions(+), 4 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index c638de6..829db47 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -344,7 +344,8 @@ the LABELS that are clobbered by the effects of LABEL."
     ('pair &pair)
     ('vector &vector)
     ('box &box)
-    ('closure &closure)))
+    ('closure &closure)
+    ('struct &struct)))
 
 (define-primitive-effects* param
   ((allocate-words size)           (&allocate (annotation->memory-kind param)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index fc649b0..810ad15 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -728,7 +728,8 @@ minimum, and maximum."
     ('pair &pair)
     ('vector &vector)
     ('box &box)
-    ('closure &procedure)))
+    ('closure &procedure)
+    ('struct &struct)))
 
 (define-type-inferrer/param (allocate-words param size result)
   (define! result (annotation->type param) (&min/0 size) (&max/scm-size size)))
@@ -749,8 +750,11 @@ minimum, and maximum."
      (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
      (define! result &all-types -inf.0 +inf.0))))
 
-(define-simple-type-inferrer (scm-ref/tag &pair) &all-types)
-(define-simple-type-inferrer (scm-set!/tag &pair &all-types))
+(define-type-inferrer/param (scm-ref/tag param obj result)
+  (restrict! obj (annotation->type param) -inf.0 +inf.0)
+  (define! result &all-types -inf.0 +inf.0))
+(define-type-inferrer/param (scm-set!/tag param obj val)
+  (restrict! obj (annotation->type param) -inf.0 +inf.0))
 
 (define-type-inferrer/param (scm-set! param obj idx val)
   (restrict! obj (annotation->type param) (1+ (&min/0 idx)) +inf.0))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 60a4072..03861a9 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -616,6 +616,32 @@
            ($continue k src
              ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))
 
+(define (ensure-struct cps src op x have-vtable)
+  (define not-struct
+    (vector 'wrong-type-arg
+            (symbol->string op)
+            "Wrong type argument in position 1 (expecting struct): ~S"))
+  (with-cps cps
+    (letv vtable)
+    (letk knot-struct
+          ($kargs () () ($throw src 'throw/value+data not-struct (x))))
+    (let$ body (have-vtable vtable))
+    (letk k ($kargs ('vtable) (vtable) ,body))
+    (letk kvtable ($kargs () ()
+                    ($continue k src ($primcall 'scm-ref/tag 'struct (x)))))
+    (letk kheap-object
+          ($kargs () () ($branch knot-struct kvtable src 'struct? #f (x))))
+    (build-term ($branch knot-struct kheap-object src 'heap-object? #f (x)))))
+
+(define-primcall-converter struct-vtable
+  (lambda (cps k src op param struct)
+    (ensure-struct
+     cps src 'struct-vtable struct
+     (lambda (cps vtable)
+       (with-cps cps
+         (build-term
+           ($continue k src ($values (vtable)))))))))
+
 (define-primcall-converters
   (char->integer scm >u64)
   (integer->char u64 >scm)