call sematics and more arithmetic vm ops

parent a79eba74
......@@ -67,6 +67,7 @@ constant = #(nlocals nstack constants code)
(<declare-s> SCM scm_difference ((SCM a) (SCM b)))
(<declare-s> SCM scm_logand ((SCM a) (SCM b)))
(<declare-s> SCM scm_logior ((SCM a) (SCM b)))
(<declare-s> SCM scm_logxor ((SCM a) (SCM b)))
(<declare-s> SCM scm_modulo ((SCM a) (SCM b)))
(<declare-s> SCM scm_ash ((SCM a) (SCM b)))
(<declare-s> SCM gp_cons_bang ((SCM a) (SCM b) (SCM s)))
......@@ -475,6 +476,26 @@ constant = #(nlocals nstack constants code)
(<=> (ARG -1 sp) (fkn ... x y))
(NEXT inst-pt))))
(define-syntax-rule (mk-scm-binop-l s op (fkn ...) inst-pt sp fp)
(<begin>
(LABEL op)
(PRSTACK sp fp)
(<let> ((SCM x (<*> inst-pt))
(SCM y (<call> gp_gp_lookup (ARG -1 sp) s)))
(<=> (ARG -1 sp) (fkn ... x y))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(NEXT inst-pt))))
(define-syntax-rule (mk-scm-binop-r s op (fkn ...) inst-pt sp fp)
(<begin>
(LABEL op)
(PRSTACK sp fp)
(<let> ((SCM x (<*> inst-pt))
(SCM y (<call> gp_gp_lookup (ARG -1 sp) s)))
(<=> (ARG -1 sp) (fkn ... y x))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(NEXT inst-pt))))
(define-syntax-rule (mk-scm-unop-minus s op inst-pt sp fp)
(<begin>
(LABEL op)
......@@ -483,6 +504,14 @@ constant = #(nlocals nstack constants code)
(<=> (ARG -1 sp) (<call> scm_difference (int->scm (<c> 0)) x))
(NEXT inst-pt))))
(define-syntax-rule (mk-scm-unop s op (fkn ...) inst-pt sp fp)
(<begin>
(LABEL op)
(PRSTACK sp fp)
(<let> ((SCM x (<call> gp_gp_lookup (ARG -1 sp) s)))
(<=> (ARG -1 sp) (fkn ... x))
(NEXT inst-pt))))
(define-syntax-rule (mk-scm-test-2 op fkn s p instructions inst-pt sp fp)
(<begin>
(LABEL op)
......@@ -804,6 +833,7 @@ constant = #(nlocals nstack constants code)
(REGISTER post-unify)
(REGISTER post-unify-tail)
(REGISTER post-s)
(REGISTER post-q)
(REGISTER clear-sp)
(REGISTER false)
......@@ -853,7 +883,8 @@ constant = #(nlocals nstack constants code)
(REGISTER mk-cons)
(REGISTER mk-fkn)
(REGISTER mk-curly)
(REGISTER #{\\}# lognot)
(REGISTER op1_- uminus)
(REGISTER op2+ plus)
(REGISTER op2- minus)
......@@ -861,6 +892,24 @@ constant = #(nlocals nstack constants code)
(REGISTER op2/ divide)
(REGISTER << shift_l)
(REGISTER >> shift_r)
(REGISTER xor)
(REGISTER plus2_1)
(REGISTER minus2_1)
(REGISTER mul2_1)
(REGISTER div2_1)
(REGISTER bitand)
(REGISTER bitor)
(REGISTER xor1)
(REGISTER shiftLL)
(REGISTER shiftLR)
(REGISTER shiftRL)
(REGISTER shiftRR)
(REGISTER shiftLL)
(REGISTER modL)
(REGISTER modR)
;(REGISTER //)
(REGISTER mod modulo)
;(REGISTER rem)
......@@ -1102,6 +1151,14 @@ constant = #(nlocals nstack constants code)
(<call> schmop x y)))
(<call> schmop x y)))
(define-syntax-rule (ARITH-1 op schmop x)
(<if> (<call> SCM_I_INUMP x)
(<let> ((scm_t_int64 n (op (<call> SCM_I_INUM x))))
(<if> (<call> SCM_FIXABLE n)
(<call> SCM_I_MAKINUM n)
(<call> schmop x)))
(<call> schmop x)))
(define-syntax-rule (CMP op schmop p instructions inst-pt fp sp)
(<let> ((y (<let> ((nn (<*> inst-pt)))
(<++> inst-pt)
......@@ -1575,6 +1632,14 @@ constant = #(nlocals nstack constants code)
(UNWIND-TAIL s)
(NEXT inst-pt))
(LABEL post-q)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> cut (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL s p np ctrl-stack)
(NEXT inst-pt))
;; We will
(LABEL unwind-tail)
(PRSTACK sp fp)
......@@ -1660,7 +1725,7 @@ constant = #(nlocals nstack constants code)
(LABEL cut)
(PRSTACK sp fp)
(<if> (<==> cut (<c> 0))
(<if> (EQ cut (<scm> 0))
(<=> p (GET-P variables))
(<=> p cut))
(NEXT inst-pt)
......@@ -1939,6 +2004,9 @@ constant = #(nlocals nstack constants code)
inst-pt sp fp)
(mk-scm-binop s bor (ARITH <bit-or> scm_logior)
inst-pt sp fp)
(mk-scm_binop a xor (ARITH <^> scm_logxor)
inst-pt sp fp)
(mk-scm-binop s modulo (ARITH <%> scm_modulo)
inst-pt sp fp)
......@@ -1952,9 +2020,48 @@ constant = #(nlocals nstack constants code)
(mk-scm-binop s divide (<call> scm_divide )
inst-pt sp fp)
(mk-scm-binop-l s plus2_1 (ARITH <+> scm_sum )
inst-pt sp fp)
(mk-scm-binop-l s minus2_1 (ARITH <-> scm_difference )
inst-pt sp fp)
(mk-scm-binop-l s mul2_1 (MUL) inst-pt sp fp)
(mk-scm-binop-l s div2_1 (<call> scm_divide )
inst-pt sp fp)
(mk-scm-binop-l s bitand (ARITH <bit-and> scm_logand)
inst-pt sp fp)
(mk-scm-binop-l s bitor (ARITH <bit-or> scm_logior)
inst-pt sp fp)
(mk-scm_binop-l a xor1 (ARITH <^> scm_logxor)
inst-pt sp fp)
(mk-scm-binop-l s shift_LL (SHIFT-L q<< scm_ash)
inst-pt sp fp)
(mk-scm-binop-l s shift_RL (SHIFT-R q>> scm_ash)
inst-pt sp fp)
(mk-scm-binop-r s shift_LR (SHIFT-L q<< scm_ash)
inst-pt sp fp)
(mk-scm-binop-r s shift_RR (SHIFT-R q>> scm_ash)
inst-pt sp fp)
(mk-scm-binop-l s modL (ARITH <%> scm_modulo)
inst-pt sp fp)
(mk-scm-binop-r s modR (ARITH <%> scm_modulo)
inst-pt sp fp)
(mk-scm-unop-minus s uminus inst-pt sp fp)
(mk-scm-unop s lognot (ARITH-1 <bitnot> scm_lognot) inst-pt sp fp)
(LABEL gt)
(PRSTACK sp fp)
(CMP q> scm_gr_p p instructions inst-pt fp sp)
......
......@@ -60,6 +60,8 @@ compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
(
E==#t ->
(Tail==#t -> L=[[softie,A],[cc]|LL] ; L=[[softie,A]|LL]);
E==c ->
throw(c);
throw(softie(A))
)
),
......
......@@ -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))
#:export (begin_att end_att recur verbatim_call))
(compile-prolog-string "
reverse_op(<,>).
......@@ -152,7 +152,7 @@ compile_goal((F :- Goal),Tail,V,L) :- !,
push_v(4,V),
wrap(compile_goal((pop(4),Goal),Tail,V,L),L).
compile_goal(Op(recur,(F(|U))),Tail,V,L) :-
compile_goal(Op(recur,(F(|U))),Tail,V,L) :- !,
Op=\"op2*\",
get_line(U,X,Xin,N),
reverse(X,XX),
......@@ -191,6 +191,44 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
)
).
compile_goal(verbatim_call(X),Tail,V,[L,LL]) :-
( nonvar(X),
(
F(|Args)=X ->
(
(var(F) ; isApply(Args)) -> fail ; true
) ;
true
)
),
!,
compile_goal(X,Tail,V,[L,LL]).
compile_goal(call(X),Tail,V,[L,LL]) :-
( nonvar(X),
(
F(|Args)=X ->
(
(var(F) ; isApply(Args)) -> fail ; true
) ;
true
)
),
!,
L=[['newframe-negation',Al,0]|LX],
get_C(V,C),
C = [C0|_],
CC = [Al|C],
compile_goal(X,#f,V,[LX,LLX]),
set_C(V,C),
(Tail=#t -> LG==[[cc]|LL] ; LG=LL),
LLX = [[goto-inst ,Bl ],
[label ,Al ],
['unwind-negation' ,Al,C0],
[label ,Bl ],
['post-q' ,Al,C0]|LG].
compile_goal((X =.. Y),Tail,V, L, LL) :- !,
(var(X);constant(X)) ->
(
......@@ -233,7 +271,7 @@ compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !,
compile_goal(\\+X,Tail,V,[L,LL]).
compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
L=[[newframe,Al,0]|LX],
L=[['newframe-negation',Al,0]|LX],
get_ACESB(V,A,C,E,S,B),
C = [C0|_],
CC = [Al|C],
......
......@@ -184,6 +184,7 @@ t(unwind).
t('unwind-tail').
t(softie).
t('post-s').
t('post-q').
t('newframe-negation').
t('unwind-negation').
......
......@@ -185,19 +185,6 @@
(-vector- #:brace (arg stx l))
(-vector- #:brace))))
(((and a (_ _ ";" _)) ((and b (_ _ "->" _)) c d n2 m2) y n1 m2)
(=> fail)
(if first?
(fget
`(,a (,b ,c
((xfy _ "," _)
(#:atom ! #f #f ,n2 ,m2)
,d
,n2 ,m2)
,n2 ,m2)
,y ,n1 ,m2) #:first? #f)
(fail)))
((#:term (and atom (#:atom f _ _ n m)) () #f . _)
(add-sym mod local? atom)
(-eval- (car (f->stxfkn #f mod f local? atom arg #f stx #f n m '()))))
......
This diff is collapsed.
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