diff options
Diffstat (limited to 'type/dictionary.scm')
| -rw-r--r-- | type/dictionary.scm | 229 |
1 files changed, 229 insertions, 0 deletions
diff --git a/type/dictionary.scm b/type/dictionary.scm new file mode 100644 index 0000000..0a0260e --- /dev/null +++ b/type/dictionary.scm @@ -0,0 +1,229 @@ + +;;; type/dictionary.scm + +;;; This function supports dictionary conversion. It creates lambda +;;; variables to bind to the dictionary args needed by the context. +;;; The actual conversion to lambda is done in the cfn. Each tyvar in +;;; the context has an associated mapping from class to dictionary +;;; variable. This mapping depends on the decl containing the placeholder +;;; since different recursive decls share common tyvars. The mapping is +;;; two levels: decl -> class -> var. + +;;; Due to language restrictions this valdef must be a simple variable +;;; definition. + +(define (dictionary-conversion/definition valdef tyvars) + (let* ((var (decl-var valdef)) + (type (var-type var)) + (context (gtype-context type)) + (dict-param-vars '())) + (dolist (c context) + (let ((tyvar (car tyvars)) + (dparams '())) + (when (not (null? c)) + (dolist (class c) + (let ((var (create-temp-var + (string-append "d_" + (symbol->string (def-name class)))))) + (setf (var-force-strict? var) '#t) + (push (tuple class var) dparams) + (push var dict-param-vars))) + (push (tuple valdef dparams) (ntyvar-dict-params tyvar))) + (setf tyvars (cdr tyvars)))) + (setf (valdef-dictionary-args valdef) (nreverse dict-param-vars)))) + +;;; These routines deal with dict-var processing. + +;;; This discharges the tyvars associated with dictionaries. The dict-vars +;;; to be processed at the next level are returned. + +(define (process-placeholders placeholders deferred decls) + (if (null? placeholders) + deferred + (let ((d1 (process-placeholder (car placeholders) deferred decls))) + (process-placeholders (cdr placeholders) d1 decls)))) + +;;; This processes a placeholder. The following cases arise: +;;; a) the variable has already been processed (no placeholders remain) - +;;; ignore it. placeholders may contain duplicates so this is likely. +;;; b) the type variable is from an outer type environment (in ng-list) +;;; and should just be passed up to the next level (added to old-placeholders) +;;; c) the type variable is associated with a dictionary parameter +;;; d) the type variable is instantiated to a type constructor +;;; e) the type variable is ambiguous (none of the above) + +(define (process-placeholder p deferred decls) + (let* ((tyvar (placeholder-tyvar p)) + (type (prune tyvar))) + (cond ((ntycon? type) + (process-instantiated-tyvar + (expand-ntype-synonym type) p deferred decls)) + ((non-generic? type) + (cons p deferred)) + ((not (null? (ntyvar-dict-params type))) + (if (dict-placeholder? p) + (placeholder->dict-param p (ntyvar-dict-params type) decls) + (placeholder->method p (ntyvar-dict-params type) decls)) + deferred) + (else + ;; Since default types are monotypes, no new vars will + ;; be added to old-placeholders + (when (maybe-default-ambiguous-tyvar + type (placeholder-overloaded-var p) + (valdef-module (car (placeholder-enclosing-decls p)))) + (process-placeholder p deferred decls)) + deferred)))) + +;;; The type variable is associated with a dictionary parameter. The only +;;; complication here is that the class needed may not be directly available - +;;; it may need to be obtained from the super classes of the parameter +;;; dictionaries. + +(define (placeholder->dict-param p param-vars decls) + (let ((class (dict-placeholder-class p)) + (edecls (dict-placeholder-enclosing-decls p))) + (setf (placeholder-exp p) + (dict-reference-code class (locate-params param-vars edecls decls))))) + +(define (dict-reference-code class param-vars) + (let ((var (assq class param-vars))) + (if (not (eq? var '#f)) + (**var/def (tuple-2-2 var)) + (search-superclasses class param-vars)))) + +(define (locate-params param-vars enclosing-decls decls) + (if (null? (cdr param-vars)) + (tuple-2-2 (car param-vars)) + (let ((decl (search-enclosing-decls enclosing-decls decls))) + (tuple-2-2 (assq decl param-vars))))) + +;;; This finds the first dictionary containing the needed class in its +;;; super classes and generates a selector to get the needed dictionary. + +(define (search-superclasses class param-vars) + (let ((pclass (tuple-2-1 (car param-vars)))) + (if (memq class (class-super* pclass)) + (**dsel/dict pclass class (**var/def (tuple-2-2 (car param-vars)))) + (search-superclasses class (cdr param-vars))))) + +(define (placeholder->method p param-vars decls) + (let* ((method (method-placeholder-method p)) + (class (method-var-class method)) + (edecls (placeholder-enclosing-decls p)) + (params (locate-params param-vars edecls decls))) + (setf (placeholder-exp p) + (method-reference-code method class params)))) + +(define (method-reference-code m c param-vars) + (let ((pclass (tuple-2-1 (car param-vars)))) + (if (or (eq? c pclass) + (memq c (class-super* pclass))) + (let* ((msel (assq m (class-selectors pclass))) + (mvar (tuple-2-2 msel))) + (**app (**var/def mvar) (**var/def (tuple-2-2 (car param-vars))))) + (method-reference-code m c (cdr param-vars))))) + +;;; This is for tyvars instantiated to a tycon. A reference to the +;;; appropriate dictionary is generated. This reference must be recursively +;;; dictionary converted since dictionaries may need subdictionaries +;;; when referenced. + +(define (process-instantiated-tyvar tycon p deferred decls) + (let* ((alg (ntycon-tycon tycon)) + (edecls (placeholder-enclosing-decls p)) + (var (placeholder-overloaded-var p)) + (class (if (dict-placeholder? p) + (dict-placeholder-class p) + (method-var-class (method-placeholder-method p)))) + (instance (lookup-instance alg class))) + (if (dict-placeholder? p) + (mlet (((code def1) + (generate-dict-ref instance tycon deferred decls edecls var))) + (setf (placeholder-exp p) code) + (setf deferred def1)) + (let ((method (method-placeholder-method p))) + (if (every (function null?) (instance-gcontext instance)) + (let ((mvar (tuple-2-2 + (assq method (instance-methods instance))))) + (setf (placeholder-exp p) (**var/def mvar))) + (mlet (((code def1) + (generate-dict-ref + instance tycon deferred decls edecls var)) + (sel (tuple-2-2 (assq method (class-selectors class))))) + (setf (method-placeholder-exp p) (**app (**var/def sel) code)) + (setf deferred def1))))) + deferred)) + +;;; This generates a reference to a specific dictionary and binds +;;; needed subdictionaries. Since subdictionaries may be part of the outer +;;; type environment new placeholders may be generated for later resolution. + +(define (generate-dict-ref instance type deferred decls edecls var) + (let* ((ctxt (instance-gcontext instance)) + (dict (dict-ref-code instance))) + (do-contexts (class ctxt) (ty (ntycon-args type)) + (let ((ntype (prune ty))) + (cond + ((ntycon? ntype) + (mlet ((ntype (expand-ntype-synonym ntype)) + (alg (ntycon-tycon ntype)) + (instance (lookup-instance alg class)) + ((code dv1) + (generate-dict-ref + instance ntype deferred decls edecls var))) + (setf dict (**app dict code)) + (setf deferred dv1))) + ((non-generic? ntype) + (let ((p (**dict-placeholder + class ntype edecls var))) + (setf dict (**app dict p)) + (push p deferred))) + ((null? (ntyvar-dict-params ntype)) + (let ((ref-code (**dict-placeholder + class ntype edecls var))) + (when (maybe-default-ambiguous-tyvar + ntype var (valdef-module (car edecls))) + (process-placeholder ref-code '() decls)) + (setf dict (**app dict ref-code)))) + (else + (let ((p (locate-params (ntyvar-dict-params ntype) edecls decls))) + (setf dict (**app dict (dict-reference-code class p)))))))) + (values dict deferred))) + +;;; The following routines deal with recursive placeholders. The basic +;;; strategy is to pass the entire context as a parameter with each +;;; recursive call (this could be optimized later to make use of an +;;; internal entry point). The basic complication is that the context +;;; of each function in a letrec may be arranged differently. + +;;; This generates a call inside decl 'from' to the var 'to'. Vmap is an +;;; alist from vars to a list of vars corresponding to the gtyvars of +;;; the decl signature. + +(define (recursive-call-code from to vmap) + (let ((exp (**var/def to)) + (tyvars (tuple-2-2 (assq to vmap))) + (contexts (gtype-context (var-type to)))) + (do-contexts (class contexts) (tyvar tyvars) + (setf exp (**app exp (locate-param-var tyvar class from)))) + exp)) + +(define (locate-param-var tyvar class decl) + (let ((vmap (tuple-2-2 (assq decl (ntyvar-dict-params tyvar))))) + (**var/def (tuple-2-2 (assq class vmap))))) + +;;; This is used to get the code for a specific dictionary reference. + +(define (dict-ref-code instance) + (**var/def (instance-dictionary instance))) + +;;; This is used to locate the correct enclosing decl. + +(define (search-enclosing-decls decl-list decls) + (cond ((null? decl-list) + (error "Lost decl in search-enclosing-decls!")) + ((memq (car decl-list) decls) + (car decl-list)) + (else + (search-enclosing-decls (cdr decl-list) decls)))) + |