Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
G
Guile Log
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Commits
Issue Boards
Open sidebar
gule-log
Guile Log
Commits
6794ff0b
Commit
6794ff0b
authored
May 02, 2014
by
Stefan Israelsson Tampe
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
initial commit for gc of logical variables
parent
29a01677
Changes
12
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
1056 additions
and
193 deletions
+1056
-193
NEWS
NEWS
+11
-1
code-load.scm
logic/guile-log/code-load.scm
+7
-1
interpreter.scm
logic/guile-log/guile-prolog/interpreter.scm
+5
-1
macros.scm
logic/guile-log/macros.scm
+39
-20
goal-transformers.scm
logic/guile-log/prolog/goal-transformers.scm
+1
-1
state.c
logic/guile-log/src/state.c
+498
-18
unify-undo-redo.c
logic/guile-log/src/unify-undo-redo.c
+194
-52
unify.c
logic/guile-log/src/unify.c
+133
-89
unify.h
logic/guile-log/src/unify.h
+5
-0
variable.c
logic/guile-log/src/variable.c
+86
-0
umatch.scm
logic/guile-log/umatch.scm
+38
-10
gc.scm
tests/gc.scm
+39
-0
No files found.
NEWS
View file @
6794ff0b
...
...
@@ -15,6 +15,10 @@ Version 0.4
* Delimeted continuations
* A catch and throw system
Version 0.4.1
* Fixed some compiler bugs
* Fixed bug in stall
Version 0.5, TODO
* Multi threading capabilities (all)
* Tablating (all)
...
...
@@ -26,4 +30,10 @@ Version 0.5, TODO
* GC of prolog variables (all)
* GC of the (almost) unreachable tail of a stream (all)
* More general functional hashmps (all)
* Attributed variables (all)
\ No newline at end of file
* Attributed variables (all)
* Debugging facilities (prolog)
* Better error messages (prolog)
* Better compilation errors (prolog)
* Faster compilation (prolog)
* Improved matcher (prolog)
* Use guile variables when possible (prolog)
logic/guile-log/code-load.scm
View file @
6794ff0b
...
...
@@ -39,8 +39,14 @@
gp-handlers-set!
gp-cont-ids-ref
gp-cont-ids-set!
gp-guard-vars
gp-clear-frame
gp-clear-frame!
gp-gc
vlist?
vlist-cons
vlist-head
vlist-tail
vlist-null?
vlist-null
list->vlist
vlist-ref
vlist-set!
...
...
logic/guile-log/guile-prolog/interpreter.scm
View file @
6794ff0b
...
...
@@ -2,7 +2,8 @@
#
:use-module
((
logic
guile-log
)
#
:select
(
<clear>
<define>
<let>
<let*>
<=>
<lookup>
<match>
<fail>
<cut>
<wrap>
<state-ref>
<state-set!>
<continue>
<code>
<scm>
<stall>
<case-lambda>
))
<code>
<scm>
<stall>
<case-lambda>
<cc>
<newframe>
))
#
:use-module
(
logic
guile-log
guile-prolog
hash
)
#
:use-module
(
logic
guile-log
guile-prolog
fluid
)
#
:use-module
(
logic
guile-log
vlist
)
...
...
@@ -264,6 +265,8 @@ HELP FOR PROLOG COMMANDS
(
else
l
))))
(
<define>
(
wrap_frame
)
(
<let>
((
fr
(
<newframe>
)))
<cc>
))
(
<define>
(
readline_term
T
O
)
(
<let*>
((
n
(
fluid-ref
-n-
))
(
pr
(
if
(
=
n
1
)
"-? "
(
format
#f
"(~a)? "
n
)))
...
...
@@ -324,6 +327,7 @@ conversation1(X,All,Mute) :-
fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-]),
state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-],
scm[*user-data*]),
wrap_frame,
conversation2(X,All,Mute).
conversation2(X,All,Mute) :-
...
...
logic/guile-log/macros.scm
View file @
6794ff0b
...
...
@@ -8,7 +8,7 @@
#
:use-module
(
srfi
srfi-11
)
#
:use-module
(
system
repl
repl
)
#
:export
(
<next>
<or>
<and>
<not>
<cond>
<if>
#
:export
(
<next>
<or>
<and>
<not>
<cond>
<if>
<scm-if>
<with-guile-log>
<if-some>
<cc>
<fail>
<let>
<let*>
<var>
<hvar>
</
.
>
<when>
<define>
<cut>
<pp>
<pp-dyn>
<dyn>
<unify>
...
...
@@ -135,7 +135,7 @@
(
define-guile-log
<or>
(
syntax-rules
(
****
)
((
_
meta
)
(
parse<>
meta
<fail>
))
((
_
meta
e1
)
(
parse<>
meta
e1
))
((
_
(
cut
s
pr
cc
)
.
l
)
...
...
@@ -145,7 +145,9 @@
(
define-syntax
or-aux
(
syntax-rules
()
((
_
meta
a
)
(
parse<>
meta
a
))
(
begin
(
gp-clear-frame
)
(
parse<>
meta
a
)))
((
_
(
cut
s
p
cc
)
a
.
as
)
(
let
((
pp
(
lambda
()
(
gp-unwind
s
)
...
...
@@ -328,9 +330,24 @@
(
parse<>
meta
(
<and>
(
<and!>
p
)
a
)))
((
_
(
cut
s
p
cc
)
pred
a
b
)
(
<or>
(
cut
s
p
cc
)
(
<and>
(
<and!>
pred
)
(
<with-fail>
p
a
))
(
<let>
((
ss
S
))
(
<and>
(
<and!>
pred
)
(
<with-fail>
p
(
<code>
(
gp-clear-frame!
ss
))
a
)))
b
))))
(
define-guile-log
<scm-if>
(
syntax-rules
()
((
_
(
cut
s
p
cc
)
pred
a
)
(
if
pred
(
parse<>
(
cut
s
p
cc
)
a
)
(
p
)))
((
_
(
cut
s
p
cc
)
pred
a
b
)
(
if
pred
(
parse<>
(
cut
s
p
cc
)
a
)
(
parse<>
(
cut
s
p
cc
)
b
)))))
(
define-guile-log
<if-some>
(
syntax-rules
()
...
...
@@ -470,23 +487,22 @@
;(pp `(parse<> ,@(syntax->datum (syntax l))))
(
syntax
(
parse2<>
.
l
))))))
(
define-syntax
parse2<>
(
lambda
(
x
)
(
syntax-case
x
(
if
when
cond
else
case
)
((
_
meta
(
if
p
.
l
)
)
#'
(
<
if>
meta
(
<when>
p
)
.
l
))
#'
(
<
scm-if>
meta
p
.
l
))
((
_
meta
(
when
p
.
l
)
)
#'
(
<
if>
meta
(
<when>
p
)
(
<and>
.
l
)))
#'
(
<
scm-if>
meta
p
(
<and>
.
l
)))
((
_
meta
(
cond
(
else
a
...
)
.
l
))
#'
(
<and>
meta
a
...
))
((
_
meta
(
cond
(
p
a
...
)
.
l
))
#'
(
<
if>
meta
(
<when>
p
)
(
<and>
a
...
)
(
cond
.
l
)))
#'
(
<
scm-if>
meta
p
(
<and>
a
...
)
(
cond
.
l
)))
((
_
meta
(
cond
))
#'
(
parse2<>
meta
<fail>
))
...
...
@@ -544,6 +560,7 @@
((
_
(
name
.
a
)
code
...
)
(
define
name
(
letrec
((
name
(
lambda
(
<S>
<Cut>
<CC>
.
a
)
(
gp-gc
)
(
<with-guile-log>
(
<S>
<Cut>
<CC>
)
(
<and>
code
...
)))))
(
set-procedure-property!
name
'module
get-module
)
...
...
@@ -569,6 +586,7 @@
(
syntax-rules
()
((
_
as
code
...
)
(
lambda
(
<S>
<Cut>
<CC>
.
as
)
(
gp-gc
)
(
<with-guile-log>
(
<S>
<Cut>
<CC>
)
(
<and>
code
...
))))))
...
...
@@ -577,6 +595,7 @@
((
_
(
as
code
...
)
...
)
(
case-lambda
((
<S>
<Cut>
<CC>
.
as
)
(
gp-gc
)
(
<with-guile-log>
(
<S>
<Cut>
<CC>
)
(
<and>
code
...
)))
...
))))
...
...
@@ -589,32 +608,31 @@
(
car
#'
((
a
...
)
...
))))
((
r
...
)
(
map
(
lambda
x
#
'_
)
(
car
#'
((
a
...
)
...
)))))
#'
(
lambda
(
<S>
<Cut>
<CC>
b
...
)
(
gp-gc
)
(
<with-guile-log>
(
<S>
<Cut>
<CC>
)
(
<match>
(
#
:mode
+
)
(
b
...
)
(
a
...
code
)
...
(
r
...
(
<cut>
<fail>
))))))))))
(
define-syntax-rule
(
map2
f
(
a
...
)
(
b
...
)
)
(
map
(
lambda
(
a
...
)
(
map
(
lambda
(
a
...
)
f
)
a
...
))
b
...
))
(
define-syntax-rule
(
map2
f
(
a
...
)
b
)
(
map
(
lambda
(
a
...
)
(
map
(
lambda
(
a
...
)
f
)
a
...
))
b
))
(
define-syntax
<<case-lambda>>
(
lambda
(
x
)
(
syntax-case
x
()
((
_
((
a
...
code
)
...
)
...
)
((
_
((
a
s
...
codes
)
...
(
a
...
code
)
)
...
)
(
with-syntax
((((
b
...
)
...
)
(
map2
(
datum->syntax
#
'q
(
gensym
"q"
))
(
l
)
((
map
car
#'
(((
a
...
)
...
)
...
)))))
(((
r
...
)
...
)
(
map2
#
'_
(
l
)
((
map
car
#'
(((
a
...
)
...
)
...
))))))
#'
((
a
...
)
...
))))
#'
(
case-lambda
((
<S>
<Cut>
<CC>
b
...
)
(
gp-gc
)
(
<with-guile-log>
(
<S>
<Cut>
<CC>
)
(
<match>
(
#
:mode
+
)
(
b
...
)
(
a
...
code
)
(
a
s
...
codes
)
...
(
r
...
(
<cut>
<fail>
)))))
(
a
...
(
<cut>
code
)))))
...
))))))
...
...
@@ -623,6 +641,7 @@
(
syntax-rules
()
((
_
(
cut
s
p
cc
)
n
((
w
v
)
...
)
code
...
)
(
letrec
((
n
(
lambda
(
ss
pp
cccc
w
...
)
(
gp-gc
)
(
<with-guile-log>
(
cut
ss
pp
cccc
)
(
<and>
code
...
)))))
(
parse<>
(
cut
s
p
cc
)
...
...
logic/guile-log/prolog/goal-transformers.scm
View file @
6794ff0b
...
...
@@ -245,7 +245,7 @@
(
<define>
(
<iss>
x
y
)
(
<let>
((
x
(
<lookup>
x
)))
(
if
(
number?
x
)
(
if
(
number?
x
)
(
if
(
number?
y
)
(
if
(
inexact?
x
)
(
if
(
inexact?
y
)
(
when
(
my-equal?
x
y
))
...
...
logic/guile-log/src/state.c
View file @
6794ff0b
This diff is collapsed.
Click to expand it.
logic/guile-log/src/unify-undo-redo.c
View file @
6794ff0b
This diff is collapsed.
Click to expand it.
logic/guile-log/src/unify.c
View file @
6794ff0b
...
...
@@ -23,6 +23,7 @@
#include "unify.h"
#define VECTOR_HEADER_SIZE 2
#define GP_USE_GC_MOCK 1
SCM
tester
=
SCM_BOOL_F
;
...
...
@@ -30,6 +31,12 @@ SCM inline get_cs(SCM v);
SCM
gp_current_stack
=
SCM_BOOL_F
;
int
do_gp_mark
=
1
;
#define gp_store 1
#define gp_redo 2
#define gp_redo_tag 10
#define gp_save_tag 14
SCM_DEFINE
(
gp_get_current_stack
,
"gp-current-stack-ref"
,
0
,
0
,
0
,
(),
"takes cdr a prolog pair or scheme pair"
)
...
...
@@ -143,7 +150,8 @@ scm_t_bits gp_smob_t;
#define GPQ_EQ B(0xa0000)
#define GPI_SCM_M B(0x400000)
#define GPI_GL_M B(0x1800000)
#define GPI_SCM_C B(0x800000)
#define GPI_SCM_Q B(0x1000000)
#define GPM_PTR B(0x0ffff)
#define GPM_CONS B(0x1ffff)
...
...
@@ -204,6 +212,18 @@ scm_t_bits gp_smob_t;
#define N_BITS 22
#define H_BITS 36
#define GP_GC_MARK(x) (x = ((x) | GPI_SCM_M))
#define GP_GC_ISMARKED(x) ((x) & GPI_SCM_M)
#define GP_GC_CLEAR(x) ((x) = (x) & ~(GPI_SCM_M))
#define GP_GC_CAND(x) (x = ((x) | GPI_SCM_C))
#define GP_GC_ISCAND(x) ((x) & GPI_SCM_C)
#define GP_GC_CLEARCAND(x) ((x) = (x) & ~(GPI_SCM_C))
#define GP_GC_QAND(x) (x = ((x) | GPI_SCM_Q))
#define GP_GC_ISQAND(x) ((x) & GPI_SCM_Q)
#define GP_GC_CLEARQAND(x) ((x) = (x) & ~(GPI_SCM_Q))
inline
static
SCM
GP_IT
(
SCM
*
id
)
{
return
GP_UNREF
(
id
);
...
...
@@ -233,19 +253,9 @@ SCM gp_unwind_fluid;
SCM
gp_cons_sym
;
SCM
gp_cons_str
;
#include "state.c"
static
inline
struct
gp_stack
*
get_gp
()
{
SCM
gp
=
scm_fluid_ref
(
gp_current_stack
);
if
(
GP_STACKP
(
gp
))
return
(
struct
gp_stack
*
)
SCM_SMOB_DATA
(
gp
);
scm_misc_error
(
"get_gp"
,
"could not find stacks"
,
SCM_EOL
);
return
(
struct
gp_stack
*
)
0
;
}
static
inline
SCM
gp_make_vector
(
int
n
,
struct
gp_stack
*
gp
)
{
...
...
@@ -370,14 +380,13 @@ inline SCM gp_make_s(SCM ci, SCM *l)
return
scm_cons
(
ci
,
ll
);
}
#define GP_TEST_CSTACK if(gp->gp_ci > gp->gp_nnc) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_nc))
static
inline
void
gp_store_var_2
(
SCM
*
id
,
int
simple
,
struct
gp_stack
*
gp
)
{
GP_TEST_CSTACK
;
if
(
!
GP
(
GP_UNREF
(
id
)))
scm_misc_error
(
"gp_store_var_2"
,
" got non gp variable to set"
,
SCM_EOL
);
scm_misc_error
(
"gp_store_var_2"
,
" got non gp variable to set ~a"
,
scm_list_1
(
GP_UNREF
(
id
)));
if
(
GP_UNBOUND
(
id
))
{
...
...
@@ -406,7 +415,8 @@ static inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp,
{
if
(
!
GP
(
GP_UNREF
(
id
)))
scm_misc_error
(
"unify.c: handle"
,
" got non gp variable to set"
,
SCM_EOL
);
scm_misc_error
(
"unify.c: handle"
,
" got non gp variable to set ~a"
,
scm_list_1
(
GP_UNREF
(
id
)));
if
(
gp
->
_logical_
)
return
logical_add2
(
GP_UNREF
(
id
),
v
,
l
);
...
...
@@ -439,7 +449,8 @@ static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *g
{
if
(
!
GP
(
GP_UNREF
(
id
)))
scm_misc_error
(
"unify.c: handle"
,
" got non gp variable to set"
,
SCM_EOL
);
scm_misc_error
(
"unify.c: handle_l"
,
" got non gp variable to set ~a"
,
scm_list_1
(
GP_UNREF
(
id
)));
if
(
gp
->
_logical_
)
return
logical_add2_l
(
GP_UNREF
(
id
),
v
,
l
);
...
...
@@ -472,12 +483,29 @@ static inline void handle_force(SCM *id, SCM flags, SCM v)
{
if
(
!
GP
(
GP_UNREF
(
id
)))
scm_misc_error
(
"unify.c: handle"
,
" got non gp variable to set"
,
SCM_EOL
);
scm_misc_error
(
"unify.c: handle force"
,
" got non gp variable to set ~a"
,
scm_list_1
(
GP_UNREF
(
id
)));
int
i
=
SCM_UNPACK
(
id
[
0
])
>>
N_BITS
;
mask_on
(
i
,
id
,
flags
);
*
(
id
+
1
)
=
v
;
}
SCM
*
set_ci
(
SCM
*
ci
,
struct
gp_stack
*
gp
)
{
SCM
*
f
=
get_gp_var
(
gp
);
SCM
flags
=
SCM_PACK
(
GP_MK_FRAME_EQ
(
gp_type
));
handle_force
(
f
,
flags
,
SCM_PACK
(((
ci
-
gp
->
gp_cstack
)
<<
2
)
+
2
));
ci
[
-
2
]
=
PTR2NUM
(
f
);
return
f
;
}
static
inline
void
set_ci_f
(
SCM
*
ci
,
SCM
f
,
struct
gp_stack
*
gp
)
{
ci
[
-
2
]
=
PTR2NUM
(
GP_GETREF
(
f
));
GP_GETREF
(
f
)[
1
]
=
SCM_PACK
(((
ci
-
gp
->
gp_cstack
)
<<
2
)
|
1
);
}
static
inline
SCM
gp_set_val
(
SCM
*
id
,
SCM
v
,
SCM
l
,
struct
gp_stack
*
gp
)
{
...
...
@@ -751,99 +779,88 @@ static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
//#define DB(X) X
static
inline
SCM
gp_newframe
(
SCM
s
)
{
SCM
*
ci
,
l
;
SCM
l
;
struct
gp_stack
*
gp
=
get_gp
();
SCM
tag
;
if
(
SCM_CONSP
(
s
))
{
tag
=
SCM_CAR
(
s
);
ci
=
NUM2PTR
(
tag
);
l
=
SCM_CDR
(
s
);
}
else
{
s
=
SCM_PACK
(
0
);
ci
=
gp
->
gp_ci
;
l
=
SCM_EOL
;
}
{
SCM
ha
=
ci
[
-
4
];
scm_t_bits
dyn_n
=
SCM_UNPACK
(
ci
[
-
3
]);
SCM
*
si
=
NUM2PTR
(
ci
[
-
2
]);
SCM
v
=
get_cs
(
ci
[
-
1
]);
SCM
*
cs
=
NUM2PTR
(
v
);
gp_debug0
(
"check
\n
"
);
DB
(
if
(
cs
<
gp
->
gp_cons_stack
||
cs
>
gp
->
gp_cons_stack
+
1000
)
{
printf
(
"er %x %x
\n
"
,
cs
-
gp
->
gp_cons_stack
,
cs
-
gp
->
gp_stack
);
scm_misc_error
(
"newframe"
,
"cs got wrong value ~a"
,
scm_list_1
(
ci
[
-
1
]));
});
check_cs
(
cs
,
gp
,
"newframe 0"
);
gp_debug3
(
"work (%p %p %p)
\n
"
,
gp
->
gp_ci
-
ci
,
gp
->
gp_si
-
si
,
gp
->
gp_cs
-
cs
);
if
(
si
==
gp
->
gp_si
&&
cs
==
gp
->
gp_cs
&&
dyn_n
==
gp
->
dynstack_length
&&
ha
==
gp
->
handlers
&&
ci
==
gp
->
gp_ci
)
{
gp_debug0
(
"return same
\n
"
);
if
(
s
)
return
s
;
else
return
scm_cons
(
PTR2NUM
(
gp
->
gp_ci
),
l
);
}
{
SCM
ret
;
gp_debug0
(
"newframe
\n
"
);
GP_TEST_CSTACK
;
gp
->
gp_ci
+=
4
;
SCM
ret
;
SCM
*
f
;
SCM
*
ci
;
gp_debug0
(
"newframe
\n
"
);
GP_TEST_CSTACK
;
SCM
cons
=
PTR2NUM
(
gp
->
gp_ci
);
ci
=
gp
->
gp_ci
+
4
;
l
=
scm_is_false
(
l
)
?
SCM_EOL
:
l
;
ret
=
scm_cons
(
cons
,
l
);
gp
->
gp_ci
[
-
4
]
=
gp
->
handlers
;
gp
->
gp_ci
[
-
3
]
=
SCM_PACK
(
gp
->
dynstack_length
);
gp
->
gp_ci
[
-
2
]
=
PTR2NUM
(
gp
->
gp_si
);
gp
->
gp_ci
[
-
1
]
=
PTR2NUM
(
gp
->
gp_cs
);
gp_debug0
(
"return
\n
"
);
return
ret
;
}
}
l
=
scm_is_false
(
l
)
?
SCM_EOL
:
l
;
ci
[
-
4
]
=
gp
->
handlers
;
ci
[
-
3
]
=
SCM_PACK
(
gp
->
dynstack_length
);
f
=
set_ci
(
ci
,
gp
);
set_cs_si
(
ci
,
gp
);
ret
=
scm_cons
(
GP_UNREF
(
f
),
l
);
gp
->
gp_ci
=
ci
;
gp_debug0
(
"return
\n
"
);
return
ret
;
}
}
//#define DB(X)
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
int
gp_gc_counter
=
0
;
static
inline
SCM
*
gp_mk_var
(
SCM
s
)
{
SCM
*
ret
;
struct
gp_stack
*
gp
=
get_gp
();
int
n
=
gp
->
gp_nns
-
gp
->
gp_si
;
gp_debug0
(
"got a gp"
);
if
(
gp
->
_logical_
)
return
GP_GETREF
(
make_logical
());
GP_TEST_STACK
;
gp_debug1
(
"test stack handled! %x
\n
"
,
gp
->
gp_si
);
ret
=
gp
->
gp_si
;
gp
->
gp_si
+=
2
;
gp_gc_counter
++
;
if
(
n
>
10000
)
{
gp_gc_counter
++
;
}
else
if
(
n
>
1000
)
{
if
(
gp_gc_counter
>=
10000
)
{
scm_gc
();
gp_gc_counter
=
0
;
}
}
else
if
(
n
>
100
)
{
if
(
gp_gc_counter
>=
1000
)
{
scm_gc
();
gp_gc_counter
=
0
;
}
}
else
{
if
(
gp_gc_counter
>=
100
)
{
scm_gc
();
gp_gc_counter
=
0
;
}
}
ret
=
get_gp_var
(
gp
);
mask_on
(
gp
->
id
,
ret
,
SCM_PACK
(
GP_MK_FRAME_UNBD
(
gp_type
)));
*
(
ret
+
1
)
=
SCM_UNBOUND
;
...
...
@@ -861,7 +878,7 @@ static inline SCM gp_mk_cons(SCM s)
struct
gp_stack
*
gp
;
gp
=
get_gp
();
if
(
gp
->
_logical_
)
return
scm_cons
(
make_logical
(),
make_logical
());
if
(
1
||
gp
->
_logical_
)
return
scm_cons
(
make_logical
(),
make_logical
());
...
...
@@ -2369,7 +2386,7 @@ SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s),
SCM
*
id
;
struct
gp_stack
*
gp
=
get_gp
();
if
(
gp
->
_logical_
)
return
scm_cons
(
car
,
cdr
);
if
(
1
||
gp
->
_logical_
)
return
scm_cons
(
car
,
cdr
);
gp_debus0
(
"gp-cons>
\n
"
);
cons
=
GP_GETREF
(
gp_mk_cons
(
s
));
...
...
@@ -2865,10 +2882,28 @@ SCM gp_save_mark_sym;
#include "unify-undo-redo.c"
#ifndef GP_USE_GC_MOCK
static
size_t
gp_type_free
(
SCM
obj
)
{
SCM
*
v
=
GP_GETREF
(
obj
);
scm_t_bits
head
=
SCM_UNPACK
(
v
[
0
]);
if
(
!
GP_GC_ISQAND
(
head
))
{
scm_gc_free
(
GP_GETREF
(
obj
),
2
*
sizeof
(
SCM
),
"gp-variable-free"
);
}
return
0
;
}
#endif
static
SCM
gp_type_mark
(
SCM
obj
)
{
SCM
*
v
=
GP_GETREF
(
obj
);
scm_gc_mark
(
v
[
1
]);
scm_t_bits
head
=
SCM_UNPACK
(
v
[
0
]);
GP_GC_MARK
(
head
);
v
[
0
]
=
SCM_PACK
(
head
);
return
SCM_BOOL_T
;
}
...
...
@@ -2905,7 +2940,7 @@ SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (),
int
old
=
gp
->
_logical_
;
gp
->
_logical_
=
0
;
SCM_NEWSMOB
(
ret
,
GP_MK_FRAME_UNBD
(
gp_type
),(
void
*
)
0
);
ret
=
gp_make_variable
(
);
gp_set_unbound_bang
(
GP_GETREF
(
ret
),
l
,
gp
);
gp
->
_logical_
=
old
;
return
ret
;
...
...
@@ -3127,6 +3162,7 @@ int _gp_pair_star(SCM **spp, int nargs, SCM *cl, SCM *max)
//#include "util.c"
#include "indexer/indexer.c"
void
gp_init
()
{
#include "unify.x"
...
...
@@ -3145,15 +3181,23 @@ void gp_init()
gp_cons_sym
=
scm_string_to_symbol
(
gp_cons_str
);
gp_type
=
scm_make_smob_type
(
"unify-variable"
,
0
);
scm_set_smob_print
(
gp_type
,
gp_printer
);
scm_set_smob_mark
(
gp_type
,
gp_type_mark
);
scm_set_smob_print
(
gp_type
,
gp_printer
);
scm_set_smob_mark
(
gp_type
,
gp_type_mark
);
#ifndef GP_USE_GC_MOCK
scm_set_smob_free
(
gp_type
,
gp_type_free
);
#endif
gp_current_stack
=
scm_make_fluid
();
gp_module_stack_init
();
vlist_init
();
gp_init_stacks
();
init_gpgc
();
init_variables
();
}
...
...
logic/guile-log/src/unify.h
View file @
6794ff0b
...
...
@@ -114,3 +114,8 @@ SCM_API SCM gp_cont_ids_ref();
SCM_API
SCM
gp_cont_ids_set_x
(
SCM
h
);
SCM_API
SCM
gp_guard_vars
(
SCM
s
);
SCM_API
SCM
gp_clear_frame
();
SCM_API
SCM
gp_clear_frame_x
(
SCM
s
);
SCM_API
SCM
gp_gc
();
logic/guile-log/src/variable.c
0 → 100644
View file @
6794ff0b
#include <gc.h>
#include <gc/gc_mark.h>
/*
We need a special variable
*/
#ifdef GP_USE_GC_MOCK
static
int
gp_variable_gc_kind
;
static
struct
GC_ms_entry
*
gp_mark_variable
(
GC_word
*
addr
,
struct
GC_ms_entry
*
mark_stack_ptr
,
struct
GC_ms_entry
*
mark_stack_limit
,
GC_word
env
)
{
register
SCM
cell
;
cell
=
PTR2SCM
(
addr
);
if
(
SCM_TYP7
(
cell
)
!=
scm_tc7_smob
)
/* It is likely that the GC passed us a pointer to a free-list element
which we must ignore (see warning in `gc/gc_mark.h'). */
return
mark_stack_ptr
;
mark_stack_ptr
=
GC_MARK_AND_PUSH
(
SCM2PTR
(
SCM_CELL_OBJECT_1
(
cell
)),
mark_stack_ptr
,
mark_stack_limit
,
NULL
);
return
mark_stack_ptr
;
}
#endif
SCM
gp_make_variable
()
{
#ifdef GP_USE_GC_MOCK
SCM
ret
=
PTR2SCM
(
GC_generic_malloc
(
2
*
sizeof
(
scm_t_cell
),
gp_variable_gc_kind
));
SCM
tc
=
SCM_PACK
(
GP_MK_FRAME_UNBD
(
gp_type
));
SCM_SET_CELL_WORD_1
(
ret
,
SCM_UNBOUND
);
SCM_SET_CELL_WORD_0
(
ret
,
tc
);
return
ret
;
#else
SCM
ret
=
scm_new_smob
(
gp_type
,
(
scm_t_bits
)
0
);
SCM
*
v
=
GP_GETREF
(
ret
);
v
[
0
]
=
SCM_PACK
(
GP_MK_FRAME_UNBD
(
gp_type
)
|
GPI_SCM_Q
);
v
[
1
]
=
SCM_UNBOUND
;
return
ret
;
#endif
}
void
gp_gc_mark_no_touch
(
SCM
o
)
{
#ifdef GP_USE_GC_MOCK
if
(
SCM_NIMP
(
o
))
{
void
*
mark_stack_ptr
,
*
mark_stack_limit
;
mark_stack_ptr
=
NULL
;
mark_stack_limit
=
NULL
;
GC_MARK_AND_PUSH_NO_TOUCH
(
SCM2PTR
(
o
),
mark_stack_ptr
,
mark_stack_limit
,
NULL
);
}
#else
{
// Mark the byte to prvent gc in the finalizer
SCM
*
v
=
GP_GETREF
(
o
);
scm_t_bits
head
=
SCM_UNPACK
(
v
[
0
]);
GP_GC_QAND
(
head
);
v
[
0
]
=
SCM_PACK
(
head
);
}
#endif
}
void
init_variables
()
{
#ifdef GP_USE_GC_MOCK
gp_variable_gc_kind
=
GC_new_kind_adv
(
GC_new_free_list
(),
GC_MAKE_PROC
(
GC_new_proc
(
gp_mark_variable
),
0
),
0
,
1
,(
GC_word
)
GPI_SCM_M
);
#endif
}
logic/guile-log/umatch.scm
View file @
6794ff0b
...
...
@@ -54,11 +54,16 @@
gp-undo-safe-variable-guard
gp-abort
gp-prompt
gp-clear-frame
gp-clear-frame!
gp-handlers-ref
gp-handlers-set!
gp-cont-ids-ref
gp-cont-ids-set!
)
gp-cont-ids-set!
gp-gc
)
...
...
@@ -126,9 +131,8 @@
(
define
*states*
#t
)
(
define
*gp*
(
gp-current-stack-ref
))