klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

kgpromises.c (4432B)

      1 /*
      2 ** kgpromises.c
      3 ** Promises features for the ground environment
      4 ** See Copyright Notice in klisp.h
      5 */
      6 
      7 #include <stdlib.h>
      8 #include <stdbool.h>
      9 #include <stdint.h>
     10 
     11 #include "kstate.h"
     12 #include "kobject.h"
     13 #include "kpromise.h"
     14 #include "kapplicative.h"
     15 #include "koperative.h"
     16 #include "kcontinuation.h"
     17 #include "kerror.h"
     18 
     19 #include "kghelpers.h"
     20 #include "kgpromises.h"
     21 
     22 /* Continuations */
     23 void do_handle_result(klisp_State *K);
     24 
     25 
     26 /* SOURCE_NOTE: this is mostly an adaptation of the library derivation
     27    in the report */
     28 
     29 /* 9.1.1 promise? */
     30 /* uses typep */
     31 
     32 /* Helper for force */
     33 void do_handle_result(klisp_State *K)
     34 {
     35     TValue *xparams = K->next_xparams;
     36     TValue obj = K->next_value;
     37     klisp_assert(ttisnil(K->next_env));
     38     /*
     39     ** xparams[0]: promise
     40     */
     41     TValue prom = xparams[0];
     42 
     43     /* check to see if promise was determined before the eval completed */
     44     if (ttisnil(kpromise_maybe_env(prom))) {
     45         /* discard obj, return previous result */
     46         kapply_cc(K, kpromise_exp(prom));
     47     } else if (ttispromise(obj)) {
     48         /* force iteratively, by sharing pairs so that when obj
     49            determines a value, prom also does */
     50         TValue node = kpromise_node(obj);
     51         kpromise_node(prom) = node;
     52         TValue expr = kpromise_exp(prom);
     53         TValue maybe_env = kpromise_maybe_env(prom);
     54         if (ttisnil(maybe_env)) {
     55             /* promise was already determined */
     56             kapply_cc(K, expr);
     57         } else {
     58             TValue new_cont = kmake_continuation(K, kget_cc(K),
     59                                                  do_handle_result, 1, prom);
     60             kset_cc(K, new_cont);
     61             ktail_eval(K, expr, maybe_env);
     62         }
     63     } else {
     64         /* memoize result */
     65         TValue node = kpromise_node(prom);
     66         kset_car(node, obj);
     67         kset_cdr(node, KNIL);
     68     }
     69 }
     70 
     71 /* 9.1.2 force */
     72 void force(klisp_State *K)
     73 {
     74     TValue *xparams = K->next_xparams;
     75     TValue ptree = K->next_value;
     76     TValue denv = K->next_env;
     77     klisp_assert(ttisenvironment(K->next_env));
     78     UNUSED(xparams);
     79     UNUSED(denv);
     80     bind_1p(K, ptree, obj);
     81     if (!ttispromise(obj)) {
     82         /* non promises force to themselves */
     83         kapply_cc(K, obj);
     84     } else if (ttisnil(kpromise_maybe_env(obj))) {
     85         /* promise was already determined */
     86         kapply_cc(K, kpromise_exp(obj));
     87     } else {
     88         TValue expr = kpromise_exp(obj);
     89         TValue env = kpromise_maybe_env(obj);
     90         TValue new_cont = kmake_continuation(K, kget_cc(K), do_handle_result, 
     91                                              1, obj);
     92         kset_cc(K, new_cont);
     93         ktail_eval(K, expr, env);
     94     }
     95 }
     96 
     97 /* 9.1.3 $lazy */
     98 void Slazy(klisp_State *K)
     99 {
    100     TValue *xparams = K->next_xparams;
    101     TValue ptree = K->next_value;
    102     TValue denv = K->next_env;
    103     klisp_assert(ttisenvironment(K->next_env));
    104     UNUSED(xparams);
    105 
    106     bind_1p(K, ptree, exp);
    107     TValue new_prom = kmake_promise(K, exp, denv);
    108     kapply_cc(K, new_prom);
    109 }
    110 
    111 /* 9.1.4 memoize */
    112 /* in kghelpers.c */
    113 
    114 /* $delay it's actually a short hand for ($lazy (memoize ...)) */
    115 void Sdelay(klisp_State *K)
    116 {
    117     TValue *xparams = K->next_xparams;
    118     TValue ptree = K->next_value;
    119     TValue denv = K->next_env;
    120     klisp_assert(ttisenvironment(K->next_env));
    121     UNUSED(xparams);
    122     UNUSED(denv);
    123 
    124     bind_1p(K, ptree, exp);
    125     TValue promise_body = kcons(K, exp, KNIL);
    126     krooted_vars_push(K, &promise_body);
    127     promise_body = kcons(K, G(K)->memoize_app, promise_body);
    128     TValue new_prom = kmake_promise(K, promise_body, denv);
    129     krooted_vars_pop(K);
    130     kapply_cc(K, new_prom);
    131 }
    132 
    133 /* init ground */
    134 void kinit_promises_ground_env(klisp_State *K)
    135 {
    136     TValue ground_env = G(K)->ground_env;
    137     TValue symbol, value;
    138 
    139     /* 9.1.1 promise? */
    140     add_applicative(K, ground_env, "promise?", typep, 2, symbol, 
    141                     i2tv(K_TPROMISE));
    142     /* 9.1.2 force */
    143     add_applicative(K, ground_env, "force", force, 0); 
    144     /* 9.1.3 $lazy */
    145     add_operative(K, ground_env, "$lazy", Slazy, 0); 
    146     /* 9.1.4 memoize */
    147     add_applicative(K, ground_env, "memoize", memoize, 0); 
    148     /* 9.1.5? $delay */
    149     add_applicative(K, ground_env, "$delay", Sdelay, 0); 
    150 }
    151 
    152 /* XXX lock? */
    153 /* init continuation names */
    154 void kinit_promises_cont_names(klisp_State *K)
    155 {
    156     Table *t = tv2table(G(K)->cont_name_table);
    157 
    158     add_cont_name(K, t, do_handle_result, "promise-handle-result");
    159 }