diff options
| -rw-r--r-- | stdlib/compiler.tl | 3 | ||||
| -rw-r--r-- | stdlib/optimize.tl | 35 |
2 files changed, 27 insertions, 11 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index 08e1e16e..451b7988 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -244,6 +244,7 @@ symvec lt-frags last-form + top-form closure-spies access-spies @@ -2354,7 +2355,7 @@ (eval (if-match (sys:dvbind @nil @exp) form exp form))) (defun usr:compile-toplevel (exp : (expanded-p nil)) - (let ((co (new compiler)) + (let ((co (new compiler top-form exp)) (as (new assembler)) (*dedup* (or *dedup* (hash))) (*load-time* nil) diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl index 702a4252..d4043528 100644 --- a/stdlib/optimize.tl +++ b/stdlib/optimize.tl @@ -68,6 +68,7 @@ recalc reelim tryjoin + warned-insns (:static start (gensym "start-")) (:static jump-ops '(jmp if ifq ifql close swtch ret abscsr uwprot catch block jend xend)) @@ -538,17 +539,31 @@ (@(require ((@(as op @(or gapply gcall)) @tgt @idx . @(all @(or (d @dn) @(with (t 0) dn nil)))) - . @rest) + . @(with @rest + val nil)) [%const-foldable% [bb.symvec idx]] - [none dn (lop member bb.lt-dregs : cadr)]) - (let* ((co bb.compiler) - (dvec co.(get-datavec)) - (fun [bb.symvec idx]) - (args (mapcar [iffi true dvec] dn)) - (val (if (eq op 'gcall) - (apply fun args) - (apply fun (append [args 0..-1] [args -1])))) - (dreg co.(get-dreg val))) + [none dn (lop member bb.lt-dregs : cadr)] + (let ((err '#:err)) + (set val (let* ((insn (car insns)) + (co bb.compiler) + (dvec co.(get-datavec)) + (fun [bb.symvec idx]) + (args (mapcar [iffi true dvec] dn)) + (val (usr:catch + (if (eq op 'gcall) + (apply fun args) + (apply fun (append [args 0..-1] + [args -1]))) + (error (#:x) err)))) + (when (and (eq val err) + (not (member insn bb.warned-insns))) + (compile-warning co.top-form + "function ~s with arguments ~s throws" + fun args) + (push insn bb.warned-insns)) + val)) + (neq val err))) + (let* ((dreg bb.compiler.(get-dreg val))) ^((mov ,tgt ,dreg) ,*rest))) ;; apply to gapply (@(require @(with ((getf @(as treg (t @tn)) @idx) . @rest) |