mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Allow unchecked functions to have unboxed arguments

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2021-06-03 21:35:20 +02:00
parent 8fab68f8b1
commit c8c35c6987
2 changed files with 18 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

13
module/language/cps/utils.scm
View file

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

11
module/language/tree-il/compile-cps.scm
View file

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