make the prolog vm interuptable and play nicely with gc issues

parent 9060ed0c
......@@ -49,6 +49,8 @@ constant = #(nlocals nstack constants code)
(<global> SCM *gp-not-n* (<scm> #f))
(<global> SCM *gp-is-delayed?* (<scm> #f))
(<declare-s> void INTERUPT ())
(<declare-s> void gp_gc ())
(<declare-s> SCM gp_get_state_token ())
(<declare-s> SCM gp_cons_bang ((SCM x) (SCM y) (SCM s)))
(<declare-s> SCM gp_cons_simple ((SCM x) (SCM y) (SCM s)))
......@@ -1407,6 +1409,10 @@ constant = #(nlocals nstack constants code)
code)
p))
(define-syntax-rule (GC iter)
(<begin>
(<=> iter (<%> (<+> iter (<c> 1)) (<c> 20)))
(<if> (<==> iter (<c> 0)) (<call> gp_gc))))
(define-syntax-rule (MAKE-CC narg nlocals session middle inst ctrl-stack
sp-stack p0 p pp)
......@@ -1447,7 +1453,9 @@ constant = #(nlocals nstack constants code)
(<=> *model-lambda* model-lambda )
(<scm> #f))
(<define> (SCM *) vm-raw (((SCM *) fp)
(<define> (SCM *) vm-raw (((scm_i_thread *) thread)
((vp_t *) vp)
((SCM *) fp)
((SCM *) sp)
((SCM *) free)
((scm_t_uint32 *) recieve?)
......@@ -1481,7 +1489,8 @@ constant = #(nlocals nstack constants code)
(SCM pp (<scm> #f))
(SCM s (<scm> #f))
(SCM p (<scm> 0))
(SCM cut (<scm> 0)))
(SCM cut (<scm> 0))
(int iter (<c> 0)))
(UNPACK-ENV free narg nlocals)
......@@ -1520,6 +1529,9 @@ constant = #(nlocals nstack constants code)
(<=> inst-pt (<+> instructions ninst))
(<call> INTERUPT)
(<call> gp_gc)
(NEXT inst-pt)
(LABEL pre-unify)
......@@ -1641,6 +1653,7 @@ constant = #(nlocals nstack constants code)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> ctrl-stack (STORE-STATE-SOFT s np p ctrl-stack))
(<call> INTERUPT)
(NEXT inst-pt))
(LABEL newframe-light)
......@@ -1649,6 +1662,7 @@ constant = #(nlocals nstack constants code)
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> ctrl-stack (STORE-STATE-SOFT s np p ctrl-stack))
(<=> p np)
(<call> INTERUPT)
(NEXT inst-pt))
(LABEL newframe)
......@@ -1660,6 +1674,7 @@ constant = #(nlocals nstack constants code)
(<=> s ss)
(<=> ctrl-stack (STORE-STATE tp np s p ctrl-stack))
(<=> p np)
(<call> INTERUPT)
(NEXT inst-pt))
(LABEL newframe-negation)
......@@ -1682,6 +1697,7 @@ constant = #(nlocals nstack constants code)
(<=> ctrl-stack (STORE-STATE tp np ss p ctrl-stack))
(<=> p np)
(<=> cut np)
(<call> INTERUPT)
(NEXT inst-pt))
......@@ -1794,6 +1810,8 @@ constant = #(nlocals nstack constants code)
(LABEL goto-inst)
(PRSTACK sp fp)
(<call> INTERUPT)
(GC iter)
(<let> ((int ni (scm->int (<*> inst-pt))))
(<=> inst-pt (<+> instructions ni))
(NEXT inst-pt))
......@@ -2229,7 +2247,7 @@ constant = #(nlocals nstack constants code)
(<define> void init_prolog_vm()
(auto-inits)
(<call> vm-raw (<c> 0) (<c> 0) (<c> 0) (<c> 0) (<c> 1)))
(<call> vm-raw (<c> 0) (<c> 0) (<c> 0) (<c> 0) (<c> 0) (<c> 0) (<c> 1)))
(eval-when (compile)
(hash-for-each
......@@ -2239,5 +2257,3 @@ constant = #(nlocals nstack constants code)
touch))
(clambda->c "prolog-vm.c")
......@@ -3989,8 +3989,38 @@ SCM_DEFINE(gp_custom_fkn, "gp-custom-fkn",3,0,0,
#include "matcher.c"
#include "guile-2.2.c"
#define SCM_ASYNC_TICK_WITH_GUARD_CODE(thr, pre, post) \
do \
{ \
if (SCM_UNLIKELY (thr->pending_asyncs)) \
{ \
pre; \
scm_async_tick (); \
post; \
} \
} \
while (0)
#define AREF(a,i) ((a)[i])
#define NOOP()
#define CACHE_SP() \
do \
{ \
if(vp->fp != fp) \
{ \
long diff = fp - vp->fp + 1; \
fp = fp - diff; \
sp = sp - diff; \
} \
} while(0)
#define INTERUPT() \
SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, NOOP(), CACHE_SP ())
SCM gp_copy_vector(SCM **vector, int nvar)
{
SCM newvec = scm_c_make_vector(nvar,SCM_BOOL_F);
......@@ -4016,6 +4046,13 @@ SCM inline gp_cons_simple(SCM x, SCM y, SCM s)
return GP_UNREF(f);
}
typedef struct gp_vm
{
scm_t_uint32 *ip; /* instruction pointer */
SCM *sp; /* stack pointer */
SCM *fp; /* frame pointer */
} vp_t;
#include "prolog-vm.c"
......
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment