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