diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-06-24 07:21:38 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-06-24 07:21:38 -0700 |
| commit | 2034729c70161b16d99eee0503c4354df39cd49d (patch) | |
| tree | 400e7b2f7c67625e7ab6da3fe4a16c3257f30eb8 /stdlib/compiler.tl | |
| parent | 65f1445db0d677189ab01635906869bfda56d3d9 (diff) | |
| download | txr-2034729c70161b16d99eee0503c4354df39cd49d.tar.gz txr-2034729c70161b16d99eee0503c4354df39cd49d.tar.bz2 txr-2034729c70161b16d99eee0503c4354df39cd49d.zip | |
file layout: moving share/txr/stdlib to stdlib.
This affects run-time also. Txr installations where the
executable is not in directory ending in ${bindir}
will look for stdlib rather than share/txr/stdlib,
relative to the determined installation directory.
* txr.c (sysroot_init): If we detect relative to the short
name, or fall back on the program directory, use stdlib
rather than share/txr/stdlib as the stdlib_path.
* INSTALL: Update some installation notes not to refer to
share/txr/stdlib but stdlib.
* Makefile (STDLIB_SRCS): Refer to stdlib, not
share/txr/stdlib.
(clean): In unconfigured mode, remove the old share/txr/stdlib
entirely. Remove .tlo files from stdlib.
(install): Install lib materials from stdlib.
* txr.1: Updated documentation under Deployment Directory Structure.
* share/txr/stdlib/{asm,awk,build,cadr}.tl:
Renamed to stdlib/{asm,awk,build,cadr}.tl.
* share/txr/stdlib/{compiler,conv,copy-file,debugger}.tl:
Renamed to stdlib/{compiler,conv,copy-file,debugger}.tl.
* share/txr/stdlib/{defset,doc-lookup,doc-syms,doloop}.tl:
Renamed to stdlib/{defset,doc-lookup,doc-syms,doloop}.tl.
* share/txr/stdlib/{each-prod,error,except,ffi}.tl:
Renamed to stdlib/{each-prod,error,except,ffi}.tl.
* share/txr/stdlib/{getopts,getput,hash,ifa}.tl:
Renamed to stdlib/{getopts,getput,hash,ifa}.tl.
* share/txr/stdlib/{keyparams,match,op,optimize}.tl:
Renamed to stdlib/{keyparams,match,op,optimize}.tl.
* share/txr/stdlib/{package,param,path-test,pic}.tl:
Renamed to stdlib/{package,param,path-test,pic}.tl.
* share/txr/stdlib/{place,pmac,quips,save-exe}.tl:
Renamed to stdlib/{place,pmac,quips,save-exe}.tl.
* share/txr/stdlib/{socket,stream-wrap,struct,tagbody}.tl:
Renamed to stdlib/{socket,stream-wrap,struct,tagbody}.tl.
* share/txr/stdlib/{termios,trace,txr-case,type}.tl:
Renamed to stdlib/{termios,trace,txr-case,type}.tl.
* share/txr/stdlib/{ver,vm-param,with-resources,with-stream}.tl:
Renamed to stdlib/{ver,vm-param,with-resources,with-stream}.tl.
* share/txr/stdlib/yield.tl: Renamed to stdlib/yield.tl.
* share/txr/stdlib/{txr-case,ver}.txr:
Renamed to stdlib/{txr-case,ver}.txr.
* gencadr.txr: Update to stdlib/place.tl.
* genman.txr: Update to stdlib/cadr.tl.
Diffstat (limited to 'stdlib/compiler.tl')
| -rw-r--r-- | stdlib/compiler.tl | 2394 |
1 files changed, 2394 insertions, 0 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl new file mode 100644 index 00000000..c30ebbd6 --- /dev/null +++ b/stdlib/compiler.tl @@ -0,0 +1,2394 @@ +;; Copyright 2018-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(load "vm-param") +(load "optimize") + +(compile-only + (load-for (struct sys:param-parser-base "param"))) + +(defstruct (frag oreg code : fvars ffuns pars) nil + oreg + code + pars + fvars + ffuns) + +(defstruct binding nil + sym + loc + used + sys:env) + +(defstruct vbinding binding) + +(defstruct fbinding binding + pars) + +(defstruct blockinfo nil + sym + used + sys:env) + +(defstruct sys:env nil + vb + fb + bb + up + co + lev + (v-cntr 0) + + (:postinit (me) + (unless me.lev + (set me.lev (succ (or me.up.?lev 0)))) + (unless (or me.co (null me.up)) + (set me.co me.up.co)) + me.co.(new-env me)) + + (:method lookup-var (me sym) + (condlet + (((cell (assoc sym me.vb))) + (cdr cell)) + (((up me.up)) up.(lookup-var sym)) + (t nil))) + + (:method lookup-fun (me sym : mark-used) + (condlet + (((cell (assoc sym me.fb))) + (let ((bi (cdr cell))) + (if mark-used (set bi.used t)) + bi)) + (((up me.up)) up.(lookup-fun sym mark-used)) + (t nil))) + + (:method lookup-lisp1 (me sym : mark-used) + (condlet + (((cell (or (assoc sym me.vb) + (assoc sym me.fb)))) + (let ((bi (cdr cell))) + (if mark-used (set bi.used t)) + bi)) + (((up me.up)) up.(lookup-lisp1 sym mark-used)) + (t nil))) + + (:method lookup-block (me sym : mark-used) + (condlet + (((cell (assoc sym me.bb))) + (let ((bi (cdr cell))) + (if mark-used (set bi.used t)) + bi)) + (((up me.up)) up.(lookup-block sym mark-used)) + (t nil))) + + (:method extend-var (me sym) + (when (assoc sym me.vb) + (compile-error me.co.last-form "duplicate variable: ~s" sym)) + (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) + (bn (new vbinding sym sym loc loc env me))) + (set me.vb (acons sym bn me.vb)))) + + (:method extend-var* (me sym) + (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) + (bn (new vbinding sym sym loc loc env me))) + (set me.vb (acons sym bn me.vb)))) + + (:method extend-fun (me sym) + (when (assoc sym me.fb) + (compile-error me.co.last-form "duplicate function ~s" sym)) + (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) + (bn (new fbinding sym sym loc loc env me))) + (set me.fb (acons sym bn me.fb)))) + + (:method rename-var (me from-sym to-sym) + (iflet ((cell (assoc from-sym me.vb))) + (rplaca cell to-sym) + (let ((bn (cdr cell))) + (set bn.sym to-sym)))) + + (:method out-of-scope (me reg) + (if (eq (car reg) 'v) + (let ((lev (ssucc (cadr reg)))) + (< me.lev lev)))) + + (:method extend-block (me sym) + (let* ((bn (new blockinfo sym sym env me))) + (set me.bb (acons sym bn me.bb))))) + +(defstruct closure-spy () + env + cap-vars + + (:method captured (me vbin sym) + (when (eq vbin.env me.env) + (pushnew sym me.cap-vars)))) + +(defstruct access-spy () + closure-spies + + (:method accessed (me vbin sym) + (each ((spy me.closure-spies)) + (when (neq spy me) + spy.(captured vbin sym)))) + + (:method assigned (me vbin sym) + (each ((spy me.closure-spies)) + (when (neq spy me) + spy.(captured vbin sym))))) + +(compile-only + (defstruct compiler nil + (treg-cntr 2) + (dreg-cntr 0) + (sidx-cntr 0) + (nlev 2) + (loop-nest 0) + (tregs nil) + (discards nil) + (dreg (hash :eql-based)) + (data (hash :eql-based)) + (sidx (hash :eql-based)) + (stab (hash :eql-based)) + datavec + symvec + lt-frags + last-form + closure-spies + access-spies + + (:method snapshot (me) + (let ((snap (copy me))) + (set snap.dreg (copy me.dreg) + snap.data (copy me.data) + snap.sidx (copy me.sidx) + snap.stab (copy me.stab)) + snap)) + + (:method restore (me snap) + (replace-struct me snap)))) + + +(eval-only + (defmacro compile-in-toplevel (me . body) + (with-gensyms (saved-tregs saved-treg-cntr saved-nlev saved-discards) + ^(let* ((,saved-tregs (qref ,me tregs)) + (,saved-treg-cntr (qref ,me treg-cntr)) + (,saved-discards (qref ,me discards))) + (unwind-protect + (progn + (set (qref ,me tregs) nil + (qref ,me treg-cntr) 2 + (qref ,me discards) nil) + (prog1 + (progn ,*body) + (qref ,me (check-treg-leak)))) + (set (qref ,me tregs) ,saved-tregs + (qref ,me treg-cntr) ,saved-treg-cntr + (qref ,me discards) ,saved-discards))))) + + (defmacro compile-with-fresh-tregs (me . body) + (with-gensyms (saved-tregs saved-treg-cntr saved-discards) + ^(let* ((,saved-tregs (qref ,me tregs)) + (,saved-treg-cntr (qref ,me treg-cntr)) + (,saved-discards (qref ,me discards))) + (unwind-protect + (progn + (set (qref ,me tregs) nil + (qref ,me treg-cntr) 2 + (qref ,me discards) nil) + (prog1 + (progn ,*body) + (qref ,me (check-treg-leak)))) + (set (qref ,me tregs) ,saved-tregs + (qref ,me treg-cntr) ,saved-treg-cntr + (qref ,me discards) ,saved-discards))))) + + (defun with-spy (me flag spy spy-expr body push-meth pop-meth) + ^(let ((,spy (if ,flag ,spy-expr))) + (unwind-protect + (progn + (if ,spy (qref ,me (,push-meth ,spy))) + ,*body) + (if ,spy (qref ,me (,pop-meth ,spy)))))) + + (defmacro with-closure-spy (me flag spy spy-expr . body) + (with-spy me flag spy spy-expr body 'push-closure-spy 'pop-closure-spy)) + + (defmacro with-access-spy (me flag spy spy-expr . body) + (with-spy me flag spy spy-expr body 'push-access-spy 'pop-access-spy))) + +(defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall))) + +(defvarl %call-op% (relate '(apply usr:apply call) '(apply apply call))) + +(defvarl %test-funs-pos% '(eq eql)) + +(defvarl %test-funs-neg% '(neq neql)) + +(defvarl %test-funs-ops% '(ifq ifql)) + +(defvarl %test-funs% (append %test-funs-pos% %test-funs-neg%)) + +(defvarl %test-inv% (relate %test-funs-neg% %test-funs-pos%)) + +(defvarl %test-opcode% (relate %test-funs-pos% %test-funs-ops%)) + +(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun + eval load compile compile-file compile-toplevel)) + +(defvarl %nary-ops% '(< > <= => = + - * /)) + +(defvarl %bin-ops% '(b< b> b<= b=> b= b+ b- b* b/)) + +(defvarl %bin-op% (relate %nary-ops% %bin-ops% nil)) + +(defvarl %const-foldable-funs% + '(+ - * / sum prod abs trunc mod zerop nzerop plusp minusp evenp oddp + > < >= <= = /= wrap wrap* expt exptmod isqrt square gcd lcm floor ceil + round trunc-rem floor-rem ceil-rem round-rem sin cos tan asin acos atan + atan2 sinh cosh tanh asinh acosh atanh log log10 log2 exp sqrt + logand logior logxor logtest lognot logtrunc sign-extend ash bit mask + width logcount bitset cum-norm-dist inv-cum-norm n-choose-k n-perm-k + fixnump bignump floatp integerp numberp signum bignum-len divides sys:bits + digpow digits poly rpoly b< b> b<= b=> b= b+ b- b* b/ neg + pred ppred ppred pppred succ ssucc ssucc sssucc + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr + cdadar cdaddr cddaar cddadr cdddar cddddr caaaaar caaaadr caaadar caaaddr + caadaar caadadr caaddar caadddr cadaaar cadaadr cadadar cadaddr caddaar + caddadr cadddar caddddr cdaaaar cdaaadr cdaadar cdaaddr cdadaar cdadadr + cdaddar cdadddr cddaaar cddaadr cddadar cddaddr cdddaar cdddadr cddddar + cdddddr cons first rest sub-list identity typeof atom null false true have + consp listp endp proper-listp length-list second third fourth fifth + sixth seventh eighth ninth tenth conses ldiff nthcdr nth tailp + memq memql memqual rmemq rmemql rmemqual countq countql countqual + posq posql posqual rposq rposql rposqual eq eql equal meq meql mequal + neq neql nequal max min clamp bracket take drop uniq if or and progn + prog1 prog2 nilf tf tostring tostringp display-width sys:fmt-simple + sys:fmt-flex join join-with sys:fmt-join packagep + symbolp keywordp bindable stringp length-str + coded-length cmp-str string-lt str= str< str> str<= str>= int-str + flo-str num-str int-flo flo-int tofloat toint tointz less greater + lequal gequal chrp chr-isalnum chr-isalnum chr-isalpha chr-isascii + chr-iscntrl chr-isdigit chr-digit chr-isgraph chr-islower chr-isprint + chr-ispunct chr-isspace chr-isblank chr-isunisp chr-isupper chr-isxdigit + chr-xdigit chr-toupper chr-tolower num-chr int-chr chr-num chr-int + chr-str span-str compl-span-str break-str vectorp length-vec size-vec + assq assql assoc rassq rassql rassoc prop memp length len empty ref + rangep from to in-range in-range* nullify)) + +(defvarl %const-foldable% (hash-list %const-foldable-funs% :eq-based)) + +(defvarl %effect-free-funs% + '(append append* revappend list list* zip interpose copy-list reverse + flatten flatten* flatcar flatcar* tuples remq remql remqual + keepq keepq keepqual remq* remql* remq* make-sym gensym + mkstring copy-str upcase-str downcase-str cat-str split-str spl + split-str-set sspl tok-str tok tok-where list-str trim-str + get-lines lazy-str length-str-> length-str->= length-str-< + length-str-<= vector vec vector-list list-vector list-vec + copy-vec sub-vec cat-vec acons acons-new aconsql-new alist-remove + copy-cons copy-tree copy-alist plist-to-alist improper-plist-to-alist + merge sort shuffle list-seq vec-seq str-seq copy sub seq-begin + iter-begin rcons make-like nullify symbol-value symbol-function + symbol-macro boundp fboundp mboundp special-operator-p special-var-p + copy-fun func-get-form func-get-name func-get-env functionp + interp-fun-p vm-fun-p fun-fixparam-count fun-optparam-count + fun-variadic sys:ctx-form sys:ctx-name range range* rlist rlist* + repeat pad weave promisep rperm perm comb rcomb source-loc + source-loc-str macro-ancestor cptr-int cptr-obj cptr-buf + int-cptr cptrp cptr-type cptr-size-hint)) + +(defvarl %effect-free% (hash-uni %const-foldable% + (hash-list %effect-free-funs% :eq-based))) + + +(defvarl %functional-funs% + '(chain chand juxt andf orf notf iff iffi dup flipargs if or and + progn prog1 prog2 retf apf ipf callf mapf tf nilf umethod uslot)) + +(defvarl %functional% (hash-list %functional-funs% :eq-based)) + +(defvarl assumed-fun) + +(defvar *in-compilation-unit* nil) + +(defvar *dedup*) + +(defvar *unchecked-calls*) + +(defvarl %param-info% (hash :eq-based :weak-keys)) + +(defvar *load-time*) + +;; 0 - no optimization +;; 1 - constant folding, algebraics. +;; 2 - block elimination, frame elimination +;; 3 - lambda/combinator lifting +;; 4 - control-flow: jump-threading, dead code +;; 5 - data-flow: dead registers, useless regisers +;; 6 - more expensive size or speed optimizations +(defvar usr:*opt-level* 6) + +(defun dedup (obj) + (cond + ((null obj) nil) + ((null *dedup*) obj) + ((or (stringp obj) (bignump obj)) + (or [*dedup* obj] (set [*dedup* obj] obj))) + (t obj))) + +(defun null-reg (reg) + (equal reg '(t 0))) + +(defmeth compiler get-dreg (me obj) + (let ((dobj (dedup obj))) + (condlet + ((((null dobj))) '(t 0)) + (((dreg [me.dreg dobj])) dreg) + ((((< me.dreg-cntr %lev-size%))) + (let ((dreg ^(d ,(pinc me.dreg-cntr)))) + (set [me.data (cadr dreg)] dobj) + (set [me.dreg dobj] dreg))) + (t (compile-error me.last-form "code too complex: too many literals"))))) + +(defmeth compiler alloc-dreg (me) + (if (< me.dreg-cntr %lev-size%) + (let ((dreg ^(d ,(pinc me.dreg-cntr)))) + (set [me.data (cadr dreg)] nil) + dreg) + (compile-error me.last-form "code too complex: too many literals"))) + +(defmeth compiler get-sidx (me atom) + (iflet ((sidx [me.sidx atom])) + sidx + (let* ((sidx (pinc me.sidx-cntr))) + (set [me.stab sidx] atom) + (set [me.sidx atom] sidx)))) + +(defmeth compiler get-datavec (me) + (or me.datavec + (set me.datavec (vec-list [mapcar me.data (range* 0 me.dreg-cntr)])))) + +(defmeth compiler get-symvec (me) + (or me.symvec + (set me.symvec (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)])))) + +(defmeth compiler alloc-treg (me) + (cond + (me.tregs (pop me.tregs)) + ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr))) + (t (compile-error me.last-form "code too complex: out of registers")))) + +(defmeth compiler alloc-new-treg (me) + (cond + ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr))) + (t (compile-error me.last-form "code too complex: out of registers")))) + +(defmeth compiler alloc-discard-treg (me) + (let ((treg me.(alloc-treg))) + (push treg me.discards) + treg)) + +(defmeth compiler free-treg (me treg) + (when (and (eq t (car treg)) (neq 0 (cadr treg))) + (when me.discards + (set me.discards (remqual treg me.discards))) + (push treg me.tregs))) + +(defmeth compiler free-tregs (me tregs) + (mapdo (meth me free-treg) tregs)) + +(defmeth compiler unalloc-reg-count (me) + (- %lev-size% me.treg-cntr)) + +(defmeth compiler maybe-alloc-treg (me given) + (if (and (eq t (car given)) (not (member given me.discards))) + given + me.(alloc-treg))) + +(defmeth compiler maybe-free-treg (me treg given) + (when (nequal treg given) + me.(free-treg treg))) + +(defmeth compiler check-treg-leak (me) + (let ((balance (- (ppred me.treg-cntr) (len me.tregs)))) + (unless (zerop balance) + (error "t-register leak in compiler: ~s outstanding" balance)))) + +(defmeth compiler maybe-mov (me to-reg from-reg) + (if (and (nequal to-reg from-reg) (not (member to-reg me.discards))) + ^((mov ,to-reg ,from-reg)))) + +(defmeth compiler new-env (me env) + (when (>= env.lev me.nlev) + (unless (<= env.lev %max-lev%) + (compile-error me.last-form + "code too complex: lexical nesting too deep")) + (set me.nlev (succ env.lev)))) + +(defmeth compiler push-closure-spy (me spy) + (push spy me.closure-spies)) + +(defmeth compiler pop-closure-spy (me spy) + (let ((top (pop me.closure-spies))) + (unless top + (error "closure spy stack bug in compiler")) + (unless (eq top spy) + (error "closure spy stack balance problem in compiler")))) + +(defmeth compiler push-access-spy (me spy) + (push spy me.access-spies)) + +(defmeth compiler pop-access-spy (me spy) + (let ((top (pop me.access-spies))) + (unless top + (error "access spy stack bug in compiler")) + (unless (eq top spy) + (error "access spy stack balance problem in compiler")))) + +(defmeth compiler compile (me oreg env form) + (set me.last-form form) + (cond + ((symbolp form) + (if (bindable form) + me.(comp-var oreg env form) + me.(comp-atom oreg form))) + ((atom form) me.(comp-atom oreg form)) + (t (let ((sym (car form))) + (cond + ((bindable sym) + (caseq sym + (quote me.(comp-atom oreg (cadr form))) + (sys:setq me.(comp-setq oreg env form)) + (sys:lisp1-setq me.(comp-lisp1-setq oreg env form)) + (sys:setqf me.(comp-setqf oreg env form)) + (cond me.(comp-cond oreg env form)) + (if me.(comp-if oreg env form)) + (switch me.(comp-switch oreg env form)) + (unwind-protect me.(comp-unwind-protect oreg env form)) + ((block block* sys:blk) me.(comp-block oreg env form)) + ((return-from sys:abscond-from) me.(comp-return-from oreg env form)) + (return me.(comp-return oreg env form)) + (handler-bind me.(comp-handler-bind oreg env form)) + (sys:catch me.(comp-catch oreg env form)) + ((let let*) me.(comp-let oreg env form)) + ((sys:fbind sys:lbind) me.(comp-fbind oreg env form)) + (lambda me.(comp-lambda oreg env form)) + (fun me.(comp-fun oreg env form)) + (sys:for-op me.(comp-for oreg env form)) + (sys:each-op me.(compile oreg env (expand-each form env))) + ((progn eval-only compile-only) me.(comp-progn oreg env (cdr form))) + (and me.(compile oreg env (expand-and form))) + (or me.(comp-or oreg env form)) + (prog1 me.(comp-prog1 oreg env form)) + (sys:quasi me.(comp-quasi oreg env form)) + (dohash me.(compile oreg env (expand-dohash form))) + (tree-bind me.(comp-tree-bind oreg env form)) + (mac-param-bind me.(comp-mac-param-bind oreg env form)) + (mac-env-param-bind me.(comp-mac-env-param-bind oreg env form)) + (tree-case me.(comp-tree-case oreg env form)) + (sys:lisp1-value me.(comp-lisp1-value oreg env form)) + (dwim me.(comp-dwim oreg env form)) + (prof me.(comp-prof oreg env form)) + (defvarl me.(compile oreg env (expand-defvarl form))) + (defun me.(compile oreg env (expand-defun form))) + (defmacro me.(compile oreg env (expand-defmacro form))) + (defsymacro me.(compile oreg env (expand-defsymacro form))) + (sys:upenv me.(compile oreg env.up (cadr form))) + (sys:dvbind me.(compile oreg env (caddr form))) + (sys:load-time-lit me.(comp-load-time-lit oreg env form)) + ;; compiler-only special operators: + (ift me.(comp-ift oreg env form)) + ;; specially treated functions + ((call apply usr:apply) me.(comp-apply-call oreg env form)) + ;; error cases + ((macrolet symacrolet macro-time) + (compile-error form "unexpanded ~s encountered" sym)) + ((sys:var sys:expr) + (compile-error form "meta with no meaning: ~s " form)) + ((usr:qquote usr:unquote usr:splice + sys:qquote sys:unquote sys:splice) + (compile-error form "unexpanded quasiquote encountered")) + ;; function call + ((+ *) me.(comp-arith-form oreg env form)) + ((- /) me.(comp-arith-neg-form oreg env form)) + (t me.(comp-fun-form oreg env form)))) + ((and (consp sym) + (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form))) + (t (compile-error form "invalid operator"))))))) + +(defmeth compiler comp-atom (me oreg form) + (cond + ((null form) (new (frag '(t 0) nil))) + (t (let ((dreg me.(get-dreg form))) + (new (frag dreg nil)))))) + +(defmeth compiler comp-var (me oreg env sym) + (let ((vbin env.(lookup-var sym))) + (cond + (vbin + (each ((spy me.access-spies)) + spy.(accessed vbin sym)) + (new (frag vbin.loc nil (list sym)))) + ((special-var-p sym) + (let ((dreg me.(get-dreg sym))) + (new (frag oreg ^((getv ,oreg ,dreg)) (list sym))))) + (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym))))))) + +(defmeth compiler comp-setq (me oreg env form) + (mac-param-bind form (op sym value) form + (let* ((bind env.(lookup-var sym)) + (spec (special-var-p sym)) + (vloc (cond + (bind bind.loc) + (spec me.(get-dreg sym)) + (t me.(get-sidx sym)))) + (vfrag me.(compile (if bind vloc oreg) env value))) + (when bind + (each ((spy me.access-spies)) + spy.(assigned bind sym))) + (new (frag vfrag.oreg + ^(,*vfrag.code + ,*(if bind + me.(maybe-mov vloc vfrag.oreg) + (if spec + ^((setv ,vfrag.oreg ,vloc)) + ^((setlx ,vfrag.oreg ,me.(get-sidx sym)))))) + (uni (list sym) vfrag.fvars) + vfrag.ffuns))))) + +(defmeth compiler comp-lisp1-setq (me oreg env form) + (mac-param-bind form (op sym val) form + (let ((bind env.(lookup-lisp1 sym))) + (cond + ((typep bind 'fbinding) + (compile-error form "assignment to lexical function binding")) + ((null bind) + (let ((vfrag me.(compile oreg env val)) + (l1loc me.(get-dreg sym))) + (new (frag vfrag.oreg + ^(,*vfrag.code + (setl1 ,vfrag.oreg ,l1loc)) + (uni (list sym) vfrag.fvars) + vfrag.ffuns)))) + (t (each ((spy me.access-spies)) + spy.(assigned bind sym)) + me.(compile oreg env ^(sys:setq ,sym ,val))))))) + +(defmeth compiler comp-setqf (me oreg env form) + (mac-param-bind form (op sym val) form + (if env.(lookup-fun sym) + (compile-error form "assignment to lexical function binding") + (let ((vfrag me.(compile oreg env val)) + (fname me.(get-dreg sym)) + (rplcd me.(get-sidx 'usr:rplacd)) + (treg me.(alloc-treg))) + me.(free-treg treg) + (new (frag vfrag.oreg + ^(,*vfrag.code + (getfb ,treg ,fname) + (gcall ,treg ,rplcd ,treg ,vfrag.oreg)) + vfrag.fvars + (uni (list sym) vfrag.ffuns))))))) + +(defmeth compiler comp-cond (me oreg env form) + (tree-case form + ((op) me.(comp-atom oreg nil)) + ((op (test) . more) me.(compile oreg env ^(or ,test (cond ,*more)))) + ((op (test . forms) . more) me.(compile oreg env + ^(if ,test + (progn ,*forms) + (cond ,*more)))) + ((op atom . more) + (compile-error form "atom in cond syntax; pair expected")) + ((op . atom) + (compile-error form "trailing atom in cond syntax")))) + +(defmeth compiler comp-if (me oreg env form) + (match-case (cdr form) + (@(require ((@(and @(or equal nequal) @op) @a @b) . @rest) + (or (eql-comparable a) + (eql-comparable b))) + (let* ((pos (eq op 'equal)) + (cf (if (or (eq-comparable a) + (eq-comparable b)) + (if pos 'eq 'neq) + (if pos'eql 'neql)))) + me.(compile oreg env ^(if (,cf ,a ,b) ,*rest)))) + (((not (@(and @(or eq eql equal) @op) . @eargs)) . @args) + (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal)))) + me.(comp-if oreg env ^(if (,nop ,*eargs) ,*args)))) + ((@(constantp @test) @then @else) + me.(compile oreg env (if (eval test) then else))) + ((@(constantp @test) @then) + me.(compile oreg env (if (eval test) then))) + ((@(constantp @test)) + me.(compile oreg env nil)) + (((@(member @op %test-funs%) @a @b) . @rest) + me.(compile oreg env ^(ift ,op ,a ,b ,*rest))) + ((@test @then @else) + (let* ((te-oreg me.(maybe-alloc-treg oreg)) + (lelse (gensym "l")) + (lskip (gensym "l")) + (te-frag me.(compile te-oreg env test)) + (th-frag me.(compile oreg env then)) + (el-frag me.(compile oreg env else))) + me.(maybe-free-treg te-oreg oreg) + (new (frag oreg + ^(,*te-frag.code + (if ,te-frag.oreg ,lelse) + ,*th-frag.code + ,*me.(maybe-mov oreg th-frag.oreg) + (jmp ,lskip) + ,lelse + ,*el-frag.code + ,*me.(maybe-mov oreg el-frag.oreg) + ,lskip) + (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars)) + (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns)))))) + ((@test @then) + (let* ((lskip (gensym "l")) + (te-oreg me.(maybe-alloc-treg oreg)) + (te-frag me.(compile te-oreg env test)) + (th-frag me.(compile oreg env then))) + me.(maybe-free-treg te-oreg oreg) + (new (frag oreg + ^(,*te-frag.code + ,*me.(maybe-mov oreg te-frag.oreg) + (if ,te-frag.oreg ,lskip) + ,*th-frag.code + ,*me.(maybe-mov oreg th-frag.oreg) + ,lskip) + (uni te-frag.fvars th-frag.fvars) + (uni te-frag.ffuns th-frag.ffuns))))) + ((@test) + (let ((te-frag me.(compile oreg env test))) + (new (frag oreg + ^(,*te-frag.code + (mov ,oreg nil)) + te-frag.fvars + te-frag.ffuns)))) + (() me.(compile oreg env nil)) + (@else (compile-error form "excess argument forms")))) + +(defmeth compiler comp-ift (me oreg env form) + (mac-param-bind form (op fun left right : then else) form + (when (member fun %test-funs-neg%) + (set fun [%test-inv% fun]) + (swap then else)) + (if (and (constantp left) (constantp right)) + me.(compile oreg env (if (call fun (eval left) (eval right)) then else)) + (let* ((opcode [%test-opcode% fun]) + (le-oreg me.(alloc-treg)) + (ri-oreg me.(alloc-treg)) + (lelse (gensym "l")) + (lskip (gensym "l")) + (le-frag me.(compile le-oreg env left)) + (ri-frag me.(compile ri-oreg env right)) + (th-frag me.(compile oreg env then)) + (el-frag me.(compile oreg env else))) + me.(free-treg le-oreg) + me.(free-treg ri-oreg) + (new (frag oreg + ^(,*le-frag.code + ,*ri-frag.code + (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse) + ,*th-frag.code + ,*me.(maybe-mov oreg th-frag.oreg) + (jmp ,lskip) + ,lelse + ,*el-frag.code + ,*me.(maybe-mov oreg el-frag.oreg) + ,lskip) + (uni (uni le-frag.fvars ri-frag.fvars) + (uni th-frag.fvars el-frag.fvars)) + (uni (uni le-frag.ffuns ri-frag.ffuns) + (uni th-frag.ffuns el-frag.ffuns)))))))) + +(defmeth compiler comp-switch (me oreg env form) + (mac-param-bind form (op idx-form cases-vec) form + (let* ((ncases (len cases-vec)) + (cs (and (plusp ncases) (conses [cases-vec 0]))) + (shared (and cs + (let ((c cs) + (d (cdr (list-vec cases-vec)))) + (whilet ((m (if d (memq (pop d) c)))) + (set c m)) + (null d)))) + (cases (if shared + (let ((cs-nil ^(,*cs nil))) + (vec-list [mapcar ldiff cs-nil (cdr cs-nil)])) + cases-vec)) + (lend (gensym "l")) + (clabels (mapcar (ret (gensym "l")) cases)) + (treg me.(maybe-alloc-treg oreg)) + (ifrag me.(compile treg env idx-form)) + (seen (unless shared (hash :eql-based))) + last-cfrag + (cfrags (collect-each ((cs cases) + (lb clabels) + (i (range 1))) + (iflet ((seen-lb (and seen [seen cs]))) + (progn + (set [clabels (pred i)] seen-lb) + (new (frag oreg nil))) + (let ((cfrag me.(comp-progn oreg env cs))) + (when (eq i ncases) + (set last-cfrag cfrag)) + (unless shared + (set [seen cs] lb)) + (new (frag oreg + ^(,lb + ,*cfrag.code + ,*(unless shared + ^(,*me.(maybe-mov oreg cfrag.oreg) + ,*(unless (= i ncases) + ^((jmp ,lend)))))) + cfrag.fvars cfrag.ffuns))))))) + me.(maybe-free-treg treg oreg) + (new (frag oreg + ^(,*ifrag.code + (swtch ,ifrag.oreg ,*(list-vec clabels)) + ,*(mappend .code cfrags) + ,*(when (and shared last-cfrag) + me.(maybe-mov oreg last-cfrag.oreg)) + ,lend) + (uni ifrag.fvars [reduce-left uni cfrags nil .fvars]) + (uni ifrag.ffuns [reduce-left uni cfrags nil .ffuns])))))) + +(defmeth compiler comp-unwind-protect (me oreg env form) + (mac-param-bind form (op prot-form . cleanup-body) form + (let* ((treg me.(alloc-treg)) + (pfrag me.(compile oreg env prot-form)) + (cfrag me.(comp-progn treg env cleanup-body)) + (lclean (gensym "l"))) + me.(free-treg treg) + (cond + ((null pfrag.code) + (new (frag pfrag.oreg + cfrag.code + cfrag.fvars + cfrag.ffuns))) + ((null cfrag.code) pfrag) + (t (new (frag pfrag.oreg + ^((uwprot ,lclean) + ,*pfrag.code + (end nil) + ,lclean + ,*cfrag.code + (end nil)) + (uni pfrag.fvars pfrag.fvars) + (uni cfrag.fvars cfrag.fvars)))))))) + +(defmeth compiler comp-block (me oreg env form) + (mac-param-bind form (op name . body) form + (let* ((star (and name (eq op 'block*))) + (nenv (unless star + (new env up env lev env.lev co me))) + (binfo (unless star + (cdar nenv.(extend-block name)))) + (treg (if star me.(maybe-alloc-treg oreg))) + (nfrag (if star me.(compile treg env name))) + (nreg (if star nfrag.oreg me.(get-dreg name))) + (bfrag me.(comp-progn oreg (or nenv env) body)) + (lskip (gensym "l"))) + (when treg + me.(maybe-free-treg treg oreg)) + (if (and (>= *opt-level* 2) + (not star) + (not binfo.used) + (if (eq op 'sys:blk) + [all bfrag.ffuns [orf system-symbol-p (op eq name)]] + [all bfrag.ffuns system-symbol-p]) + [none bfrag.ffuns (op member @1 %block-using-funs%)]) + bfrag + (new (frag oreg + ^(,*(if nfrag nfrag.code) + (block ,oreg ,nreg ,lskip) + ,*bfrag.code + ,*me.(maybe-mov oreg bfrag.oreg) + (end ,oreg) + ,lskip) + bfrag.fvars + bfrag.ffuns)))))) + +(defmeth compiler comp-return-from (me oreg env form) + (mac-param-bind form (op name : value) form + (let* ((nreg (if (null name) + nil + me.(get-dreg name))) + (opcode (if (eq op 'return-from) 'ret 'abscsr)) + (vfrag me.(compile oreg env value)) + (binfo env.(lookup-block name t))) + (new (frag oreg + ^(,*vfrag.code + (,opcode ,nreg ,vfrag.oreg)) + vfrag.fvars + vfrag.ffuns))))) + +(defmeth compiler comp-return (me oreg env form) + (mac-param-bind form (op : value) form + me.(comp-return-from oreg env ^(return-from nil ,value)))) + +(defmeth compiler comp-handler-bind (me oreg env form) + (mac-param-bind form (op func-form ex-syms . body) form + (let* ((freg me.(maybe-alloc-treg oreg)) + (ffrag me.(compile freg env func-form)) + (sreg me.(get-dreg ex-syms)) + (bfrag me.(comp-progn oreg env body))) + me.(maybe-free-treg freg oreg) + (new (frag bfrag.oreg + ^(,*ffrag.code + (handle ,ffrag.oreg ,sreg) + ,*bfrag.code + (end ,bfrag.oreg)) + (uni ffrag.fvars bfrag.fvars) + (uni ffrag.ffuns bfrag.ffuns)))))) + +(defmeth compiler comp-catch (me oreg env form) + (mac-param-bind form (op symbols try-expr desc-expr . clauses) form + (with-gensyms (ex-sym-var ex-args-var) + (let* ((nenv (new env up env co me)) + (esvb (cdar nenv.(extend-var ex-sym-var))) + (eavb (cdar nenv.(extend-var ex-args-var))) + (tfrag me.(compile oreg nenv try-expr)) + (dfrag me.(compile oreg nenv desc-expr)) + (coreg (if (equal tfrag.oreg '(t 0)) oreg tfrag.oreg)) + (lhand (gensym "l")) + (lhend (gensym "l")) + (treg me.(alloc-treg)) + (nclauses (len clauses)) + (cfrags (collect-each ((cl clauses) + (i (range 1))) + (mac-param-bind form (sym params . body) cl + (let* ((cl-src ^(apply (lambda ,params ,*body) + ,ex-sym-var ,ex-args-var)) + (cfrag me.(compile coreg nenv (expand cl-src))) + (lskip (gensym "l"))) + (new (frag coreg + ^((gcall ,treg + ,me.(get-sidx 'exception-subtype-p) + ,esvb.loc + ,me.(get-dreg sym)) + (if ,treg ,lskip) + ,*cfrag.code + ,*me.(maybe-mov coreg cfrag.oreg) + ,*(unless (eql i nclauses) + ^((jmp ,lhend))) + ,lskip) + cfrag.fvars + cfrag.ffuns))))))) + me.(free-treg treg) + (new (frag coreg + ^((frame ,nenv.lev ,nenv.v-cntr) + ,*dfrag.code + (catch ,esvb.loc ,eavb.loc + ,me.(get-dreg symbols) ,dfrag.oreg ,lhand) + ,*tfrag.code + ,*me.(maybe-mov coreg tfrag.oreg) + (jmp ,lhend) + ,lhand + ,*(mappend .code cfrags) + ,lhend + (end ,coreg) + (end ,coreg)) + (uni tfrag.fvars [reduce-left uni cfrags nil .fvars]) + (uni tfrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))) + +(defmeth compiler eliminate-frame (me code env) + (if (>= me.(unalloc-reg-count) (len env.vb)) + (let ((trhash (hash)) + (vbhash (hash)) + (vlev (ppred env.lev)) + (tregs nil)) + (each ((cell env.vb)) + (tree-bind (sym . vbind) cell + (let ((treg me.(alloc-new-treg))) + (set [trhash vbind.loc] treg) + (set [vbhash vbind.loc] vbind) + (push treg tregs)))) + (let ((ncode (append-each ((insns (conses code))) + (match-case insns + (((frame @lev @size) . @rest) + ^((frame ,(pred lev) ,size))) + (((dframe @lev @size) . @rest) + ^((dframe ,(pred lev) ,size))) + (((@op . @args) . @rest) + (let ((nargs (mapcar (lambda-match + ((@(as arg (v @lev @idx))) + (or [trhash arg] + (if (> lev vlev) + ^(v ,(pred lev) ,idx) + arg))) + ((@arg) arg)) + args))) + ^((,op ,*nargs)))) + ((@else . @rest) (list else)))))) + (dohash (loc treg trhash) + (let ((vb [vbhash loc])) + (set vb.loc treg) + me.(free-treg treg))) + (if (plusp me.loop-nest) + (append (mapcar (ret ^(mov ,@1 (t 0))) (nreverse tregs)) ncode) + ncode))) + code)) + +(defmeth compiler comp-let (me oreg env form) + (mac-param-bind form (sym raw-vis . body) form + (let* ((vis (mapcar [iffi atom list] raw-vis)) + (specials [keep-if special-var-p vis car]) + (lexsyms [remove-if special-var-p [mapcar car vis]]) + allsyms + (specials-occur [find-if special-var-p vis car]) + (treg (if specials-occur me.(alloc-treg))) + (frsize (len lexsyms)) + (seq (eq sym 'let*)) + (nenv (new env up env co me)) + (fenv (if seq nenv (new env up env co me)))) + (with-closure-spy me (and (not specials-occur) + (>= *opt-level* 2)) + cspy (new closure-spy env nenv) + (unless seq + (each ((lsym lexsyms)) + nenv.(extend-var lsym))) + (let* (ffuns fvars + (code (build + (add ^(,(if specials-occur 'dframe 'frame) + ,nenv.lev ,frsize)) + (each ((vi vis)) + (tree-bind (sym : form) vi + (push sym allsyms) + (cond + ((special-var-p sym) + (let ((frag me.(compile treg fenv form)) + (dreg me.(get-dreg sym))) + (pend frag.code) + (add ^(bindv ,frag.oreg ,dreg)) + (set ffuns (uni ffuns frag.ffuns) + fvars (uni fvars + (if seq + (diff frag.fvars + (cdr allsyms)) + frag.fvars))))) + (form + (let* ((tmp (if seq (gensym))) + (bind (if seq + (cdar nenv.(extend-var tmp)) + nenv.(lookup-var sym))) + (frag me.(compile bind.loc fenv form))) + (when seq + fenv.(rename-var tmp sym)) + (pend frag.code) + (unless (null-reg frag.oreg) + (pend me.(maybe-mov bind.loc frag.oreg))) + (set ffuns (uni ffuns frag.ffuns) + fvars (uni fvars + (if seq + (diff frag.fvars + (cdr allsyms)) + frag.fvars))))) + (t (if seq nenv.(extend-var* sym)))))))) + (bfrag me.(comp-progn oreg nenv body)) + (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg)) + (code (append code bfrag.code + me.(maybe-mov boreg bfrag.oreg) + ^((end ,boreg))))) + (when (and cspy (null cspy.cap-vars)) + (set code me.(eliminate-frame [code 1..-1] nenv))) + (when treg + me.(free-treg treg)) + (new (frag boreg + code + (uni (diff bfrag.fvars allsyms) fvars) + (uni ffuns bfrag.ffuns)))))))) + +(defmeth compiler comp-fbind (me oreg env form) + (mac-param-bind form (sym raw-fis . body) form + (let* ((fis (mapcar [iffi atom list] raw-fis)) + (lexfuns [mapcar car fis]) + (frsize (len lexfuns)) + (rec (eq sym 'sys:lbind)) + (eenv (unless rec (new env up env co me))) + (nenv (new env up env co me))) + (each ((lfun lexfuns)) + nenv.(extend-fun lfun)) + (let* (ffuns fvars + (ffrags (collect-each ((fi fis)) + (tree-bind (sym : form) fi + (let* ((bind nenv.(lookup-fun sym)) + (frag me.(compile bind.loc + (if rec nenv eenv) + form))) + (set bind.pars frag.pars) + (list bind + (new (frag frag.oreg + (append frag.code + me.(maybe-mov bind.loc frag.oreg)) + frag.fvars + frag.ffuns))))))) + (bfrag me.(comp-progn oreg nenv body)) + (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))) + (set ffrags (append-each ((bf ffrags)) + (tree-bind (bind ff) bf + (when bind.used + (set ffuns (uni ffuns ff.ffuns) + fvars (uni fvars ff.fvars)) + (list ff))))) + (new (frag boreg + (append ^((frame ,nenv.lev ,frsize)) + (mappend .code ffrags) + bfrag.code + me.(maybe-mov boreg bfrag.oreg) + ^((end ,boreg))) + (uni fvars bfrag.fvars) + (uni (diff bfrag.ffuns lexfuns) + (if rec (diff ffuns lexfuns) ffuns)))))))) + +(defmeth compiler comp-lambda-impl (me oreg env form) + (mac-param-bind form (op par-syntax . body) form + (with-access-spy me me.closure-spies + spy (new access-spy + closure-spies me.closure-spies) + (compile-with-fresh-tregs me + (let* ((*load-time* nil) + (pars (new (fun-param-parser par-syntax form))) + (need-frame (or (plusp pars.nfix) pars.rest)) + (nenv (if need-frame (new env up env co me) env)) + lexsyms fvars specials need-dframe) + (when (> pars.nfix %max-lambda-fixed-args%) + (compile-warning form "~s arguments in a lambda (max is ~s)" + pars.nfix %max-lambda-fixed-args%)) + (flet ((spec-sub (sym) + (cond + ((special-var-p sym) + (let ((sub (gensym))) + (push (cons sym sub) specials) + (set need-dframe t) + nenv.(extend-var sub) + sub)) + (t + (push sym lexsyms) + nenv.(extend-var sym) + sym)))) + (let* ((req-pars (collect-each ((rp pars.req)) + (spec-sub rp))) + (opt-pars (collect-each ((op pars.opt)) + (tree-bind (var-sym : init-form have-sym) op + (list (spec-sub var-sym) + init-form + (if have-sym (spec-sub have-sym)))))) + (rest-par (when pars.rest (spec-sub pars.rest))) + (allsyms req-pars)) + (upd specials nreverse) + (with-closure-spy me (and (not specials) + (>= *opt-level* 2)) + cspy (new closure-spy env nenv) + (let* ((col-reg (if opt-pars me.(get-dreg :))) + (tee-reg (if opt-pars me.(get-dreg t))) + (ifrags (collect-each ((op opt-pars)) + (tree-bind (var-sym init-form have-sym) op + (let* ((vbind nenv.(lookup-var var-sym)) + (ifrag me.(compile vbind.loc nenv init-form))) + (set fvars (uni fvars + (diff ifrag.fvars allsyms))) + (push var-sym allsyms) + (push have-sym allsyms) + ifrag)))) + (opt-code (append-each ((op opt-pars) + (ifrg ifrags)) + (tree-bind (var-sym init-form have-sym) op + (let ((vbind nenv.(lookup-var var-sym)) + (have-bind nenv.(lookup-var have-sym)) + (lskip (gensym "l"))) + ^(,*(if have-sym + ^((mov ,have-bind.loc ,tee-reg))) + (ifq ,vbind.loc ,col-reg ,lskip) + ,*(if have-sym + ^((mov ,have-bind.loc nil))) + ,*ifrg.code + ,*me.(maybe-mov vbind.loc ifrg.oreg) + ,lskip + ,*(whenlet ((spec-sub [find var-sym specials : cdr])) + (set specials [remq var-sym specials cdr]) + ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub))))) + ,*(whenlet ((spec-sub [find have-sym specials : cdr])) + (set specials [remq have-sym specials cdr]) + ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub)))))))))) + (benv (if need-dframe (new env up nenv co me) nenv)) + (btreg me.(alloc-treg)) + (bfrag me.(comp-progn btreg benv body)) + (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg)) + (lskip (gensym "l")) + (frsize (if need-frame nenv.v-cntr 0)) + (code ^((close ,oreg ,frsize ,me.treg-cntr ,lskip + ,pars.nfix ,pars.nreq ,(if rest-par t nil) + ,*(collect-each ((rp req-pars)) + nenv.(lookup-var rp).loc) + ,*(collect-each ((op opt-pars)) + nenv.(lookup-var (car op)).loc) + ,*(if rest-par + (list nenv.(lookup-var rest-par).loc))) + ,*(if need-dframe + ^((dframe ,benv.lev 0))) + ,*(if specials + (collect-each ((vs specials)) + (tree-bind (special . gensym) vs + (let ((sub-bind nenv.(lookup-var gensym)) + (dreg me.(get-dreg special))) + ^(bindv ,sub-bind.loc ,dreg))))) + ,*opt-code + ,*bfrag.code + ,*(if need-dframe + ^((end ,boreg))) + ,*me.(maybe-mov boreg bfrag.oreg) + (jend ,boreg) + ,lskip))) + me.(free-treg btreg) + (when (and cspy (plusp frsize) (null cspy.cap-vars)) + (when-match ((close @reg @frsize @nreg . @irest) . @crest) + me.(eliminate-frame code nenv) + (set code ^((close ,reg 0 ,me.treg-cntr ,*irest) + ,*crest)))) + (new (frag oreg code + (uni fvars (diff bfrag.fvars lexsyms)) + (uni [reduce-left uni ifrags nil .ffuns] + bfrag.ffuns) + pars))))))))))) + +(defmeth compiler comp-lambda (me oreg env form) + (if (or *load-time* (< *opt-level* 3)) + me.(comp-lambda-impl oreg env form) + (let* ((snap me.(snapshot)) + (lambda-frag me.(comp-lambda-impl oreg env form)) + (ok-lift-var-pov (all lambda-frag.fvars + (lambda (sym) + (not env.(lookup-var sym))))) + (ok-lift-fun-pov (all lambda-frag.ffuns + (lambda (sym) + (not env.(lookup-fun sym)))))) + (cond + ((and ok-lift-var-pov ok-lift-fun-pov) + me.(restore snap) + me.(compile oreg env ^(sys:load-time-lit nil ,form))) + (t lambda-frag))))) + +(defmeth compiler comp-fun (me oreg env form) + (mac-param-bind form (op arg) form + (let ((fbin env.(lookup-fun arg t))) + (cond + (fbin (new (frag fbin.loc nil nil (list arg)))) + ((and (consp arg) (eq (car arg) 'lambda)) + me.(compile oreg env arg)) + (t (new (frag oreg ^((getf ,oreg ,me.(get-sidx arg))) + nil (list arg)))))))) + +(defmeth compiler comp-progn (me oreg env args) + (let* (ffuns fvars + (lead-forms (butlastn 1 args)) + (last-form (nthlast 1 args)) + (eff-lead-forms (remove-if [orf constantp symbolp] lead-forms)) + (forms (append eff-lead-forms last-form)) + (nargs (len forms)) + lastfrag + (oreg-discard me.(alloc-discard-treg)) + (code (build + (each ((form forms) + (n (range 1))) + (let ((islast (eql n nargs))) + (let ((frag me.(compile (if islast oreg oreg-discard) + env form))) + (when islast + (set lastfrag frag)) + (set fvars (uni fvars frag.fvars)) + (set ffuns (uni ffuns frag.ffuns)) + (pend frag.code))))))) + me.(free-treg oreg-discard) + (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns)))) + +(defmeth compiler comp-or (me oreg env form) + (tree-case (simplify-or form) + ((op) me.(compile oreg env nil)) + ((op arg) me.(compile oreg env arg)) + ((op . args) + (let* (ffuns fvars + (nargs (len args)) + lastfrag + (lout (gensym "l")) + (treg me.(maybe-alloc-treg oreg)) + (code (build + (each ((form args) + (n (range 1))) + (let ((islast (eql n nargs))) + (let ((frag me.(compile treg env form))) + (when islast + (set lastfrag frag)) + (pend frag.code + me.(maybe-mov treg frag.oreg)) + (unless islast + (add ^(ifq ,treg (t 0) ,lout))) + (set fvars (uni fvars frag.fvars)) + (set ffuns (uni ffuns frag.ffuns)))))))) + me.(maybe-free-treg treg oreg) + (new (frag oreg + (append code ^(,lout + ,*me.(maybe-mov oreg treg))) + fvars ffuns)))))) + +(defmeth compiler comp-prog1 (me oreg env form) + (tree-case form + ((prog1 fi . re) (let* ((igreg me.(alloc-discard-treg)) + (fireg me.(maybe-alloc-treg oreg)) + (fi-frag me.(compile fireg env fi)) + (re-frag me.(comp-progn igreg env + (append re '(nil))))) + me.(maybe-free-treg fireg oreg) + me.(free-treg igreg) + (new (frag fireg + (append fi-frag.code + me.(maybe-mov fireg fi-frag.oreg) + re-frag.code) + (uni fi-frag.fvars re-frag.fvars) + (uni fi-frag.ffuns re-frag.ffuns))))) + ((prog1 fi) me.(compile oreg env fi)) + ((prog1) me.(compile oreg env nil)))) + +(defmeth compiler comp-quasi (me oreg env form) + (let ((qexp (expand-quasi form))) + me.(compile oreg env (expand qexp)))) + +(defmeth compiler comp-arith-form (me oreg env form) + (if (plusp *opt-level*) + (let ((rform (reduce-constant env form))) + (tree-case rform + ((op . args) + (let* ((pargs [partition-by constantp args]) + (fargs (append-each ((pa pargs)) + (if (and (constantp (car pa)) + (all pa [chain eval integerp])) + (list (eval ^(,op ,*pa))) + pa)))) + me.(comp-fun-form oreg env ^(,op ,*fargs)))) + (else me.(compile oreg env rform)))) + me.(comp-fun-form oreg env form))) + +(defmeth compiler comp-arith-neg-form (me oreg env form) + (if (> (len form) 3) + (tree-bind (nop . args) form + (let ((op (caseq nop (- '+) (/ '*))) + (a1 (car args))) + (if (and (eq nop '-) + (constantp a1)) + me.(comp-arith-form oreg env + ^(,op (- ,a1) ,*(cdr args))) + me.(comp-fun-form oreg env + ^(,nop ,(car args) (,op ,*(cdr args))))))) + me.(comp-fun-form oreg env form))) + +(defmeth compiler comp-fun-form (me oreg env form) + (let* ((olev *opt-level*) + (sym (car form)) + (nargs (len (cdr form))) + (fbin env.(lookup-fun sym t)) + (pars (or fbin.?pars + (get-param-info sym)))) + (if pars + (param-check form nargs pars) + (push (cons form nargs) *unchecked-calls*)) + + (when (null fbin) + (when (plusp olev) + (match-case form + ((equal @a @b) + (cond + ((or (eq-comparable a) + (eq-comparable b)) + (set form ^(eq ,a ,b))) + ((or (eql-comparable a) + (eql-comparable b)) + (set form ^(eql ,a ,b))))) + ((not (@(and @(or eq eql equal) @op) @a @b)) + (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal)))) + (return-from comp-fun-form me.(compile oreg env ^(,nop ,a ,b))))) + ((@(or append cons list list*) . @args) + (set form (reduce-lisp form))) + ((@(@bin [%bin-op% @sym]) @a @b) + (set form ^(,bin ,a ,b))) + ((- @a) + (set form ^(neg ,a))) + ((@(or identity + * min max) @a) + (return-from comp-fun-form me.(compile oreg env a))))) + + (when (plusp olev) + (tree-case form + ((sym . args) + (set form (reduce-constant env form))))) + + (when (or (atom form) (special-operator-p (car form))) + (return-from comp-fun-form me.(compile oreg env form)))) + + (tree-bind (sym . args) form + (let* ((fbind env.(lookup-fun sym t))) + (macrolet ((comp-fun () + 'me.(comp-call-impl oreg env (if fbind 'call 'gcall) + (if fbind fbind.loc me.(get-sidx sym)) + args sym))) + (if (and (>= olev 3) + (not fbind) + (not *load-time*) + [%functional% sym]) + (let* ((snap me.(snapshot)) + (cfrag (comp-fun)) + (ok-lift-var-pov (null cfrag.fvars)) + (ok-lift-fun-pov (all cfrag.ffuns + (lambda (sym) + (and (not env.(lookup-fun sym)) + (eq (symbol-package sym) + user-package)))))) + (cond + ((and ok-lift-var-pov ok-lift-fun-pov) + me.(restore snap) + me.(compile oreg env ^(sys:load-time-lit nil ,form))) + (t (pushnew sym cfrag.ffuns) + cfrag))) + (let ((cfrag (comp-fun))) + (pushnew sym cfrag.ffuns) + cfrag))))))) + +(defmeth compiler comp-apply-call (me oreg env form) + (let ((olev *opt-level*)) + (tree-bind (sym . oargs) form + (let ((args (if (plusp olev) + [mapcar (op reduce-constant env) oargs] + oargs))) + (let ((gopcode [%gcall-op% sym]) + (opcode [%call-op% sym])) + (cond + ((and (plusp olev) + (eq sym 'call) + [all args constantp] + (let ((op (eval (car args)))) + (or [%const-foldable% op] + (not (bindable op))))) + me.(compile oreg env ^(quote ,(eval form)))) + (t (tree-case (car args) + ((op arg . more) + (caseq op + (fun (cond + (more (compile-error form "excess args in fun form")) + ((bindable arg) + (let ((fbind env.(lookup-fun arg t))) + me.(comp-call-impl oreg env (if fbind opcode gopcode) + (if fbind fbind.loc me.(get-sidx arg)) + (cdr args) arg))) + ((and (consp arg) (eq (car arg) 'lambda)) + me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args)))) + (t :))) + (lambda me.(comp-inline-lambda oreg env opcode + (car args) (cdr args))) + (t :))) + (arg me.(comp-call oreg env + (if (eq sym 'usr:apply) 'apply sym) args)))))))))) + +(defmeth compiler comp-call (me oreg env opcode args) + (tree-bind (fform . fargs) args + (let* ((foreg me.(maybe-alloc-treg oreg)) + (ffrag me.(compile foreg env fform)) + (cfrag me.(comp-call-impl oreg env opcode ffrag.oreg fargs))) + me.(maybe-free-treg foreg oreg) + (new (frag cfrag.oreg + (append ffrag.code + cfrag.code) + (uni ffrag.fvars cfrag.fvars) + (uni ffrag.ffuns cfrag.ffuns)))))) + +(defmeth compiler comp-call-impl (me oreg env opcode freg args : extra-ffun) + (let* ((aoregs nil) + (afrags (collect-each ((arg args)) + (let* ((aoreg me.(alloc-treg)) + (afrag me.(compile aoreg env arg))) + (if (nequal afrag.oreg aoreg) + me.(free-treg aoreg) + (push aoreg aoregs)) + afrag))) + (fvars [reduce-left uni afrags nil .fvars]) + (ffuns [reduce-left uni afrags nil .ffuns])) + me.(free-tregs aoregs) + (when extra-ffun + (pushnew extra-ffun ffuns)) + (new (frag oreg + ^(,*(mappend .code afrags) + (,opcode ,oreg ,freg ,*(mapcar .oreg afrags))) + fvars ffuns)))) + +(defmeth compiler comp-inline-lambda (me oreg env opcode lambda args) + (let ((reg-args args) apply-list-arg) + (when (eql opcode 'apply) + (unless args + (compile-error lambda "apply requires arguments")) + (set reg-args (butlast args) + apply-list-arg (car (last args)))) + me.(compile oreg env (expand (lambda-apply-transform lambda + reg-args + apply-list-arg + nil))))) + +(defmeth compiler comp-for (me oreg env form) + (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form + (let* ((treg me.(alloc-treg)) + (ifrag me.(comp-progn treg env inits)) + (*load-time* nil) + (dummy (inc me.loop-nest)) + (tfrag (if test-p me.(compile treg env test))) + (rfrag me.(comp-progn oreg env rets)) + (nfrag me.(comp-progn treg env incs)) + (bfrag me.(comp-progn treg env body)) + (dummy (dec me.loop-nest)) + (lback (gensym "l")) + (lskip (gensym "l")) + (frags (build + (add ifrag) + (if test-p (add tfrag)) + (add rfrag nfrag bfrag)))) + me.(free-treg treg) + (new (frag rfrag.oreg + ^(,*ifrag.code + ,lback + ,*(if test-p + ^(,*tfrag.code + (if ,tfrag.oreg ,lskip))) + ,*bfrag.code + ,*nfrag.code + (jmp ,lback) + ,*(if test-p + ^(,lskip + ,*rfrag.code))) + [reduce-left uni frags nil .fvars] + [reduce-left uni frags nil .ffuns]))))) + +(defmeth compiler comp-tree-bind (me oreg env form) + (tree-bind (op params obj . body) form + (with-gensyms (obj-var) + (let ((expn (expand ^(let ((,obj-var ,obj)) + ,(expand-bind-mac-params ^',form + ^',(rlcp ^(,(car form)) + form) + params nil + obj-var t nil body))))) + me.(compile oreg env expn))))) + +(defmeth compiler comp-mac-param-bind (me oreg env form) + (mac-param-bind form (op context params obj . body) form + (with-gensyms (obj-var form-var) + (let ((expn (expand ^(let* ((,obj-var ,obj) + (,form-var ,context)) + ,(expand-bind-mac-params form-var + form-var + params nil + obj-var t nil body))))) + me.(compile oreg env expn))))) + +(defmeth compiler comp-mac-env-param-bind (me oreg env form) + (mac-param-bind form (op context menv params obj . body) form + (with-gensyms (obj-var form-var) + (let ((expn (expand ^(let* ((,obj-var ,obj) + (,form-var ,context)) + ,(expand-bind-mac-params form-var + form-var + params menv + obj-var t nil body))))) + me.(compile oreg env expn))))) + +(defmeth compiler comp-tree-case (me oreg env form) + (mac-param-bind form (op obj . cases) form + (let* ((ncases (len cases)) + (nenv (new env up env co me)) + (obj-immut-var (cdar nenv.(extend-var (gensym)))) + (obj-var (cdar nenv.(extend-var (gensym)))) + (err-blk (gensym)) + (lout (gensym "l")) + (ctx-form ^',form) + (err-form ^',(rlcp ^(,(car form)) form)) + (treg me.(maybe-alloc-treg oreg)) + (objfrag me.(compile treg env obj)) + (cfrags (collect-each ((c cases) + (i (range 1))) + (mac-param-bind form (params . body) c + (let* ((src (expand ^(block ,err-blk + (set ,obj-var.sym + ,obj-immut-var.sym) + ,(expand-bind-mac-params + ctx-form err-form + params nil obj-var.sym : + err-blk + body)))) + (lerrtest (gensym "l")) + (lnext (gensym "l")) + (cfrag me.(compile treg nenv src))) + (new (frag treg + ^(,*cfrag.code + ,*me.(maybe-mov treg cfrag.oreg) + (ifq ,treg ,me.(get-dreg :) ,lout)) + cfrag.fvars + cfrag.ffuns)))))) + (allfrags (cons objfrag cfrags))) + me.(maybe-free-treg treg oreg) + (new (frag oreg + ^(,*objfrag.code + (frame ,nenv.lev ,nenv.v-cntr) + ,*me.(maybe-mov obj-immut-var.loc objfrag.oreg) + ,*(mappend .code cfrags) + (mov ,treg nil) + ,lout + ,*me.(maybe-mov oreg treg) + (end ,oreg)) + [reduce-left uni allfrags nil .fvars] + [reduce-left uni allfrags nil .ffuns]))))) + +(defmeth compiler comp-lisp1-value (me oreg env form) + (mac-param-bind form (op arg) form + (cond + ((bindable arg) + (let ((bind env.(lookup-lisp1 arg t))) + (cond + (bind + (each ((spy me.access-spies)) + spy.(accessed bind arg)) + (new (frag bind.loc + nil + (if (typep bind 'vbinding) (list arg)) + (if (typep bind 'fbinding) (list arg))))) + ((not (boundp arg)) + (pushnew arg assumed-fun) + (new (frag oreg + ^((getf ,oreg ,me.(get-sidx arg))) + nil + (list arg)))) + ((special-var-p arg) + (new (frag oreg + ^((getv ,oreg ,me.(get-dreg arg))) + (list arg) + nil))) + (t (new (frag oreg + ^((getlx ,oreg ,me.(get-sidx arg))) + (list arg) + nil)))))) + (t me.(compile oreg env arg))))) + +(defmeth compiler comp-dwim (me oreg env form) + (mac-param-bind form (op obj . args) form + (let* ((l1-exprs (cdr form)) + (fun (car l1-exprs)) + (bind env.(lookup-lisp1 fun nil))) + me.(compile oreg env + (if (and (symbolp fun) + (not bind) + (not (boundp fun))) + (progn + (pushnew fun assumed-fun) + ^(,fun ,*(mapcar [iffi bindable (op list 'sys:lisp1-value)] (cdr l1-exprs)))) + ^(call ,*(mapcar [iffi bindable (op list 'sys:lisp1-value)] l1-exprs))))))) + +(defmeth compiler comp-prof (me oreg env form) + (mac-param-bind form (op . forms) form + (let ((bfrag me.(comp-progn oreg env forms))) + (new (frag oreg + ^((prof ,oreg) + ,*bfrag.code + (end ,bfrag.oreg)) + bfrag.fvars bfrag.ffuns))))) + +(defun misleading-ref-check (frag env form) + (each ((v frag.fvars)) + (when env.(lookup-var v) + (compile-warning form "cannot refer to lexical variable ~s" v))) + (each ((f frag.ffuns)) + (when env.(lookup-fun f) + (compile-warning form "cannot refer to lexical function ~s" f)))) + +(defmeth compiler comp-load-time-lit (me oreg env form) + (mac-param-bind form (op loaded-p exp) form + (cond + (loaded-p me.(compile oreg env ^(quote ,exp))) + ((or *load-time* (constantp exp)) me.(compile oreg env exp)) + (t (compile-in-toplevel me + (let* ((*load-time* t) + (dreg me.(alloc-dreg)) + (exp me.(compile dreg (new env co me) exp)) + (lt-frag (new (frag dreg + ^(,*exp.code + ,*me.(maybe-mov dreg exp.oreg)) + exp.fvars + exp.ffuns + exp.pars)))) + (misleading-ref-check exp env form) + (push lt-frag me.lt-frags) + (new (frag dreg nil nil nil exp.pars)))))))) + +(defmeth compiler optimize (me insns) + (let ((olev *opt-level*)) + (if (>= olev 4) + (let* ((lt-dregs (mapcar .oreg me.lt-frags)) + (bb (new (basic-blocks insns lt-dregs me.(get-symvec))))) + (when (>= olev 4) + bb.(thread-jumps) + bb.(elim-dead-code)) + (when (>= olev 5) + bb.(calc-liveness) + bb.(peephole)) + (cond + ((>= olev 6) + bb.(merge-jump-thunks) + bb.(late-peephole bb.(get-insns))) + (t bb.(get-insns)))) + insns))) + +(defun true-const-p (arg) + (and arg (constantp arg))) + +(defun eq-comparable (arg) + (and (constantp arg) + [[orf fixnump chrp symbolp] (eval arg)])) + +(defun eql-comparable (arg) + (and (constantp arg) + [[orf symbolp chrp numberp] (eval arg)])) + +(defun expand-and (form) + (match-case form + ((and) t) + ((and @a) a) + ((and @(true-const-p) . @rest) (expand-and ^(and ,*rest))) + ((and nil . @rest) nil) + ((and @a . @rest) ^(if ,a ,(expand-and ^(and ,*rest)))) + (@else else))) + +(defun flatten-or (form) + (match-case form + ((or . @args) ^(or ,*[mappend [chain flatten-or cdr] args])) + (@else ^(or ,else)))) + +(defun reduce-or (form) + (match-case form + ((or) form) + ((or @a) form) + ((or nil . @rest) (reduce-or ^(or ,*rest))) + ((or @(true-const-p @c) . @rest) ^(or ,c)) + ((or @a . @rest) ^(or ,a ,*(cdr (reduce-or ^(or ,*rest))))) + (@else else))) + +(defun simplify-or (form) + (reduce-or (flatten-or form))) + +(defmacro fixed-point (eqfn sym exp) + (with-gensyms (osym) + ^(let (,osym) + (while* (not (,eqfn ,osym ,sym)) + (set ,osym ,sym + ,sym ,exp)) + ,sym))) + +(defun reduce-lisp (form) + (fixed-point equal form + (rlcp + (match-case form + ((append (list . @largs) . @aargs) + ^(list* ,*largs (append ,*aargs))) + ((@(or append list*) @arg) arg) + (@(require (list* . @(listp @args)) + (equal '(nil) (last args))) + ^(list ,*(butlastn 1 args))) + (@(with (list* . @(listp @args)) + ((@(and @op @(or list list*)) . @largs)) (last args)) + ^(,op ,*(butlast args) ,*largs)) + (@(with (list* . @(listp @args)) + ((append . @aargs)) (last args)) + ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs)))) + ((@(or append list list*)) nil) + ((cons @a @b) + (let* ((lstar ^(list* ,a ,b)) + (rstar (reduce-lisp lstar))) + (if (eq lstar rstar) form rstar))) + ((cons @a (cons @b @c)) + ^(list* ,a ,b ,c)) + ((cons @a (@(and @op @(or list list*)) . @args)) + ^(,op ,a ,*args)) + (@else else)) + form))) + +(defun reduce-constant (env form) + (if (consp form) + (tree-bind (op . args) form + (if (and [%const-foldable% op] + (not env.(lookup-fun op))) + (let ((cargs [mapcar (op reduce-constant env) args])) + (if [all cargs constantp] + ^(quote ,(eval (rlcp ^(,op ,*cargs) form))) + (rlcp ^(,op ,*cargs) form))) + form)) + form)) + +(defun expand-quasi-mods (obj mods : form) + (let (plist num sep rng-ix scalar-ix-p flex gens) + (flet ((get-sym (exp) + (let ((gen (gensym))) + (push (list gen exp) gens) + gen))) + (for () (mods) ((pop mods)) + (let ((mel (car mods))) + (cond + ((keywordp mel) + (set plist mods) + (return)) + ((integerp mel) + (when num + (compile-error form "duplicate modifier (width/alignment): ~s" + num)) + (set num mel)) + ((stringp mel) + (when sep + (compile-error form "duplicate modifier (separator): ~s" + num)) + (set sep mel)) + ((atom mel) + (push (get-sym mel) flex)) + (t + (caseq (car mel) + (dwim + (when rng-ix + (compile-error form "duplicate modifier (range/index): ~s" + mel)) + (unless (consp (cdr mel)) + (compile-error form "missing argument in range/index: ~s" + mel)) + (unless (null (cddr mel)) + (compile-error form "excess args in range/index: ~s" + num)) + (let ((arg (cadr mel))) + (cond + ((and (consp arg) (eq (car arg) 'range)) + (set rng-ix (get-sym ^(rcons ,(cadr arg) ,(caddr arg))))) + (t + (set rng-ix (get-sym arg)) + (set scalar-ix-p t))))) + (sys:expr (push (get-sym flex) (cadr mel))) + (t (push (get-sym mel) flex))))))) + (let ((mcount (+ (if num 1 0) + (if sep 1 0) + (if rng-ix 1 0) + (len flex)))) + (when (> mcount 3) + (compile-error form "too many formatting modifiers")) + ^(alet ,(nreverse gens) + ,(if flex + ^(sys:fmt-flex ,obj ',plist + ,*(remq nil (list* num sep + (if scalar-ix-p + ^(rcons ,rng-ix nil) + rng-ix) + (nreverse flex)))) + (cond + (plist ^(sys:fmt-simple ,obj ,num ,sep, rng-ix ',plist)) + (rng-ix ^(sys:fmt-simple ,obj ,num ,sep, rng-ix)) + (sep ^(sys:fmt-simple ,obj ,num ,sep)) + (num ^(sys:fmt-simple ,obj ,num)) + (t ^(sys:fmt-simple ,obj ,num))))))))) + +(defun expand-quasi-args (form) + (append-each ((el (cdr form))) + (cond + ((consp el) + (caseq (car el) + (sys:var (mac-param-bind form (sym exp : mods) el + (list (expand-quasi-mods exp mods)))) + (sys:quasi (expand-quasi-args el)) + (t (list ^(sys:fmt-simple ,el))))) + ((bindable el) + (list ^(sys:fmt-simple ,el))) + (t + (list el))))) + +(defun expand-quasi (form) + (let ((qa (expand-quasi-args form))) + (cond + ((cdr qa) ^(sys:fmt-join ,*qa)) + (qa (car qa)) + (t '(mkstring 0))))) + +(defun expand-dohash (form) + (mac-param-bind form (op (key-var val-var hash-form : res-form) . body) form + (with-gensyms (iter-var cell-var) + ^(let (,key-var ,val-var (,iter-var (hash-begin ,hash-form)) ,cell-var) + (block nil + (sys:for-op ((sys:setq ,cell-var (hash-next ,iter-var))) + (,cell-var ,res-form) + ((sys:setq ,cell-var (hash-next ,iter-var))) + (sys:setq ,key-var (car ,cell-var)) + (sys:setq ,val-var (cdr ,cell-var)) + ,*body)))))) + +(defun expand-each (form env) + (mac-param-bind form (op each-type vars . body) form + (when (eq vars t) + (set vars [mapcar car env.vb])) + (let* ((gens (mapcar (ret (gensym)) vars)) + (out (if (member each-type '(collect-each append-each)) + (gensym))) + (accum (if out (gensym)))) + ^(let* (,*(mapcar (ret ^(,@1 (iter-begin ,@2))) gens vars) + ,*(if accum ^((,out (cons nil nil)) (,accum ,out)))) + (block nil + (sys:for-op () + ((and ,*(mapcar (op list 'iter-more) gens)) + ,*(if accum (if (eq each-type 'collect-each) + ^((cdr ,out)) + ^((sys:apply (fun append) ,out))))) + (,*(mapcar (ret ^(sys:setq ,@1 (iter-step ,@1))) gens)) + ,*(mapcar (ret ^(sys:setq ,@1 (iter-item ,@2))) vars gens) + ,*(caseq each-type + ((collect-each append-each) + ^((rplacd ,accum (cons (progn ,*body) nil)) + (sys:setq ,accum (cdr ,accum)))) + (t body)))))))) + +(defun expand-bind-mac-params (ctx-form err-form params menv-var + obj-var strict err-block body) + (let (gen-stk stmt vars) + (labels ((get-gen () + (or (pop gen-stk) (gensym))) + (put-gen (g) + (push g gen-stk)) + (expand-rec (par-syntax obj-var check-var) + (labels ((emit-stmt (form) + (when form + (if check-var + (push ^(when ,check-var ,form) stmt) + (push form stmt)))) + (emit-var (sym init-form) + (push (if stmt + (prog1 + ^(,sym (progn ,*(nreverse stmt) + ,(if check-var + ^(when ,check-var ,init-form) + init-form))) + (set stmt nil)) + ^(,sym ,(if check-var + ^(when ,check-var ,init-form) + init-form))) + vars))) + (let ((pars (new (mac-param-parser par-syntax ctx-form)))) + (progn + (cond + ((eq strict t) + (emit-stmt + ^(sys:bind-mac-check ,err-form ',par-syntax + ,obj-var ,pars.nreq + ,(unless pars.rest + pars.nfix)))) + ((null strict)) + ((symbolp strict) + (emit-stmt + (let ((len-expr ^(if (consp ,obj-var) + (len ,obj-var) 0))) + (if pars.rest + ^(unless (<= ,pars.nreq ,len-expr) + (return-from ,err-block ',strict)) + ^(unless (<= ,pars.nreq ,len-expr ,pars.nfix) + (return-from ,err-block ',strict))))))) + (each ((k pars.key)) + (tree-bind (key . sym) k + (caseq key + (:whole (emit-var sym obj-var)) + (:form (emit-var sym ctx-form)) + (:env (emit-var sym menv-var))))) + (each ((p pars.req)) + (cond + ((listp p) + (let ((curs (get-gen))) + (emit-stmt ^(set ,curs (car ,obj-var))) + (emit-stmt ^(set ,obj-var (cdr ,obj-var))) + (expand-rec p curs check-var) + (put-gen curs))) + (t + (emit-var p ^(car ,obj-var)) + (emit-stmt ^(set ,obj-var (cdr ,obj-var)))))) + (each ((o pars.opt)) + (tree-bind (p : init-form pres-p) o + (cond + ((listp p) + (let* ((curs (get-gen)) + (stmt ^(cond + (,obj-var + (set ,curs (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,*(if pres-p '(t))) + (t + (set ,curs ,init-form) + ,*(if pres-p '(nil)))))) + (if pres-p + (emit-var pres-p stmt) + (emit-stmt stmt)) + (let ((cv (gensym))) + (emit-var cv curs) + (expand-rec p curs cv) + (put-gen curs)))) + (t + (cond + (pres-p + (emit-var p nil) + (emit-var pres-p + ^(cond + (,obj-var + (set ,p (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,(if pres-p t)) + (t + ,(if init-form + ^(set ,p ,init-form)) + ,(if pres-p nil))))) + (t + (emit-var p ^(if ,obj-var + (prog1 + (car ,obj-var) + (set ,obj-var (cdr ,obj-var))) + (if ,init-form ,init-form))))))))) + (when pars.rest + (emit-var pars.rest obj-var))))))) + (expand-rec params obj-var nil) + (when stmt + (push ^(,(gensym) (progn ,*(nreverse stmt))) vars)) + ^(let* (,*gen-stk ,*(nreverse vars)) + ,*body)))) + +(defun expand-defvarl (form) + (mac-param-bind form (op sym : value) form + (with-gensyms (cell) + (if value + ^(let ((,cell (sys:rt-defv ',sym))) + (if ,cell + (usr:rplacd ,cell ,value)) + ',sym) + ^(progn (sys:rt-defv ',sym) ',sym))))) + +(defun expand-defun (form) + (mac-param-bind form (op name args . body) form + (flet ((mklambda (block-name block-sym) + ^(lambda ,args (,block-sym ,block-name ,*body)))) + (cond + ((bindable name) + ^(sys:rt-defun ',name ,(mklambda name 'sys:blk))) + ((consp name) + (caseq (car name) + (meth + (mac-param-bind form (meth type slot) name + ^(sys:define-method ',type ',slot ,(mklambda slot 'block)))) + (macro + (mac-param-bind form (macro sym) name + ^(sys:rt-defmacro ',sym ',name ,(mklambda sym 'sys:blk)))) + (t (compile-error form "~s isn't a valid compound function name" + name)))) + (t (compile-error form "~s isn't a valid function name" name)))))) + +(defun expand-defmacro (form) + (mac-param-bind form (op name mac-args . body) form + (with-gensyms (form menv spine-iter) + (let ((exp-lam ^(lambda (,form ,menv) + (let ((,spine-iter (cdr ,form))) + ,(expand (expand-bind-mac-params form form mac-args + menv spine-iter + t nil + ^((sys:set-macro-ancestor + (block ,name ,*body) + ,form)))))))) + ^(progn + (sys:rt-defmacro ',name '(macro ,name) ,exp-lam) + ',name))))) + +(defun expand-defsymacro (form) + (mac-param-bind form (op name def) form + ^(sys:rt-defsymacro ',name ',def))) + +(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed) + (if (and (not recursed) + apply-list-expr + (constantp apply-list-expr)) + (let* ((apply-list-val (eval apply-list-expr)) + (apply-atom (nthlast 0 apply-list-val)) + (apply-fixed (butlastn 0 apply-list-val))) + (lambda-apply-transform lm-expr (append fix-arg-exprs + (mapcar (ret ^',@1) apply-fixed)) + ^',apply-atom t)) + (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr + (let* ((pars (new (fun-param-parser lm-args lm-expr))) + (fix-vals (mapcar (ret (gensym)) fix-arg-exprs)) + (ign-sym (gensym)) + (al-val (gensym)) + (shadow-p (let ((all-vars (append pars.req pars.(opt-syms) + (if pars.rest (list pars.rest))))) + (or (isec all-vars fix-arg-exprs) + (member apply-list-expr all-vars))))) + ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs) + (let* ,(build + (if apply-list-expr + (add ^(,al-val ,apply-list-expr))) + (while (and fix-vals pars.req) + (add ^(,(pop pars.req) ,(pop fix-vals)))) + (while (and fix-vals pars.opt) + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (add ^(,var-sym ,(pop fix-vals))) + (if have-sym + (add ^(,have-sym t))))) + (cond + ((and (null pars.req) + (null pars.opt)) + (if fix-vals + (if pars.rest + (add ^(,pars.rest + (list* + ,*(nthcdr pars.nfix + ^(,*fix-arg-exprs ,apply-list-expr))))) + (lambda-too-many-args lm-expr)) + (when (or pars.rest apply-list-expr) + (add ^(,(or pars.rest ign-sym) ,apply-list-expr))))) + ((and fix-vals apply-list-expr) + (lambda-too-many-args lm-expr)) + (apply-list-expr + (when pars.req + (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req)) + (lambda-short-apply-list))))) + (while pars.req + (add ^(,(pop pars.req) (pop ,al-val)))) + (while pars.opt + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (cond + (have-sym + (add ^(,var-sym (if ,al-val + (car ,al-val) + ,init-form))) + (add ^(,have-sym (when ,al-val + (pop ,al-val) + t)))) + (t (add ^(,var-sym (if ,al-val + (pop ,al-val) + ,init-form))))))) + (when pars.rest + (add ^(,pars.rest ,al-val)))) + (pars.req + (lambda-too-few-args lm-expr)) + (pars.opt + (while pars.opt + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (add ^(,var-sym ,init-form)) + (if have-sym + (add ^(,have-sym))))) + (when pars.rest + (add ^(,pars.rest)))))) + ,*lm-body)))))) + +(defun system-symbol-p (sym) + (member (symbol-package sym) + (load-time (list user-package system-package)))) + +(defun usr:compile-toplevel (exp : (expanded-p nil)) + (let ((co (new compiler)) + (as (new assembler)) + (*dedup* (or *dedup* (hash))) + (*opt-level* (or *opt-level* 0))) + (let* ((*load-time* t) + (oreg co.(alloc-treg)) + (xexp (if expanded-p + exp + (unwind-protect + (expand* exp) + (unless *load-recursive* + (release-deferred-warnings))))) + (frag co.(compile oreg (new env co co) xexp))) + co.(free-treg oreg) + co.(check-treg-leak) + as.(asm co.(optimize ^(,*(mappend .code (nreverse co.lt-frags)) + ,*frag.code + (jend ,frag.oreg)))) + (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec))))) + +(defun get-param-info (sym) + (whenlet ((fun (symbol-function sym))) + (or [%param-info% fun] + (set [%param-info% fun] + (new param-info fun fun))))) + +(defun param-check (form nargs pars) + (cond + ((< nargs pars.nreq) + (compile-warning form "too few arguments: needs ~s, given ~s" + pars.nreq nargs)) + (pars.rest) + ((> nargs pars.nfix) + (compile-warning form "too many arguments: max ~s, given ~s" + pars.nfix nargs)))) + +(defun compiler-emit-warnings () + (let ((warn-fun [keep-if boundp (zap assumed-fun)])) + (when warn-fun + (usr:catch + (throw 'warning + `uses of @{warn-fun ", "} compiled as functions,\ + \ then defined as vars`) + (continue ())))) + (each ((uc (zap *unchecked-calls*))) + (when-match (@(as form (@sym . @args)) . @nargs) uc + (whenlet ((fun (symbol-function sym))) + (param-check form nargs (get-param-info sym)))))) + +(defvarl %file-suff-rx% #/[.][^\\\/.]+/) + +(defvar *emit*) + +(defvar *eval*) + +(defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001')) + +(defvarl %tlo-ver% ^(7 0 ,%big-endian%)) + +(defvarl %package-manip% '(make-package delete-package + use-package unuse-package + set-package-fallback-list + intern unintern rehome-sym + use-sym unuse-sym)) + +(defun open-compile-streams (in-path out-path test-fn) + (let* ((parent (or *load-path* "")) + (sep [path-sep-chars 0]) + (in-path (if (and (pure-rel-path-p in-path) (not (empty parent))) + `@(dir-name parent)@sep@{in-path}` + in-path)) + (rsuff (r$ %file-suff-rx% in-path)) + (suff (if rsuff [in-path rsuff])) + (ip-nosuff (if rsuff [in-path 0..(from rsuff)] in-path)) + in-stream out-stream) + (cond + ((ends-with ".txr" in-path) + (error "~s: cannot compile TXR files" 'compile-file)) + ((ends-with ".tl" in-path) + (set in-stream (ignerr (open-file in-path)) + out-path (or out-path `@{in-path [0..-3]}.tlo`))) + (t + (set in-stream (or (ignerr (open-file `@{in-path}.tl`)) + (ignerr (open-file in-path))) + out-path (or out-path `@{in-path}.tlo`)))) + + (unless in-stream + (error "~s: unable to open input file ~s" 'compile-file in-path)) + + (unless [test-fn in-stream out-path] + (close-stream in-stream) + (return-from open-compile-streams nil)) + + (set out-stream (ignerr (open-file out-path "w"))) + + (unless out-stream + (close-stream in-stream) + (error "~s: unable to open output file ~s" 'compile-file out-path)) + + (list in-stream out-stream out-path))) + +(defun list-from-vm-desc (vd) + (list (sys:vm-desc-nlevels vd) + (sys:vm-desc-nregs vd) + (sys:vm-desc-bytecode vd) + (copy (sys:vm-desc-datavec vd)) + (sys:vm-desc-symvec vd))) + +(defmacro usr:with-compilation-unit (. body) + (with-gensyms (rec) + ^(let* ((,rec *in-compilation-unit*) + (*in-compilation-unit* t) + (sys:*load-recursive* t) + (*dedup* (or *dedup* (hash)))) + (unwind-protect + (progn ,*body) + (unless ,rec + (release-deferred-warnings) + (compiler-emit-warnings)))))) + +(defun dump-to-tlo (out-stream out) + (let* ((*print-circle* t) + (*package* (sys:make-anon-package)) + (out-forms (split* out.(get) (op where (op eq :fence))))) + (prinl %tlo-ver% out-stream) + [mapdo (op prinl @1 out-stream) out-forms] + (delete-package *package*))) + +(defun propagate-perms (in-stream out-stream) + (let ((sti (stat in-stream))) + (when (plusp (logand sti.mode s-ixusr)) + (let ((mode "+x") + (suid (if (plusp (logand sti.mode s-isuid)) ",u+s")) + (sgid (if (and (plusp (logand sti.mode s-isgid)) + (plusp (logand sti.mode s-ixgrp))) ",g+s"))) + (when (or suid sgid) + (let ((sto (stat out-stream))) + (set mode (append mode + (if (eql sti.uid sto.uid) suid) + (if (eql sti.gid sto.gid) sgid))))) + (chmod out-stream mode))))) + +(defun compile-file-conditionally (in-path out-path test-fn) + (whenlet ((success nil) + (perms nil) + (streams (open-compile-streams in-path out-path test-fn))) + (with-resources ((in-stream (car streams) (close-stream in-stream)) + (out-stream (cadr streams) (progn + (when perms + (propagate-perms in-stream + out-stream)) + (close-stream out-stream) + (unless success + (remove-path (caddr streams)))))) + (let* ((err-ret (gensym)) + (*package* *package*) + (*emit* t) + (*eval* t) + (*load-path* (stream-get-prop (car streams) :name)) + (*rec-source-loc* t) + (out (new list-builder))) + (with-compilation-unit + (iflet ((line (get-line in-stream)) + ((starts-with "#!" line))) + (progn + (set line `@line `) + (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`))) + (put-line (butlast line) out-stream) + (set perms t)) + (seek-stream in-stream 0 :from-start)) + (labels ((compile-form (unex-form) + (let* ((form (macroexpand unex-form)) + (sym (if (consp form) (car form)))) + (caseq sym + (progn [mapdo compile-form (cdr form)]) + (compile-only (let ((*eval* nil)) + [mapdo compile-form (cdr form)])) + (eval-only (let ((*emit* nil)) + [mapdo compile-form (cdr form)])) + (sys:load-time-lit + (if (cadr form) + (compile-form ^(quote ,(caddr form))) + (compile-form (caddr form)))) + (t (when (and (or *eval* *emit*) + (not (constantp form))) + (let* ((vm-desc (compile-toplevel form)) + (flat-vd (list-from-vm-desc vm-desc)) + (fence (member sym %package-manip%))) + (when *eval* + (let ((pa *package-alist*)) + (sys:vm-execute-toplevel vm-desc) + (when (neq pa *package-alist*) + (set fence t)))) + (when (and *emit* (consp form)) + out.(add flat-vd) + (when fence + out.(add :fence)))))))))) + (unwind-protect + (whilet ((obj (read in-stream *stderr* err-ret)) + ((neq obj err-ret))) + (compile-form obj)) + (dump-to-tlo out-stream out)) + + (when (parse-errors in-stream) + (error "~s: compilation of ~s failed" 'compile-file + (stream-get-prop in-stream :name)))) + (flush-stream out-stream) + (set success t)))))) + +(defun usr:compile-file (in-path : out-path) + [compile-file-conditionally in-path out-path tf]) + +(defun usr:compile-update-file (in-path : out-path) + [compile-file-conditionally in-path out-path [mapf path-newer fstat identity]]) + +(defun usr:dump-compiled-objects (out-stream . compiled-objs) + (symacrolet ((self 'dump-compiled-objects)) + (let ((out (new list-builder))) + (flet ((vm-from-fun (fun) + (unless (vm-fun-p fun) + (error "~s: not a vm function: ~s" self fun)) + (sys:vm-closure-desc (func-get-env fun)))) + (each ((obj compiled-objs)) + (let* ((vm-desc (typecase obj + (vm-desc obj) + (fun (vm-from-fun obj)) + (t (iflet ((fun (symbol-function obj))) + (vm-from-fun fun) + (error "~s: not a compiled object: ~s" + self obj))))) + (symvec (sys:vm-desc-symvec vm-desc))) + out.(add (list-from-vm-desc vm-desc)) + (when (isec symvec %package-manip%) + out.(add :fence))))) + (dump-to-tlo out-stream out)))) + +(defun sys:env-to-let (env form) + (when env + (let ((vb (env-vbindings env)) + (fb (env-fbindings env)) + (up (env-next env))) + (when vb + (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form))) + (when fb + (let (lbind fbind) + (each ((pair fb)) + (tree-bind (a . d) pair + (let* ((fun-p (interp-fun-p d)) + (fe (if fun-p (func-get-env d))) + (lb-p (and fe (eq fe env))) + (fb-p (and fe (eq fe up)))) + (cond + (lb-p (push ^(,a ,(func-get-form d)) lbind)) + (fb-p (push ^(,a ,(func-get-form d)) fbind)) + (t (push ^(,a ',d) fbind)))))) + (when lbind + (set form ^(sys:lbind ,(nreverse lbind) ,form))) + (when fbind + (set form ^(sys:fbind ,(nreverse fbind) ,form))))) + (if up + (set form (sys:env-to-let up form))))) + form) + +(defun usr:compile (obj) + (typecase obj + (fun (tree-bind (indicator args . body) (func-get-form obj) + (let* ((form (sys:env-to-let (func-get-env obj) + ^(lambda ,args ,*body))) + (vm-desc (compile-toplevel form t))) + (vm-execute-toplevel vm-desc)))) + (t (condlet + (((fun (symbol-function obj))) + (tree-bind (indicator args . body) (func-get-form fun) + (let* ((form (sys:env-to-let (func-get-env fun) + ^(lambda ,args ,*body))) + (vm-desc (compile-toplevel form t)) + (comp-fun (vm-execute-toplevel vm-desc))) + (set (symbol-function obj) comp-fun)))) + (t (error "~s: cannot compile ~s" 'compile obj)))))) |