debugging the codeing of ix operations

parent ceae9974
...@@ -27,7 +27,7 @@ constant = #(nlocals nstack constants code) ...@@ -27,7 +27,7 @@ constant = #(nlocals nstack constants code)
(auto-defs) (auto-defs)
(eval-when (compile eval load) (eval-when (compile eval load)
(define debug #f)) (define debug #t))
(define-syntax DB (define-syntax DB
(lambda (x) (lambda (x)
...@@ -798,6 +798,47 @@ constant = #(nlocals nstack constants code) ...@@ -798,6 +798,47 @@ constant = #(nlocals nstack constants code)
(<=> (<ref> variables v2) z)) (<=> (<ref> variables v2) z))
(NEXT inst-pt))))) (NEXT inst-pt)))))
(define-syntax-rule (handle-kc lookup z k
s variables p instructions inst-pt fp sp)
(<if> (<bit-and> k (<c> 1))
(<let> ((s0 (<call> gp_gp_unify_raw
lookup z s)))
(<if> (TRUE s0)
(<=> s s0)
(BACKTRACK
p instructions inst-pt fp sp)))
(<=> lookup z)))
(define-syntax-rule (mk-scm-move-i-op-x op binop schmop
s p variables variables-scm
nvar pinned? cnst session middle nstack
instructions vars inst-pt sp fp)
(<begin>
(LABEL op)
(PRSTACK sp fp)
(<let*> ((SCM x (<ref> inst-pt (<c> 0)))
(ulong v (scm->ulong (<ref> inst-pt (<c> 1))))
(int v1 (<bit-and> v (<c> #xffff)))
(int v2 (q>> (<bit-and> v (<c> #xffff0000)) (<c> 16)))
(int q (q>> v (<c> 32)))
(int k (q>> v (<c> 34))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<let*> ((SCM y (UNPACK-VAR-A (<bit-and> q (<c> 1))
0 pinned? variables variables-scm nvar
cnst session middle
(SVAR-REF fp nstack v1)
(<ref> variables v1)))
(SCM z (ARITH binop schmop x y)))
(UNPACK-VAR-A (<bit-and> q (<c> 2))
1 pinned? variables variables-scm nvar
cnst session middle
(handle-kc (SVAR-REF fp nstack v2) z k
s variables p instructions inst-pt fp sp)
(handle-kc (<ref> variables v2) z k
s variables p instructions inst-pt fp sp))
(NEXT inst-pt)))))
(define-syntax-rule (mk-scm-xmove-op op binop schmop (define-syntax-rule (mk-scm-xmove-op op binop schmop
s p variables variables-scm s p variables variables-scm
nvar pinned? cnst session middle nstack nvar pinned? cnst session middle nstack
...@@ -867,6 +908,7 @@ constant = #(nlocals nstack constants code) ...@@ -867,6 +908,7 @@ constant = #(nlocals nstack constants code)
(<begin> (<begin>
(<=> s ss) (<=> s ss)
(NEXT inst-pt)) (NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp)))))))) (BACKTRACK p instructions inst-pt fp sp))))))))
(mk-i-c mk-scm-unify-i constants i i) (mk-i-c mk-scm-unify-i constants i i)
...@@ -1254,6 +1296,7 @@ constant = #(nlocals nstack constants code) ...@@ -1254,6 +1296,7 @@ constant = #(nlocals nstack constants code)
(REGISTER #{=\\=}# neq) (REGISTER #{=\\=}# neq)
(REGISTER is-addi-s) (REGISTER is-addi-s)
(REGISTER is-addi-x)
sp)) sp))
(define-syntax-rule (UNPACK-1 free always middle session const) (define-syntax-rule (UNPACK-1 free always middle session const)
...@@ -1409,7 +1452,7 @@ constant = #(nlocals nstack constants code) ...@@ -1409,7 +1452,7 @@ constant = #(nlocals nstack constants code)
(<if> var? (<if> var?
(<=> (<ref> vv i) (<call> gp_mkvar s))) (<=> (<ref> vv i) (<call> gp_mkvar s)))
(<next> lp (<+> i (<c> 1)))))) (<next> lp (<+> i (<c> 1))))))
(<=> (<ref> vv (<c> 2)) (GET-TOKEN)) (<=> (GET-PINNED vv) (GET-TOKEN))
vv)))) vv))))
(define-syntax-rule (DO-CONS s sp) (define-syntax-rule (DO-CONS s sp)
...@@ -1851,7 +1894,7 @@ constant = #(nlocals nstack constants code) ...@@ -1851,7 +1894,7 @@ constant = #(nlocals nstack constants code)
(SCM scut (<scm> 0)) (SCM scut (<scm> 0))
(int iter (<c> 0))) (int iter (<c> 0)))
(UNPACK-ENV free narg nlocals) (UNPACK-ENV free narg nlocals)
(UNPACK-1 free always middle session cnst) (UNPACK-1 free always middle session cnst)
(PRSTACK sp fp) (PRSTACK sp fp)
...@@ -2258,6 +2301,11 @@ constant = #(nlocals nstack constants code) ...@@ -2258,6 +2301,11 @@ constant = #(nlocals nstack constants code)
nvar pinned? cnst session middle nstack nvar pinned? cnst session middle nstack
instructions variables inst-pt sp fp) instructions variables inst-pt sp fp)
(mk-scm-move-i-op-x is-addi-x <+> scm_sum
s p variables variables-scm
nvar pinned? cnst session middle nstack
instructions variables inst-pt sp fp)
(mk-scm-move sp-move (<c> 0) s p variables variables-scm (mk-scm-move sp-move (<c> 0) s p variables variables-scm
nvar pinned? cnst session middle nstack nvar pinned? cnst session middle nstack
instructions variables inst-pt sp fp) instructions variables inst-pt sp fp)
......
...@@ -59,7 +59,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !, ...@@ -59,7 +59,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
handle_all(L,LL), handle_all(L,LL),
(var(Constants)-> get_consts(Constants);true), (var(Constants)-> get_consts(Constants);true),
%print(LL),nl,!, print(LL),nl,!,
(Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))). (Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
compile_goal(X,Tail,V,L) :- var_p(X),!, compile_goal(X,Tail,V,L) :- var_p(X),!,
......
...@@ -305,27 +305,27 @@ handle([(Kind,(ibin;bini)),Op,X, ...@@ -305,27 +305,27 @@ handle([(Kind,(ibin;bini)),Op,X,
(F3==#t,S3==#t) -> (F3==#t,S3==#t) ->
( (
new_var(V3,Q3,S3), new_var(V3,Q3,S3),
code([Kind,Op,V2,V3,#t],K,Add), code([Kind,Op,V2,V3,3],K,Add),
L=[[Add,X,K]|LL], L=[[Add,X,K]|LL],
II is I + 3 II is I + 3
); );
F3==#t -> F3==#t ->
( (
new_var(V3,Q3,S3), new_var(V3,Q3,S3),
code([Kind,Op,V2,V3,#f],K,Add), code([Kind,Op,V2,V3,0],K,Add),
L=[[Add,X,K]|LL], L=[[Add,X,K]|LL],
II is I + 3 II is I + 3
); );
N3==1 -> N3==1 ->
( (
new_var(V3,Q3,S3), new_var(V3,Q3,S3),
code([Kind,Op,V2,V3,1],K,Add), code([Kind,Op,V2,V3,5],K,Add),
L=[[Add,X,K]|LL], L=[[Add,X,K]|LL],
II is I + 3 II is I + 3
) ; ) ;
( (
new_var(V3,Q3,S3), new_var(V3,Q3,S3),
code([Kind,Op,V2,V3,0],K,Unify), code([Kind,Op,V2,V3,1],K,Unify),
L=[[Unify,X,K]|LL], L=[[Unify,X,K]|LL],
II is I + 3 II is I + 3
) )
...@@ -590,7 +590,7 @@ code([bini,OP,V2,V3,K3],Code,Action) :- ...@@ -590,7 +590,7 @@ code([bini,OP,V2,V3,K3],Code,Action) :-
( (
V3 = [V3C|_] -> V3 = [V3C|_] ->
( (
K3 == #f -> K3 == 0 ->
( (
!, !,
code2(V2C,V3C,Code), code2(V2C,V3C,Code),
...@@ -603,14 +603,9 @@ code([bini,OP,V2,V3,K3],Code,Action) :- ...@@ -603,14 +603,9 @@ code([bini,OP,V2,V3,K3],Code,Action) :-
code([bini,OP,V1,V2,K],Code,Action) :- code([bini,OP,V1,V2,K],Code,Action) :-
(V1=[V1C|_] -> A1=1 ; (V1=V1C, A1=0)), (V1=[V1C|_] -> A1=1 ; (V1=V1C, A1=0)),
(V2=[V2C|_] -> A2=1 ; (V2=V2C, A2=0)), (V2=[V2C|_] -> A2=1 ; (V2=V2C, A2=0)),
( A is A1 + A2 << 1 + K << 2,
K = #f -> KC=2; Code is V1C + V2C << 16 + A << 32,
K = #t -> K=3 ; binxi2(OP,Action).
KC = K
),
A is A1 + A2 << 1 + KC << 2,
Code is V1C + V2C << 16 + A << 32,
binxi2(OP,Action).
code([ibin,OP,V2,V3,K3],Code,Action) :- code([ibin,OP,V2,V3,K3],Code,Action) :-
( (
......
(use-modules (logic guile-log iso-prolog)) (use-modules (logic guile-log iso-prolog))
(use-modules (logic guile-log guile-prolog ops)) (use-modules (logic guile-log guile-prolog ops))
(use-modules (logic guile-log guile-prolog vm-compiler2)) (use-modules (logic guile-log guile-prolog vm-compiler))
(compile-prolog-string (compile-prolog-string
...@@ -10,7 +10,15 @@ the_tr2(X,[X]). ...@@ -10,7 +10,15 @@ the_tr2(X,[X]).
:- add_term_expansion_temp(the_tr2). :- add_term_expansion_temp(the_tr2).
") ")
(define-prolog b "
b(X,Y) :- Y is X + 1.
")
(define-prolog a "
a(X,Z) :- b(X,Y),b(Y,Z)
")
#;
(define-prolog f1 " (define-prolog f1 "
f1(N,I,J,S) :- f1(N,I,J,S) :-
I < N -> I < N ->
......
...@@ -4031,7 +4031,7 @@ SCM gp_copy_vector(SCM **vector, int nvar) ...@@ -4031,7 +4031,7 @@ SCM gp_copy_vector(SCM **vector, int nvar)
{ {
newp[i] = vecp[i]; newp[i] = vecp[i];
} }
newp[2] = gp_get_state_token(); newp[3] = gp_get_state_token();
*vector = newp; *vector = newp;
return newvec; return newvec;
} }
......
This diff is collapsed.
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