mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Baseline compiler emits source locations

Browse source 
* module/language/tree-il/compile-bytecode.scm (compile-closure): Emit
  source annotations where we have them.
This commit is contained in:
Andy Wingo 2020-05-11 16:53:23 +02:00
parent f66111a203
commit b02a889659
1 changed files with 42 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

48
module/language/tree-il/compile-bytecode.scm
View file

@ -798,6 +798,9 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-current-module asm 0) (emit-current-module asm 0)
(emit-cache-set! asm scope 0))) (emit-cache-set! asm scope 0)))
(define (maybe-emit-source source)
(when source (emit-source asm source)))
(define (init-free-vars dst free-vars env tmp0 tmp1) (define (init-free-vars dst free-vars env tmp0 tmp1)
(let lp ((free-idx 0) (free-vars free-vars)) (let lp ((free-idx 0) (free-vars free-vars))
(unless (null? free-vars) (unless (null? free-vars)
@ -822,6 +825,7 @@ in the frame with for the lambda-case clause @var{clause}."
env names syms)) env names syms))
(let ((proc-slot (stack-height env)) (let ((proc-slot (stack-height env))
(nreq (length req))) (nreq (length req)))
(maybe-emit-source src)
(unless (and rest (zero? nreq)) (unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq)) (emit-receive-values asm proc-slot (->bool rest) nreq))
(when rest (when rest
@ -835,6 +839,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta ($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
(maybe-emit-source src)
(let ((tag (env-idx (for-value tag env))) (let ((tag (env-idx (for-value tag env)))
(proc-slot (stack-height env)) (proc-slot (stack-height env))
(khandler (gensym "handler")) (khandler (gensym "handler"))
@ -863,10 +868,12 @@ in the frame with for the lambda-case clause @var{clause}."
(match exp (match exp
(($ <conditional> src ($ <primcall> tsrc name args) (($ <conditional> src ($ <primcall> tsrc name args)
consequent alternate) consequent alternate)
(maybe-emit-source tsrc)
(let ((emit (primitive-emitter (lookup-primitive name))) (let ((emit (primitive-emitter (lookup-primitive name)))
(args (for-args args env)) (args (for-args args env))
(kf (gensym "false")) (kf (gensym "false"))
(kdone (gensym "done"))) (kdone (gensym "done")))
(maybe-emit-source src)
(match args (match args
((a) (emit asm a kf)) ((a) (emit asm a kf))
((a b) (emit asm a b kf))) ((a b) (emit asm a b kf)))
@ -880,6 +887,7 @@ in the frame with for the lambda-case clause @var{clause}."
(define (visit-seq exp env ctx) (define (visit-seq exp env ctx)
(match exp (match exp
(($ <seq> src head tail) (($ <seq> src head tail)
(maybe-emit-source src)
(for-effect head env) (for-effect head env)
(for-context tail env ctx)))) (for-context tail env ctx))))
@ -894,6 +902,7 @@ in the frame with for the lambda-case clause @var{clause}."
env names syms vals)) env names syms vals))
(match exp (match exp
(($ <let> src names syms vals body) (($ <let> src names syms vals body)
(maybe-emit-source src)
(for-context body (push-bindings names syms vals env) ctx)))) (for-context body (push-bindings names syms vals env) ctx))))
(define (visit-fix exp env ctx) (define (visit-fix exp env ctx)
@ -920,12 +929,14 @@ in the frame with for the lambda-case clause @var{clause}."
env)) env))
(match exp (match exp
(($ <fix> src names syms vals body) (($ <fix> src names syms vals body)
(maybe-emit-source src)
(for-context body (push-bindings names syms vals env) ctx)))) (for-context body (push-bindings names syms vals env) ctx))))
(define (visit-let-values exp env ctx) (define (visit-let-values exp env ctx)
(match exp (match exp
(($ <let-values> src exp (($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f)) ($ <lambda-case> lsrc req #f rest #f () syms body #f))
(maybe-emit-source src)
(for-values exp env) (for-values exp env)
(visit-values-handler lsrc req rest syms body env ctx)))) (visit-values-handler lsrc req rest syms body env ctx))))
@ -957,6 +968,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <lexical-set> src name sym exp) (($ <lexical-set> src name sym exp)
(let ((env (for-value exp env))) (let ((env (for-value exp env)))
(maybe-emit-source src)
(match (lookup-lexical sym env) (match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t) ;; Boxed closure. (($ <env> _ _ _ idx #t #t) ;; Boxed closure.
(emit-load-free-variable asm 0 (1- frame-size) idx 0) (emit-load-free-variable asm 0 (1- frame-size) idx 0)
@ -966,11 +978,13 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <module-set> src mod name public? exp) (($ <module-set> src mod name public? exp)
(let ((env (for-value exp env))) (let ((env (for-value exp env)))
(maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #f 1) (emit-cached-module-box asm 0 mod name public? #f 1)
(emit-box-set! asm 0 (env-idx env)))) (emit-box-set! asm 0 (env-idx env))))
(($ <toplevel-set> src mod name exp) (($ <toplevel-set> src mod name exp)
(let ((env (for-value exp env))) (let ((env (for-value exp env)))
(maybe-emit-source src)
(if module-scope (if module-scope
(emit-cached-toplevel-box asm 0 module-scope name #f 1) (emit-cached-toplevel-box asm 0 module-scope name #f 1)
(emit-toplevel-box asm 0 name #f 1)) (emit-toplevel-box asm 0 name #f 1))
@ -978,6 +992,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <toplevel-define> src mod name exp) (($ <toplevel-define> src mod name exp)
(let ((env (for-value exp env))) (let ((env (for-value exp env)))
(maybe-emit-source src)
(emit-current-module asm 0) (emit-current-module asm 0)
(emit-load-constant asm 1 name) (emit-load-constant asm 1 name)
(emit-define! asm 0 0 1) (emit-define! asm 0 0 1)
@ -987,6 +1002,7 @@ in the frame with for the lambda-case clause @var{clause}."
(let ((proc-slot (let ((env (push-frame env))) (let ((proc-slot (let ((env (push-frame env)))
(fold for-push (for-push proc env) args) (fold for-push (for-push proc env) args)
(stack-height env)))) (stack-height env))))
(maybe-emit-source src)
(emit-handle-interrupts asm) (emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args))) (emit-call asm proc-slot (1+ (length args)))
(emit-reset-frame asm frame-size))) (emit-reset-frame asm frame-size)))
@ -1004,14 +1020,20 @@ in the frame with for the lambda-case clause @var{clause}."
((a ($ <const> _ (? emit/immediate? b))) ((a ($ <const> _ (? emit/immediate? b)))
(let ((emit (primitive-emitter/immediate prim))) (let ((emit (primitive-emitter/immediate prim)))
(match (for-args (list a) env) (match (for-args (list a) env)
((a) (emit asm a b))))) ((a)
(maybe-emit-source src)
(emit asm a b)))))
((a ($ <const> _ (? emit/immediate? b)) c) ((a ($ <const> _ (? emit/immediate? b)) c)
(let ((emit (primitive-emitter/immediate prim))) (let ((emit (primitive-emitter/immediate prim)))
(match (for-args (list a c) env) (match (for-args (list a c) env)
((a c) (emit asm a b c))))) ((a c)
(maybe-emit-source src)
(emit asm a b c)))))
(_ (_
(let ((emit (primitive-emitter prim))) (let ((emit (primitive-emitter prim))
(apply emit asm (for-args args env))))))))) (args (for-args args env)))
(maybe-emit-source src)
(apply emit asm args))))))))
(($ <prompt>) (visit-prompt exp env 'effect)) (($ <prompt>) (visit-prompt exp env 'effect))
(($ <conditional>) (visit-conditional exp env 'effect)) (($ <conditional>) (visit-conditional exp env 'effect))
@ -1067,6 +1089,7 @@ in the frame with for the lambda-case clause @var{clause}."
(define dst (env-idx dst-env)) (define dst (env-idx dst-env))
(match exp (match exp
(($ <lexical-ref> src name sym) (($ <lexical-ref> src name sym)
(maybe-emit-source src)
(match (lookup-lexical sym env) (match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t) (($ <env> _ _ _ idx #t #t)
(emit-load-free-variable asm dst (1- frame-size) idx 0) (emit-load-free-variable asm dst (1- frame-size) idx 0)
@ -1079,19 +1102,23 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-mov asm dst idx)))) (emit-mov asm dst idx))))
(($ <const> src val) (($ <const> src val)
(maybe-emit-source src)
(emit-load-constant asm dst val)) (emit-load-constant asm dst val))
(($ <module-ref> src mod name public?) (($ <module-ref> src mod name public?)
(maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #t 1) (emit-cached-module-box asm 0 mod name public? #t 1)
(emit-box-ref asm dst 0)) (emit-box-ref asm dst 0))
(($ <toplevel-ref> src mod name) (($ <toplevel-ref> src mod name)
(maybe-emit-source src)
(if module-scope (if module-scope
(emit-cached-toplevel-box asm 0 module-scope name #t 1) (emit-cached-toplevel-box asm 0 module-scope name #t 1)
(emit-toplevel-box asm 0 name #t 1)) (emit-toplevel-box asm 0 name #t 1))
(emit-box-ref asm dst 0)) (emit-box-ref asm dst 0))
(($ <lambda> src) (($ <lambda> src)
(maybe-emit-source src)
(match (lookup-closure exp) (match (lookup-closure exp)
(($ <closure> label code scope free-vars) (($ <closure> label code scope free-vars)
(maybe-cache-module! scope 0) (maybe-cache-module! scope 0)
@ -1116,6 +1143,7 @@ in the frame with for the lambda-case clause @var{clause}."
(let ((proc-slot (let ((env (push-frame env))) (let ((proc-slot (let ((env (push-frame env)))
(fold for-push (for-push proc env) args) (fold for-push (for-push proc env) args)
(stack-height env)))) (stack-height env))))
(maybe-emit-source src)
(emit-handle-interrupts asm) (emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args))) (emit-call asm proc-slot (1+ (length args)))
(emit-receive asm (stack-height base) proc-slot frame-size))) (emit-receive asm (stack-height base) proc-slot frame-size)))
@ -1123,6 +1151,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <primcall> src (? variadic-constructor? name) args) (($ <primcall> src (? variadic-constructor? name) args)
;; Stage result in 0 to avoid stompling args. ;; Stage result in 0 to avoid stompling args.
(let ((args (for-args args env))) (let ((args (for-args args env)))
(maybe-emit-source src)
(match name (match name
('list ('list
(emit-load-constant asm 0 '()) (emit-load-constant asm 0 '())
@ -1162,14 +1191,18 @@ in the frame with for the lambda-case clause @var{clause}."
(match args (match args
((($ <const> _ (? emit/immediate? a))) ((($ <const> _ (? emit/immediate? a)))
(let* ((emit (primitive-emitter/immediate prim))) (let* ((emit (primitive-emitter/immediate prim)))
(maybe-emit-source src)
(emit asm dst a))) (emit asm dst a)))
((a ($ <const> _ (? emit/immediate? b))) ((a ($ <const> _ (? emit/immediate? b)))
(let* ((emit (primitive-emitter/immediate prim)) (let* ((emit (primitive-emitter/immediate prim))
(a (for-value a env))) (a (for-value a env)))
(maybe-emit-source src)
(emit asm dst (env-idx a) b))) (emit asm dst (env-idx a) b)))
(_ (_
(let ((emit (primitive-emitter prim))) (let ((emit (primitive-emitter prim))
(apply emit asm dst (for-args args env))))))))) (args (for-args args env)))
(maybe-emit-source src)
(apply emit asm dst args))))))))
(($ <prompt>) (visit-prompt exp env `(value-at . ,base))) (($ <prompt>) (visit-prompt exp env `(value-at . ,base)))
(($ <conditional>) (visit-conditional exp env `(value-at . ,base))) (($ <conditional>) (visit-conditional exp env `(value-at . ,base)))
@ -1222,6 +1255,7 @@ in the frame with for the lambda-case clause @var{clause}."
(env (push-frame env)) (env (push-frame env))
(from (stack-height env))) (from (stack-height env)))
(fold for-push (for-push proc env) args) (fold for-push (for-push proc env) args)
(maybe-emit-source src)
(emit-handle-interrupts asm) (emit-handle-interrupts asm)
(emit-call asm from (1+ (length args))) (emit-call asm from (1+ (length args)))
(unless (= from to) (unless (= from to)
@ -1256,6 +1290,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <call> src proc args) (($ <call> src proc args)
(let* ((base (stack-height env)) (let* ((base (stack-height env))
(env (fold for-push (for-push proc env) args))) (env (fold for-push (for-push proc env) args)))
(maybe-emit-source src)
(let lp ((i (length args)) (env env)) (let lp ((i (length args)) (env env))
(when (<= 0 i) (when (<= 0 i)
(lp (1- i) (env-prev env)) (lp (1- i) (env-prev env))
@ -1285,6 +1320,7 @@ in the frame with for the lambda-case clause @var{clause}."
(list-tail inits (if opt (length opt) 0))))) (list-tail inits (if opt (length opt) 0)))))
(unless (= (length names) (length syms) (length inits)) (unless (= (length names) (length syms) (length inits))
(error "unexpected args" names syms inits)) (error "unexpected args" names syms inits))
(maybe-emit-source src)
(let ((env (create-initial-env names syms free-vars))) (let ((env (create-initial-env names syms free-vars)))
(for-each (lambda (sym init) (for-init sym init env)) syms inits) (for-each (lambda (sym init) (for-init sym init env)) syms inits)
(for-tail body env)))))) (for-tail body env))))))