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

@@ -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)))

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))

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)