new version of mockalambda compile files

parent 99ea7442
......@@ -5,15 +5,20 @@
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log match)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-goal)
#:use-module (logic guile-log prolog compile)
#:use-module ((logic guile-log umatch) #:select (gp-var!))
#:use-module (system vm assembler)
#:re-export (compile_goal begin_att end_att cc)
#:export (compilable_scm collect_data define-prolog-fkn
make-vm-function
compile_to_fkn
instr define-prolog))
#:export (compilable_scm
collect_data define-prolog-fkn
make-vm-function
compile_to_fkn
instr define-prolog
mockalambda))
(define instr (@@ (logic guile-log guile-prolog vm vm-pre) instr))
......@@ -220,6 +225,33 @@ variables is the most difficult part to maintain
#`,(vector #,@constants-r)
tvar)))))))))
(<define> (eval_to_meta stx code meta)
(<var> (stackSize constants l nvar nsvar tvar narg)
(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>
(<=> meta
,(make-vm-function
`(,(+ narg 4) . ,(+ stackSize nsvar))
(pack-start nvar
stackSize
(mk-instructions instructions)
constants
tvar)))))))))
(define readline_term_str (@@ (logic guile-log guile-prolog interpreter)
readline_term_str))
......@@ -285,3 +317,46 @@ generate_stx(STX,X,F) :-
'n gg)
(apply gg x)))))
n)))))))
(define (mockalambda source? s pat code)
(let* ((Cut (gp-var! s))
(SCut (gp-var! s))
(rhs (vector (list #{,}# (vector (list with_cut Cut SCut)) code)))
(lhs (vector (cons* mockalambda Cut SCut pat)))
(oth (compile-prolog s pat code source? (list #t #t)))
(all (vector (list :- lhs rhs))))
;(<pp> (s (lambda () #f) (lambda () #f) (lambda x x)) all)
(if source?
#`(let ((o #,oth))
(list
(car o)
#,(let ((comp
(prolog-run-rewind
1 (meta)
(compile_to_meta source? all meta))))
(if (pair? comp)
#`(lambda ()
(let ((f #,(car comp)))
(lambda (s p cc cut scut x)
(apply f s p cc cut scut x))))
(begin
(warn "failed compiling")
(lambda () (error "misscompiled")))))
(cadr o)))
(let ((comp
(prolog-run-rewind
1 (meta)
(eval_to_meta all meta))))
(if (pair? comp)
(let ((f (car comp)))
(lambda ()
(lambda (s p cc cut scut x)
(apply f s p cc cut scut x))))
(begin
(warn "failed compiling")
#f))))))
(set! (@@ (logic guile-log match) mockalambda) mockalambda)
This diff is collapsed.
......@@ -15,7 +15,7 @@
#:use-module (logic guile-log guile-prolog vm vm-conj)
#:use-module (logic guile-log guile-prolog vm vm-handle)
#:use-module (system vm assembler)
#:export (begin_att end_att recur verbatim_call))
#:export (begin_att end_att recur verbatim_call with_cut))
(compile-prolog-string "
reverse_op(<,>).
......@@ -128,6 +128,12 @@ compile_goal(pop(N),Tail,V,[L,LL]) :- !,
tail(Tail,LL,LLL),
L=[[pop,N]|LLL].
compile_goal(with_cut(C,CS),Tail,V,[L,LL]) :- !,
var_p(C),
var_p(CS),
add_var(C ,V,TagC ),
add_var(CS,V,TagCS),
L=[[cutter,TagC,TagCS]|LL].
compile_goal((Args <= Goal),Tail,V,L) :- !,
(listp(Args) -> true ; throw(not_proper_head(Args <= goal))),
......
......@@ -55,26 +55,30 @@ handle_all([['push-variable-scm',A],
handle_all([['push-variable-scm',A],
['push-variable-scm',B],
[+],
[Op],
[unify,C,#t]|Y]
,I,II,L,LL) :- !,
handle([add,A,B,C],I,I1,L,L1),
,I,II,L,LL) :-
binss2(Op,_),!,
handle([bin,Op,A,B,C],I,I1,L,L1),
handle_all(Y,I1,II,L1,LL).
handle_all([['push-instruction',A],
['push-variable-scm',B],
[+],
[Op],
[unify,C,#t]|Y]
,I,II,L,LL) :- !,
handle([addi,A,B,C],I,I1,L,L1),
binis2(Op,_),!,
handle([ibin,Op,A,B,C],I,I1,L,L1),
handle_all(Y,I1,II,L1,LL).
handle_all([['push-variable-scm',B],
['push-instruction',A],
[+],
[Op],
[unify,C,#t]|Y]
,I,II,L,LL) :- !,
handle([addi,A,B,C],I,I1,L,L1),
,I,II,L,LL) :-
binsi2(Op,_),
!,
handle([bini,Op,A,B,C],I,I1,L,L1),
handle_all(Y,I1,II,L1,LL).
handle_all([X|Y],I,II,L,LL) :- !,
......@@ -142,6 +146,21 @@ handle((X,['post-unicall',A,P]),I,II,L,LL) :- !,
handle(['newvar', _],I,I,L,L) :- !.
handle([cutter,[[S1,V1,Q1],N1,F1|_],[[S2,V2,Q2],N2,F2|_]],I,II,L,LL) :-
!,
(
F==#t -> throw(end_with_no_begin) ;
(
new_var(V1,Q1,S1),
new_var(V2,Q2,S2),
V1=[V1C|_],
V2=[V2C|_],
VC is V1C + V2C << 16,
L=[[cutter,VC]|LL],
II is I + 2
)
).
handle(['pre-unify',At,Vx],I,II,L,LL) :- !,
Vx=[[S,V,Q],N,F|_],
(
......@@ -237,9 +256,9 @@ handle([comp,CMP,[[S1,V1,Q1],N1,F1|_],
L=[[Comp,Code]|LL],
II is I + 2.
handle([add,[[S1,V1,Q1],N1,F1|_],
[[S2,V2,Q2],N2,F2|_],
[[S3,V3,Q3],N3,F3|_]],I,II,L,LL) :- !,
handle([bin,Op,[[S1,V1,Q1],N1,F1|_],
[[S2,V2,Q2],N2,F2|_],
[[S3,V3,Q3],N3,F3|_]],I,II,L,LL) :- !,
chech_push(F1),
chech_push(F2),
new_var(V1,Q1,S1),
......@@ -252,33 +271,33 @@ handle([add,[[S1,V1,Q1],N1,F1|_],
(F3==#t,S3==#t) ->
(
new_var(V3,Q3,S3),
code([add,V1,V2,V3,#t],K,Add),
code([bin,Op,V1,V2,V3,#t],K,Add),
L=[[Add,K]|LL],
II is I + 2
);
F3==#t ->
(
new_var(V3,Q3,S3),
code([add,V1,V2,V3,#f],K,Add),
code([bin,Op,V1,V2,V3,#f],K,Add),
L=[[Add,K]|LL],
II is I + 2
);
N3==1 ->
(
new_var(V3,Q3,S3),
code([add,V1,V2,V3,1],K,Add),
code([bin,Op,V1,V2,V3,1],K,Add),
L=[[Add,K]|LL],
II is I + 2
) ;
(
new_var(V3,Q3,S3),
code([add,V1,V2,V3,0],K,Unify),
code([bin,Op,V1,V2,V3,0],K,Unify),
L=[[Unify,K]|LL],
II is I + 2
)
).
handle([addi,X,
handle([(Kind,(ibin;bini)),Op,X,
[[S2,V2,Q2],N2,F2|_],
[[S3,V3,Q3],N3,F3|_]],I,II,L,LL) :- !,
chech_push(F2),
......@@ -291,27 +310,27 @@ handle([addi,X,
(F3==#t,S3==#t) ->
(
new_var(V3,Q3,S3),
code([addi,V2,V3,#t],K,Add),
code([Kind,Op,V2,V3,#t],K,Add),
L=[[Add,X,K]|LL],
II is I + 3
);
F3==#t ->
(
new_var(V3,Q3,S3),
code([addi,V2,V3,#f],K,Add),
code([Kind,Op,V2,V3,#f],K,Add),
L=[[Add,X,K]|LL],
II is I + 3
);
N3==1 ->
(
new_var(V3,Q3,S3),
code([addi,V2,V3,1],K,Add),
code([Kind,Op,V2,V3,1],K,Add),
L=[[Add,X,K]|LL],
II is I + 3
) ;
(
new_var(V3,Q3,S3),
code([addi,V2,V3,0],K,Unify),
code([Kind,Op,V2,V3,0],K,Unify),
L=[[Unify,X,K]|LL],
II is I + 3
)
......@@ -531,7 +550,7 @@ code(['unify-2',M,V1,K1,V2,K2],Code) :- !,
U2 is A2 + K2C << 1 + V2C << 3,
Code is MC + U1 << 2 + U2 << (2 + 24).
code([add,V1,V2,V3,K3],Code,Action) :-
code([bin,Op,V1,V2,V3,K3],Code,Action) :-
(
V1=[V1C|_] ->
(
......@@ -543,14 +562,14 @@ code([add,V1,V2,V3,K3],Code,Action) :-
(
!,
code3(V1C,V2C,V3C,Code),
Action = 'ss-add-s'
binss2(Op,Action)
)
)
)
)
).
code([add,V1,V2,V3,K3],Code,Action) :-
code([bin,Op,V1,V2,V3,K3],Code,Action) :-
(V1=[V1C|_] -> A1=1 ; (V1=V1C, A1=0)),
(V2=[V2C|_] -> A2=1 ; (V2=V2C, A2=0)),
(V3=[V3C|_] -> A3=1 ; (V3=V3C, A3=0)),
......@@ -561,9 +580,25 @@ code([add,V1,V2,V3,K3],Code,Action) :-
),
A is A1 + A2 << 1 + A3 << 2 + K1C << 3,
Code is V1C + V2C << 16 + V3C << 32 + A << 48,
K1==#f -> Action = 'xx-add-x' ; Action = 'xx-uadd-x'.
K1==#f -> binxx2(Op,Action) ; binxxu2(Op,Action).
code([bini,OP,V2,V3,K3],Code,Action) :-
(
V2=[V2C|_] ->
(
V3 = [V3C|_] ->
(
K3 == #f ->
(
!,
code2(V2C,V3C,Code),
binsi2(OP,Action)
)
)
)
).
code([addi,V2,V3,K3],Code,Action) :-
code([ibin,OP,V2,V3,K3],Code,Action) :-
(
V2=[V2C|_] ->
(
......@@ -573,7 +608,7 @@ code([addi,V2,V3,K3],Code,Action) :-
(
!,
code2(V2C,V3C,Code),
Action = 'is-addi-s'
binis2(OP,Action)
)
)
)
......
......@@ -14,7 +14,7 @@
("+" "+") ("*" "*") ("-" "-")))
(define *recurs* (make-fluid vlist-null))
(define *tag* (make-fluid 0))
(define *varn* (make-fluid 3))
(define *varn* (make-fluid 4))
(define *svarn* (make-fluid vlist-null))
(define *var-to-type* (make-fluid '()))
(<define> (get_recur x y n)
......@@ -43,7 +43,7 @@
(fluid-set! *recurs* vlist-null)
(fluid-set! *tag* 0)
(fluid-set! *var-to-type* '())
(fluid-set! *varn* 3)
(fluid-set! *varn* 4)
(fluid-set! *svarn* vlist-null)))
(<define> (get_nsvars q n)
......@@ -161,6 +161,18 @@
the_tr(t(X) , [tr(X,N)]) :- inc(N).
the_tr((t(X,Y):-L),[tr(X,Y) :- L]).
the_tr(binss2_(X,Y) ,[tr(Y,N),binss2(X,Y)]) :- inc(N).
the_tr(binxx2_(X,Y) ,[tr(Y,N),binxx2(X,Y)]) :- inc(N).
the_tr(binxxu2_(X,Y),[tr(Y,N),binxxu2(X,Y)]) :- inc(N).
the_tr(binsi2_(X,Y) ,[tr(Y,N),binsi2(X,Y)]) :- inc(N).
the_tr(binxi2_(X,Y) ,[tr(Y,N),binxi2(X,Y)]) :- inc(N).
the_tr(binxiu2_(X,Y),[tr(Y,N),binxiu2(X,Y)]) :- inc(N).
the_tr(binis2_(X,Y) ,[tr(Y,N),binis2(X,Y)]) :- inc(N).
the_tr(binix2_(X,Y) ,[tr(Y,N),binix2(X,Y)]) :- inc(N).
the_tr(binixu2_(X,Y),[tr(Y,N),binixu2(X,Y)]) :- inc(N).
the_tr(bin(X), [binop(X,N),tr(X,N)]) :- inc(N).
the_tr((bin(X,Y):-L),[binop(X,Y) :- L]).
......@@ -263,10 +275,6 @@ t(dup).
t(=..).
t('ss-add-s').
t('is-addi-s').
t('xx-add-x').
t('xx-uadd-x').
t('ss-gt').
t('ss-lt').
t('ss-ge').
......@@ -295,6 +303,8 @@ t(dup).
t('equal-constant').
t('equal-instruction').
t(cutter).
t('unify-variable').
t(X,_) :-
print_error_if_fail.
......@@ -340,6 +350,51 @@ binxx(=< ,'xx-le').
binxx(=:= ,'xx-e' ).
binxx(=\\= ,'xx-ne').
binss2_(+,'ss-add-s').
binss2_(-,'ss-sub-s').
binss2_(*,'ss-mul-s').
binss2_(/,'ss-div-s').
binss2_(mod,'ss-mod-s').
binss2_(rem,'ss-rem-s').
binss2_(<<,'ss-lshift-s').
binss2_(>>,'ss-rshift-s').
binss2_(/\\,'ss-and-s').
binss2_(\\/,'ss-or-s').
binss2_(xor,'ss-xor-s').
binss2_(^,'ss-pow-s').
binss2_(**,'ss-pow-s').
binxx2_(+,'xx-add-x').
binxx2_(-,'xx-sub-x').
binxx2_(*,'xx-mul-x').
binxx2_(/,'xx-div-x').
binxx2_(mod,'xx-mod-x').
binxx2_(rem,'xx-rem-x').
binxx2_(<<,'xx-lshift-x').
binxx2_(>>,'xx-rshift-x').
binxx2_(/\\,'xx-and-x').
binxx2_(\\/,'xx-or-x').
binxx2_(xor,'xx-xor-x').
binxx2_(^,'xx-pow-x').
binxx2_(**,'xx-pow-x').
binxxu2_(+,'xx-uadd-x').
binxxu2_(-,'xx-usub-x').
binxxu2_(*,'xx-umul-x').
binxxu2_(/,'xx-udiv-x').
binxxu2_(mod,'xx-umod-x').
binxxu2_(rem,'xx-urem-x').
binxxu2_(<<,'xx-ulshift-x').
binxxu2_(>>,'xx-urshift-x').
binxxu2_(/\\,'xx-uand-x').
binxxu2_(\\/,'xx-uor-x').
binxxu2_(xor,'xx-uxor-x').
binxxu2_(^,'xx-upow-x').
binxxu2_(**,'xx-upow-x').
binsi2_(+,'is-addi-s').
binis2_(+,'is-addi-s').
")
......
......@@ -2,7 +2,14 @@
(use-modules (logic guile-log guile-prolog ops))
(use-modules (logic guile-log guile-prolog vm-compiler))
(compile-prolog-string
"
- eval_when(compile).
the_tr2(X,[X]).
:- add_term_expansion_temp(the_tr2).
")
#;
(define-prolog f1 "
f1(N,I,J,S) :-
I < N ->
......@@ -14,6 +21,7 @@
S=J
")
#;
(define-prolog f0 "
f1(N,I,J,S) :-
I > N -> S=J ;
......@@ -24,6 +32,7 @@
).
")
#;
(define-prolog f2 "
f2(N,S) :-
recur * lp((I,0),(J,0)),
......@@ -38,6 +47,7 @@
).
")
(compile-prolog-string "
f3(N,I,J,S) :-
I < N ->
......@@ -46,9 +56,75 @@
JJ is J + I,
f3(N,II,JJ,S)
) ;
S=J
S=J.
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
f([[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1],
[1,1,1,1,1,1,1,1,1]]).
")
#;
(define-prolog memb "
memb(X,L) :-
recur * lp((LL,L)),
......
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