From c8c35c6987a1f072aacb5d8d2a41b245d255dac2 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 3 Jun 2021 21:35:20 +0200
Subject: Allow unchecked functions to have unboxed arguments

* module/language/cps/utils.scm (compute-var-representations): Use
'arg-representations from metadata for arg representations.
* module/language/tree-il/compile-cps.scm (sanitize-meta):
(convert): Make sure incoming terms have no arg representations.
---
 module/language/cps/utils.scm           | 13 ++++++++-----
 module/language/tree-il/compile-cps.scm | 11 ++++++++++-
 2 files changed, 18 insertions(+), 6 deletions(-)

(limited to 'module')

diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 8f36e4d53..2b0c91c4b 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -429,12 +429,15 @@ by a label, respectively."
        (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
         representations)
        (($ $kfun src meta self tail entry)
-        (let ((representations (if self
+        (let* ((representations (if self
                                    (intmap-add representations self 'scm)
-                                   representations)))
-          (fold1 (lambda (var representations)
-                   (intmap-add representations var 'scm))
-                 (get-defs entry) representations)))
+                                   representations))
+               (defs (get-defs entry))
+               (reprs (or (assq-ref meta 'arg-representations)
+                          (map (lambda (_) 'scm) defs))))
+          (fold (lambda (var repr representations)
+                   (intmap-add representations var repr))
+                representations defs reprs)))
        (($ $kclause arity body alt)
         (fold1 (lambda (var representations)
                  (intmap-add representations var 'scm))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index ffc8308a6..918e9044a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1581,6 +1581,15 @@ use as the proc slot."
        (letk ktail ($kargs ('tail) (tail) ,head))
        ($ (build-list ktail src vals))))))
 
+(define (sanitize-meta meta)
+  (match meta
+    (() '())
+    (((k . v) . meta)
+     (let ((meta (sanitize-meta meta)))
+       (case k
+         ((arg-representations) meta)
+         (else (acons k v meta)))))))
+
 ;;; The conversion from Tree-IL to CPS essentially wraps every
 ;;; expression in a $kreceive, which models the Tree-IL semantics that
 ;;; extra values are simply truncated.  In CPS, this means that the
@@ -1865,7 +1874,7 @@ use as the proc slot."
              (letv self)
              (letk ktail ($ktail))
              (let$ kclause (convert-clauses body ktail))
-             (letk kfun ($kfun fun-src meta self ktail kclause))
+             (letk kfun ($kfun fun-src (sanitize-meta meta) self ktail kclause))
              (let$ k (adapt-arity k fun-src 1))
              (build-term ($continue k fun-src ($fun kfun))))
            (let ((scope-id (fresh-scope-id)))
-- 
cgit v1.2.1