correct closure handling

parent b95102a8
(define instr (@@ (logic guile-log guile-prolog vm vm-pre) instr))
(use-modules (logic guile-log vm vm))
(use-modules (ice-9 pretty-print))
#|
The question is if we can design a system for prolog programs
......@@ -147,24 +149,30 @@ variables is the most difficult part to maintain
(define (name-it x) (set-procedure-property! x 'name 'anonymous) x)
(<define> (compile_to_fkn code f)
(<code> (parse-extended))
(<var> (stackSize constants l nvar nsvar tvar narg)
(<var> (stackSize constants l nvar nsvar tvar narg ll u)
(compile_goal code l stackSize narg constants #f)
(get_varn nvar)
(get_vart tvar)
(max_svarns nsvar)
(<recur> lp ((l (<scm> l)) (o '()))
(<<match>> (#:mode -) (l)
((x . l) (lp l ((@ (guile) append) ((@ (guile) reverse) x) o)))
(()
(let ((instructions (pp 'instructions: ((@ (guile) reverse) o)))
(nvar (pp 'nvar: (<lookup> nvar)))
(tvar (pp 'tvar: (<lookup> tvar)))
(nsvar (pp 'nsvar: (<lookup> nsvar)))
(narg (pp 'narg: (<lookup> narg)))
(stackSize (pp 'size: (<lookup> stackSize)))
(constants (pp 'constants: (map car (<scm> constants)))))
<cut>
(<=> f ,(list instructions nvar tvar nsvar narg stackSize constants))))))))
(set base u)
(let* ((nvar (pp 'nvar: (<lookup> nvar)))
(tvar (pp 'tvar: (<lookup> tvar)))
(nsvar (pp 'nsvar: (<lookup> nsvar)))
(narg (pp 'narg: (<lookup> narg)))
(stackSize (pp 'size: (<lookup> stackSize)))
(rigid-size (max (+ 4 narg) nsvar))
(stack-pt rigid-size)
(all-size (+ rigid-size stackSize)))
(<var> (ll lll)
(init-proc narg all-size ll lll)
(set base stack-pt)
(<=> lll ())
(let ((instructions ((@ (guile) append) (<scm> ll) (<scm> l))))
(let lp ((i instructions))
(if (pair? i)
(<and> (write (car i)) (nl) (lp (cdr i)))
<cc>))
(<=> f ,(list nvar tvar nsvar narg stackSize)))))))
(define (get-mod c)
......@@ -245,7 +253,7 @@ variables is the most difficult part to maintain
(compile-prolog-string "
generate_lambda(X,F) :-
readline_term_str(X,T,[variables(V),variable_names(N)]),
compile_to_fkn(T,F).
compile_to_fkn(T,F), write(F),nl.
")
......
......@@ -64,9 +64,9 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
print(L),nl,!,
get_M(V,StackSize),
handle_all(L,LL),
(var(Constants)-> get_consts(Constants);true),
print(LL),nl,!,
(Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
%(var(Constants)-> get_consts(Constants);true),
%print(LL),nl,!,
(true -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
compile_goal(X,Tail,V,L) :- var_p(X),!,
compile_goal(call(X),Tail,V,L).
......
......@@ -20,13 +20,15 @@
(compile-prolog-string
"
'handle-spcc'(C,I,I,L,LL) :-
NCC is C,
NP is C + 1,
NS is C + 2,
gset(cc,svar(NCC),I,L,L2),
gset(p,svar(NP),I,L2,L3),
gset(s,svar(NS),I,L3,L4),
gset(vec,lvec,I,L4,LL).
NCC is C,
NP is C + 1,
NS is C + 2,
NVEC is C + 3,
gset(vec,svar(NVEC),I,L,L2),
gset(cc,svar(NCC),I,L2,L3),
gset(p,svar(NP),I,L3,L4),
gset(s,svar(NS),I,L4,LL).
'push-3'(C,I,II,L,LL) :-
args([cc(C),pp,s],I,II,L,LL).
......@@ -63,7 +65,7 @@
tailstub(NN,L2,LL).
'in-post-call'(I,II,L,LL) :-
gset(vec,lvec,I,L,LL),
generate('assert-narg-ee/locals'(3,nvec),L,LL),
II = 0.
'post-unicall'(I,II,L,LL) :-
......
......@@ -4,7 +4,8 @@
#:export (reset gset gref move movex scmcall make_p make_cc j je jne
scmtailcall scmtailcall2 scmcall1 generate
label gfalse gtrue isTrue pltest lookup2 svar args
test sp cc p s c vec lvec cut stack call? scut pp pltest_s base
test sp cc p s c vec lvec cut stack call? scut pp pltest_s
base init-proc
tailstub stub inlabel))
(define base (gp-make-var))
......@@ -26,6 +27,13 @@
id(ret ,cl(1)).
sp(6).
unpack_vec(Nargs,II,L,LL) :-
I is Nargs + 1,
II is I + 1,
generate('scm-ref/immediate'(I,I,2),L,L2),
generate('scm-ref/immediate'(II,I,2),L2,L3),
generate('scm-ref/immediate'(I,I,1),L3,LL).
pp(I,II,L,LL) :-
II is I + 1,
gset(sp(I),p,II,L,L1),
......@@ -53,27 +61,34 @@
reset(I,L,LL) :-
call(II is I),
generate(reset(base+II),L,LL).
generate('reset-frame'(base+II),L,LL).
varref(Pos,I,II,L,LL) :-
generate('vector-ref'(base+I,0,Pos),L,LL),
id(vec,svar(IVEC)),
PPos is Pos + 1,
generate('scm-ref/immediate'(base+I,IVEC,PPos),L,LL),
II is I + 1.
varset(I,J,L,LL) :-
generate('vector-set!'(3,I,base+J),L,LL).
varset(I,J,L,LL) :-
id(vec,svar(IVEC)),
Pos is I + 1,
generate('scm-set!/immediate'(IVEC,Pos,base+J),L,LL).
varset_s(I,J,L,LL) :-
generate('vector-set!'(3,I,J),L,LL).
id(vec,svar(IVEC)),
Pos is I + 1,
generate('scm-set!/immediate'(IVEC,Pos,J),L,LL).
constant(C,I,L,LL) :-
generate(constant(I,C),L,LL).
move(I,J,L,LL) :-
generate(move(I,J),L,LL).
generate(mov(I,J),L,LL).
movex(I,J,L,LL) :-
call(II is I),
call(JJ is J),
generate(move(base+II,base+JJ),L,LL).
generate(mov(base+II,base+JJ),L,LL).
gref(cl(X),I,L,LL) :- !,
call(II is I),
......@@ -186,14 +201,18 @@
gset(X,Val,I,L,LL) :-
id(X,XX),
gset(XX,Val,I,L,LL).
-trace.
'init-proc'(Nargs,Nvec,L,LL) :-
N is Nargs + 3 + 1,
NJ is N + 1,
id(ret,cl(NRET)),
id(lvec,cl(NLV)),
NN is Nvec - N,
generate(initialJump(NRET,NLV),L,L2),
generate('assert-narg-ee/locals'(N,NN),L2,L3),
generate('handle-interrupts',L3,LL).
init(Nargs,Nvec,I,L,LL) :-
N is Nargs + 3,
generate('pljump',L,L2),
generate('assert-narg-ee/locals'(Nargs,0),L2,L3),
generate('handle-interrupts',L3,L4),
I = N,
generate('pl-setup-frame',L4,LL).
args([],I,I,L,L).
......
......@@ -25,7 +25,7 @@
newframe-negation store-state store-ps store-p
;; utils
gfalse gtrue sp svar inlabel
gfalse gtrue sp svar inlabel init-proc base
;; push
cutter goto-inst sp-move equal-instruction
......
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