diff options
author | Andy Wingo <wingo@pobox.com> | 2021-06-03 21:35:20 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-10-01 11:28:22 +0200 |
commit | c8c35c6987a1f072aacb5d8d2a41b245d255dac2 (patch) | |
tree | d11eb78ae2110c1a951f0c1ae163086b125929b5 | |
parent | 8fab68f8b1e50c6e429bc8053cfeeff26baae4c4 (diff) | |
download | guile-c8c35c6987a1f072aacb5d8d2a41b245d255dac2.tar.gz |
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.
-rw-r--r-- | module/language/cps/utils.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 11 |
2 files changed, 18 insertions, 6 deletions
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))) |