mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-15 16:20:17 +02:00
Add VM ops needed for string-ref
* libguile/vm-engine.c (tail-pointer-ref/immediate, tag-char) (untag-char): New instructions. * module/language/cps/compile-bytecode.scm (compile-function): Add support for new instructions. * module/language/cps/cse.scm (compute-equivalent-subexpressions): CSE cases for tag-char / untag-char. * module/language/cps/effects-analysis.scm: * module/language/cps/types.scm: Add cases for new primcalls. * module/language/cps/reify-primitives.scm (reify-primitives): Update comment. * module/language/cps/slot-allocation.scm (compute-var-representations): Add cases for untag-char, tail-pointer-ref/immediate. * module/language/cps/specialize-primcalls.scm (specialize-primcalls): Add untag-char case, and add FIXME comment for tag-char. * module/system/vm/assembler.scm: Export new assemblers.
This commit is contained in:
Andy Wingo
parent
39fb7e540b
commit
91d0db1bf7
9 changed files with 62 additions and 12 deletions
|
|
@ -1431,10 +1431,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
NEXT (1);
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (47, unused_47, NULL, NOP)
|
||||
VM_DEFINE_OP (47, tail_pointer_ref_immediate, "tail-pointer-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
|
||||
{
|
||||
vm_error_bad_instruction (op);
|
||||
abort ();
|
||||
scm_t_uint8 dst, obj, idx;
|
||||
|
||||
UNPACK_8_8_8 (op, dst, obj, idx);
|
||||
|
||||
SP_SET_PTR (dst, ((scm_t_bits *) SCM2PTR (SP_REF (obj))) + idx);
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -2206,8 +2211,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
|
||||
|
||||
|
||||
VM_DEFINE_OP (81, unused_81, NULL, NOP)
|
||||
VM_DEFINE_OP (82, unused_82, NULL, NOP)
|
||||
VM_DEFINE_OP (81, tag_char, "tag-char", OP1 (X8_S12_S12) | OP_DST)
|
||||
{
|
||||
scm_t_uint16 dst, src;
|
||||
UNPACK_12_12 (op, dst, src);
|
||||
SP_SET (dst,
|
||||
SCM_MAKE_ITAG8 ((scm_t_bits) (scm_t_wchar) SP_REF_U64 (src),
|
||||
scm_tc8_char));
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (82, untag_char, "untag-char", OP1 (X8_S12_S12) | OP_DST)
|
||||
{
|
||||
scm_t_uint16 dst, src;
|
||||
UNPACK_12_12 (op, dst, src);
|
||||
SP_SET_U64 (dst, SCM_CHAR (SP_REF (src)));
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (83, unused_83, NULL, NOP)
|
||||
VM_DEFINE_OP (84, unused_84, NULL, NOP)
|
||||
VM_DEFINE_OP (85, unused_85, NULL, NOP)
|
||||
|
|
|
|||
|
|
@ -172,6 +172,9 @@
|
|||
(emit-word-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
|
||||
(($ $primcall 'pointer-ref/immediate (annotation . idx) (obj))
|
||||
(emit-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
|
||||
(($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
|
||||
(emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj))
|
||||
idx))
|
||||
(($ $primcall 'char->integer #f (src))
|
||||
(emit-char->integer asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'integer->char #f (src))
|
||||
|
|
@ -269,6 +272,10 @@
|
|||
(emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'tag-fixnum #f (src))
|
||||
(emit-tag-fixnum asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'untag-char #f (src))
|
||||
(emit-untag-char asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'tag-char #f (src))
|
||||
(emit-tag-char asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall name #f args)
|
||||
;; FIXME: Inline all the cases.
|
||||
(emit-text asm `((,name ,(from-sp dst)
|
||||
|
|
|
|||
|
|
@ -275,7 +275,10 @@ false. It could be that both true and false proofs are available."
|
|||
((s <- tag-fixnum #f u) (u <- scm->s64 #f s)
|
||||
(u <- untag-fixnum #f s))
|
||||
((s <- u64->s64 #f u) (u <- s64->u64 #f s))
|
||||
((u <- s64->u64 #f s) (s <- u64->s64 #f u)))))
|
||||
((u <- s64->u64 #f s) (s <- u64->s64 #f u))
|
||||
|
||||
((u <- untag-char #f s) (s <- tag-char #f u))
|
||||
((s <- tag-char #f u) (u <- untag-char #f s)))))
|
||||
|
||||
(define (visit-label label equiv-labels var-substs)
|
||||
(define (term-defs term)
|
||||
|
|
|
|||
|
|
@ -395,7 +395,8 @@ the LABELS that are clobbered by the effects of LABEL."
|
|||
(match param
|
||||
((ann . idx)
|
||||
(&write-field
|
||||
(annotation->memory-kind ann) idx)))))
|
||||
(annotation->memory-kind ann) idx))))
|
||||
((tail-pointer-ref/immediate obj)))
|
||||
|
||||
;; Strings.
|
||||
(define-primitive-effects
|
||||
|
|
@ -542,6 +543,8 @@ the LABELS that are clobbered by the effects of LABEL."
|
|||
|
||||
;; Characters.
|
||||
(define-primitive-effects
|
||||
((untag-char _))
|
||||
((tag-char _))
|
||||
((integer->char _) &type-check)
|
||||
((char->integer _) &type-check))
|
||||
|
||||
|
|
|
|||
|
|
@ -352,7 +352,7 @@
|
|||
(setk label ($kargs names vars
|
||||
($continue kop src
|
||||
($primcall 'load-u64 n ())))))))))
|
||||
;; Assume pointer-ref/immediate is within u8 range.
|
||||
;; Assume (tail-)pointer-ref/immediate is within u8 range.
|
||||
(((or 'word-ref/immediate 'scm-ref/immediate) obj)
|
||||
(match param
|
||||
((ann . idx)
|
||||
|
|
|
|||
|
|
@ -758,7 +758,8 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
'uadd/immediate 'usub/immediate 'umul/immediate
|
||||
'ursh/immediate 'ulsh/immediate
|
||||
'u8-ref 'u16-ref 'u32-ref 'u64-ref
|
||||
'word-ref 'word-ref/immediate))
|
||||
'word-ref 'word-ref/immediate
|
||||
'untag-char))
|
||||
(intmap-add representations var 'u64))
|
||||
(($ $primcall (or 'untag-fixnum
|
||||
'assume-s64
|
||||
|
|
@ -766,7 +767,8 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
'srsh 'srsh/immediate
|
||||
's8-ref 's16-ref 's32-ref 's64-ref))
|
||||
(intmap-add representations var 's64))
|
||||
(($ $primcall (or 'pointer-ref/immediate))
|
||||
(($ $primcall (or 'pointer-ref/immediate
|
||||
'tail-pointer-ref/immediate))
|
||||
(intmap-add representations var 'ptr))
|
||||
(_
|
||||
(intmap-add representations var 'scm))))
|
||||
|
|
|
|||
|
|
@ -124,7 +124,7 @@
|
|||
(('allocate-words (? uint? n)) (allocate-words/immediate n ()))
|
||||
(('scm-ref o (? uint? i)) (scm-ref/immediate i (o)))
|
||||
(('scm-set! o (? uint? i) x) (scm-set!/immediate i (o x)))
|
||||
;; Assume pointer-ref/immediate can always be emitted directly.
|
||||
;; Assume (tail-)pointer-ref/immediate can always be emitted directly.
|
||||
(('word-ref o (? uint? i)) (word-ref/immediate i (o)))
|
||||
(('word-set! o (? uint? i) x) (word-set!/immediate i (o x)))
|
||||
(('add x (? num? y)) (add/immediate y (x)))
|
||||
|
|
@ -139,7 +139,11 @@
|
|||
(('scm->u64 (? u64? var)) (load-u64 var ()))
|
||||
(('scm->u64/truncate (? u64? var)) (load-u64 var ()))
|
||||
(('scm->s64 (? s64? var)) (load-s64 var ()))
|
||||
(('untag-fixnum (? s64? var)) (load-s64 var ()))))
|
||||
(('untag-fixnum (? s64? var)) (load-s64 var ()))
|
||||
(('untag-char (? u64? var)) (load-u64 var ()))
|
||||
;; FIXME: add support for tagging immediate chars
|
||||
;; (('tag-char (? u64? var)) (load-const var ()))
|
||||
))
|
||||
(intmap-map
|
||||
(lambda (label cont)
|
||||
(match cont
|
||||
|
|
|
|||
|
|
@ -787,6 +787,8 @@ minimum, and maximum."
|
|||
|
||||
(define-type-inferrer/param (pointer-ref/immediate param obj result)
|
||||
(define! result &other-heap-object -inf.0 +inf.0))
|
||||
(define-type-inferrer/param (tail-pointer-ref/immediate param obj result)
|
||||
(define! result &other-heap-object -inf.0 +inf.0))
|
||||
|
||||
(define-type-inferrer/param (assume-u64 param val result)
|
||||
(match param
|
||||
|
|
@ -1616,6 +1618,11 @@ minimum, and maximum."
|
|||
;;; Characters.
|
||||
;;;
|
||||
|
||||
(define-type-inferrer (untag-char c result)
|
||||
(define! result &s64 0 (min (&max c) *max-codepoint*)))
|
||||
(define-type-inferrer (tag-char u64 result)
|
||||
(define! result &char 0 (min (&max u64) *max-codepoint*)))
|
||||
|
||||
(define-simple-type-checker (integer->char (&u64 0 *max-codepoint*)))
|
||||
(define-type-inferrer (integer->char i result)
|
||||
(restrict! i &u64 0 *max-codepoint*)
|
||||
|
|
|
|||
|
|
@ -103,6 +103,8 @@
|
|||
|
||||
emit-untag-fixnum
|
||||
emit-tag-fixnum
|
||||
emit-untag-char
|
||||
emit-tag-char
|
||||
|
||||
emit-throw
|
||||
(emit-throw/value* . emit-throw/value)
|
||||
|
|
@ -157,6 +159,7 @@
|
|||
|
||||
emit-pointer-ref/immediate
|
||||
emit-pointer-set!/immediate
|
||||
emit-tail-pointer-ref/immediate
|
||||
|
||||
emit-u8-ref
|
||||
emit-s8-ref
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue