[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/06: Baseline compiler emits source locations
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 06/06: Baseline compiler emits source locations |
|
Date: |
Mon, 11 May 2020 11:02:42 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit b02a8896592b45a16e901a5f268d120d767f9ebc
Author: Andy Wingo <address@hidden>
AuthorDate: Mon May 11 16:53:23 2020 +0200
Baseline compiler emits source locations
* module/language/tree-il/compile-bytecode.scm (compile-closure): Emit
source annotations where we have them.
---
module/language/tree-il/compile-bytecode.scm | 48 ++++++++++++++++++++++++----
1 file changed, 42 insertions(+), 6 deletions(-)
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
index 680738e..ab4d7e1 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -798,6 +798,9 @@ in the frame with for the lambda-case clause @var{clause}."
(emit-current-module asm 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)
(let lp ((free-idx 0) (free-vars free-vars))
(unless (null? free-vars)
@@ -822,6 +825,7 @@ in the frame with for the lambda-case clause @var{clause}."
env names syms))
(let ((proc-slot (stack-height env))
(nreq (length req)))
+ (maybe-emit-source src)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when rest
@@ -835,6 +839,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ (maybe-emit-source src)
(let ((tag (env-idx (for-value tag env)))
(proc-slot (stack-height env))
(khandler (gensym "handler"))
@@ -863,10 +868,12 @@ in the frame with for the lambda-case clause
@var{clause}."
(match exp
(($ <conditional> src ($ <primcall> tsrc name args)
consequent alternate)
+ (maybe-emit-source tsrc)
(let ((emit (primitive-emitter (lookup-primitive name)))
(args (for-args args env))
(kf (gensym "false"))
(kdone (gensym "done")))
+ (maybe-emit-source src)
(match args
((a) (emit asm a 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)
(match exp
(($ <seq> src head tail)
+ (maybe-emit-source src)
(for-effect head env)
(for-context tail env ctx))))
@@ -894,6 +902,7 @@ in the frame with for the lambda-case clause @var{clause}."
env names syms vals))
(match exp
(($ <let> src names syms vals body)
+ (maybe-emit-source src)
(for-context body (push-bindings names syms vals env) ctx))))
(define (visit-fix exp env ctx)
@@ -920,12 +929,14 @@ in the frame with for the lambda-case clause
@var{clause}."
env))
(match exp
(($ <fix> src names syms vals body)
+ (maybe-emit-source src)
(for-context body (push-bindings names syms vals env) ctx))))
(define (visit-let-values exp env ctx)
(match exp
(($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ (maybe-emit-source src)
(for-values exp env)
(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)
(let ((env (for-value exp env)))
+ (maybe-emit-source src)
(match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t) ;; Boxed closure.
(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)
(let ((env (for-value exp env)))
+ (maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #f 1)
(emit-box-set! asm 0 (env-idx env))))
(($ <toplevel-set> src mod name exp)
(let ((env (for-value exp env)))
+ (maybe-emit-source src)
(if module-scope
(emit-cached-toplevel-box asm 0 module-scope 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)
(let ((env (for-value exp env)))
+ (maybe-emit-source src)
(emit-current-module asm 0)
(emit-load-constant asm 1 name)
(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)))
(fold for-push (for-push proc env) args)
(stack-height env))))
+ (maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args)))
(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)))
(let ((emit (primitive-emitter/immediate prim)))
(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)
(let ((emit (primitive-emitter/immediate prim)))
(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)))
- (apply emit asm (for-args args env)))))))))
+ (let ((emit (primitive-emitter prim))
+ (args (for-args args env)))
+ (maybe-emit-source src)
+ (apply emit asm args))))))))
(($ <prompt>) (visit-prompt 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))
(match exp
(($ <lexical-ref> src name sym)
+ (maybe-emit-source src)
(match (lookup-lexical sym env)
(($ <env> _ _ _ idx #t #t)
(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))))
(($ <const> src val)
+ (maybe-emit-source src)
(emit-load-constant asm dst val))
(($ <module-ref> src mod name public?)
+ (maybe-emit-source src)
(emit-cached-module-box asm 0 mod name public? #t 1)
(emit-box-ref asm dst 0))
(($ <toplevel-ref> src mod name)
+ (maybe-emit-source src)
(if module-scope
(emit-cached-toplevel-box asm 0 module-scope name #t 1)
(emit-toplevel-box asm 0 name #t 1))
(emit-box-ref asm dst 0))
(($ <lambda> src)
+ (maybe-emit-source src)
(match (lookup-closure exp)
(($ <closure> label code scope free-vars)
(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)))
(fold for-push (for-push proc env) args)
(stack-height env))))
+ (maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm proc-slot (1+ (length args)))
(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)
;; Stage result in 0 to avoid stompling args.
(let ((args (for-args args env)))
+ (maybe-emit-source src)
(match name
('list
(emit-load-constant asm 0 '())
@@ -1162,14 +1191,18 @@ in the frame with for the lambda-case clause
@var{clause}."
(match args
((($ <const> _ (? emit/immediate? a)))
(let* ((emit (primitive-emitter/immediate prim)))
+ (maybe-emit-source src)
(emit asm dst a)))
((a ($ <const> _ (? emit/immediate? b)))
(let* ((emit (primitive-emitter/immediate prim))
(a (for-value a env)))
+ (maybe-emit-source src)
(emit asm dst (env-idx a) b)))
(_
- (let ((emit (primitive-emitter prim)))
- (apply emit asm dst (for-args args env)))))))))
+ (let ((emit (primitive-emitter prim))
+ (args (for-args args env)))
+ (maybe-emit-source src)
+ (apply emit asm dst args))))))))
(($ <prompt>) (visit-prompt 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))
(from (stack-height env)))
(fold for-push (for-push proc env) args)
+ (maybe-emit-source src)
(emit-handle-interrupts asm)
(emit-call asm from (1+ (length args)))
(unless (= from to)
@@ -1256,6 +1290,7 @@ in the frame with for the lambda-case clause
@var{clause}."
(($ <call> src proc args)
(let* ((base (stack-height env))
(env (fold for-push (for-push proc env) args)))
+ (maybe-emit-source src)
(let lp ((i (length args)) (env env))
(when (<= 0 i)
(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)))))
(unless (= (length names) (length syms) (length inits))
(error "unexpected args" names syms inits))
+ (maybe-emit-source src)
(let ((env (create-initial-env names syms free-vars)))
(for-each (lambda (sym init) (for-init sym init env)) syms inits)
(for-tail body env))))))
- [Guile-commits] branch master updated (2ba3eb4 -> b02a889), Andy Wingo, 2020/05/11
- [Guile-commits] 02/06: Avoid having "guild compile" load optimizers, Andy Wingo, 2020/05/11
- [Guile-commits] 03/06: Emit handle-interrupts in baseline compiler, Andy Wingo, 2020/05/11
- [Guile-commits] 01/06: Switch to baseline compiler for bootstrap/, Andy Wingo, 2020/05/11
- [Guile-commits] 06/06: Baseline compiler emits source locations,
Andy Wingo <=
- [Guile-commits] 05/06: Baseline O(1) access to frame-base env, Andy Wingo, 2020/05/11
- [Guile-commits] 04/06: Slight tweaks to bootstrap order, Andy Wingo, 2020/05/11