[
  {
    "path": ".gitignore",
    "content": "*~\n*.elc\n"
  },
  {
    "path": "BUGS",
    "content": "(elcomp--do '(\n\t      (defun qqz ()\n\t\t(let ((f  (lambda () 23)))\n\t\t  (funcall f)))\n\t\t)\n\t    #'elcomp--c-translate\n\t    )\n\nthis should not generate code for the lambda but it does\nthe equivalent without a binding does not generate it\n\n================================================================\n\nC back end writes some bogus symbol names\n\nC back end doesn't do out-of-ssa\n[it does but still...]\nwe probably need to keep edges after all\n\n================================================================\n\ndocument the compilation / linkage model\n"
  },
  {
    "path": "Makefile",
    "content": "EMACS := /home/tromey/Emacs/install/bin/emacs\n\nHERE := $(shell pwd)\n\nall:\n\t$(EMACS) --batch --eval '(push \"$(HERE)\" load-path)' \\\n\t\t--eval '(byte-recompile-directory \".\" 0)'\n\nclean:\n\t-rm *.elc */*.elc\n"
  },
  {
    "path": "README.md",
    "content": "Welcome to El Compilador, a compiler for Emacs Lisp.\n\n## Breaking News\n\nThe compiler can now generate C code that can be compiled as part of\nEmacs.  Using the bubble sort benchmark from\nhttp://www.emacswiki.org/emacs/EmacsLispBenchmark (with the list\nbumped to 1000 elements), with 100 runs, I got some timings:\n\nApproach | Seconds\n:-------- | -------:\ninterpreted | 54.874574673000005\nbyte-compiled | 13.390510359999999\nel-compilador | 4.312016277000001\n\n## Dreams\n\nI've long wanted to write a compiler for Emacs Lisp.  Here it is.\nWell, the start of it.  In the long term I have a few goals for Emacs\nand Emacs Lisp that are served by this project:\n\nI think Emacs should move more strongly toward self-hosting.  Too much\nof Emacs is written in C, and in the long term this should be migrated\nto lisp.  Beyond just being more fun to hack, having Emacs written in\nEmacs Lisp would make it simpler to upgrade the language\nimplementation.\n\nThere are plenty of functions currently written in C which were either\ntranslated for performance (`widget-apply`) or just because some other\npart of the core needed to call it.  These would stop being acceptable\nreasons to write in C.\n\nThe C core is also badly behaved about making direct calls.  This is\nok for primitives like `cons`, but not ok for functions that one might\nreasonably want to advise or rewrite, like `read`.  Normally this lack\nof indirection is just because it is a pain to write out in C -- but\nautomatic translation could eliminate this problem.\n\nI'm also interested in using the compiler to either write a JIT or a\nnew register-based bytecode interpreter.  These could be done without\nmodifying Emacs once the new FFI code lands.\n\nFinally, it is bad and wrong that Emacs has three bytecode\ninterpreters (the Emacs Lisp one, the regexp engine, and CCL).  There\nshould be only one, and we can use this work to push Emacs toward that\ngoal.\n\n## Use\n\nYou can use the function in `loadup.el` to load the compiler and then\nuse the two handy entry points:\n\n* `elcomp--do`.  The debugging entry point.  This takes a form,\n  compiles it, and then dumps the resulting IR into a buffer.  For\n  example, you can try this on a reasonably direct translation of\n  `nthcdr` from `fns.c`:\n\n```elisp\n(elcomp--do '(defun nthcdr (num list)\n               (cl-check-type num integer)\n               (let ((i 0))\n                 (while (and (< i num) list)\n                   (setq list (cdr list))\n                   (setq i (1+ i)))\n                 list)))\n```\n\n* You can pass `elcomp--c-translate` as the third argument to\n  `elcomp--do` to use the \"C\" back end.  At least some forms of the\n  output will compile.  It targets the API used by the Emacs source\n  tree (not the Emacs dynamic module API).  Some constructs don't have\n  the needed back end support yet, so not everything will work.\n\n## Implementation\n\nEl Compilador is an\n[SSA-based](http://en.wikipedia.org/wiki/Static_single_assignment_form)\ncompiler.  The objects in the IR are described in `elcomp.el`.  EIEIO\nor `cl-defstruct` are used for most things.\n\nThe compiler provides a number of optimization passes:\n\n* Jump threading, `elcomp/jump-thread.el`.  This also does some simple\n  optimizations on predicates, like `not` removal.  This can sometimes\n  turn a `throw` into a `goto` when it is caught in the same `defun`.\n\n* Exception handling cleanup, `elcomp/eh-cleanup.el`.  This removes\n  useless exception edges.\n\n* Block coalescing, `elcomp/coalesce.el`.  This merges basic blocks\n  when possible.\n\n* Constant and copy propagation, `elcomp/cprop.el`.  This also\n  evaluates pure functions.\n\n* Dead code elimination, `elcomp/dce.el`.\n\n* Type inference, `elcomp/typeinf.el`.  This is a flow-sensitive type\n  inferencer.\n\n\n## To-Do\n\nThere are any number of bugs.  There are some notes about them in\nvarious files.  Some are filed in the github issues.\n\nThe into-SSA pass is written in the stupidest possible way.  Making\nthis smarter would be nice.\n"
  },
  {
    "path": "el-compile",
    "content": "#!/bin/sh\n:; exec emacs --quick --script $0 -- \"$@\"\n\n(setq debug-on-error t)\n;; FIXME debug.el says it tries to preserve the start of the stack\n;; trace, but in practice I'm not seeing this.\n(setq debugger-batch-max-lines 1000)\n\n(defconst elcomp--dir (file-name-directory load-file-name))\n\n(load (expand-file-name \"loadup.el\" elcomp--dir) nil t)\n(elcomp--loadup)\n\n(defun elcomp--skip-comments ()\n  (while (forward-comment 1)))\n\n(defun elcomp--read-forms ()\n  (let ((result '()))\n    (elcomp--skip-comments)\n    (while (not (eobp))\n      (push (read (current-buffer)) result)\n      (elcomp--skip-comments))\n    result))\n\n(defun elcomp--read-forms-from-file (lisp-file)\n  (save-excursion\n    (find-file lisp-file)\n    (goto-char (point-min))\n    (elcomp--read-forms)))\n\n(defun elcomp--driver-convert-one (output-file lisp-file)\n  (message \"Reading %s...\" lisp-file)\n  (let ((forms (elcomp--read-forms-from-file lisp-file)))\n    (let ((unit (make-elcomp--compilation-unit)))\n      ;; FIXME for now we only handle a file full of defuns\n      ;; and eval-when-compile.\n      (dolist (form forms)\n\t(cl-case (car form)\n\t  (eval-when-compile\n\t    (eval (cons 'progn (cdr form))))\n\t  ((defun define-ffi-library define-ffi-function)\n\t   (elcomp--plan-to-compile unit form))\n\t  (t\n\t   (message \"Skipping form %S\" (car form)))))\n      (elcomp--translate-all unit)\n      (elcomp--c-translate unit\n\t\t\t   (if output-file\n\t\t\t       (file-name-sans-extension\n\t\t\t\t(file-name-nondirectory output-file)))))))\n\n(defun elcomp--driver-compile (output-file files)\n  (find-file (or output-file \"OUTPUT\"))\n  (setq-local backup-inhibited t)\n  (erase-buffer)\n  (dolist (file files)\n    ;; FIXME this only works for a single file\n    (elcomp--driver-convert-one output-file file))\n  (save-buffer))\n\n;; FIXME it would be nice to have an argument parsing library in\n;; elisp.\n(when (equal (car argv) \"--\")\n  (pop argv))\n\n(if (equal (car argv) \"--help\")\n    (message \"Usage: el-compile FILE...\")\n  (let ((filename nil))\n    (when (equal (car argv) \"--output\")\n      (pop argv)\n      (setf filename (pop argv))\n      ;; Arrange for FFI to be available.\n      (elcomp--use-ffi))\n    (elcomp--driver-compile filename\n\t\t\t    (mapcar #'expand-file-name argv))))\n\n(setf argv nil)\n\n;; Local variables:\n;; Mode: emacs-lisp\n;; End:\n"
  },
  {
    "path": "elcomp/back.el",
    "content": ";;; back.el --- fix up back edges. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; Reconstruct the back edges in the CFG.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/iter)\n\n(defun elcomp--reset-back-edges (compiler init)\n  \"Reset the back edges of all basic blocks in COMPILER.\n\nThis sets all the back edges to nil.\"\n  (elcomp--iterate-over-bbs\n   compiler\n   (lambda (bb)\n     (setf (elcomp--basic-block-parents bb)\n\t   (if init (make-hash-table) nil)))))\n\n(cl-defgeneric elcomp--add-links (insn block)\n  \"Add backlinks for the instruction INSN, which appears in BLOCK.\n\nThe base case does nothing.  Most instructions don't have links.\"\n  ;; Do nothing.\n  nil)\n\n(cl-defmethod elcomp--add-links ((insn elcomp--goto) block)\n  \"Add backlinks for a `goto'.\"\n  (puthash block t (elcomp--basic-block-parents (elcomp--block insn))))\n\n(cl-defmethod elcomp--add-links ((insn elcomp--if) block)\n  \"Add backlinks for an `if'.\"\n  (puthash block t (elcomp--basic-block-parents (elcomp--block-true insn)))\n  (puthash block t (elcomp--basic-block-parents (elcomp--block-false insn))))\n\n(defun elcomp--require-back-edges (compiler)\n  \"Require the back links in COMPILER to be valid.\n\nIf the links are already believed to be valid, this does nothing.\nOtherwise, it recreates the links.\"\n  (unless (elcomp--back-edges-valid compiler)\n    (elcomp--reset-back-edges compiler t)\n    (elcomp--iterate-over-bbs\n     compiler\n     (lambda (bb)\n       (dolist (exception (elcomp--basic-block-exceptions bb))\n\t (when (elcomp--handler exception)\n\t   (puthash bb t\n\t\t    (elcomp--basic-block-parents (elcomp--handler exception)))))\n       (elcomp--add-links (elcomp--last-instruction bb) bb)))\n    (setf (elcomp--back-edges-valid compiler) t)))\n\n(defun elcomp--invalidate-back-edges (compiler)\n  \"Invalidate the back links in COMPILER.\"\n  (when (elcomp--back-edges-valid compiler)\n    (elcomp--reset-back-edges compiler nil)\n    (setf (elcomp--back-edges-valid compiler) nil)))\n\n(declare-function elcomp--clear-dominators \"elcomp/dom\")\n\n(defun elcomp--invalidate-cfg (compiler)\n  (elcomp--clear-dominators compiler)\n  (elcomp--invalidate-back-edges compiler))\n\n(provide 'elcomp/back)\n\n;;; back.el ends here\n"
  },
  {
    "path": "elcomp/c-inl.el",
    "content": ";; -*- emacs-lisp -*-\n\n(require 'elcomp)\n(require 'elcomp/typeinf)\n\n(defvar elcomp--c-compare-type-lists (make-hash-table))\n\n(defun elcomp--define-c-substitution (name type-list substitution)\n  (let ((existing (gethash name elcomp--c-compare-type-lists)))\n    (push (cons substitution type-list) existing)\n    (puthash name existing elcomp--c-compare-type-lists)))\n\n(defun elcomp--c-compare-type-lists (declared-types arg-types)\n  ;; FIXME - for now we require eq but we could do better.\n  ;; for example an actual type of 'null is ok for 'list.\n  (cl-every (lambda (declared-type arg-type)\n\t      (eq (elcomp--pretend-eval-type-predicate declared-type arg-type)\n\t\t  t))\n\t    declared-types arg-types))\n\n(defun elcomp--c-opt (call types)\n  (let ((call-sym (elcomp--func call)))\n    (when (symbolp call-sym)\n      (cl-dolist (entry (gethash call-sym elcomp--c-compare-type-lists))\n\t(when (elcomp--c-compare-type-lists (cdr entry) types)\n\t  ;; Found a match, so optimize.\n\t  (cl-return (car entry)))))))\n\n(dolist (entry '((car (cons) \"XCAR\")\n\t\t (cdr (cons) \"XCDR\")\n\t\t (setcar (cons :bottom) \"XSETCAR\")\n\t\t (setcdr (cons :bottom) \"XSETCDR\")\n\t\t (length (vector) \"ASIZE\")\n\t\t (length (string) \"SCHARS\")\n\t\t (length (bool-vector) \"bool_vector_size\")\n\t\t ;; not a function: (length (char-table) \"MAX_CHAR\")\n\t\t ;; Also: (length (null) 0)\n\t\t (symbol-name (symbol) \"SYMBOL_NAME\")))\n  (apply #'elcomp--define-c-substitution entry))\n\n;; there's no need for this once we fix cprop\n;; (elcomp--define-c-substitution car ((arg null))\n;; \t\t\t\"Qnil\")\n;; (elcomp--define-c-substitution cdr ((arg null))\n;; \t\t\t\"Qnil\")\n\n;; (elcomp--define-c-substitution aref ((v vector) (x integer))\n;; \t\t\t;; what about bounds?\n;; \t\t\t;; what about XFASTINT\n;; \t\t\t`(\"AREF\" v x))\n\n;; (elcomp--define-c-substitution null (arg)\n;; \t\t\t(concat \"NILP (\" arg \")\"))\n\n;; (dolist (simple '(integerp eq floatp markerp symbolp consp\n;; \t\t\t   stringp bool-vector-p bufferp\n;; \t\t\t   char-table-p functionp overlayp\n;; \t\t\t   processp subrp symbolp windowp))\n;;   ;; fixme this is wack\n;;   (elcomp--do-define-c-substitution simple FIXME upper-case...))\n\n(provide 'elcomp/c-inl)\n"
  },
  {
    "path": "elcomp/c-renames.el",
    "content": ";; Autogenerated by get-defuns.el\n(defvar elcomp--c-renames\n  '((internal-event-symbol-parse-modifiers . \"Fevent_symbol_parse_modifiers\")\n    (internal--track-mouse . \"Ftrack_mouse\")\n    (frame-bottom-divider-width . \"Fbottom_divider_width\")\n    (frame-right-divider-width . \"Fright_divider_width\")\n    (frame-border-width . \"Fborder_width\")\n    (frame-fringe-width . \"Ffringe_width\")\n    (frame-scroll-bar-height . \"Fscroll_bar_height\")\n    (frame-scroll-bar-width . \"Fscroll_bar_width\")\n    (last-nonminibuffer-frame . \"Flast_nonminibuf_frame\")\n    (let* . \"FletX\")\n    (internal-make-var-non-special . \"Fmake_var_non_special\")\n    (insert-before-markers-and-inherit . \"Finsert_and_inherit_before_markers\")\n    (preceding-char . \"Fprevious_char\")\n    (msdos-memput . \"Fdos_memput\")\n    (msdos-memget . \"Fdos_memget\")\n    (Snarf-documentation . \"Fsnarf_documentation\")\n    (1- . \"Fsub1\")\n    (1+ . \"Fadd1\")\n    (% . \"Frem\")\n    (/ . \"Fquo\")\n    (* . \"Ftimes\")\n    (- . \"Fminus\")\n    (+ . \"Fplus\")\n    (/= . \"Fneq\")\n    (>= . \"Fgeq\")\n    (<= . \"Fleq\")\n    (> . \"Fgtr\")\n    (< . \"Flss\")\n    (= . \"Feqlsign\")))\n(provide 'elcomp/c-renames)\n"
  },
  {
    "path": "elcomp/cmacros.el",
    "content": ";;; cmacros.el --- Compiler macros. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; Some compiler macros used by this compiler.\n\n;;; Code:\n\n(require 'elcomp)\n\n(defun elcomp--macro-declare (&rest specs)\n  \"A compiler macro for `declare'.\n\nThis just ensures we preserve the declaration so the compiler can\nsee it.\"\n  (cons 'declare specs))\n\n(defun elcomp--macro-condition-case (var bodyform &rest handlers)\n  \"A compiler macro for `condition-case'.\n\nThis pushes VAR as a let-binding into HANDLERS, when VAR is not\nnil.\"\n  ;; Use a special name so we (us humans hacking on this) don't get\n  ;; confused later on.\n  (append (list :elcomp-condition-case bodyform)\n\t  (if var\n\t      (mapcar (lambda (handler)\n\t\t\t(list (car handler)\n\t\t\t      `(let ((,var (:elcomp-fetch-condition)))\n\t\t\t\t ,@(cdr handler))))\n\t\t      handlers)\n\t    handlers)))\n\n(defun elcomp--macro-save-current-buffer (&rest body)\n  (let ((sym (cl-gensym)))\n    `(let ((,sym (current-buffer)))\n       (unwind-protect\n\t   (progn ,@body)\n\t (if (buffer-live-p ,sym)\n\t     (set-buffer ,sym))))))\n\n(defun elcomp--macro-save-excursion (&rest body)\n  (let ((sym (cl-gensym)))\n    `(let ((,sym (:save-excursion-save)))\n       (unwind-protect\n\t   (progn ,@body)\n\t (:save-excursion-restore ,sym)))))\n\n(defun elcomp--macro-save-restriction (&rest body)\n  (let ((sym (cl-gensym)))\n    `(let ((,sym (:save-restriction-save)))\n       (unwind-protect\n\t   (progn ,@body)\n\t (:save-restriction-restore ,sym)))))\n\n(defvar elcomp--compiler-macros\n  '((declare . elcomp--macro-declare)\n    (condition-case . elcomp--macro-condition-case)\n    (save-current-buffer . elcomp--macro-save-current-buffer)\n    (save-excursion . elcomp--macro-save-excursion)\n    (save-restriction . elcomp--macro-save-restriction)))\n\n(provide 'elcomp/cmacros)\n\n;;; cmacros.el ends here\n"
  },
  {
    "path": "elcomp/coalesce.el",
    "content": ";;; coalesce.el --- Coalesce blocks. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; A simple pass to coalesce blocks when possible.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/back)\n\n(defun elcomp--coalesce-pass (compiler)\n  \"A compiler pass to coalesce blocks.\n\nA block can be coalesced with a second block if the second block\nis the sole successor of the original, and the original is the\nsole predecessor of the second, and if they have compatible\noutgoing exception edges.\"\n  (elcomp--require-back-edges compiler)\n  (let ((rewrote-one nil)\n\t(ever-rewrote-one nil))\n    (elcomp--iterate-over-bbs\n     compiler\n     (lambda (bb)\n       ;; Loop until we're done with this block.\n       (setf rewrote-one t)\n       (while rewrote-one\n\t (setf rewrote-one nil)\n\t (when ;; If there is just one successor...\n\t     (elcomp--goto-p (elcomp--last-instruction bb))\n\t   (let ((succ\n\t\t  (elcomp--block (elcomp--last-instruction bb))))\n\t     (when (and\n\t\t    ;; and the successor block has a single predecessor...\n\t\t    (= (hash-table-count (elcomp--basic-block-parents succ)) 1)\n\t\t    ;; and either...\n\t\t    (or\n\t\t     ;; the exception regions are the same -- we can\n\t\t     ;; use `eq' due to how the exception lists are\n\t\t     ;; constructed...\n\t\t     (eq (elcomp--basic-block-exceptions bb)\n\t\t\t (elcomp--basic-block-exceptions succ))\n\t\t     ;; or this block is empty, in which case its\n\t\t     ;; exception regions are immaterial...\n\t\t     (eq (elcomp--basic-block-code bb)\n\t\t\t (elcomp--basic-block-code-link bb))))\n\t       ;; ... we can coalesce the blocks.\n\t       (setf (elcomp--basic-block-code bb)\n\t\t     (append\n\t\t      (nbutlast (elcomp--basic-block-code bb))\n\t\t      (elcomp--basic-block-code succ)))\n\t       (setf (elcomp--basic-block-code-link bb)\n\t\t     (elcomp--basic-block-code-link succ))\n\t       ;; If the current block was empty, then we need to take\n\t       ;; the exceptions from the successor block.  It doesn't\n\t       ;; hurt to do this unconditionally.\n\t       (setf (elcomp--basic-block-exceptions bb)\n\t\t     (elcomp--basic-block-exceptions succ))\n\t       (setf rewrote-one t)\n\t       (setf ever-rewrote-one t)))))))\n    (when ever-rewrote-one\n      (elcomp--invalidate-cfg compiler))))\n\n(provide 'elcomp/coalesce)\n\n;;; coalesce.el ends here\n"
  },
  {
    "path": "elcomp/comp-debug.el",
    "content": ";;; comp-debug.el --- Debugging the compiler. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; Debugging helpers for the compiler.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/typeinf)\n\n(cl-defgeneric elcomp--pp (obj _verbose)\n  \"Pretty-print a compiler object.\n\nOBJ is the object to pretty-print.\nVERBOSE non-nil means to write a more verbose description.\"\n  (princ obj))\n\n;; FIXME eldoc for cl-defmethod is messed up\n(cl-defmethod elcomp--pp ((obj elcomp--set) verbose)\n  (if verbose\n      (progn\n\t(princ \"set \")\n\t(elcomp--pp (elcomp--sym obj) nil)\n\t(princ \" = \")\n\t(elcomp--pp (elcomp--value obj) nil))\n    (elcomp--pp (elcomp--sym obj) nil)))\n\n(cl-defmethod elcomp--pp ((obj elcomp--call) verbose)\n  (if verbose\n      (progn\n\t(princ \"call \")\n\t(elcomp--pp (elcomp--sym obj) nil)\n\t(princ \" = \")\n\t(elcomp--pp (elcomp--func obj) nil)\n\t(when (elcomp--args obj)\n\t  (let ((first t))\n\t    (dolist (arg (elcomp--args obj))\n\t      (princ (if first \"(\" \" \"))\n\t      (setf first nil)\n\t      (elcomp--pp arg nil))\n\t    (princ \")\"))))\n    (elcomp--pp (elcomp--sym obj) nil)))\n\n(cl-defmethod elcomp--pp ((obj elcomp--goto) _verbose)\n  (princ \"goto BB \")\n  (princ (elcomp--basic-block-number (elcomp--block obj))))\n\n(cl-defmethod elcomp--pp ((obj elcomp--if) _verbose)\n  (princ \"if \")\n  (elcomp--pp (elcomp--sym obj) nil)\n  (princ \" BB \")\n  (princ (elcomp--basic-block-number (elcomp--block-true obj)))\n  (princ \" else BB \")\n  (princ (elcomp--basic-block-number (elcomp--block-false obj))))\n\n(cl-defmethod elcomp--pp ((obj elcomp--return) _verbose)\n  (princ \"return \")\n  (elcomp--pp (elcomp--sym obj) nil))\n\n(cl-defmethod elcomp--pp ((obj elcomp--constant) _verbose)\n  (princ \"<< \")\n  (princ (elcomp--value obj))\n  (princ \" >>\"))\n\n(cl-defmethod elcomp--pp ((obj elcomp--phi) verbose)\n  (princ \"ϕ:\")\n  (princ (elcomp--original-name obj))\n  (when verbose\n    (princ \" =\")\n    (maphash (lambda (item _ignore)\n\t       (princ \" \")\n\t       (elcomp--pp item nil))\n\t     (elcomp--args obj))))\n\n(cl-defmethod elcomp--pp ((obj elcomp--argument) _verbose)\n  (princ \"argument \")\n  (princ (elcomp--original-name obj)))\n\n(cl-defmethod elcomp--pp ((obj elcomp--catch) _verbose)\n  (princ \"catch \")\n  (princ (elcomp--tag obj))\n  (princ \" => BB \")\n  (princ (elcomp--basic-block-number (elcomp--handler obj))))\n\n(cl-defmethod elcomp--pp ((obj elcomp--condition-case) _verbose)\n  (princ \"condition-case \")\n  (princ (elcomp--condition-name obj))\n  (princ \" => BB \")\n  (princ (elcomp--basic-block-number (elcomp--handler obj))))\n\n(cl-defmethod elcomp--pp ((obj elcomp--unwind-protect) _verbose)\n  (princ \"unwind-protect => BB \")\n  (princ (elcomp--basic-block-number (elcomp--handler obj))))\n\n(cl-defmethod elcomp--pp ((obj elcomp--fake-unwind-protect) _verbose)\n  (princ \"fake-unwind-protect \")\n  (princ (elcomp--count obj)))\n\n(defun elcomp--pp-insn (text insn verbose)\n  (princ text)\n  (princ \" \")\n  (elcomp--pp insn verbose)\n  (princ \"\\n\"))\n\n(defun elcomp--pp-basic-block (bb)\n  (princ (format \"\\n[BB %d\"\n\t\t (elcomp--basic-block-number bb)))\n  (when (and (elcomp--basic-block-parents bb)\n\t     (> (hash-table-count (elcomp--basic-block-parents bb)) 0))\n    (princ \" (parents:\")\n    (maphash (lambda (parent-bb _ignore)\n\t       (princ (format \" %d\" (elcomp--basic-block-number parent-bb))))\n\t     (elcomp--basic-block-parents bb))\n    (princ \")\"))\n  (princ (format \" (idom: %s)\"\n\t\t (if (elcomp--basic-block-immediate-dominator bb)\n\t\t     (elcomp--basic-block-number\n\t\t      (elcomp--basic-block-immediate-dominator bb))\n\t\t   \"nil\")))\n  (princ \"]\\n\")\n  (dolist (exception (elcomp--basic-block-exceptions bb))\n    (princ \"    \")\n    (elcomp--pp exception (current-buffer))\n    (princ \"\\n\"))\n  (when (elcomp--basic-block-phis bb)\n    (maphash (lambda (_ignore_name phi)\n\t       (princ \"    \")\n\t       (elcomp--pp phi t)\n\t       (let ((type (elcomp--look-up-type bb phi)))\n\t\t (when type\n\t\t   (princ \" ; TYPE = \")\n\t\t   (princ type)))\n\t       (princ \"\\n\"))\n\t     (elcomp--basic-block-phis bb)))\n  (dolist (item (elcomp--basic-block-code bb))\n    (elcomp--pp item (current-buffer))\n    (let ((type (elcomp--look-up-type bb item)))\n      (when type\n\t(princ \" ; TYPE = \")\n\t(princ type)))\n    (princ \"\\n\")))\n\n(defun elcomp--pp-compiler (compiler &optional title)\n  \"Pretty-print the contents of COMPILER into the current buffer.\"\n  (when title\n    (insert \"==== \" title \"\\n\"))\n  (elcomp--iterate-over-bbs compiler #'elcomp--pp-basic-block)\n  (insert \"\\n=============================================================\\n\"))\n\n(defun elcomp--pp-unit (unit)\n  (maphash (lambda (_ignore compiler) (elcomp--pp-compiler compiler))\n\t   (elcomp--compilation-unit-defuns unit)))\n\n(provide 'elcomp/comp-debug)\n\n;;; comp-debug.el ends here\n"
  },
  {
    "path": "elcomp/cprop.el",
    "content": ";;; cprop.el --- Constant propagation. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This pass does constant propagation, copy propagation, and\n;; evaluation of pure functions.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/dce)\n(require 'elcomp/props)\n(require 'elcomp/subst)\n\n(defun elcomp--cprop-insert (rewrite-map from to)\n  (puthash from (or (gethash to rewrite-map) to) rewrite-map))\n\n(defun elcomp--cprop-basic (compiler)\n  \"Do constant and copy propagation.\nReturn non-nil if anything was changed.\"\n  (let ((rewrites nil))\n    (elcomp--iterate-over-bbs\n     compiler\n     (lambda (bb)\n       (dolist (insn (elcomp--basic-block-code bb))\n\t ;; We can eliminate SET instructions in general.  This\n\t ;; handles both constant and copy propagation.\n\t (when (elcomp--set-p insn)\n\t   (unless rewrites\n\t     (setf rewrites (make-hash-table)))\n\t   (elcomp--cprop-insert rewrites insn (elcomp--value insn))))))\n\n    (when rewrites\n      (elcomp--rewrite-using-map compiler rewrites)\n      t)))\n\n(cl-defun elcomp--all-arguments-constant (call)\n  (dolist (arg (elcomp--args call))\n    (unless (elcomp--constant-p arg)\n      (cl-return-from elcomp--all-arguments-constant nil)))\n  t)\n\n(defun elcomp--cprop-pure (compiler)\n  (let ((rewrites (make-hash-table)))\n    (elcomp--iterate-over-bbs\n     compiler\n     (lambda (bb)\n       ;; Remove phis that have a single argument.\n       ;; FIXME with a loop can we see ϕ1 -> ϕ1 ϕ2?\n       ;; That is a self-reference?\n       (maphash\n\t(lambda (_ignore phi)\n\t  (when (eq (hash-table-count (elcomp--args phi)) 1)\n\t    (elcomp--cprop-insert rewrites phi\n\t\t\t\t  (elcomp--any-hash-key (elcomp--args phi)))))\n\t(elcomp--basic-block-phis bb))\n       ;; Perform other optimizations.\n       (dolist (insn (elcomp--basic-block-code bb))\n\t (when (and (elcomp--call-p insn)\n\t\t    (elcomp--func-pure-p (elcomp--func insn))\n\t\t    (elcomp--all-arguments-constant insn))\n\t   (let ((new-value\n\t\t  (apply (elcomp--func insn)\n\t\t\t (mapcar (lambda (arg)\n\t\t\t\t   (elcomp--value arg))\n\t\t\t\t (elcomp--args insn)))))\n\t     (elcomp--cprop-insert rewrites insn\n\t\t\t\t   (elcomp--constant :value new-value)))))))\n\n    (when (> (hash-table-count rewrites) 0)\n      (elcomp--rewrite-using-map compiler rewrites)\n      t)))\n\n(defun elcomp--cprop-pass (compiler)\n  \"A constant- and copy-propagation pass.\n\nThis pass operates on COMPILER, performing constant- and\ncopy-propagation.  It also evaluates `pure' functions and removes\nunnecessary phis.\"\n  (while (and (elcomp--cprop-basic compiler)\n\t      (prog1\n\t\t  (elcomp--cprop-pure compiler)\n\t\t(elcomp--dce-pass compiler)))\n    ;; Nothing.\n    nil))\n\n(provide 'elcomp/cprop)\n\n;;; cprop.el ends here\n"
  },
  {
    "path": "elcomp/dce.el",
    "content": ";;; dce.el --- Dead Code Elimination. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; A simple dead code elimination pass.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/props)\n\n(cl-defstruct elcomp--dce\n  \"A structure that holds the data for a DCE pass.\n\nAn object of this type is allocated when `elcomp--dce-pass' is working.\nIt holds data internal to the pass.\"\n  ;; WORK-LIST holds a list of instructions to mark as needed.\n  work-list\n  ;; HASH is a hash table whose keys are instructions which have been\n  ;; marked as needed.\n  (hash (make-hash-table)))\n\n(defun elcomp--dce-add (insn dce)\n  \"Add INSN to the work list of DCE, unless it is already marked.\"\n  (push insn (elcomp--dce-work-list dce)))\n\n(cl-defgeneric elcomp--mark-necessary (insn dce _just-intrinsic)\n  \"Possibly mark the instruction INSN as necessary.\nDCE is the DCE state object for the pass.\n\nIf JUST-INTRINSIC is non-nil, then only mark the instruction if\nit is intrinsically needed.  If it is nil, then mark the\ninstruction.\n\nMarking the instruction means adding it to the hash and then\npushing the instruction's arguments onto the work list.\n\nThe default case is to mark a statement as needed.\"\n  (puthash insn t (elcomp--dce-hash dce)))\n\n(cl-defmethod elcomp--mark-necessary ((insn elcomp--if) dce _just-intrinsic)\n  \"`If' statements are marked as needed and their argument is pushed.\"\n  ;; An IF is always needed.\n  (puthash insn t (elcomp--dce-hash dce))\n  ;; And so is its reference.\n  (elcomp--dce-add (elcomp--sym insn) dce))\n\n(cl-defmethod elcomp--mark-necessary ((insn elcomp--goto) dce _just-intrinsic)\n  \"`Goto' statements are marked as needed.\"\n  ;; A GOTO is always needed.\n  (puthash insn t (elcomp--dce-hash dce)))\n\n(cl-defmethod elcomp--mark-necessary ((insn elcomp--return) dce _just-intrinsic)\n  \"`Return' statements are marked as needed and their argument is pushed.\"\n  ;; A RETURN is always needed.\n  (puthash insn t (elcomp--dce-hash dce))\n  ;; And so is its reference.\n  (elcomp--dce-add (elcomp--sym insn) dce))\n\n(cl-defmethod elcomp--mark-necessary ((insn elcomp--set) dce just-intrinsic)\n  \"Mark a `set' statement as necessary.\n\nIn the first pass, do nothing.  A `set' is not intrinsically needed.\nIn the second pass, mark this statement as needed, and then push\nits references on the work list.\"\n  ;; A SET is not intrinsically needed, so check which pass this is.\n  (unless just-intrinsic\n    (puthash insn t (elcomp--dce-hash dce))\n    (elcomp--dce-add (elcomp--value insn) dce)))\n\n(cl-defmethod elcomp--mark-necessary ((insn elcomp--phi) dce just-intrinsic)\n  \"Mark a `phi' statement as necessary.\n\nIn the first pass, do nothing.  A `phi' is not intrinsically needed.\nIn the second pass, mark this statement as needed, and then push\nits references on the work list.\"\n  ;; A PHI is not intrinsically needed, so check which pass this is.\n  (unless just-intrinsic\n    (puthash insn t (elcomp--dce-hash dce))\n    (maphash (lambda (arg _ignore)\n\t       (elcomp--dce-add arg dce))\n\t     (elcomp--args insn))))\n\n(cl-defmethod elcomp--mark-necessary ((insn elcomp--call) dce just-intrinsic)\n  \"Mark a `call' statement as necessary.\"\n  (let ((push-args nil))\n    (if just-intrinsic\n\t;; A non-const call is intrinsically needed.  However, we mark\n\t;; it specially so we can determine whether its LHS is needed\n\t;; as well.  Note that the \"const\" check also picks up the\n\t;; \"diediedie\" statements.\n\t(unless (elcomp--func-const-p (elcomp--func insn))\n\t  (puthash insn :call (elcomp--dce-hash dce))\n\t  (setf push-args t))\n      ;; Otherwise, we're propagating.\n      (puthash insn t (elcomp--dce-hash dce))\n      (setf push-args t))\n    (when push-args\n      ;; Push the arguments on the work list.\n      (dolist (arg (elcomp--args insn))\n\t(elcomp--dce-add arg dce)))))\n\n(defun elcomp--dce-mark-intrinsically-necessary (compiler dce)\n  \"Mark all intrinsically necessary statements.\n\nThis is the first pass of DCE.\n\nAny intrinsically necessary statement is entered into the `hash'\nfield of DCE and its references are pushed onto `work-list'.\"\n  (elcomp--iterate-over-bbs\n   compiler\n   (lambda (bb)\n     (dolist (insn (elcomp--basic-block-code bb))\n       (elcomp--mark-necessary insn dce t)))))\n\n(defun elcomp--dce-propagate-necessary (dce)\n  \"Propagate the \\\"necessary\\\" property through the function.\n\nThis is the second pass of DCE.\n\nThis iterates over the work list, entering statements into the\nDCE's `hash' table and pushing references onto the `work-list'.\"\n  (while (elcomp--dce-work-list dce)\n    (let* ((insn (pop (elcomp--dce-work-list dce)))\n\t   (mark (gethash insn (elcomp--dce-hash dce))))\n      ;; If it is marked as 't', then we don't need to do any more.\n      ;; If it is marked as :call, upgrade to 't'.\n      (if mark\n\t  (when (eq mark :call)\n\t    ;; Upgrade a call.\n\t    (puthash insn t (elcomp--dce-hash dce)))\n\t(elcomp--mark-necessary insn dce nil)))))\n\n(defun elcomp--dce-delete-dead-statements (compiler dce)\n  \"Delete dead statements.\n\nIterate over the statements in the function and remove any\nstatement that has not been marked as necessary.\"\n  (elcomp--iterate-over-bbs\n   compiler\n   (lambda (bb)\n     ;; Delete dead statements.\n     (let ((iter (elcomp--basic-block-code bb)))\n       (while iter\n\t (let ((mark (gethash (car iter) (elcomp--dce-hash dce))))\n\t   (cl-case mark\n\t     ((:call)\n\t      ;; We found a call whose result is not needed.  Drop the\n\t      ;; result if it is an SSA name.\n\t      (when (elcomp--ssa-name-p (car iter))\n\t\t(setf (elcomp--sym (car iter)) nil)))\n\t     ((nil)\n\t      ;; Remove the entire instruction.\n\t      (setf (car iter) nil))))\n\t (setf iter (cdr iter))))\n     (setf (elcomp--basic-block-code bb)\n\t   (delq nil (elcomp--basic-block-code bb)))\n     ;; Delete dead phi nodes.\n     (let ((phi-table (elcomp--basic-block-phis bb)))\n       (maphash (lambda (name phi)\n\t\t  (unless (gethash phi (elcomp--dce-hash dce))\n\t\t    (remhash name phi-table)))\n\t\tphi-table)))))\n\n(defun elcomp--dce-pass (compiler)\n  \"Delete dead code.\"\n  (let ((dce (make-elcomp--dce)))\n    (elcomp--dce-mark-intrinsically-necessary compiler dce)\n    (elcomp--dce-propagate-necessary dce)\n    (elcomp--dce-delete-dead-statements compiler dce)))\n\n(provide 'elcomp/dce)\n\n;;; dce.el ends here\n"
  },
  {
    "path": "elcomp/dom.el",
    "content": ";;; Dominators. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/back)\n\n(cl-defun elcomp--first-processed-predecessor (bb)\n  (maphash\n   (lambda (pred _ignore)\n     (if (elcomp--basic-block-immediate-dominator pred)\n\t (cl-return-from elcomp--first-processed-predecessor pred)))\n   (elcomp--basic-block-parents bb))\n  (error \"couldn't find processed predecessor in %S\"\n\t (elcomp--basic-block-number bb)))\n\n(defun elcomp--predecessors (bb)\n  (let ((result nil))\n    (maphash\n     (lambda (pred _ignore)\n       (push pred result))\n     (elcomp--basic-block-parents bb))\n    result))\n\n(defun elcomp--intersect (bb1 bb2 postorder-number)\n  (let ((f1 (gethash bb1 postorder-number))\n\t(f2 (gethash bb2 postorder-number)))\n    (while (not (eq f1 f2))\n      (while (< f1 f2)\n\t(setf bb1 (elcomp--basic-block-immediate-dominator bb1))\n\t(setf f1 (gethash bb1 postorder-number)))\n      (while (< f2 f1)\n\t(setf bb2 (elcomp--basic-block-immediate-dominator bb2))\n\t(setf f2 (gethash bb2 postorder-number))))\n    bb1))\n\n(defun elcomp--clear-dominators (compiler)\n  ;; Clear out the old dominators.\n  (elcomp--iterate-over-bbs\n   compiler\n   (lambda (bb)\n     (setf (elcomp--basic-block-immediate-dominator bb) nil))))\n\n(defun elcomp--compute-dominators (compiler)\n  ;; Require back edges.\n  (elcomp--require-back-edges compiler)\n  (elcomp--clear-dominators compiler)\n\n  (let ((nodes (elcomp--postorder compiler))\n\treversed\n\t(postorder-number (make-hash-table)))\n\n    ;; Perhaps POSTORDER-NUMBER should simply be an attribute on the\n    ;; BB.\n    (let ((i 0))\n      (dolist (bb nodes)\n\t(puthash bb i postorder-number)\n\t(cl-incf i)))\n\n    (setf reversed (delq (elcomp--entry-block compiler) (nreverse nodes)))\n    (setf nodes nil)\t\t\t; Paranoia.\n    (setf (elcomp--basic-block-immediate-dominator\n\t   (elcomp--entry-block compiler))\n\t  (elcomp--entry-block compiler))\n\n    (let ((changed t))\n      (while changed\n\t(setf changed nil)\n\t(dolist (bb reversed)\n\t  (let ((new-idom (elcomp--first-processed-predecessor bb)))\n\t    (dolist (pred (elcomp--predecessors bb))\n\t      (unless (eq new-idom pred)\n\t\t(if (elcomp--basic-block-immediate-dominator pred)\n\t\t    (setf new-idom (elcomp--intersect pred new-idom\n\t\t\t\t\t\t      postorder-number)))))\n\t    (unless (eq new-idom\n\t\t\t(elcomp--basic-block-immediate-dominator bb))\n\t      (setf (elcomp--basic-block-immediate-dominator bb) new-idom)\n\t      (setf changed t))))))))\n\n(provide 'elcomp/dom)\n\n;;; dom.el ends here\n"
  },
  {
    "path": "elcomp/eh-cleanup.el",
    "content": ";;; eh-cleanup.el --- Clean up exceptions. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; A pass to remove obviously-dead exception edges.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/back)\n(require 'elcomp/props)\n\n(cl-defgeneric elcomp--can-throw (_insn)\n  \"Return t if INSN can `throw' or `signal', otherwise nil.\n\nThe base case is to assume any instruction can throw.\"\n  t)\n\n(cl-defmethod elcomp--can-throw ((_insn elcomp--set))\n  \"A `set' instruction cannot throw.\"\n  nil)\n\n(cl-defmethod elcomp--can-throw ((_insn elcomp--goto))\n  \"A `goto' instruction cannot throw.\"\n  nil)\n\n(cl-defmethod elcomp--can-throw ((_insn elcomp--if))\n  \"An `if' instruction cannot throw.\"\n  nil)\n\n(cl-defmethod elcomp--can-throw ((_insn elcomp--return))\n  \"A `return' instruction cannot throw.\"\n  nil)\n\n(cl-defmethod elcomp--can-throw ((insn elcomp--call))\n  \"A `call' instruction usually can throw.\nA function marked `nothrow' will not throw.\"\n  ;; Note that we can't really be picky about `signal' or `throw'\n  ;; tags, due to QUIT and `throw-on-input'.\n  (if (and (symbolp (elcomp--func insn))\n\t   (elcomp--func-nothrow-p (elcomp--func insn)))\n      nil\n    t))\n\n(cl-defmethod elcomp--can-throw ((_insn elcomp--diediedie))\n  \"A `diediedie' instruction always throws.\"\n  t)\n\n(cl-defun elcomp--eh-remove-unwinds (bb)\n  \"Remove any empty `unwind-protect' edges from the basic block BB.\n\nAn empty `unwind-protect' edge is one where the target block\nconsists of just a call to the special `:unwind-protect-continue'\nfunction.\"\n  ;; There's probably some cl-loop formulation that isn't so ugly.\n  (while t\n    (let ((exception (car (elcomp--basic-block-exceptions bb))))\n      ;; Only the outermost exception edge is eligible for removal.\n      (unless (elcomp--unwind-protect-p exception)\n\t(cl-return-from elcomp--eh-remove-unwinds nil))\n      (let ((exc-block (elcomp--handler exception)))\n\t(when exc-block\n\t  ;; If the block is just a single instruction, then we know\n\t  ;; it is a call to the special :unwind-protect-continue\n\t  ;; function, and so the edge can be removed.\n\t  (unless (eq (elcomp--basic-block-code exc-block)\n\t\t      (elcomp--basic-block-code-link exc-block))\n\t    (cl-return-from elcomp--eh-remove-unwinds nil))\n\t  (cl-assert (elcomp--diediedie-p\n\t\t      (car (elcomp--basic-block-code exc-block))))\n\t  (pop (elcomp--basic-block-exceptions bb)))))))\n\n(defun elcomp--eh-cleanup-pass (compiler)\n  \"Remove useless exception handling edges from a function.\n\nThis operates on the function currently being defined in COMPILER.\n\nThis pass will remove useless `unwind-protect' edges.  See\n`elcomp--eh-remove-unwinds'.\n\nIt will also remove all exception edges from a basic block if\nthat block has no instructions which may throw.\"\n  (let ((found-one nil))\n    (elcomp--iterate-over-bbs\n     compiler\n     (lambda (bb)\n       (elcomp--eh-remove-unwinds bb)\n       ;; Don't bother if there are already no exception handlers.\n       (when (elcomp--basic-block-exceptions bb)\n\t (unless (cl-dolist (insn (elcomp--basic-block-code bb))\n\t\t   (when (elcomp--can-throw insn)\n\t\t     (cl-return t)))\n\t   ;; Since nothing here can throw, we can remove the\n\t   ;; exception handlers.\n\t   (setf (elcomp--basic-block-exceptions bb) nil)\n\t   (setf found-one t)))))\n    (when found-one\n      (elcomp--invalidate-cfg compiler))))\n\n(provide 'elcomp/eh-cleanup)\n\n;;; eh-cleanup.el ends here\n"
  },
  {
    "path": "elcomp/eltoc.el",
    "content": ";;; eltoc.el --- compile to C. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; A backend to generate Emacs-flavored C.\n\n;; TO DO:\n;; emit constants properly\n;; handle phi nodes\n;; emit lambdas without using DEFUN; call them directly\n;;\n;; We should also allow a declaration that allows a direct C\n;; call, not allowing symbol redefinition.\n;; (declare (direct FUNC))\n\n;;; Code:\n\n(require 'subr-x)\n(require 'elcomp)\n(require 'elcomp/c-inl)\n(require 'elcomp/c-renames)\n(require 'elcomp/dom)\n(require 'elcomp/linearize)\n(require 'elcomp/name-map)\n(require 'elcomp/props)\n\n;; FIXME - emacs must supply this value\n(defconst elcomp--c-max-args 8)\n\n(cl-defstruct elcomp--c\n  decls\n  decl-marker\n  ;; Map symbols to their C names.\n  interned-symbols\n  ;; Map SSA names to their defining blocks.\n  ;; This is a hack because we don't have a good out-of-ssa approach\n  ;; yet.\n  name-map\n  (eh-count 0))\n\n(defun elcomp--c-quote-string (str)\n  \"Quote a Lisp string according to C rules.\"\n  (concat \"\\\"\"\n\t  (mapconcat (lambda (c)\n\t\t       ;; Not really complete yet.\n\t\t       (cl-case c\n\t\t\t ((?\\\\ ?\\\")\n\t\t\t  (string ?\\\\ c))\n\t\t\t (?\\n \"\\\\n\")\n\t\t\t (?\\r \"\\\\r\")\n\t\t\t (?\\t \"\\\\t\")\n\t\t\t (t (string c))))\n\t\t     str \"\")\n\t  \"\\\"\"))\n\n(defun elcomp--c-name (symbol)\n  \"Compute the C name for a symbol.\"\n  ;; FIXME there can be name clashes, and leading number is not handled.\n  (replace-regexp-in-string \"[^a-zA-Z0-9_]\" \"_\" (symbol-name symbol)))\n\n(defun elcomp--c-intern-symbol (eltoc symbol)\n  \"Mark a symbol for init-time interning and return its name.\nThis is used for references to global symbols.\"\n  (or (gethash symbol (elcomp--c-interned-symbols eltoc))\n      ;; Use LQsym, not Qsym, to avoid clashes with things Emacs\n      ;; defines itself.\n      (puthash symbol (concat \"LQ\" (elcomp--c-name symbol))\n\t       (elcomp--c-interned-symbols eltoc))))\n\n(defun elcomp--c-declare (eltoc sym)\n  (unless (gethash sym (elcomp--c-decls eltoc))\n    (save-excursion\n      (goto-char (elcomp--c-decl-marker eltoc))\n      (insert \"  Lisp_Object \" (elcomp--c-name sym) \";\\n\")\n      (puthash sym t (elcomp--c-decls eltoc)))))\n\n(defun elcomp--c-declare-handler (eltoc)\n  (let ((name (format \"h%d\" (cl-incf (elcomp--c-eh-count eltoc)))))\n    (save-excursion\n      (goto-char (elcomp--c-decl-marker eltoc))\n      (insert \"  struct handler *\" name \";\\n\")\n      name)))\n\n(defun elcomp--c-symbol (eltoc sym &optional no-declare)\n  (unless no-declare\n    (elcomp--c-declare eltoc sym))\n  (insert (elcomp--c-name sym)))\n\n;; FIXME - in emacs 25 this can be a generic.\n(defun elcomp--c-emit-symref (eltoc insn)\n  (cond\n   ((symbolp insn)\n    (insert (elcomp--c-intern-symbol eltoc insn)))\n   ((elcomp--set-p insn)\n    (elcomp--c-symbol eltoc (elcomp--sym insn)))\n   ((elcomp--call-p insn)\n    (elcomp--c-symbol eltoc (elcomp--sym insn)))\n   ((elcomp--phi-p insn)\n    ;; FIXME??\n    (elcomp--c-symbol eltoc (elcomp--original-name insn)))\n   ((elcomp--argument-p insn)\n    (elcomp--c-symbol eltoc (elcomp--original-name insn) t))\n   ((elcomp--constant-p insn)\n    (let ((value (elcomp--value insn)))\n      (cond\n       ;; FIXME - in emacs 25 this can be a generic.\n       ((symbolp value)\n\t(insert (elcomp--c-intern-symbol eltoc value)))\n       ((integerp value)\n\t(insert \"make_number (\" (number-to-string value) \")\"))\n       ((stringp value)\n\t;; Could use make_string, but there's little point since GCC\n\t;; will optimize the strlen anyhow.\n\t(insert \"build_string (\" (elcomp--c-quote-string value) \")\"))\n       ((cl-typep value 'elcomp)\n\t(insert \"K\" (elcomp--c-name (elcomp--get-name value))))\n       (t\n\t;: FIXME why does calling error here cause problems?\n\t;; Anyway this ought to emit some initialization code to\n\t;; construct non-primitve constants.\n\t;; (error \"unhandled constant of type %S\" (type-of value))\n\t(insert \"BUG in elcomp--c-emit-symref\")))))\n   (t\n    (error \"unhandled case: %S\" insn))))\n\n(defun elcomp--c-emit-label (block)\n  (insert (format \"BB_%d\" (elcomp--basic-block-number block))))\n\n(cl-defgeneric elcomp--c-emit (insn _eltoc _bb)\n  \"FIXME\"\n  (error \"unhandled case: %S\" insn))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--set) eltoc _bb)\n  (elcomp--c-emit-symref eltoc insn)\n  (insert \" = \")\n  (elcomp--c-emit-symref eltoc (elcomp--value insn)))\n\n(defun elcomp--unbind-emitter (insn)\n  \"Emit a call to :elcomp-unbind.\nThis must be handled specially for now to avoid boxing the\nargument.\"\n  (let* ((args (elcomp--args insn))\n\t (first-arg (car args)))\n  (cl-assert (eq (length args) 1))\n  (cl-assert (elcomp--constant-p first-arg))\n  (let ((value (elcomp--value first-arg)))\n    (cl-assert (integerp value))\n    (insert \"unbind_to (SPECPDL_INDEX - \"\n\t    (number-to-string value)\n\t    \", Qnil)\"))))\n\n(defconst elcomp--c-direct-renames\n  '((:elcomp-specbind . \"specbind\")\n    (:elcomp-fetch-condition . \"signal_value\")\n    (:save-excursion-save . \"save_excursion_save\")\n    (:save-excursion-restore . \"save_excursion_restore\")\n    (:save-restriction-save . \"save_restriction_save\")\n    (:save-restriction-restore . \"save_restriction_restore\")\n    (:unwind-protect-continue . \"unwind_protect_continue\")\n    (:catch-value . \"catch_value\")\n    (:pop-exception-handler . \"pop_exception_handler\")\n    ;; FIXME\n    (:ffi-call . \"FFI_CALL\")))\n\n(defconst elcomp--c-numeric-comparisons '(> >= < <= =))\n\n(defun elcomp--c-numeric-comparison-p (function args bb)\n  (and (memq function elcomp--c-numeric-comparisons)\n       (> (length args) 1)\n       (cl-every (lambda (arg)\n\t\t   (let ((type (elcomp--look-up-type bb arg)))\n\t\t     (or (eq type 'integer)\n\t\t\t (eq type 'float))))\n\t\t args)))\n\n(defun elcomp--c-numeric-comparison (function args eltoc bb)\n  (let* ((operator (if (eq function '=)\n\t\t       \"==\"\n\t\t     (symbol-name function)))\n\t (unwrapper (lambda (arg)\n\t\t      (if (elcomp--constant-p arg)\n\t\t\t  (insert (format \"%s\" (elcomp--value arg)))\n\t\t\t(insert\n\t\t\t (if (eq (elcomp--look-up-type bb arg) 'integer)\n\t\t\t     \"XINT\"\n\t\t\t   \"XFLOAT_DATA\")\n\t\t\t \" (\")\n\t\t\t(elcomp--c-emit-symref eltoc arg)\n\t\t\t(insert \")\"))))\n\t (prev (car args))\n\t (first t))\n    (insert \"(\")\n    (dolist (arg (cdr args))\n      (if first\n\t  (setf first nil)\n\t(insert \" && \"))\n      (funcall unwrapper prev)\n      (insert \" \" operator \" \")\n      (funcall unwrapper arg)\n      (setf prev arg))\n    (insert \") ? Qt : Qnil\")))\n\n(defun elcomp--c-unary-numeric-op-p (function args bb)\n  (and (memq function '(1+ 1- -))\n       (eq (length args) 1)\n       (cl-every (lambda (arg)\n\t\t   (let ((type (elcomp--look-up-type bb arg)))\n\t\t     (or (eq type 'integer)\n\t\t\t (eq type 'float))))\n\t\t args)))\n\n(defun elcomp--c-unary-numeric-op (function args eltoc bb)\n  (cl-assert (eq (length args) 1))\n  (let* ((arg (car args))\n\t (type (elcomp--look-up-type bb arg))\n\t (maker (if (eq type 'integer)\n\t\t    \"make_number\"\n\t\t  \"make_float\"))\n\t (unwrapper (if (eq type 'integer)\n\t\t    \"XINT\"\n\t\t    \"XFLOAT_DATA\")))\n    (cl-case function\n      ((1+)\n       (insert maker \" (\" unwrapper \" (\")\n       (elcomp--c-emit-symref eltoc arg)\n       (insert \") + 1)\"))\n      ((1-)\n       (insert maker \" (\" unwrapper \" (\")\n       (elcomp--c-emit-symref eltoc arg)\n       (insert \") - 1)\"))\n      ((-)\n       (insert maker \" (-\" unwrapper \" (\")\n       (elcomp--c-emit-symref eltoc arg)\n       (insert \"))\"))\n      (t\n       (error \"whoops %S\" function)))))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--call) eltoc bb)\n  (when (elcomp--sym insn)\n    (elcomp--c-emit-symref eltoc insn)\n    (insert \" = \"))\n  (cond\n   ((eq (elcomp--func insn) :elcomp-unbind)\n    (elcomp--unbind-emitter insn))\n\n   ((elcomp--c-numeric-comparison-p (elcomp--func insn) (elcomp--args insn) bb)\n    (elcomp--c-numeric-comparison (elcomp--func insn) (elcomp--args insn)\n\t\t\t\t  eltoc bb))\n\n   ((elcomp--c-unary-numeric-op-p (elcomp--func insn) (elcomp--args insn) bb)\n    (elcomp--c-unary-numeric-op (elcomp--func insn) (elcomp--args insn)\n\t\t\t\teltoc bb))\n\n   (t\n    (let* ((function\n\t    (or\t(elcomp--c-opt insn\n\t\t\t       (mapcar (lambda (arg)\n\t\t\t\t\t (elcomp--look-up-type bb arg))\n\t\t\t\t       (elcomp--args insn)))\n\t\t(elcomp--func insn)))\n\t   (arg-list (elcomp--args insn))\n\t   (is-direct (elcomp--func-direct-p function))\n\t   (is-vararg nil))\n      (cond\n       ((stringp function)\t     ; Was optimized by elcomp--c-opt.\n\t(insert function \" (\"))\n       ((keywordp function)\n\t(insert (or (cdr (assq function elcomp--c-direct-renames))\n\t\t    (format \"BUG«%S»\" function))\n\t\t\" (\")\n\t;; FIXME hack\n\t(when (memq function '(:catch-value :elcomp-fetch-condition\n\t\t\t\t\t    :unwind-protect-continue))\n\t  (insert \"&prev_handler\")))\n       (is-direct\n\t(if-let ((rename (assq function elcomp--c-renames)))\n\t    (insert (cdr rename) \" (\")\n\t  (insert \"F\" (elcomp--c-name function) \" (\"))\n\t(when (and (symbolp function)\n\t\t   (fboundp function)\n\t\t   (subrp (symbol-function function))\n\t\t   (eq (cdr (subr-arity (symbol-function function))) 'many))\n\t  (insert (format \"%d, ((Lisp_Object[]) { \" (length arg-list)))\n\t  (setf is-vararg t)))\n       (t\n\t(push function arg-list)\n\t;; FIXME - what if not a symbol, etc.\n\t(setf is-vararg t)\n\t(insert (format \"Ffuncall (%d, ((Lisp_Object[]) { \"\n\t\t\t(length arg-list)))))\n      (let ((first t))\n\t(dolist (arg arg-list)\n\t  (if first\n\t      (setf first nil)\n\t    (insert \", \"))\n\t  (elcomp--c-emit-symref eltoc arg)))\n      (if is-vararg\n\t  (insert \" }))\")\n\t(insert \")\"))))))\n\n(defun elcomp--c-set-phis-on-entry (eltoc this-bb target-bb)\n  (maphash\n   (lambda (_name phi)\n     (insert \"      \")\n     (elcomp--c-emit-symref eltoc phi)\n     (insert \" = \")\n     (cl-block done\n       ;; This algorithm sucks.\n       (let ((check-bb this-bb))\n\t (while t\n\t   (maphash\n\t    (lambda (arg _ignore)\n\t      (when (eq (gethash arg (elcomp--c-name-map eltoc)) check-bb)\n\t\t(elcomp--c-emit-symref eltoc arg)\n\t\t(cl-return-from done)))\n\t    (elcomp--args phi))\n\t   (when (eq check-bb\n\t\t     (elcomp--basic-block-immediate-dominator check-bb))\n\t     (cl-return-from done))\n\t   (setf check-bb\n\t\t (elcomp--basic-block-immediate-dominator check-bb)))))\n     (insert \";\\n\"))\n   (elcomp--basic-block-phis target-bb)))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--goto) eltoc bb)\n  (elcomp--c-set-phis-on-entry eltoc bb (elcomp--block insn))\n  (insert \"  goto \")\n  (elcomp--c-emit-label (elcomp--block insn)))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--if) eltoc bb)\n  (insert \"if (!NILP (\")\n  (elcomp--c-emit-symref eltoc (elcomp--sym insn))\n  (insert \"))\\n\")\n  (insert \"    {\\n\")\n  (elcomp--c-set-phis-on-entry eltoc bb (elcomp--block-true insn))\n  (insert \"      goto \")\n  (elcomp--c-emit-label (elcomp--block-true insn))\n  (insert \";\\n\")\n  (insert \"    }\\n\")\n  (insert \"  else\\n\")\n  (insert \"    {\\n\")\n  (elcomp--c-set-phis-on-entry eltoc bb (elcomp--block-false insn))\n  (insert \"      goto \")\n  (elcomp--c-emit-label (elcomp--block-false insn))\n  (insert \";\\n\")\n  (insert \"    }\"))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--return) eltoc _bb)\n  (insert \"return \")\n  (elcomp--c-emit-symref eltoc (elcomp--sym insn)))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--catch) eltoc _bb)\n  (let ((name (elcomp--c-declare-handler eltoc)))\n    (insert \"  \" name \" = push_handler (\")\n    (elcomp--c-emit-symref eltoc (elcomp--tag insn))\n    (insert \", CATCHER);\\n\")\n    (insert \"  if (sys_setjmp (\" name \"->jmp))\\n\")\n    (insert \"    {\\n\")\n    (insert \"      eassert (handlerlist == \" name \");\\n\")\n    (insert \"      exit_exception_handler ();\\n\")\n    (insert \"      goto \")\n    (elcomp--c-emit-label (elcomp--handler insn))\n    (insert \";\\n\")\n    (insert \"    }\\n\")))\n\n(cl-defmethod elcomp--c-emit ((_insn elcomp--condition-case) _eltoc _bb)\n  ;; This one is handled specially for efficiency.\n  (error \"should not be called\"))\n\n(cl-defmethod elcomp--c-emit ((insn elcomp--unwind-protect) eltoc _bb)\n  (let ((name (elcomp--c-declare-handler eltoc)))\n    ;; Emacs doesn't actually have anything for this yet.\n    (insert \"  \" name \" = push_handler (Qnil, CATCHER_ALL);\\n\")\n    (insert \"  if (sys_setjmp (\" name \"->jmp))\\n\")\n    (insert \"    {\\n\")\n    (insert \"      eassert (handlerlist == \" name \");\\n\")\n    (insert \"      exit_exception_handler ();\\n\")\n    (insert \"      goto \")\n    (elcomp--c-emit-label (elcomp--handler insn))\n    (insert \";\\n\")\n    (insert \"    }\\n\")))\n\n(cl-defmethod elcomp--c-emit ((_insn elcomp--fake-unwind-protect) _eltoc _bb)\n  ;; Nothing.\n  )\n\n(defun elcomp--c-emit-condition-case (eltoc eh-from eh-to)\n  (let ((name (elcomp--c-declare-handler eltoc)))\n    ;; The magic Qt means to stop on all conditions; see\n    ;; eval.c:find_handler_clause.\n    (insert \"  \" name \" = push_handler (Qt, CONDITION_CASE);\\n\")\n    (insert \"  if (sys_setjmp (\" name \"->jmp))\\n\")\n    (insert \"    {\\n\")\n    (insert \"      eassert (handlerlist == \" name \");\\n\")\n    (insert \"      exit_exception_handler ();\\n\")\n    (while (and (not (eq eh-from eh-to))\n\t\t(elcomp--condition-case-p (car eh-from)))\n      (insert \"      if (!NILP (find_handler_clause (\")\n      (elcomp--c-emit-symref eltoc (elcomp--condition-name (car eh-from)))\n      (insert \", signal_conditions (&prev_handler))))\\n\")\n      (insert \"        goto \")\n      (elcomp--c-emit-label (elcomp--handler (car eh-from)))\n      (insert \";\\n\")\n      (setf eh-from (cdr eh-from)))\n    (insert \"    }\\n\"))\n  eh-from)\n\n(defun elcomp--c-first-parent (block)\n  (elcomp--any-hash-key (elcomp--basic-block-parents block)))\n\n(defun elcomp--c-emit-exceptions (eltoc block)\n  (let* ((first-parent (elcomp--c-first-parent block))\n\t (parent-eh (if first-parent\n\t\t\t(elcomp--basic-block-exceptions first-parent)\n\t\t      ;; No parent means it is the first block.\n\t\t      nil)))\n    (let ((bb-eh (elcomp--basic-block-exceptions block)))\n      (when (and (not (or (memq (car bb-eh) parent-eh)\n\t\t\t  (and parent-eh (not bb-eh))))\n\t\t bb-eh)\n\t;; If our first exception does not appear in the parent\n\t;; list, then we have to push at least one.\n\t(while (and bb-eh (not (eq bb-eh parent-eh)))\n\t  (if (elcomp--condition-case-p (car bb-eh))\n\t      (setf bb-eh (elcomp--c-emit-condition-case eltoc bb-eh\n\t\t\t\t\t\t\t parent-eh))\n\t    (elcomp--c-emit (car bb-eh) eltoc block)\n\t    (setf bb-eh (cdr bb-eh))))))))\n\n(defun elcomp--c-emit-block (eltoc bb)\n  (elcomp--c-emit-label bb)\n  (insert \":\\n\")\n  (elcomp--c-emit-exceptions eltoc bb)\n  (dolist (insn (elcomp--basic-block-code bb))\n    (insert \"  \")\n    (elcomp--c-emit insn eltoc bb)\n    (insert \";\\n\")))\n\n(defun elcomp--c-parse-args (arg-list)\n  (let ((min-args 0))\n    (while (and arg-list (not (memq (car arg-list) '(&optional &rest))))\n      (pop arg-list)\n      (cl-incf min-args))\n    (let ((max-args min-args))\n      (while (eq (car arg-list) '&optional)\n\t(pop arg-list)\n\t(pop arg-list)\n\t(cl-incf max-args))\n      (if (or (eq (car arg-list) '&rest)\n\t      (> max-args elcomp--c-max-args))\n\t  (cons min-args \"MANY\")\n\t(cons min-args max-args)))))\n\n(defun elcomp--c-generate-defun (compiler)\n  (let* ((info (elcomp--defun compiler))\n\t (sym (elcomp--get-name compiler))\n\t (c-name (elcomp--c-name sym))\n\t (arg-info (elcomp--c-parse-args (cadr info))))\n    (insert\n     (format \"DEFUN (%s, F%s, S%s, %s, %s,\\n    %s,\\n    doc: /* %s */)\\n\"\n\t     (elcomp--c-quote-string (symbol-name sym))\n\t     c-name c-name\n\t     (car arg-info) (cdr arg-info)\n\t     ;; Interactive.\n\t     ;; FIXME: quoting for the interactive spec\n\t     ;; Note that we can have a whole lisp form here.\n\t     (or (nth 3 info) \"0\")\n\t     ;; Doc string.  FIXME - comment quoting\n\t     (or (nth 2 info) \"nothing??\"))) ;FIXME anything?\n    (if (equal (cdr arg-info) \"MANY\")\n\t(let ((nargs (elcomp--c-name (cl-gensym \"nargs\")))\n\t      (args (elcomp--c-name (cl-gensym \"args\"))))\n\t  (insert \"  (ptrdiff_t \" nargs \", Lisp_Object *\" args \")\\n{\\n\")\n\t  ;; We need special parsing for &rest arguments or when the\n\t  ;; number of format arguments is greater than the maximum.\n\t  ;; First emit the declarations.\n\t  (dolist (arg (cadr info))\n\t    (unless (memq arg '(&optional &rest))\n\t      (insert \"  Lisp_Object \" (symbol-name arg) \" = Qnil;\\n\")))\n\t  ;; Now initialize each one.\n\t  (let ((is-rest nil))\n\t    (dolist (arg (cadr info))\n\t      (cond\n\t       ((eq arg '&rest)\n\t\t(setf is-rest t))\n\t       ((eq arg '&optional)\n\t\t;; Nothing.\n\t\t)\n\t       (t\n\t\t(if is-rest\n\t\t    (insert \"  \" (symbol-name arg) \" = Flist (\"\n\t\t\t    nargs \", \" args \");\\n\")\n\t\t  (insert \"  if (\" nargs \" > 0)\\n\"\n\t\t\t  \"    {\\n\"\n\t\t\t  \"      \" (symbol-name arg) \" = *\" args \"++;\\n\"\n\t\t\t  \"      --\" nargs \";\\n\"\n\t\t\t  \"    }\\n\")))))))\n      (insert \"  (\")\n      (let ((first t))\n\t(dolist (arg (cadr info))\n\t  (unless (eq arg '&optional)\n\t    (unless first\n\t      (insert \", \"))\n\t    (setf first nil)\n\t    (insert \"Lisp_Object \" (symbol-name arg)))))\n      (insert \")\\n{\\n\"))))\n\n(defun elcomp--c-translate-one (compiler symbol-hash)\n  (elcomp--require-back-edges compiler)\n  (elcomp--compute-dominators compiler)\n  (let ((eltoc (make-elcomp--c :decls (make-hash-table)\n\t\t\t       :decl-marker (make-marker)\n\t\t\t       :interned-symbols symbol-hash\n\t\t\t       :name-map (elcomp--make-name-map compiler))))\n    (elcomp--c-generate-defun compiler)\n    ;; This approach is pretty hacky.\n    (insert \"  struct handler prev_handler;\\n\")\n    (set-marker (elcomp--c-decl-marker eltoc) (point))\n    (insert \"\\n\")\n    (set-marker-insertion-type (elcomp--c-decl-marker eltoc) t)\n    (elcomp--iterate-over-bbs compiler\n\t\t\t      (lambda (bb)\n\t\t\t\t(elcomp--c-emit-block eltoc bb)))\n    (insert \"}\\n\\n\")\n    (set-marker (elcomp--c-decl-marker eltoc) nil)))\n\n;; If BASE-FILENAME is nil, a module-like file is generated.  (But of\n;; course this doesn't work since modules use a JNI-like thing.)\n;; Otherwise, the generated code looks more like the Emacs internals.\n(defun elcomp--c-translate (unit &optional base-filename)\n  (let ((symbol-hash (make-hash-table)))\n    (maphash\n     (lambda (_ignore compiler)\n       (elcomp--c-translate-one compiler symbol-hash))\n     (elcomp--compilation-unit-defuns unit))\n    ;; Define the symbol variables.\n    (save-excursion\n      (goto-char (point-min))\n      (insert \"#include <config.h>\\n\"\n\t      \"#include <lisp.h>\\n\\n\"\n\t      ;; FIXME this is less efficient than it could be.\n\t      ;; We only need a couple of fields from this.\n\t      \"#define exit_exception_handler() (prev_handler = *handlerlist, handlerlist = handlerlist->next)\\n\"\n\t      \"#define pop_exception_handler() handlerlist = handlerlist->next\\n\"\n\t      \"#define catch_value(H) ((H)->val)\\n\"\n\t      \"#define signal_conditions(H) (XCAR ((H)->val))\\n\"\n\t      \"#define signal_value(H) (XCDR ((H)->val))\\n\\n\")\n      (unless base-filename\n\t(insert \"int plugin_is_GPL_compatible;\\n\\n\"))\n      (maphash (lambda (_symbol c-name)\n\t\t (insert \"static Lisp_Object \" c-name \";\\n\"))\n\t       symbol-hash)\n      (insert \"\\n\")\n\n      ;; Create \"K\" values that are are tagged SUBR values for all the\n      ;; functions.\n      (maphash\n       (lambda (_ignore compiler)\n\t (let ((name (elcomp--get-name compiler)))\n\t   (insert \"static Lisp_Object K\" (elcomp--c-name name) \";\\n\")))\n       (elcomp--compilation-unit-defuns unit))\n      (insert \"\\n\"))\n    (insert \"\\n\"\n\t    \"void\\n\"\n\t    (if base-filename\n\t\t(concat \"syms_of_\" base-filename)\n\t      \"init\")\n\t    \" (void)\\n{\\n\")\n    ;; Intern all the symbols we refer to.\n    (maphash (lambda (symbol c-name)\n\t       (insert \"  \" c-name \" = intern_c_string (\" \n\t\t       (elcomp--c-quote-string (symbol-name symbol))\n\t\t       \");\\n\")\n\t       (insert \"  staticpro (&\" c-name \");\\n\"))\n\t     symbol-hash)\n    (insert \"\\n\")\n    ;; Register our exported functions with Lisp.\n    (maphash\n     (lambda (_ignore compiler)\n       (let ((name (car (elcomp--defun compiler))))\n\t (if name\n\t     (insert \"  defsubr (&S\" (elcomp--c-name name) \");\\n\")\n\t   (insert \"  XSETPVECTYPE (&S\"\n\t\t   (symbol-name (elcomp--get-name compiler))\n\t\t   \", PVEC_SUBR);\\n\"))\n\t (insert \"  XSETSUBR (K\" (elcomp--c-name (elcomp--get-name compiler))\n\t\t \", &S\" (elcomp--c-name (elcomp--get-name compiler))\n\t\t \");\\n\")))\n     (elcomp--compilation-unit-defuns unit))\n    (insert \"}\\n\")))\n\n(provide 'elcomp/eltoc)\n\n;;; eltoc.el ends here\n"
  },
  {
    "path": "elcomp/ffi.el",
    "content": "\n;; FIXME this should probably instead find a way to compile LIBRARY to\n;; a function-scoped static.\n(defun elcomp--define-ffi-library (symbol name)\n  (let ((library (cl-gensym)))\n    `(defun ,symbol ()\n       ;; FIXME this is lame but until we handle defvar properly...\n       (unless (boundp ',library)\n\t ;; FIXME this really ought to be some low-level type anyhow.\n\t (setq ,library (ffi--dlopen ,name))))))\n\n(defconst elcomp--ffi-type-map\n  '((:int8 . integer)\n    (:uint8 . integer)\n    (:int16 . integer)\n    (:uint16 . integer)\n    (:int32 . integer)\n    (:uint32 . integer)\n    (:int64 . integer)\n    (:uint64 . integer)\n    (:float . float)\n    (:double . float)\n    (:uchar . integer)\n    (:schar . integer)\n    (:char . integer)\n    (:ushort . integer)\n    (:short . integer)\n    (:uint . integer)\n    (:int . integer)\n    (:ulong . integer)\n    (:long . integer)\n    (:ulonglong . integer)\n    (:longlong . integer)\n    (:size_t . integer)\n    (:ssize_t . integer)\n    (:ptrdiff_t . integer)\n    (:wchar_t . integer)\n    (:bool . boolean)\n    ;; :pointer - but it doesn't really matter that one is missing\n    ;; here.\n    ))\n\n(defun elcomp--define-ffi-function (name c-name return-type arg-types library)\n  (let* ((arg-names (mapcar (lambda (_ignore) (cl-gensym)) arg-types))\n\t (type-checks (cl-mapcar\n\t\t(lambda (arg type)\n\t\t  `(cl-check-type ,arg\n\t\t\t\t  ,(cdr (assq type elcomp--ffi-type-map))))\n\t\targ-names arg-types))\n\t (func-pointer (cl-gensym)))\n    ;; FIXME this is kind of lying about the return type for :bool\n    (elcomp-declare name :elcomp-type\n\t\t    (cdr (assq return-type elcomp--ffi-type-map)))\n    ;; FIXME if we had a lower-level type system, then we could inline\n    ;; this when we have type information and eliminate checks.\n    `(defun ,name ,arg-names\n       ;; FIXME another lameness until we can handle defvar and make a\n       ;; function- or file-scoped static.\n       (unless (boundp ',func-pointer)\n\t ;; FIXME this really ought to be some low-level type anyhow.\n\t (setq ,func-pointer (ffi--dlsym ,c-name (,library))))\n       ,@type-checks\n       (:ffi-call ,func-pointer ,@arg-names))))\n\n(defun elcomp--use-ffi ()\n  (push '(define-ffi-library . elcomp--define-ffi-library) elcomp--compiler-macros)\n  (push '(define-ffi-function . elcomp--define-ffi-function) elcomp--compiler-macros))\n"
  },
  {
    "path": "elcomp/iter.el",
    "content": ";;; iter.el --- iterate over blocks.  -*- lexical-binding:t -*-\n\n;;; Code:\n\n(require 'elcomp)\n\n(defun elcomp--do-iterate (hash callback bb postorder)\n  (unless (gethash bb hash)\n    (puthash bb t hash)\n    (unless postorder\n      (funcall callback bb))\n    (let ((obj (elcomp--last-instruction bb)))\n      (cond\n       ;; FIXME why is the -child- variant needed here?\n       ((elcomp--goto-p obj)\n\t(elcomp--do-iterate hash callback (elcomp--block obj) postorder))\n       ((elcomp--if-p obj)\n\t(elcomp--do-iterate hash callback (elcomp--block-true obj) postorder)\n\t(elcomp--do-iterate hash callback (elcomp--block-false obj) postorder))))\n    (dolist (exception (elcomp--basic-block-exceptions bb))\n      (when (elcomp--handler exception)\n\t(elcomp--do-iterate hash callback (elcomp--handler exception)\n\t\t\t    postorder)))\n    (when postorder\n      (funcall callback bb))))\n\n(defun elcomp--iterate-over-bbs (compiler callback &optional postorder)\n  (elcomp--do-iterate (make-hash-table) callback\n\t\t      (elcomp--entry-block compiler)\n\t\t      postorder))\n\n(defun elcomp--postorder (compiler)\n  \"Return a list of basic blocks from COMPILER, in postorder.\"\n  (let ((result))\n    (elcomp--iterate-over-bbs compiler (lambda (bb)\n\t\t\t\t\t (push bb result))\n\t\t\t      t)\n    (nreverse result)))\n\n(defun elcomp--reverse-postorder (compiler)\n  \"Return a list of basic blocks from COMPILER, in reverse postorder.\"\n  (nreverse (elcomp--postorder compiler)))\n\n(provide 'elcomp/iter)\n\n;;; iter.el ends here\n"
  },
  {
    "path": "elcomp/jump-thread.el",
    "content": ";;; Jump-threading pass. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This implements a simple jump-threading pass.  See the doc string\n;; of elcomp--thread-jumps-pass for details.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/back)\n(require 'elcomp/linearize)\n\n(defun elcomp--get-not-argument (insn)\n  \"Check if INSN uses a 'not' condition.\n\nINSN is an 'if' instruction.  If the condition was defined by a\ncall to 'not' (or 'null'), return the argument to the 'not'.\nOtherwise return nil.\"\n  (let ((call (elcomp--sym insn)))\n    (if (and (elcomp--call-p call)\n\t     (memq (elcomp--func call) '(not null)))\n\t(car (elcomp--args call)))))\n\n(defun elcomp--constant-nil-p (cst)\n  \"Return t if CST is an `elcomp--constant' whose value is nil.\"\n  (and (elcomp--constant-p cst)\n       (eq (elcomp--value cst) nil)))\n\n(defun elcomp--get-eq-argument (insn)\n  \"Check if INSN uses an `eq' condition.\n\nINSN is an `if' instruction.  If the condition is of the\nform `(eq V nil)' or `(eq nil V)', return V.  Otherwise return\nnil.\"\n  (cl-assert (elcomp--if-p insn))\n  (let ((call (elcomp--sym insn)))\n    (if (and (elcomp--call-p call)\n\t     (memq (elcomp--func call) '(eq equal)))\n\t(let ((args (elcomp--args call)))\n\t  (cond\n\t   ((elcomp--constant-nil-p (car args))\n\t    (cadr args))\n\t   ((elcomp--constant-nil-p (cadr args))\n\t    (car args))\n\t   (t nil))))))\n\n(defun elcomp--peel-condition (insn)\n  \"Peel `not' and other obviously unnecessary calls from INSN.\nINSN is the variable used by an `if'.\"\n  (let ((changed-one t))\n    (while changed-one\n      (setf changed-one nil)\n      ;; Peel a 'not'.\n      (let ((arg-to-not (elcomp--get-not-argument insn)))\n\t(when arg-to-not\n\t  (setf changed-one t)\n\t  (cl-rotatef (elcomp--block-true insn)\n\t\t      (elcomp--block-false insn))\n\t  (setf (elcomp--sym insn) arg-to-not)))\n      ;; Change (eq V nil) or (eq nil V) to plain V.\n      (let ((arg-to-eq (elcomp--get-eq-argument insn)))\n\t(when arg-to-eq\n\t  (setf changed-one t)\n\t  (setf (elcomp--sym insn) arg-to-eq))))))\n\n(defun elcomp--block-has-catch (block tag)\n  \"If the block has a `catch' exception handler, return it.\nOtherwise return nil.\nTAG is a constant that must be matched by the handler.\"\n  (cl-dolist (exception (elcomp--basic-block-exceptions block))\n    (cond\n     ((elcomp--catch-p exception)\n      (if (elcomp--constant-p (elcomp--tag exception))\n\t  (if (equal tag (elcomp--tag exception))\n\t      (cl-return exception)\n\t    ;; The tag is a different constant, so we can ignore\n\t    ;; this one and keep going.\n\t    nil)\n\t;; Non-constant tag could match anything.\n\t(cl-return nil)))\n     ((elcomp--fake-unwind-protect-p exception)\n      ;; Keep going; we can handle these properly.\n      )\n     ((elcomp--condition-case-p exception)\n      ;; Keep going; we can ignore these.\n      )\n     ;; This requires re-linearizing the unwind-protect\n     ;; original-form.  However we can't do this at present because\n     ;; we've already lost information about the variable\n     ;; remappings.  Perhaps it would be simpler to just go directly\n     ;; into SSA when linearizing?\n     ;; ((elcomp--unwind-protect-p exception)\n     ;; \t;; Keep going.\n     ;; \t)\n     (t\n      (cl-return nil)))))\n\n(defun elcomp--get-catch-symbol (exception)\n  \"Given a `catch' exception object, return the symbol holding the `throw' value.\"\n  (cl-assert (elcomp--catch-p exception))\n  (let ((insn (car (elcomp--basic-block-code (elcomp--handler exception)))))\n    (cl-assert (elcomp--call-p insn))\n    (cl-assert (eq (elcomp--func insn) :catch-value))\n    (elcomp--sym insn)))\n\n(defun elcomp--get-catch-target (exception)\n  \"Given a `catch' exception object, return the basic block of the `catch' itself.\"\n  (cl-assert (elcomp--catch-p exception))\n  (let ((insn (cadr (elcomp--basic-block-code (elcomp--handler exception)))))\n    (cl-assert (elcomp--goto-p insn))\n    (elcomp--block insn)))\n\n(defun elcomp--maybe-replace-catch (block insn)\n  ;; A `throw' with a constant tag can be transformed into an\n  ;; assignment and a GOTO when the current block's outermost handler\n  ;; is a `catch' of the same tag.\n  (when (and (elcomp--diediedie-p insn)\n\t     (eq (elcomp--func insn) 'throw)\n\t     ;; Argument to throw is a const.\n\t     (elcomp--constant-p\n\t      (car (elcomp--args insn))))\n    (let ((exception (elcomp--block-has-catch block\n\t\t\t\t\t      (car (elcomp--args insn)))))\n      (when exception\n\t;; Whew.  First drop the last instruction from the block.\n\t(setf (elcomp--basic-block-code block)\n\t      (nbutlast (elcomp--basic-block-code block) 1))\n\t(setf (elcomp--basic-block-code-link block)\n\t      (last (elcomp--basic-block-code block)))\n\t;; Emit `unbind' calls.  (Note that when we can handle real\n\t;; unwind-protects we will re-linearize those here as well.)\n\t(let ((iter (elcomp--basic-block-exceptions block)))\n\t  (while (not (elcomp--catch-p (car iter)))\n\t    (when (elcomp--fake-unwind-protect-p (car iter))\n\t      (elcomp--add-to-basic-block\n\t       block\n\t       (elcomp--call :sym nil\n\t\t\t     :func :elcomp-unbind\n\t\t\t     :args (list\n\t\t\t\t    (elcomp--constant :value\n\t\t\t\t\t\t      (elcomp--count\n\t\t\t\t\t\t       (car iter)))))))\n\t    (setf iter (cdr iter))))\n\t;; Now add an instruction with an assignment and a goto, and\n\t;; zap the `diediedie' instruction.\n\t(elcomp--add-to-basic-block\n\t block\n\t (elcomp--set :sym (elcomp--get-catch-symbol exception)\n\t\t      :value (cadr (elcomp--args insn))))\n\t(elcomp--add-to-basic-block\n\t block\n\t (elcomp--goto :block (elcomp--get-catch-target exception)))\n\tt))))\n\n(defun elcomp--thread-jumps-pass (compiler in-ssa-form)\n  \"A pass to perform jump threading on COMPILER.\n\nThis pass simplifies the CFG by eliminating redundant jumps.  In\nparticular, it:\n\n* Converts redundant gotos like\n       GOTO A;\n    A: GOTO B;\n  =>\n       GOTO B;\n\n* Likewise for either branch of an IF:\n        IF E A; else B;\n     A: GOTO C;\n  =>\n        IF E C; else B;\n\n* Converts a redundant IF into a GOTO:\n        IF E A; else A;\n  =>\n        GOTO A\n\n* Threads jumps that have the same condition:\n        IF E A; else B;\n     A: IF E C; else D;\n  =>\n        IF E C; else B;\n  This happens for either branch of an IF.\n\n* Eliminates dependencies on 'not':\n        E = (not X)\n        if E A; else B;\n  =>\n        if X B; else A;\n  Note that this leaves the computation of E in the code.  This may\n  be eliminated later by DCE.\n\n* Similarly, removes (eq X nil) or (eq nil X)\n\n* Converts IF with a constant to a GOTO:\n        if <<nil>> A; else B;\n  =>\n        goto B;\n\n* Converts a `throw' to a `goto' when it is provably correct.\n  This can be done when the `catch' and the `throw' both have a\n  constant tag argument, and when there are no intervening\n  `unwind-protect' calls (this latter restriction could be lifted\n  with some more work).\n\nNote that nothing here explicitly removes blocks.  This is not\nneeded because the only links to blocks are the various branches;\nwhen a block is not needed it will be reclaimed by the garbage\ncollector.\"\n  (let ((rewrote-one t))\n    (while rewrote-one\n      (setf rewrote-one nil)\n      (elcomp--iterate-over-bbs\n       compiler\n       (lambda (block)\n\t (let ((insn (elcomp--last-instruction block)))\n\t   ;; See if we can turn a `throw' into a `goto'.  This only\n\t   ;; works when not in SSA form, because it reuses variable\n\t   ;; names from the `catch' handler.\n\t   (unless in-ssa-form\n\t     (when (elcomp--maybe-replace-catch block insn)\n\t       (setf rewrote-one t)))\n\t   ;; A GOTO to a block holding just another branch (of any kind)\n\t   ;; can be replaced by the instruction at the target.\n\t   ;; FIXME In SSA mode we would have to deal with the phis.\n\t   (when (and (not in-ssa-form)\n\t\t      (elcomp--goto-p insn)\n\t\t      ;; Exclude a self-goto.\n\t\t      (not (eq block\n\t\t\t       (elcomp--block insn)))\n\t\t      (elcomp--nonreturn-terminator-p\n\t\t       (elcomp--first-instruction (elcomp--block insn))))\n\t     ;; Note we also set INSN for subsequent optimizations\n\t     ;; here.\n\t     (setf insn (elcomp--first-instruction (elcomp--block insn)))\n\t     (setf (elcomp--last-instruction block) insn)\n\t     (setf rewrote-one t))\n\n\t   ;; If a target of an IF is a GOTO, the destination can be\n\t   ;; hoisted.\n\t   (when (and (elcomp--if-p insn)\n\t\t      (elcomp--goto-p (elcomp--first-instruction\n\t\t\t\t       (elcomp--block-true insn))))\n\t     (setf (elcomp--block-true insn)\n\t\t   (elcomp--block\n\t\t    (elcomp--first-instruction (elcomp--block-true insn))))\n\t     (setf rewrote-one t))\n\t   (when (and (elcomp--if-p insn)\n\t\t      (elcomp--goto-p (elcomp--first-instruction\n\t\t\t\t\t     (elcomp--block-false insn))))\n\t     (setf (elcomp--block-false insn)\n\t\t   (elcomp--block\n\t\t    (elcomp--first-instruction (elcomp--block-false insn))))\n\t     (setf rewrote-one t))\n\n\t   ;; If both branches of an IF point to the same spot, turn\n\t   ;; it into a GOTO.\n\t   (when (and (elcomp--if-p insn)\n\t\t      (eq (elcomp--block-true insn)\n\t\t\t  (elcomp--block-false insn)))\n\t     (setf insn (elcomp--goto :block (elcomp--block-true insn)))\n\t     (setf (elcomp--last-instruction block) insn)\n\t     (setf rewrote-one t))\n\n\t   ;; If the condition for an IF was a call to 'not', then the\n\t   ;; call can be bypassed and the targets swapped.\n\t   (when (and in-ssa-form (elcomp--if-p insn))\n\t     (elcomp--peel-condition insn))\n\n\t   ;; If the argument to the IF is a constant, turn the IF\n\t   ;; into a GOTO.\n\t   (when (and in-ssa-form (elcomp--if-p insn))\n\t     (let ((condition (elcomp--sym insn)))\n\t       ;; FIXME could also check for calls known not to return\n\t       ;; nil.\n\t       (when (elcomp--constant-p condition)\n\t\t (let ((goto-block (if (elcomp--value condition)\n\t\t\t\t       (elcomp--block-true insn)\n\t\t\t\t     (elcomp--block-false insn))))\n\t\t   (setf insn (elcomp--goto :block goto-block))\n\t\t   (setf (elcomp--last-instruction block) insn)\n\t\t   (setf rewrote-one t)))))\n\n\t   ;; If a target of an IF is another IF, and the conditions are the\n\t   ;; same, then the target IF can be hoisted.\n\t   (when (elcomp--if-p insn)\n\t     ;; Thread the true branch.\n\t     (when (and (elcomp--if-p (elcomp--first-instruction\n\t\t\t\t\t     (elcomp--block-true insn)))\n\t\t\t(eq (elcomp--sym insn)\n\t\t\t    (elcomp--sym (elcomp--first-instruction\n\t\t\t\t\t  (elcomp--block-true insn)))))\n\t       (setf (elcomp--block-true insn)\n\t\t     (elcomp--block-true (elcomp--first-instruction\n\t\t\t\t\t  (elcomp--block-true insn)))))\n\t     ;; Thread the false branch.\n\t     (when (and (elcomp--if-p (elcomp--first-instruction\n\t\t\t\t\t     (elcomp--block-false insn)))\n\t\t\t(eq (elcomp--sym insn)\n\t\t\t    (elcomp--sym (elcomp--first-instruction\n\t\t\t\t\t  (elcomp--block-false insn)))))\n\t       (setf (elcomp--block-false insn)\n\t\t     (elcomp--block-false (elcomp--first-instruction\n\t\t\t\t\t   (elcomp--block-false insn)))))))))\n\n      (when rewrote-one\n\t(elcomp--invalidate-cfg compiler)))))\n\n(provide 'elcomp/jump-thread)\n\n;;; jump-thread.el ends here\n"
  },
  {
    "path": "elcomp/linearize.el",
    "content": ";;; linearize.el --- linearize lisp forms.  -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; Turn Emacs Lisp forms into compiler objects.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/props)\n\n(defun elcomp--push-fake-unwind-protect (compiler num)\n  (let* ((first-exception (car (elcomp--exceptions compiler)))\n\t (new-exception\n\t  (if (elcomp--fake-unwind-protect-p first-exception)\n\t      (progn\n\t\t(pop (elcomp--exceptions compiler))\n\t\t(elcomp--fake-unwind-protect\n\t\t :count (+ (elcomp--count first-exception) num)))\n\t    (elcomp--fake-unwind-protect :count num))))\n    (push new-exception (elcomp--exceptions compiler)))\n  (elcomp--make-block-current compiler (elcomp--label compiler)))\n\n(defun elcomp--pop-fake-unwind-protects (compiler num)\n  (let* ((first-exception (pop (elcomp--exceptions compiler))))\n    (cl-assert (elcomp--fake-unwind-protect-p first-exception))\n    (cl-assert (>= (elcomp--count first-exception) num))\n    (if (> (elcomp--count first-exception) num)\n\t(push (elcomp--fake-unwind-protect\n\t       :count (- (elcomp--count first-exception) num))\n\t      (elcomp--exceptions compiler))))\n  (elcomp--make-block-current compiler (elcomp--label compiler)))\n\n(defun elcomp--new-var (compiler &optional symname)\n  (let* ((cell (memq symname (elcomp--rewrite-alist compiler))))\n    (if cell\n\t(cl-gensym)\n      (or symname\n\t  (cl-gensym)))))\n\n(defun elcomp--rewrite-one-ref (compiler ref)\n  \"Rewrite REF.\nREF can be a symbol, in which case it is rewritten following\n`elcomp--rewrite-alist' and returned.\nOr REF can be a constant, in which case it is returned unchanged.\"\n  (cond\n   ((elcomp--constant-p ref)\n    ref)\n   ((special-variable-p ref)\n    (let ((var (elcomp--new-var compiler)))\n      (elcomp--add-call compiler var\n\t\t\t'symbol-value\n\t\t\t(list (elcomp--constant :value ref)))\n      var))\n   (t\n    (let ((tem (assq ref (elcomp--rewrite-alist compiler))))\n      (if tem\n\t  (cdr tem)\n\t;; If there is no rewrite for the name, then it is a global.\n\t(let ((var (elcomp--new-var compiler)))\n\t  (elcomp--add-call compiler var\n\t\t\t    'symbol-value\n\t\t\t    (list (elcomp--constant :value ref)))\n\t  var))))))\n\n(defun elcomp--label (compiler)\n  (prog1\n      (make-elcomp--basic-block :number (elcomp--next-label compiler)\n\t\t\t\t:exceptions (elcomp--exceptions compiler))\n    (cl-incf (elcomp--next-label compiler))))\n\n(defun elcomp--add-to-basic-block (block obj)\n  (let ((new-cell (cons obj nil)))\n    (if (elcomp--basic-block-code-link block)\n\t(setf (cdr (elcomp--basic-block-code-link block)) new-cell)\n      (setf (elcomp--basic-block-code block) new-cell))\n    (setf (elcomp--basic-block-code-link block) new-cell)))\n\n(defun elcomp--add-basic (compiler obj)\n  (elcomp--add-to-basic-block (elcomp--current-block compiler) obj))\n\n(defun elcomp--add-set (compiler sym value)\n  (elcomp--add-basic compiler (elcomp--set :sym sym :value value)))\n\n(defun elcomp--add-call (compiler sym func args)\n  (if (and (symbolp func)\n\t   (elcomp--func-noreturn-p func))\n      (progn\n\t;; Add the terminator instruction and push a new basic block\n\t;; -- this block will be discarded later, but that's ok.  Also\n\t;; discard the assignment.\n\t(elcomp--add-basic compiler\n\t\t\t   (elcomp--diediedie :sym nil :func func\n\t\t\t\t\t      :args args))\n\t(setf (elcomp--current-block compiler) (elcomp--label compiler)))\n    (elcomp--add-basic compiler (elcomp--call :sym sym :func func\n\t\t\t\t\t      :args args))))\n\n(defun elcomp--add-return (compiler sym)\n  (elcomp--add-basic compiler (elcomp--return :sym sym)))\n\n(defun elcomp--add-goto (compiler block)\n  (elcomp--add-basic compiler (elcomp--goto :block block))\n  ;; Push a new block.\n  (setf (elcomp--current-block compiler) (elcomp--label compiler)))\n\n(defun elcomp--add-if (compiler sym block-true block-false)\n  (cl-assert (or block-true block-false))\n  (let ((next-block))\n    (unless block-true\n      (setf block-true (elcomp--label compiler))\n      (setf next-block block-true))\n    (unless block-false\n      (setf block-false (elcomp--label compiler))\n      (setf next-block block-false))\n    (elcomp--add-basic compiler (elcomp--if :sym sym\n\t\t\t\t\t    :block-true block-true\n\t\t\t\t\t    :block-false block-false))\n    ;; Push a new block.\n    (setf (elcomp--current-block compiler) next-block)))\n\n(defun elcomp--variable-p (obj)\n  \"Return t if OBJ is a variable when linearizing.\nA variable is a symbol that is not a keyword.\"\n  (and (symbolp obj)\n       (not (keywordp obj))\n       (not (memq obj '(t nil)))))\n\n(defun elcomp--make-block-current (compiler block)\n  ;; Terminate the previous basic block.\n  (let ((insn (elcomp--last-instruction (elcomp--current-block compiler))))\n    (if (not (elcomp--terminator-p insn))\n\t(elcomp--add-basic compiler (elcomp--goto :block block)))\n    (setf (elcomp--current-block compiler) block)))\n\n(defun elcomp--linearize-body (compiler body result-location\n\t\t\t\t\t&optional result-index)\n  (let ((i 1))\n    (while body\n      (elcomp--linearize compiler (car body)\n\t\t\t (if (or (eq i result-index)\n\t\t\t\t (and (eq result-index nil)\n\t\t\t\t      (not (cdr body))))\n\t\t\t     result-location\n\t\t\t   nil))\n      (setf body (cdr body))\n      (cl-incf i))))\n\n;; (defun elcomp--handler-name (name)\n;;   (intern (concat \"elcomp--compiler--\" (symbol-name name))))\n\n;; (defmacro define-elcomp-handler (name arg-list &rest body)\n;;   `(defun ,(elcomp--handler-name name) arg-list body))\n\n(defun elcomp--operand (compiler form)\n  (cond\n   ((elcomp--variable-p form)\n    (elcomp--rewrite-one-ref compiler form))\n   ((atom form)\n    (elcomp--constant :value form))\n   ((eq (car form) 'quote)\n    (elcomp--constant :value (cadr form)))\n   (t\n    (let ((var (elcomp--new-var compiler)))\n      (elcomp--linearize compiler form var)\n      var))))\n\n(declare-function elcomp--plan-to-compile \"elcomp/toplevel\")\n\n(defun elcomp--linearize (compiler form result-location)\n  \"Linearize FORM and return the result.\n\nLinearization turns a form from an ordinary Lisp form into a\nsequence of objects.  FIXME ref the class docs\"\n  (if (atom form)\n      (if result-location\n\t  (elcomp--add-set compiler result-location\n\t\t\t   (elcomp--operand compiler form)))\n    (let ((fn (car form)))\n      (cond\n       ((eq fn 'quote)\n\t(if result-location\n\t    (elcomp--add-set compiler result-location\n\t\t\t     (elcomp--operand compiler form))))\n       ((eq 'lambda (car-safe fn))\n\t;; Shouldn't this use 'function?\n\t(error \"lambda not supported\"))\n       ((eq fn 'let)\n\t;; Arrange to reset the rewriting table outside the 'let'.\n\t(cl-letf (((elcomp--rewrite-alist compiler)\n\t\t   (elcomp--rewrite-alist compiler))\n\t\t  (let-symbols nil)\n\t\t  (spec-vars nil))\n\t  ;; Compute the values.\n\t  (dolist (sexp (cadr form))\n\t    (let* ((sym (if (symbolp sexp)\n\t\t\t    sexp\n\t\t\t  (car sexp)))\n\t\t   (sym-initializer (if (consp sexp)\n\t\t\t\t\t(cadr sexp)\n\t\t\t\t      nil))\n\t\t   (sym-result (elcomp--new-var compiler sym)))\n\t      ;; If there is a body, compute it.\n\t      (elcomp--linearize compiler sym-initializer sym-result)\n\t      (if (special-variable-p sym)\n\t\t  (push (cons sym sym-result) spec-vars)\n\t\t(push (cons sym sym-result) let-symbols))))\n\t  ;; Push the new values onto the rewrite list.\n\t  (setf (elcomp--rewrite-alist compiler)\n\t\t(nconc let-symbols (elcomp--rewrite-alist compiler)))\n\t  (when spec-vars\n\t    ;; Specbind all the special variables.\n\t    (dolist (spec-var spec-vars)\n\t      (elcomp--add-call compiler nil :elcomp-specbind\n\t\t\t\t(list\n\t\t\t\t (elcomp--constant :value (car spec-var))\n\t\t\t\t (cdr spec-var))))\n\t    (elcomp--push-fake-unwind-protect compiler (length spec-vars)))\n\t  ;; Now evaluate the body of the let.\n\t  (elcomp--linearize-body compiler (cddr form) result-location)\n\t  ;; And finally unbind.\n\t  (when spec-vars\n\t    (elcomp--pop-fake-unwind-protects compiler (length spec-vars))\n\t    (elcomp--add-call compiler nil :elcomp-unbind\n\t\t\t      (list\n\t\t\t       (elcomp--constant :value (length spec-vars)))))))\n\n       ((eq fn 'let*)\n\t;; Arrange to reset the rewriting table outside the 'let*'.\n\t(cl-letf (((elcomp--rewrite-alist compiler)\n\t\t   (elcomp--rewrite-alist compiler))\n\t\t  (num-specbinds 0))\n\t  ;; Compute the values.\n\t  (dolist (sexp (cadr form))\n\t    (let* ((sym (if (symbolp sexp)\n\t\t\t    sexp\n\t\t\t  (car sexp)))\n\t\t   (sym-initializer (if (consp sexp)\n\t\t\t\t\t(cadr sexp)\n\t\t\t\t      nil))\n\t\t   (sym-result (elcomp--new-var compiler sym)))\n\t      ;; If there is a body, compute it.\n\t      (elcomp--linearize compiler sym-initializer sym-result)\n\t      ;; Make it visible to subsequent blocks.\n\t      (if (special-variable-p sym)\n\t\t  (progn\n\t\t    (elcomp--add-call compiler nil :elcomp-specbind\n\t\t\t\t      (list\n\t\t\t\t       (elcomp--constant :value sym)\n\t\t\t\t       sym-result))\n\t\t    (elcomp--push-fake-unwind-protect compiler 1)\n\t\t    (cl-incf num-specbinds))\n\t\t(push (cons sym sym-result) (elcomp--rewrite-alist compiler)))))\n\t  ;; Evaluate the body of the let*.\n\t  (elcomp--linearize-body compiler (cddr form) result-location)\n\t  ;; And finally unbind.\n\t  (when (> num-specbinds 0)\n\t    (elcomp--pop-fake-unwind-protects compiler num-specbinds)\n\t    (elcomp--add-call compiler nil :elcomp-unbind\n\t\t\t      (list\n\t\t\t       (elcomp--constant :value num-specbinds))))))\n\n       ((eq fn 'setq-default)\n\t(setf form (cdr form))\n\t(while form\n\t  (let* ((sym (pop form))\n\t\t (val (pop form))\n\t\t ;; We store the last result but drop the others.\n\t\t (stored-variable (if form nil result-location))\n\t\t (intermediate (elcomp--new-var compiler)))\n\t    ;; This is translated straightforwardly as a call to\n\t    ;; `set-default'.\n\t    (elcomp--linearize compiler val intermediate)\n\t    (elcomp--add-call compiler stored-variable\n\t\t\t      'set-default\n\t\t\t      (list (elcomp--constant :value sym)\n\t\t\t\t    intermediate)))))\n\n       ((eq fn 'setq)\n\t(setf form (cdr form))\n\t(while form\n\t  (let* ((sym (pop form))\n\t\t (val (pop form))\n\t\t ;; We store the last `setq' but drop the results of\n\t\t ;; the rest.\n\t\t (stored-variable (if form nil result-location)))\n\t    (if (special-variable-p sym)\n\t\t(let ((intermediate (elcomp--new-var compiler)))\n\t\t  ;; A setq of a special variable is turned into a\n\t\t  ;; call to `set'.  Our \"set\" instruction is reserved\n\t\t  ;; for ordinary variables.\n\t\t  (elcomp--linearize compiler val intermediate)\n\t\t  (elcomp--add-call compiler stored-variable\n\t\t\t\t    'set\n\t\t\t\t    (list (elcomp--constant :value sym)\n\t\t\t\t\t  intermediate)))\n\t      ;; An ordinary `setq' is turned into a \"set\"\n\t      ;; instruction.\n\t      (let ((rewritten-sym (elcomp--rewrite-one-ref compiler sym)))\n\t\t(elcomp--linearize compiler val rewritten-sym)\n\t\t(when stored-variable\n\t\t  ;; Return the value.\n\t\t  (elcomp--add-set compiler stored-variable rewritten-sym)))))))\n\n       ((eq fn 'cond)\n\t(let ((label-done (elcomp--label compiler)))\n\t  (dolist (clause (cdr form))\n\t    (let ((this-cond-var (if (cdr clause)\n\t\t\t\t     (elcomp--new-var compiler)\n\t\t\t\t   result-location))\n\t\t  (next-label (elcomp--label compiler)))\n\t      ;; Emit the condition.\n\t      (elcomp--linearize compiler (car clause) this-cond-var)\n\t      ;; The test.\n\t      (elcomp--add-if compiler this-cond-var nil next-label)\n\t      ;; The body.\n\t      (if (cdr clause)\n\t\t  (elcomp--linearize-body compiler\n\t\t\t\t\t  (cdr clause) result-location))\n\t      ;; Done.  Cleaning up unnecessary labels happens in\n\t      ;; another pass, so we can be a bit lazy here.\n\t      (elcomp--add-goto compiler label-done)\n\t      (elcomp--make-block-current compiler next-label)))\n\t  ;; Emit a final case for the cond.  This will be optimized\n\t  ;; away as needed.\n\t  (when result-location\n\t    (elcomp--add-set compiler result-location\n\t\t\t     (elcomp--constant :value nil)))\n\t  (elcomp--make-block-current compiler label-done)))\n\n       ((memq fn '(progn inline))\n\t(elcomp--linearize-body compiler (cdr form) result-location))\n       ((eq fn 'prog1)\n\t(elcomp--linearize-body compiler (cdr form) result-location 1))\n       ((eq fn 'prog2)\n\t(elcomp--linearize-body compiler (cdr form) result-location 2))\n\n       ((eq fn 'while)\n\t(let ((label-top (elcomp--label compiler))\n\t      (label-done (elcomp--label compiler))\n\t      (cond-var (elcomp--new-var compiler)))\n\t  (if result-location\n\t      (elcomp--add-set compiler result-location\n\t\t\t       (elcomp--operand compiler nil)))\n\t  (elcomp--make-block-current compiler label-top)\n\t  ;; The condition expression and goto.\n\t  (elcomp--linearize compiler (cadr form) cond-var)\n\t  (elcomp--add-if compiler cond-var nil label-done)\n\t  ;; The body.\n\t  (elcomp--linearize-body compiler (cddr form) nil)\n\t  (elcomp--add-goto compiler label-top)\n\t  (elcomp--make-block-current compiler label-done)))\n\n       ((eq fn 'if)\n\t(let ((label-false (elcomp--label compiler))\n\t      (label-done (elcomp--label compiler))\n\t      (cond-var (elcomp--new-var compiler)))\n\t  ;; The condition expression and goto.\n\t  (elcomp--linearize compiler (cadr form) cond-var)\n\t  (elcomp--add-if compiler cond-var nil label-false)\n\t  ;; The true branch.\n\t  (elcomp--linearize compiler (cl-caddr form) result-location)\n\t  ;; The end of the true branch.\n\t  (elcomp--add-goto compiler label-done)\n\t  ;; The false branch.\n\t  (elcomp--make-block-current compiler label-false)\n\t  (if (cl-cdddr form)\n\t      (elcomp--linearize-body compiler (cl-cdddr form) result-location)\n\t    (when result-location\n\t      (elcomp--add-set compiler result-location\n\t\t\t       (elcomp--constant :value nil))))\n\t  ;; The end of the statement.\n\t  (elcomp--make-block-current compiler label-done)))\n\n       ((eq fn 'and)\n\t(let ((label-done (elcomp--label compiler)))\n\t  (dolist (condition (cdr form))\n\t    (let ((result-location (or result-location\n\t\t\t\t       (elcomp--new-var compiler))))\n\t      (elcomp--linearize compiler condition result-location)\n\t      ;; We don't need this \"if\" for the last iteration, and\n\t      ;; \"and\" in conditionals could be handled better -- but\n\t      ;; all this is fixed up by the optimizers.\n\t      (elcomp--add-if compiler result-location nil label-done)))\n\t  (elcomp--make-block-current compiler label-done)))\n\n       ((eq fn 'or)\n\t(let ((label-done (elcomp--label compiler)))\n\t  (dolist (condition (cdr form))\n\t    (let ((result-location (or result-location\n\t\t\t\t       (elcomp--new-var compiler))))\n\t      (elcomp--linearize compiler condition result-location)\n\t      (elcomp--add-if compiler result-location label-done nil)))\n\t  (elcomp--make-block-current compiler label-done)))\n\n       ((eq fn 'catch)\n\t(let* ((tag (elcomp--operand compiler (cadr form)))\n\t       (handler-label (elcomp--label compiler))\n\t       (done-label (elcomp--label compiler))\n\t       (exception (elcomp--catch :handler handler-label\n\t\t\t\t\t :tag tag)))\n\t  (push exception (elcomp--exceptions compiler))\n\t  ;; We need a new block because we have modified the\n\t  ;; exception handler list.\n\t  (elcomp--make-block-current compiler (elcomp--label compiler))\n\t  (elcomp--linearize-body compiler (cddr form) result-location)\n\t  ;; The catch doesn't cover the handler; but pop before the\n\t  ;; \"goto\" so the new block has the correct exception list.\n\t  (pop (elcomp--exceptions compiler))\n\t  ;; And make sure to pop the exception handler at runtime.\n\t  (elcomp--add-call compiler nil :pop-exception-handler nil)\n\t  (elcomp--add-goto compiler done-label)\n\t  (elcomp--make-block-current compiler handler-label)\n\t  ;; A magic call to get the value.\n\t  (elcomp--add-call compiler result-location :catch-value nil)\n\t  (elcomp--add-goto compiler done-label)\n\t  (elcomp--make-block-current compiler done-label)))\n\n       ((eq fn 'unwind-protect)\n\t(let ((handler-label (elcomp--label compiler))\n\t      (done-label (elcomp--label compiler))\n\t      (normal-label (elcomp--label compiler)))\n\t  (push (elcomp--unwind-protect :handler handler-label\n\t\t\t\t\t:original-form (cons 'progn\n\t\t\t\t\t\t\t     (cddr form)))\n\t\t(elcomp--exceptions compiler))\n\t  ;; We need a new block because we have modified the\n\t  ;; exception handler list.\n\t  (elcomp--make-block-current compiler (elcomp--label compiler))\n\t  (elcomp--linearize compiler (cadr form) result-location)\n\t  ;; The catch doesn't cover the handler; but pop before the\n\t  ;; \"goto\" so the new block has the correct exception list.\n\t  (pop (elcomp--exceptions compiler))\n\t  ;; And make sure to pop the exception handler at runtime.\n\t  (elcomp--add-call compiler nil :pop-exception-handler nil)\n\t  (elcomp--add-goto compiler normal-label)\n\t  (elcomp--make-block-current compiler normal-label)\n\t  ;; We double-linearize the handlers because this is simpler\n\t  ;; and usually better.\n\t  (elcomp--linearize-body compiler (cddr form)\n\t\t\t\t  (elcomp--new-var compiler))\n\t  (elcomp--add-goto compiler done-label)\n\t  (elcomp--make-block-current compiler handler-label)\n\t  ;; The second linearization.\n\t  (elcomp--linearize-body compiler (cddr form)\n\t\t\t\t  (elcomp--new-var compiler))\n\t  (elcomp--add-call compiler nil :unwind-protect-continue nil)\n\t  (elcomp--make-block-current compiler done-label)))\n\n       ((eq fn 'condition-case)\n\t(error \"somehow a condition-case made it through macro expansion\"))\n\n       ((eq fn :elcomp-condition-case)\n\t(let ((new-exceptions nil)\n\t      (body-label (elcomp--label compiler))\n\t      (done-label (elcomp--label compiler))\n\t      (saved-exceptions (elcomp--exceptions compiler)))\n\t  ;; We emit the handlers first because it is a bit simpler\n\t  ;; here, and it doesn't matter for the result.\n\t  (elcomp--add-goto compiler body-label)\n\t  (dolist (handler (cddr form))\n\t    (let ((this-label (elcomp--label compiler)))\n\t      (push (elcomp--condition-case :handler this-label\n\t\t\t\t\t    :condition-name (car handler))\n\t\t    new-exceptions)\n\t      (elcomp--make-block-current compiler this-label)\n\t      ;; Note that here we probably pretend that the handler\n\t      ;; block is surrounded by '(let ((var ...))...)'.  This\n\t      ;; is done by a compiler macro, which explains why\n\t      ;; there's no special handling here.\n\t      (elcomp--linearize-body compiler (cdr handler) result-location)\n\t      (elcomp--add-goto compiler done-label)))\n\t  ;; Careful with the ordering.\n\t  (setf new-exceptions (nreverse new-exceptions))\n\t  (dolist (exception new-exceptions)\n\t    (push exception (elcomp--exceptions compiler)))\n\t  ;; Update the body label's list of exceptions.\n\t  (setf (elcomp--basic-block-exceptions body-label)\n\t\t(elcomp--exceptions compiler))\n\t  (elcomp--make-block-current compiler body-label)\n\t  (elcomp--linearize compiler (cadr form) result-location)\n\t  ;; The catch doesn't cover the handler; but pop before the\n\t  ;; \"goto\" so the new block has the correct exception list.\n\t  (setf (elcomp--exceptions compiler) saved-exceptions)\n\t  ;; And make sure to pop the exception handler at runtime.\n\t  (elcomp--add-call compiler nil :pop-exception-handler nil)\n\t  (elcomp--add-goto compiler done-label)\n\t  (elcomp--make-block-current compiler done-label)))\n\n       ((eq fn 'interactive)\n\tnil)\n\n       ((eq fn 'function)\n\t(let ((the-function (cadr form)))\n\t  ;; For (function (lambda ...)), arrange to compile it and\n\t  ;; put use the new compiler object as the constant.\n\t  (when (listp (cadr form))\n\t    (setf the-function (elcomp--plan-to-compile (elcomp--unit compiler)\n\t\t\t\t\t\t\tthe-function)))\n\t  (when result-location\n\t    (elcomp--add-set compiler result-location\n\t\t\t     (elcomp--constant :value the-function)))))\n\n       ((not (symbolp fn))\n\t(error \"not supported: %S\" fn))\n\n       ((special-form-p (symbol-function fn))\n\t(error \"unhandled special form: %s\" (symbol-name fn)))\n\n       (t\n\t;; An ordinary function call.\n\t(let ((these-args\n\t       ;; Compute each argument.\n\t       (mapcar (lambda (arg) (elcomp--operand compiler arg))\n\t\t       (cdr form))))\n\t  ;; Make the call.\n\t  (elcomp--add-call compiler result-location fn these-args)))))))\n\n(defun elcomp--linearize-defun (compiler form result-location)\n  (let ((arg-list (cl-copy-list (cadr (elcomp--defun compiler)))))\n    (cl-delete-if (lambda (elt) (memq elt '(&rest &optional)))\n\t\t  arg-list)\n    ;; Let each argument map to itself.\n    (cl-letf (((elcomp--rewrite-alist compiler)\n\t       (mapcar (lambda (elt) (cons elt elt))\n\t\t       arg-list)))\n      (elcomp--linearize compiler form result-location))))\n\n(provide 'elcomp/linearize)\n\n;;; linearize.el ends here\n"
  },
  {
    "path": "elcomp/name-map.el",
    "content": ";;; name-map.el - Map names to  blocks. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This has some utility functions to construct a map that maps SSA\n;; names to their defining blocks.  This is only needed due to IR\n;; deficiencies and should probably be fixed a different way.\n\n;;; Code:\n\n(require 'elcomp)\n\n(cl-defgeneric elcomp--update-name-map (_insn _bb _map)\n  ;; Ignore most instructions.\n  nil)\n\n(cl-defmethod elcomp--update-name-map ((insn elcomp--set) bb map)\n  (puthash insn bb map))\n\n(cl-defmethod elcomp--update-name-map ((insn elcomp--call) bb map)\n  (when (elcomp--sym insn)\n    (puthash insn bb map)))\n\n(defun elcomp--make-name-map (compiler)\n  (let ((name-map (make-hash-table)))\n    (dolist (arg (elcomp--arguments compiler))\n      (puthash arg (elcomp--entry-block compiler) name-map))\n    (elcomp--iterate-over-bbs\n     compiler\n     (lambda (bb)\n       (maphash (lambda (_name phi) (puthash phi bb name-map))\n\t\t(elcomp--basic-block-phis bb))\n       (dolist (insn (elcomp--basic-block-code bb))\n\t (elcomp--update-name-map insn bb name-map))))\n    name-map))\n\n(provide 'elcomp/name-map)\n\n;;; name-map.el ends here\n"
  },
  {
    "path": "elcomp/props.el",
    "content": ";;; props.el --- Function properties. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This module has code to note properties of functions.  The\n;; properties in question are those which are of interest to the\n;; compiler, and which are considered immutable -- currently it is\n;; only possible for the compiler to handle properties of functions\n;; that the user cannot reasonably redefine.\n\n;; byte-compile-negated-op is not quite useful\n;; but the idea could be applied\n;; normalizing is valuable for generic optimizations\n\n;;; Code:\n\n(require 'elcomp)\n\n(defun elcomp-declare (func &rest props)\n  \"Apply PROPS, a plist of attributes, to FUNC, a symbol.\n\nDefined properties are:\n\n  :elcomp-const t|nil        If t, FUNC does not have side effects.\n                             This means a call to it can be removed if\n                             its return value is not used.\n  :elcomp-pure t|nil         Like :elcomp-const, but also does not\n                             refer to memory.\n  :elcomp-type TYPE          The return type of FUNC.\n  :elcomp-simple-numeric t|n If t, FUNC is a simple numeric function.  This\n                             means that it accepts a number of\n                             integer, marker, or float arguments,\n                             and that the type of the result\n                             follows the usual contagion rules.  Such a\n                             function can never return `nil'.\n  :elcomp-predicate TYPE     This function is a type predicate that\n                             tests for TYPE.\n  :elcomp-noreturn t|nil     If t, FUNC does not return normally.\n  :elcomp-nothrow t|nil      If t, FUNC cannot `throw' or `signal'.\n  :elcomp-direct t|nil       If t, generated C code can call this directly.\"\n  ;; add more?\n  ;; :malloc - allocates new object\n  ;; :commutative - then we could sort arguments somehow and\n  ;;         have more CSE opportunities\n  (while props\n    (put func (car props) (cadr props))\n    (setf props (cddr props))))\n\n(defun elcomp--func-const-p (func)\n  \"Return t if FUNC can be considered 'const'.\"\n  (or (elcomp--func-pure-p func)\n      (get func :elcomp-const)\n      (get func 'side-effect-free)))\n\n(defun elcomp--func-pure-p (func)\n  \"Return t if FUNC can be considered 'pure'.\"\n  (or (get func :elcomp-pure)\n      (get func 'pure)))\n\n(defun elcomp--func-type (func)\n  \"Return the type of FUNC, if known, or nil.\"\n  (get func :elcomp-type))\n\n(defun elcomp--func-simple-numeric-p (func)\n  \"Return t if FUNC can be considered 'simple-numeric'.\"\n  (get func :elcomp-simple-numeric))\n\n(defun elcomp--func-type-predicate (func)\n  \"If FUNC is a type predicate, return the corresponding type, else nil.\"\n  (get func :elcomp-predicate))\n\n(defun elcomp--func-noreturn-p (func)\n  \"Return t if FUNC can be considered 'noreturn'.\"\n  (get func :elcomp-noreturn))\n\n(defun elcomp--func-nothrow-p (func)\n  \"Return t if FUNC can be considered 'nothrow'.\"\n  (or (get func :elcomp-nothrow)\n      (eq (get func 'side-effect-free) 'error-free)))\n\n(defun elcomp--func-direct-p (func)\n  \"Return t if FUNC is `direct'-capable from C code.\n\nThis is used to limit how many direct calls are emitted.\nIndirect calls are generally preferable for `non-trivial'\nthings, so that advice continues to work.\"\n  (and (symbolp func)\n       (get func :elcomp-direct)\n       (subrp (symbol-function func))))\n\n(dolist (func '(+ - * / % 1+ 1- mod max min abs expt))\n  (elcomp-declare func :elcomp-const t :elcomp-simple-numeric t))\n\n(dolist (func '(isnan floatp integerp numberp natnump zerop = eql eq equal\n\t\t      /= < <= > >=))\n  (elcomp-declare func :elcomp-const t :elcomp-type 'boolean))\n\n(dolist (func '(ldexp copysign logb float truncate floor ceiling round\n\t\t      ffloor fceiling ftruncate fround\n\t\t      sin cos tan asin acos atan exp log\n\t\t      sqrt))\n  (elcomp-declare func :elcomp-const t :elcomp-type 'float :elcomp-direct t))\n\n(dolist (func '(lsh ash logand logior logxor lognot byteorder sxhash length))\n  (elcomp-declare func :elcomp-const t :elcomp-type 'integer :elcomp-direct t))\n\n(elcomp-declare 'cons :elcomp-type 'cons)\n(elcomp-declare 'list :elcomp-type 'list)\n(elcomp-declare 'make-list :elcomp-type 'list)\n(elcomp-declare 'vector :elcomp-type 'vector)\n(elcomp-declare 'vconcat :elcomp-type 'vector)\n(elcomp-declare 'make-vector :elcomp-type 'vector)\n(elcomp-declare 'string :elcomp-type 'string)\n(elcomp-declare 'make-string :elcomp-type 'string)\n(elcomp-declare 'make-hash-table :elcomp-type 'hash-table)\n(elcomp-declare 'intern :elcomp-type 'symbol)\n(elcomp-declare 'make-symbol :elcomp-type 'symbol)\n\n;; There are a few type predicates not on the list.  They could be\n;; added if needed.  See (elisp) Type Predicates.\n(dolist (iter '((atom . list)\n\t\t(arrayp . array)\n\t\t(bool-vector-p . bool-vector)\n\t\t(booleanp . boolean)\n\t\t(bufferp . buffer)\n\t\t(characterp . integer)\t; not clear if this is best\n\t\t(consp . cons)\n\t\t(floatp . float)\n\t\t(hash-table-p . hash-table)\n\t\t(integerp . integer)\n\t\t(listp . list)\n\t\t(markerp . marker)\n\t\t(sequencep . sequence)\n\t\t(stringp . string)\n\t\t(symbolp . symbol)\n\t\t(vectorp . vector)\n\t\t(wholenump . integer)))\n  (elcomp-declare (car iter)\n\t\t  :elcomp-predicate (cdr iter)\n\t\t  :elcomp-type 'boolean))\n\n(dolist (iter '(throw signal error user-error :unwind-protect-continue))\n  (elcomp-declare iter :elcomp-noreturn t))\n\n(dolist (iter '(car-safe cdr-safe sxhash))\n  (elcomp-declare iter :elcomp-nothrow t))\n\n(elcomp-declare :elcomp-fetch-condition :elcomp-const t)\n\n;; This first part of this list comes from the bytecode interpreter.\n;; Then there are some useful additions.  It's important not to add\n;; things here which the user might want to advise.\n(dolist (iter '(nth symbolp consp stringp listp eq memq not car cdr\n\t\t    cons list length aref aset symbol-value\n\t\t    symbol-function set fset get substring concat\n\t\t    1- 1+ = > < <= >= - + max min * point\n\t\t    goto-char insert point-max point-min char-after\n\t\t    following-char preceding-char current-column\n\t\t    indent-to eolp eobp bolp bobp current-buffer\n\t\t    set-buffer interactive-p forward-char forward-word\n\t\t    skip-chars-forward skip-chars-backward forward-line\n\t\t    char-syntax buffer-substring delete-region\n\t\t    narrow-to-region widen end-of-line\n\t\t    set-marker match-beginning match-end upcase\n\t\t    downcase string= string< equal nthcdr elt\n\t\t    member assq nreverse setcar setcdr car-safe cdr-safe\n\t\t    nconc / % numberp integerp\n\t\t    ;; These aren't from bytecode.c.\n\t\t    funcall apply sxhash))\n  (elcomp-declare iter :elcomp-direct t))\n\n(provide 'elcomp/props)\n\n;;; props.el ends here\n"
  },
  {
    "path": "elcomp/ssa.el",
    "content": ";;; ssa.el --- change to SSA form. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This is a simple and dumb approach to converting the function into\n;; SSA form.  In particular it inserts way too many phi nodes, relying\n;; on a later pass to prune them.\n\n;; I think it would be better to replace this with an algorithm using\n;; the dominance frontiers, though I haven't examined this too deeply.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/eh-cleanup)\n\n(defun elcomp--ssa-require-phis-for-block (_compiler bb)\n  \"Ensure that the `phis' slot for BB has been initialized.\"\n  (unless (elcomp--basic-block-phis bb)\n    (setf (elcomp--basic-block-phis bb) (make-hash-table))))\n\n(defun elcomp--ssa-new-name (symbol)\n  (cl-gensym (concat (symbol-name symbol) \"_\")))\n\n(defun elcomp--ssa-propagate (compiler to-block current-map)\n  \"Propagate name mappings for phi nodes.\n\nThis adds the name mappings in CURRENT-MAP to the incoming name\nmap of TO-BLOCK.  All this does is add the incoming mappings to\nthe existing phi nodes.\"\n  (elcomp--ssa-require-phis-for-block compiler to-block)\n  (let ((to-block-phis (elcomp--basic-block-phis to-block)))\n    (maphash\n     (lambda (name value)\n       (let ((phi (gethash name to-block-phis)))\n\t (unless phi\n\t   (setf phi (elcomp--phi ;; FIXME \"original-\" is a misnomer\n\t\t\t\t  :original-name (elcomp--ssa-new-name name)))\n\t   (puthash name phi to-block-phis))\n\t (puthash value t (elcomp--args phi))))\n     current-map)))\n\n(defun elcomp--ssa-note-lhs (insn current-map)\n  \"Note the left-hand side of an assignment.\n\nIf the left-hand-side of the assignment instruction INSN is\nnon-nil, then the instruction is added to CURRENT-MAP.\n\nReturns t if CURRENT-MAP was updated, or nil if not.\"\n  (let ((name (elcomp--sym insn)))\n    (if name\n\t(let ((new-name (elcomp--ssa-new-name name)))\n\t  (setf (elcomp--sym insn) new-name)\n\t  (puthash name insn current-map)\n\t  t)\n      nil)))\n\n(defsubst elcomp--ssa-rename-arg (arg current-map)\n  \"Rename ARG using CURRENT-MAP.\"\n  ;; FIXME - error if not found\n  (gethash arg current-map arg))\n\n(cl-defgeneric elcomp--ssa-rename (insn compiler current-map)\n  \"Update the instruction INSN to account for SSA renamings.\n\nOperands of INSN are looked up in CURRENT-MAP and replaced.  If\nINSN is an assignment, then the left-hand-side is also updated.\n\nThis returns t if CURRENT-MAP was modified by this renaming, and\nnil otherwise.\")\n\n(cl-defmethod elcomp--ssa-rename ((insn elcomp--set) _compiler current-map)\n  (setf (elcomp--value insn) (elcomp--ssa-rename-arg (elcomp--value insn)\n\t\t\t\t\t\t     current-map))\n  (elcomp--ssa-note-lhs insn current-map))\n\n(cl-defmethod elcomp--ssa-rename ((insn elcomp--call) _compiler current-map)\n  ;; FIXME the :func slot.\n  (let ((cell (elcomp--args insn)))\n    (while cell\n      (setf (car cell) (elcomp--ssa-rename-arg (car cell) current-map))\n      (setf cell (cdr cell))))\n  (elcomp--ssa-note-lhs insn current-map))\n\n(cl-defmethod elcomp--ssa-rename ((insn elcomp--goto) compiler current-map)\n  (elcomp--ssa-propagate compiler (elcomp--block insn) current-map)\n  nil)\n\n(cl-defmethod elcomp--ssa-rename ((insn elcomp--if) compiler current-map)\n  (setf (elcomp--sym insn) (elcomp--ssa-rename-arg (elcomp--sym insn)\n\t\t\t\t\t\t   current-map))\n  (elcomp--ssa-propagate compiler (elcomp--block-true insn) current-map)\n  (elcomp--ssa-propagate compiler (elcomp--block-false insn) current-map)\n  nil)\n\n(cl-defmethod elcomp--ssa-rename ((insn elcomp--return) _compiler current-map)\n  (setf (elcomp--sym insn) (elcomp--ssa-rename-arg (elcomp--sym insn)\n\t\t\t\t\t\t   current-map))\n  nil)\n\n(cl-defmethod elcomp--ssa-rename ((insn elcomp--return) _compiler current-map)\n  (setf (elcomp--sym insn) (elcomp--ssa-rename-arg (elcomp--sym insn)\n\t\t\t\t\t\t   current-map))\n  nil)\n\n(defun elcomp--topmost-exception (bb)\n  (cl-dolist (topmost-exception (elcomp--basic-block-exceptions bb))\n    (when (elcomp--handler topmost-exception)\n      (cl-return topmost-exception))))\n\n(defun elcomp--into-ssa-parse-args (compiler current-map)\n  (let ((arg-list (cadr (elcomp--defun compiler))))\n    (while arg-list\n      (let ((this-arg (pop arg-list))\n\t    (is-rest nil))\n\t(cond\n\t ((eq this-arg '&rest)\n\t  (setf is-rest t)\n\t  (setf this-arg (pop arg-list)))\n\t ((eq this-arg '&optional)\n\t  (setf this-arg (pop arg-list))))\n\t(let ((arg-obj (elcomp--argument :original-name this-arg\n\t\t\t\t\t :is-rest is-rest)))\n\t  (push arg-obj (elcomp--arguments compiler))\n\t  (puthash this-arg arg-obj current-map))))))\n\n(defun elcomp--block-into-ssa (compiler bb)\n  \"Convert a single basic block into SSA form.\"\n  (elcomp--ssa-require-phis-for-block compiler bb)\n  ;; FIXME how to handle renaming for catch edges with a built-in\n  ;; variable?  those variables are defined in that scope...\n  (let ((current-map (copy-hash-table (elcomp--basic-block-phis bb))))\n    ;; Set up the initial block with renamings of the arguments.\n    (when (eq bb (elcomp--entry-block compiler))\n      (elcomp--into-ssa-parse-args compiler current-map))\n    (let ((changed-since-exception t)\n\t  (topmost-exception (elcomp--topmost-exception bb)))\n      (dolist (insn (elcomp--basic-block-code bb))\n\t;; If this instruction can throw, and if there have been any\n\t;; changes since the last throwing instruction, then propagate\n\t;; any state changes to the exception handler.\n\t(when (and topmost-exception\n\t\t   changed-since-exception\n\t\t   (elcomp--can-throw insn))\n\t  (elcomp--ssa-propagate compiler (elcomp--handler topmost-exception)\n\t\t\t\t current-map)\n\t  (setf changed-since-exception nil))\n\t;; Rename the operands and also see whether the map has\n\t;; changed.\n\t(when (elcomp--ssa-rename insn compiler current-map)\n\t  (setf changed-since-exception t))))))\n\n(defun elcomp--into-ssa-pass (compiler)\n  \"A pass to convert the function in COMPILER into SSA form.\"\n  (dolist (bb (elcomp--reverse-postorder compiler))\n    (elcomp--block-into-ssa compiler bb)))\n\n(provide 'elcomp/ssa)\n\n;;; ssa.el ends here\n"
  },
  {
    "path": "elcomp/subst.el",
    "content": ";;; subst.el --- simple substitutions. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This is some utility code to rewrite SSA names in a compiler\n;; instance.  The caller provides a map and all the instructions are\n;; updated according to the map.\n\n;;; Code:\n\n(require 'elcomp)\n\n(cl-defgeneric elcomp--rewrite-insn (insn _map)\n  \"Rewrite INSN according to MAP.\n\nMAP is a hash table mapping old instructions to new ones.\n\nUnhandled cases call `error'.\"\n  (error \"unhandled case: %S\" insn))\n\n(cl-defmethod elcomp--rewrite-insn ((insn elcomp--set) map)\n  (let ((new-insn (gethash (elcomp--value insn) map)))\n    (when new-insn\n      (setf (elcomp--value insn) new-insn))))\n\n(cl-defmethod elcomp--rewrite-insn ((insn elcomp--call) map)\n  ;; FIXME: the :func slot?\n  (cl-mapl\n   (lambda (cell)\n     (let ((new-insn (gethash (car cell) map)))\n       (when new-insn\n\t (setf (car cell) new-insn))))\n   (elcomp--args insn)))\n\n(cl-defmethod elcomp--rewrite-insn ((_insn elcomp--goto) _map)\n  nil)\n\n(cl-defmethod elcomp--rewrite-insn ((insn elcomp--if) map)\n  (let ((new-insn (gethash (elcomp--sym insn) map)))\n    (when new-insn\n      (setf (elcomp--sym insn) new-insn))))\n\n(cl-defmethod elcomp--rewrite-insn ((insn elcomp--return) map)\n  (let ((new-insn (gethash (elcomp--sym insn) map)))\n    (when new-insn\n      (setf (elcomp--sym insn) new-insn))))\n\n(cl-defmethod elcomp--rewrite-insn ((insn elcomp--phi) map)\n  ;; Ugh.\n  (let ((new-hash (make-hash-table)))\n    (maphash\n     (lambda (phi _ignore)\n       (let ((subst (gethash phi map)))\n\t (puthash\n\t  ;; It never makes sense to propagate a constant into a phi.\n\t  (if (elcomp--constant-p subst)\n\t      phi\n\t    (or subst phi))\n\t  t new-hash)))\n     (elcomp--args insn))\n    (setf (elcomp--args insn) new-hash)))\n\n;; FIXME `elcomp--catch's :tag?\n\n(defun elcomp--rewrite-using-map (compiler map)\n  \"Rewrite all the instructions in COMPILER according to MAP.\n\nMAP is a hash table that maps old operands to new ones.\"\n  (elcomp--iterate-over-bbs\n   compiler\n   (lambda (bb)\n     (maphash (lambda (_ignore phi)\n\t\t(elcomp--rewrite-insn phi map))\n\t      (elcomp--basic-block-phis bb))\n     (dolist (insn (elcomp--basic-block-code bb))\n       (elcomp--rewrite-insn insn map)))))\n\n(provide 'elcomp/subst)\n\n;;; subst.el ends here\n"
  },
  {
    "path": "elcomp/toplevel.el",
    "content": ";;; toplevel.el --- compiler top level.  -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; Top level interface to compiler.\n\n;;; Code:\n\n(require 'elcomp/coalesce)\n(require 'elcomp/cmacros)\n(require 'elcomp/cprop)\n(require 'elcomp/dom)\n(require 'elcomp/eh-cleanup)\n(require 'elcomp/jump-thread)\n(require 'elcomp/ssa)\n(require 'elcomp/typeinf)\n(require 'bytecomp)\n\n(defun elcomp--extract-defun (compiler form)\n  (cond\n   ((eq (car form) 'defun)\n    (setf (elcomp--defun compiler)\n\t  (list (cadr form) (cl-caddr form)))\n    (setf form (cl-cdddr form)))\n   ((eq (car form) 'defalias)\n    (pcase form\n      ;; Lame but I couldn't find a way to get pcase to match the\n      ;; contents of the lambda as well.\n      (`(defalias (quote ,name) (function ,body))\n       (unless (eq (car body) 'lambda)\n\t (error \"defalias form missing lambda\"))\n       (setf (elcomp--defun compiler)\n\t     (list name (cadr body)))\n       (setf form (cddr body)))\n      (_ (error \"unrecognized defalias form\"))))\n   ((eq (car form) 'lambda)\n    (setf (elcomp--defun compiler)\n\t  (list nil (cadr form)))\n    (setf form (cddr form)))\n   (t\n    (error \"invalid form: currently only defalias, defun, lambda supported\")))\n\n  ;; The doc string.\n  (if (stringp (car form))\n      (progn\n\t(setf (elcomp--defun compiler)\n\t      (nconc (elcomp--defun compiler) (list (car form))))\n\t(setf form (cdr form)))\n    (setf (elcomp--defun compiler) (nconc (elcomp--defun compiler) nil)))\n  ;; Skip declarations.\n  (while (and (consp (car form))\n\t      (eq (caar form) 'declare))\n    (setf form (cdr form)))\n  ;; Interactive spec.\n  (if (and (consp (car form))\n\t   (eq (caar form) 'interactive))\n      (progn\n\t(setf (elcomp--defun compiler)\n\t      (nconc (elcomp--defun compiler) (list (cl-cadar form))))\n\t(setf form (cdr form)))\n    (setf (elcomp--defun compiler) (nconc (elcomp--defun compiler) nil)))\n  (cons 'progn form))\n\n(defun elcomp--optimize (compiler)\n  (elcomp--thread-jumps-pass compiler nil)\n  (elcomp--eh-cleanup-pass compiler)\n  (elcomp--coalesce-pass compiler)\n  (elcomp--into-ssa-pass compiler)\n  (elcomp--cprop-pass compiler)\n  (elcomp--thread-jumps-pass compiler t)\n  (elcomp--coalesce-pass compiler)\n  (elcomp--dce-pass compiler)\n  (elcomp--infer-types-pass compiler))\n\n;; See bug #18971.\n(defvar byte-compile-free-assignments)\n(defvar byte-compile-free-references)\n(defvar byte-compile--outbuffer)\n\n(defun elcomp--translate (unit compiler form)\n  (byte-compile-close-variables\n   (let* ((byte-compile-macro-environment\n\t   (append elcomp--compiler-macros\n\t\t   byte-compile-macro-environment))\n\t  (result-var (elcomp--new-var compiler)))\n     (setf form (macroexpand-all form byte-compile-macro-environment))\n     (setf (elcomp--unit compiler) unit)\n     (setf (elcomp--entry-block compiler) (elcomp--label compiler))\n     (setf (elcomp--current-block compiler) (elcomp--entry-block compiler))\n     (setf form (elcomp--extract-defun compiler form))\n     (elcomp--linearize-defun\n      compiler\n      (byte-optimize-form form)\n      result-var)\n     (elcomp--add-return compiler result-var)\n     (elcomp--optimize compiler))))\n\n(defun elcomp--translate-all (unit)\n  (while (elcomp--compilation-unit-work-list unit)\n    (let ((args (pop (elcomp--compilation-unit-work-list unit))))\n      (apply #'elcomp--translate unit args))))\n\n(defun elcomp--plan-to-compile (unit form)\n  \"Add FORM to the list of functions to be compiled by UNIT.\n\nFORM is a function definition.\nUNIT is a compilation unit object.\n\nThis returns the new compiler object.\"\n  (unless (gethash form (elcomp--compilation-unit-defuns unit))\n    (let ((compiler (make-elcomp)))\n      (puthash form compiler (elcomp--compilation-unit-defuns unit))\n      (push (list compiler form) (elcomp--compilation-unit-work-list unit))\n      compiler)))\n\n(declare-function elcomp--pp-unit \"elcomp/comp-debug\")\n\n(defun elcomp--do (form-or-forms &optional backend)\n  (unless backend\n    (setf backend #'elcomp--pp-unit))\n  (let ((buf (get-buffer-create \"*ELCOMP*\")))\n    (with-current-buffer buf\n      (erase-buffer)\n      ;; Use \"let*\" so we can hack debugging prints into the compiler\n      ;; and have them show up in the temporary buffer.\n      (let* ((standard-output buf)\n\t     (unit (make-elcomp--compilation-unit)))\n\t(if (memq (car form-or-forms) '(defun lambda))\n\t    (elcomp--plan-to-compile unit form-or-forms)\n\t  (dolist (form form-or-forms)\n\t    (elcomp--plan-to-compile unit form)))\n\t(elcomp--translate-all unit)\n\t(funcall backend unit))\n      (pop-to-buffer buf))))\n\n(provide 'elcomp/toplevel)\n\n;;; toplevel.el ends here\n"
  },
  {
    "path": "elcomp/typeinf.el",
    "content": ";;; typeinf.el --- Type inference code. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; The type inference pass attempts to assign types to SSA names.\n\n;; A type is just a symbol.  The symbols used are largely just those\n;; returned by `type-of', but there are a few differences.\n\n;; First, (type-of nil) and (type-of t) yield 'symbol, but we\n;; represent them as 'null and t.  It's nice to treat these specially\n;; as it enables some optimizations.\n\n;; We also recognize some \"merged\" types that won't ever be returned\n;; by `type-of'.  For instance, we have a 'boolean type, which\n;; corresponds to the booleanp predicate; a 'list type, which\n;; indicates either a cons or nil; and a 'number type.\n\n;; Types can be inferred in a few ways:\n\n;; 1. A constant's type is immediately known.\n;; 2. Some functions are annotated as returning a known type.\n;; 3. Some functions are annotated as being 'simple-numeric' functions,\n;;    and have special treatment.  See props.el.\n;; 4. Type predicates such as integerp are used to annotate\n;;    variables.  For example in:\n;;        (if (integerp x) (1+ x))\n;;    the type of 'x' in the '1+' expression is known to be 'integer.\n\n;; This one isn't implemented:\n;; 5. Type declarations can be used to annotate variables, e.g.:\n;;        (let ((x 0)) (declare (type integer i)) ...)\n;;    Note that these are not checked, so for argument checking it\n;;    is better to use cl-check-type, as its expansion falls under\n;;    case 4 above.\n\n;;; Code:\n\n(require 'elcomp)\n(require 'elcomp/coalesce)\n(require 'elcomp/dce)\n(require 'elcomp/jump-thread)\n(require 'elcomp/props)\n(require 'elcomp/subst)\n\n(cl-defstruct elcomp--typeinf\n  \"A structure that holds the data for a type-inference pass.\"\n  worklist)\n\n(defun elcomp--nullable-type-p (type)\n  \"Return t if value of type TYPE can be nil.\"\n  (memq type '(cons list symbol boolean :bottom)))\n\n(defun elcomp--sequence-type-p (type)\n  \"Return t if TYPE is a sequence type.\"\n  (memq type '(list cons null bool-vector char-table string\n\t\t    vector sequence)))\n\n(defun elcomp--numeric-type-p (type)\n  \"Return t if TYPE is a numeric type.\"\n  (memq type '(float integer marker number)))\n\n(defun elcomp--boolean-type-p (type)\n  \"Return t if TYPE is a boolean type.\"\n  (memq type '(null t boolean)))\n\n(defun elcomp--list-type-p (type)\n  \"Return t is TYPE is a list type.\"\n  (memq type '(null cons list)))\n\n(defun elcomp--merge-types (&rest types)\n  ;; Start with Top type.\n  (let ((result :top))\n    (dolist (type types)\n      (cond\n       ((eq result :top)\n\t;; Top + TYPE = TYPE.\n\t(setf result type))\n\n       ((eq type :top)\n\t;; TYPE + Top = TYPE.\n\t)\n\n       ((eq result :bottom)\n\t;; Nothing - already at bottom.\n\t)\n\n       ((eq type :bottom)\n\t(setf result :bottom))\n\n       ((eq result type)\n\t;; Already the same.\n\t)\n\n       ((and (elcomp--sequence-type-p result)\n\t     (elcomp--sequence-type-p type))\n\t(setf result 'sequence))\n\n       ((and (elcomp--numeric-type-p result)\n\t     (elcomp--numeric-type-p type))\n\t(setf result 'number))\n\n       ((and (elcomp--boolean-type-p result)\n\t     (elcomp--boolean-type-p type))\n\t;; does this even matter?\n\t(setf result 'boolean))\n\n       ((and (elcomp--list-type-p result)\n\t     (elcomp--list-type-p type))\n\t(setf result 'list))\n\n       (t\n\t;; Merging any two random types results in bottom.\n\t(setf result :bottom))))\n    result))\n\n(cl-defgeneric elcomp--compute-type (_obj _map)\n  \"Compute the type of OBJ in a basic block, given a type map.\n\nThe type is generally the result of `type-of'.\nHowever `:top' is used to represent the 'top' type,\n`:bottom' is used to represent the 'bottom' type,\nand `nil' is used to mean a typeless instruction.\"\n  ;; Default.\n  nil)\n\n(cl-defmethod elcomp--compute-type ((obj elcomp--constant) _map)\n  (let ((value (elcomp--value obj)))\n    (cl-case value\n      ;; nil has a type of its own.\n      ((nil) 'null)\n      ;; As does t.\n      ((t) t)\n      (t (type-of value)))))\n\n(cl-defmethod elcomp--compute-type ((obj elcomp--set) map)\n  (elcomp--find-type (elcomp--value obj) map))\n\n(defun elcomp--merge-math-types (arguments map)\n  ;; With no arguments we return integer:\n  ;; (type-of (+)) => integer.\n  (let ((result 'integer))\n    (dolist (arg arguments)\n      (let ((next-type (elcomp--find-type arg map)))\n\t(cond\n\t ((eq next-type :top)\n\t  ;; Nothing.\n\t  )\n\n\t ((eq result 'float)\n\t  ;; If we know we've seen a float, the result will be float.\n\t  )\n\n\t ;; Note here that this is true for even one argument.\n\t ;; (type-of (+ (point))) => integer\n\t ((and (memq result '(integer marker))\n\t       (memq next-type '(integer marker)))\n\t  (setf result 'integer))\n\n\t ((eq result next-type)\n\t  ;; Nothing.\n\t  )\n\n\t ((eq next-type 'float)\n\t  (setf result 'float))\n\n\t (t\n\t  ;; We know nothing.  We could be even smarter and arrange\n\t  ;; for type errors to be detected, and turn the current\n\t  ;; instruction into a `diediedie'.\n\t  (setf result 'number)))))\n\n    result))\n\n(cl-defmethod elcomp--compute-type ((obj elcomp--call) map)\n  (if (not (elcomp--sym obj))\n      ;; No symbol means no type.\n      nil\n    (let ((func (elcomp--func obj)))\n      (cond\n       ;; If the function has a defined type, use it.\n       ((elcomp--func-type func)\n\t(elcomp--func-type func))\n\n       ;; Handle simple numerics.\n       ((elcomp--func-simple-numeric-p func)\n\t(elcomp--merge-math-types (elcomp--args obj) map))\n\n       (t\n\t;; Nothing special.\n\t:bottom)))))\n\n(cl-defmethod elcomp--compute-type ((obj elcomp--phi) map)\n  (let ((arg-list nil))\n    (maphash (lambda (var _ignore)\n\t       ;; We treat phis specially: any input that isn't found\n\t       ;; is just defaulted to :top, except for arguments,\n\t       ;; which are :bottom.\n\t       (push (if (elcomp--argument-p var)\n\t\t\t :bottom\n\t\t       (gethash var map :top))\n\t\t     arg-list))\n\t     (elcomp--args obj))\n    (apply #'elcomp--merge-types arg-list)))\n\n(cl-defmethod elcomp--compute-type ((obj elcomp--argument) _map)\n  (if (elcomp--is-rest obj)\n      'list\n    :bottom))\n\n(defun elcomp--find-type (obj map)\n  (let ((value (gethash obj map)))\n    (unless value\n      (setf value (elcomp--compute-type obj map))\n      (when value\n\t(puthash obj value map)))\n    value))\n\n(defun elcomp--type-map-merge (bb from)\n  \"Merge type-map FROM into the type-map for basic block BB.\n\nReturn non-nil if any changes were made.\"\n  (if (elcomp--basic-block-type-map bb)\n      ;; Merge.\n      (let ((to-map (elcomp--basic-block-type-map bb))\n\t    (changed nil)\n\t    phi-set)\n\t;; First make a list of all the phis.  We don't update phis\n\t;; defined locally by direct propagation.  FIXME this is not\n\t;; super efficient.\n\t(maphash (lambda (_name phi) (push phi phi-set))\n\t\t (elcomp--basic-block-phis bb))\n\t(maphash\n\t (lambda (name type)\n\t   (when (not (memq name phi-set))\n\t     (let* ((to-type (gethash name to-map :top))\n\t\t    (merge-type (elcomp--merge-types to-type type)))\n\t       (unless (eq to-type merge-type)\n\t\t (puthash name merge-type to-map)\n\t\t (setf changed t)))))\n\t from)\n\tchanged)\n    ;; Else.\n    (setf (elcomp--basic-block-type-map bb) (copy-hash-table from))\n    t))\n\n(defun elcomp--type-map-propagate-one (infobj bb type-map)\n  (when (elcomp--type-map-merge bb type-map)\n    ;; Only push the BB if it isn't already on the work-list.\n    (unless (memq bb (elcomp--typeinf-worklist infobj))\n      (push bb (elcomp--typeinf-worklist infobj)))))\n\n(cl-defgeneric elcomp--type-map-propagate (_insn _infobj _type-map)\n  \"FIXME\"\n  nil)\n\n(cl-defmethod elcomp--type-map-propagate ((insn elcomp--goto) infobj type-map)\n  (elcomp--type-map-propagate-one infobj (elcomp--block insn) type-map))\n\n(defun elcomp--find-type-predicate (sym)\n  \"Return type tested by the statement INSN, or nil.\"\n  (when (elcomp--call-p sym)\n    (elcomp--func-type-predicate (elcomp--func sym))))\n\n(defun elcomp--pretend-eval-type-predicate (predicate-type arg-type)\n  (cl-assert (not (eq predicate-type :top)))\n  ;; (cl-assert (not (eq arg-type :top)))\n  (cond\n   ;; This is a \"shouldn't happen\", but it does happen when compiling\n   ;; plist-member.  FIXME.  My guess is this is due to not marking\n   ;; arguments as :bottom.\n   ((eq arg-type :top)\n    :both)\n\n   ((eq predicate-type arg-type)\n    t)\n\n   ((eq arg-type :bottom)\n    :both)\n\n   ((eq arg-type 'null)\n    (elcomp--nullable-type-p predicate-type))\n\n   ((and (eq arg-type t)\n\t (memq predicate-type '(boolean symbol)))\n    t)\n\n   ((and (eq predicate-type 'sequence)\n\t (elcomp--sequence-type-p arg-type))\n    t)\n\n   ((and (eq predicate-type 'number)\n\t (elcomp--numeric-type-p arg-type))\n    t)\n\n   ((and (eq predicate-type 'boolean)\n\t (elcomp--boolean-type-p arg-type))\n    t)\n\n   ((and (eq predicate-type 'list)\n\t (elcomp--list-type-p arg-type))\n    t)\n\n   (t\n    ;; Anything is compatible with :bottom.\n    (eq predicate-type :bottom))))\n\n(cl-defmethod elcomp--type-map-propagate ((insn elcomp--if) infobj type-map)\n  (let* ((sym (elcomp--sym insn))\n\t (predicated-type (elcomp--find-type-predicate sym))\n\t (predicate-arg (if predicated-type\n\t\t\t    (car (elcomp--args sym))\n\t\t\t  nil))\n\t ;; See whether the type predicate is known to be always true\n\t ;; or always false here.\n\t (branches (if predicated-type\n\t\t       (elcomp--pretend-eval-type-predicate\n\t\t\tpredicated-type\n\t\t\t(elcomp--find-type predicate-arg type-map))\n\t\t     :both)))\n\n    ;; Handle inferencing by pretending the variable has a certain\n    ;; type in the true branch.\n    (when (memq branches '(t :both))\n      (if predicated-type\n\t  (let ((predicate-arg (car (elcomp--args sym))))\n\t    (cl-letf (((gethash predicate-arg type-map) predicated-type))\n\t      (elcomp--type-map-propagate-one infobj (elcomp--block-true insn)\n\t\t\t\t\t      type-map)))\n\t(elcomp--type-map-propagate-one infobj (elcomp--block-true insn)\n\t\t\t\t\ttype-map)))\n\n    ;; In theory we could use an \"inverted type\" here, but my guess is\n    ;; that it isn't worthwhile.\n    (when (memq branches '(nil :both))\n      (elcomp--type-map-propagate-one infobj (elcomp--block-false insn)\n\t\t\t\t      type-map))))\n\n(defun elcomp--type-map-propagate-exception (infobj bb type-map)\n  (cl-dolist (exception (elcomp--basic-block-exceptions bb))\n    (cond\n     ((elcomp--fake-unwind-protect-p exception)\n      ;; Keep going.\n      )\n\n     (t\n      (elcomp--type-map-propagate-one infobj (elcomp--handler exception)\n\t\t\t\t      type-map)\n      (cl-return nil)))))\n\n(defun elcomp--infer-types-for-bb (bb infobj)\n  ;; Work on a local copy.  We're consing too much but it's for\n  ;; another day.\n  (let ((local-types (copy-hash-table (elcomp--basic-block-type-map bb))))\n    ;; Always reset the final map for the BB.\n    (setf (elcomp--basic-block-final-type-map bb) local-types)\n\n    ;; Compute the types for each phi node.\n    (maphash\n     (lambda (_ignore phi)\n       (elcomp--find-type phi local-types))\n     (elcomp--basic-block-phis bb))\n\n    ;; Compute the type for each statement.\n    (dolist (insn (elcomp--basic-block-code bb))\n      (elcomp--find-type insn local-types))\n\n    ;; Propagate the results and possibly add to the work list.\n    (elcomp--type-map-propagate (elcomp--last-instruction bb) infobj\n\t\t\t\tlocal-types)\n    (elcomp--type-map-propagate-exception infobj bb local-types)))\n\n(defun elcomp--look-up-type (bb var)\n  (if (elcomp--constant-p var)\n      (elcomp--compute-type var nil)\n    (when (elcomp--basic-block-final-type-map bb)\n      (gethash var (elcomp--basic-block-final-type-map bb)))))\n\n(defun elcomp--do-infer-types (compiler)\n  (let ((infobj (make-elcomp--typeinf)))\n    ;; Make sure the entry block has an initial type map.\n    (let ((entry-block (elcomp--entry-block compiler)))\n      (cl-assert (not (elcomp--basic-block-type-map entry-block)))\n      (setf (elcomp--basic-block-type-map entry-block) (make-hash-table))\n      (dolist (arg (elcomp--arguments compiler))\n\t(puthash arg :bottom (elcomp--basic-block-type-map entry-block)))\n      (push entry-block (elcomp--typeinf-worklist infobj)))\n    ;; Now keep inferring types until we're out of blocks.\n    ;; FIXME where do we store the final maps?\n    (while (elcomp--typeinf-worklist infobj)\n      (let ((bb (pop (elcomp--typeinf-worklist infobj))))\n\t(elcomp--infer-types-for-bb bb infobj)))))\n\n(defun elcomp--rewrite-type-predicates (compiler map)\n  \"Convert `if's to `goto's using type information.\n\nUpdate MAP with mappings from old to new instructions.\"\n  (elcomp--iterate-over-bbs\n   compiler\n   (lambda (bb)\n     (let ((iter (elcomp--basic-block-code bb)))\n       (while iter\n\t (let ((insn (car iter)))\n\t   (when (elcomp--call-p insn)\n\t     (let* ((predicated-type (elcomp--find-type-predicate insn))\n\t\t    (predicate-arg (if predicated-type\n\t\t\t\t       (car (elcomp--args insn))\n\t\t\t\t     nil))\n\t\t    (branches (if predicated-type\n\t\t\t\t  (elcomp--pretend-eval-type-predicate\n\t\t\t\t   predicated-type\n\t\t\t\t   (elcomp--look-up-type bb\n\t\t\t\t\t\t\t predicate-arg))\n\t\t\t\t:both)))\n\t       ;; When this is true we have a call to a type\n\t       ;; predicate, so we can replace it with a constant.\n\t       (unless (eq branches :both)\n\t\t (let ((new-insn\n\t\t\t(elcomp--set :sym (elcomp--sym insn)\n\t\t\t\t     :value\n\t\t\t\t     (elcomp--constant :value branches))))\n\t\t   (setf (car iter) new-insn)\n\t\t   (puthash insn new-insn map))))))\n\t (setf iter (cdr iter)))))))\n\n(defun elcomp--infer-types-pass (compiler)\n  (elcomp--do-infer-types compiler)\n  (let ((rewrite-map (make-hash-table)))\n    (elcomp--rewrite-type-predicates compiler rewrite-map)\n    (elcomp--rewrite-using-map compiler rewrite-map))\n  (elcomp--cprop-pass compiler)\n  (elcomp--thread-jumps-pass compiler t)\n  (elcomp--coalesce-pass compiler)\n  (elcomp--dce-pass compiler))\n\n(provide 'elcomp/typeinf)\n\n;;; typeinf.el ends here\n"
  },
  {
    "path": "elcomp.el",
    "content": ";;; elcomp.el - Compiler for Emacs Lisp. -*- lexical-binding:t -*-\n\n;;; Commentary:\n\n;; This holds basic definitions for the compiler.  Everything else is\n;; in the elcomp subdir.\n\n;;; Code:\n\n(require 'cl-macs)\n(require 'eieio)\n\n(cl-defstruct (elcomp (:conc-name elcomp--))\n  ;; An alist holding symbol rewrites.  The car of each element is a\n  ;; symbol in the original code.  The cdr is the symbol to which it\n  ;; is rewritten.\n  rewrite-alist\n  ;; Next label value.\n  (next-label 0) \n  ;; The entry block.\n  entry-block\n  ;; The current basic block.\n  current-block\n  ;; True if the back-edges in the CFG are considered valid.\n  ;; FIXME - deal with IDOM being invalid too\n  back-edges-valid\n  ;; The current list of exception handlers.\n  exceptions\n  ;; The current defun being compiled.\n  ;; This is a list (NAME ARGLIST DOC INTERACTIVE).\n  ;; NAME is nil for an anonymous function.\n  ;; FIXME this should just be separate slots of this struct.\n  defun\n  ;; The name of the defun, a symbol.  This must be computed using\n  ;; elcomp--get-name, as this is either set lazily from 'defun', or\n  ;; generated for lambdas.\n  name\n  ;; In SSA mode, a list of the argument objects representing the\n  ;; arguments to the defun.\n  arguments\n  ;; A back link to the compilation unit.  This is needed so we can\n  ;; push new functions into the compilation unit as we go.\n  unit)\n\n(cl-defstruct elcomp--compilation-unit\n  ;; A hash table mapping a cons (a defun or a lambda) to a compiler\n  ;; object.\n  (defuns (make-hash-table))\n  ;; The work-list.  This is separate from `defuns' for convenience.\n  work-list)\n\n(cl-defstruct elcomp--basic-block\n  ;; Block number.\n  number\n  ;; The code for this basic block.\n  code\n  ;; Last link of linearized code.\n  code-link\n  ;; A hash table holding back-links to parent nodes.\n  ;; Outgoing edges are represented directly by the last instruction\n  ;; in the code sequence.\n  parents\n  ;; The immediate dominator, or nil if not known.\n  immediate-dominator\n  ;; The list of exception handlers.\n  exceptions\n  ;; The phi nodes for this basic block.  This is a hash table whose\n  ;; keys are original variable names and whose values are phis.  This\n  ;; starts as nil and is initialized when converting to SSA form.\n  phis\n  ;; Final type map for this BB.\n  final-type-map\n  ;; Entry type map for this BB.  This is not needed after type\n  ;; inferencing.  FIXME store on the side.\n  type-map)\n\n(defclass elcomp--set nil\n  ((sym :initform nil :initarg :sym\n\t:accessor elcomp--sym\n\t:documentation \"The local variable being assigned to.\nInitially this is a symbol.\nAfter transformation to SSA, this will be an SSA name;\nsee `elcomp--ssa-name-p'.\")\n   (value :initform nil :initarg :value\n\t  :accessor elcomp--value\n\t  :documentation \"The value being assigned.\nInitially this is a symbol.\nAfter transformation to SSA, this will be an SSA name.\"))\n  \"A `set' instruction.\n\nThis represents a simple assignment to a local variable.\")\n\n(defclass elcomp--call nil\n  ((sym :initform nil :initarg :sym\n\t:accessor elcomp--sym\n\t:documentation \"The local variable being assigned to.\nThis can be `nil' if the result of the call is not used.\nInitially this is a symbol.\nAfter transformation to SSA, this will be an SSA name;\nsee `elcomp--ssa-name-p'.\")\n   (func :initform nil :initarg :func\n\t :accessor elcomp--func\n\t :documentation \"The function to call.\nThis may be a symbol or a `lambda' list.\")\n   (args :initform nil :initarg :args\n\t :accessor elcomp--args\n\t ;; FIXME - can a symbol wind up in here or do we make\n\t ;; symbol-value explicit?\n\t :documentation \"The arguments to the function.\nInitially this is a list of symbols.\nAfter transformation to SSA, this will be a list of SSA names.\"))\n  \"A function call instruction.\")\n\n(defclass elcomp--goto nil\n  ((block :initform nil :initarg :block\n\t  :accessor elcomp--block\n\t  :documentation \"The target block.\"))\n  \"A `goto' instruction.\nThis instruction terminates a block.\")\n\n(defclass elcomp--if nil\n  ((sym :initform nil :initarg :sym\n\t:accessor elcomp--sym\n\t:documentation \"The condition to check.\nInitially this is a symbol.\nAfter transformation to SSA, this will be an SSA name;\nsee `elcomp--ssa-name-p'.\")\n   (block-true :initform nil :initarg :block-true\n\t       :accessor elcomp--block-true\n\t       :documentation \"The target block if the value is non-`nil'.\")\n   (block-false :initform nil :initarg :block-false\n\t\t:accessor elcomp--block-false\n\t\t:documentation \"The target block if the value is `nil'.\"))\n  \"An `if' instruction.\nThis branches to one of two blocks based on whether or not the\nargument is `nil'.  This instruction terminates a block.\")\n\n\n(defclass elcomp--return nil\n  ((sym :initform nil :initarg :sym\n\t:accessor elcomp--sym\n\t:documentation \"The value to return.\nInitially this is a symbol.\nAfter transformation to SSA, this will be an SSA name;\nsee `elcomp--ssa-name-p'.\"))\n  \"A `return' instruction.\")\n\n(defclass elcomp--diediedie (elcomp--call)\n  ()\n  \"An instruction which terminates a basic block without leading anywhere.\n\nThis can only be for a call to a `nothrow' function.\")\n\n(defclass elcomp--constant nil\n  ((value :initform nil :initarg :value\n\t  :accessor elcomp--value\n\t  :documentation \"The value of the constant.\"))\n  \"This represents a constant after transformation to SSA form.\")\n\n(defclass elcomp--phi nil\n  ((original-name :initform nil :initarg :original-name\n\t\t  :accessor elcomp--original-name\n\t\t  :documentation \"The original name of this node.\nThis is handy for debugging.\")\n   (args :initform (make-hash-table) :initarg :args\n\t :accessor elcomp--args\n\t :documentation \"Arguments to this node.\nThis is a hash table whose keys are possible source values for the phi.\nThe values in the hash table are meaningless.\"))\n  \"A `phi' node.\n\nSee any good source of information about SSA to understand this.\")\n\n(defclass elcomp--argument nil\n  ((original-name :initform nil :initarg :original-name\n\t\t  :accessor elcomp--original-name\n\t\t  :documentation \"The original name of this node.\nThis is handy for debugging.\")\n   (is-rest :initform nil :initarg :is-rest\n\t    :accessor elcomp--is-rest\n\t    :documentation \"True if this argument was from `&rest'.\"))\n  \"A function argument.  This is only used in SSA form.\")\n\n(defclass elcomp--exception nil\n  ((handler :initform nil :initarg :handler\n\t    :accessor elcomp--handler\n\t    :documentation \"The target block of this exception edge.\"))\n  \"An exception edge.\n\nA block's `exceptions' slot is a list of all the active exception\nhandlers, though in most cases only the first one is ever\ntaken.\")\n\n(defclass elcomp--catch (elcomp--exception)\n  ((tag :initform nil :initarg :tag\n\t:accessor elcomp--tag\n\t:documentation \"The tag of the `catch'.\"))\n  \"An exception edge representing a `catch'.\")\n\n(defclass elcomp--condition-case (elcomp--exception)\n  ((condition-name :initform nil :initarg :condition-name\n\t\t   :accessor elcomp--condition-name\n\t\t   :documentation \"The name of the condition being handled.\n\nThis is either a symbol or nil.  Note that the variable that can\nbe bound by `condition-case' is explicit in the target block.\"))\n  \"An exception edge representing a single `condition-case' handler.\")\n\n(defclass elcomp--unwind-protect (elcomp--exception)\n  ;; The original form is used when optimizing \"catch\".\n  ;; Well.. it will be someday.  FIXME.\n  ((original-form :initform nil :initarg :original-form\n\t\t  :documentation \"The original form.\nThis is not used now but may be later for `catch' optimization.\"))\n  \"An exception edge representing an `unwind-protect'.\")\n\n;; A fake unwind-protect that is used to represent the unbind\n;; operation from a `let' of a special variable.  This is needed to\n;; properly deal with `catch' optimization from inside a `let', like:\n;; (catch 'x (let* ((var1 (something)) (var2 (throw 'x 99))) ...))\n;; Here, the `throw' has to unbind \"var1\".\n(defclass elcomp--fake-unwind-protect (elcomp--exception)\n  ((count :initform nil :initarg :count\n\t  :accessor elcomp--count\n\t  :documentation \"The number of unbinds that this represents.\"))\n  \"An exception edge representing the unbind operation from a `let'\nof a special variable.  These unbinds are done implicitly, so this\nexception edge does not represent any ordinary code -- but it is needed\nto properly deal do the `catch' optimization from inside a `let', like:\n\n    (catch 'x (let* ((var1 (something)) (var2 (throw 'x 99))) ...))\n\nHere, the `throw' has to unbind `var1'.\")\n\n(defun elcomp--ssa-name-p (arg)\n  \"Return t if ARG is an SSA name.\"\n  (or\n   (elcomp--set-p arg)\n   (elcomp--phi-p arg)\n   (elcomp--call-p arg)\n   (elcomp--argument-p arg)))\n\n(defun elcomp--last-instruction (block)\n  \"Return the last instruction in BLOCK.\n\nThis can be used with `setf'.\"\n  (car (elcomp--basic-block-code-link block)))\n\n(gv-define-setter elcomp--last-instruction (val block)\n  `(setcar (elcomp--basic-block-code-link ,block) ,val))\n\n(defun elcomp--first-instruction (block)\n  \"Return the first instruction in BLOCK.\n\nThis can be used with `setf'.\"\n  (car (elcomp--basic-block-code block)))\n\n(gv-define-setter elcomp--first-instruction (val block)\n  `(setcar (elcomp--basic-block-code ,block) ,val))\n\n(defun elcomp--nonreturn-terminator-p (obj)\n  \"Return t if OBJ is a block-terminating instruction other than\n`return' or `diediedie'.\"\n  (or (elcomp--goto-p obj)\n      (elcomp--if-p obj)))\n\n(defun elcomp--terminator-p (obj)\n  \"Return t if OBJ terminates a block.\"\n  (or (elcomp--goto-p obj)\n      (elcomp--if-p obj)\n      (elcomp--return-p obj)\n      (elcomp--diediedie-p obj)))\n\n(cl-defun elcomp--any-hash-key (hash)\n  \"Return any key of the hash table HASH, or nil.\"\n  (maphash (lambda (key _ignore) (cl-return-from elcomp--any-hash-key key))\n\t   hash))\n\n(defun elcomp--get-name (elcomp)\n  \"Get the name of the function represented by ELCOMP.\"\n  (unless (elcomp--name elcomp)\n    (setf (elcomp--name elcomp)\n\t  (if (car (elcomp--defun elcomp))\n\t      (car (elcomp--defun elcomp))\n\t    (cl-gensym \"__lambda\"))))\n  (elcomp--name elcomp))\n\n(provide 'elcomp)\n\n;;; elcomp.el ends here\n"
  },
  {
    "path": "fns.el",
    "content": "(defvar autoload-queue)\n\n(defun identity (arg)\n  \"Return the argument unchanged.\"\n  arg)\n\n(defun copy-alist (alist)\n  \"Return a copy of ALIST.\nThis is an alist which represents the same mapping from objects to objects,\nbut does not share the alist structure with ALIST.\nThe objects mapped (cars and cdrs of elements of the alist)\nare shared, however.\nElements of ALIST that are not conses are also shared.\"\n  (cl-check-type alist list)\n  (cl-loop for elt in alist\n\t   collect (if (consp elt)\n\t\t       (cons (car elt) (cdr elt))\n\t\t     elt)))\n\n(defun nthcdr (num list)\n  (cl-check-type num integer)\n  (let ((i 0))\n    (while (and (< i num) list)\n      (setq list (cdr list))\n      (setq i (1+ i)))\n    list))\n\n(defun nth (n list)\n  \"Return the Nth element of LIST.\nN counts from zero.  If LIST is not that long, nil is returned.\"\n  (car (nthcdr n list)))\n\n(defun elt (sequence n)\n  (cl-check-type n integer)\n  (if (listp sequence)\n      (car (nthcdr n sequence))\n    (aref sequence n)))\n\n(defun member (elt list)\n  \"Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.\nThe value is actually the tail of LIST whose car is ELT.\"\n  (let ((tail list)\n\t(result nil))\n    (while (and (not result) (consp tail))\n      (let ((tem (car tail)))\n\t(when (equal elt tem)\n\t  (setq result elt))))\n    result))\n\n(defun memq (elt list)\n  \"Return non-nil if ELT is an element of LIST.  Comparison done with `eq'.\nThe value is actually the tail of LIST whose car is ELT.\"\n  (let ((tail list)\n\t(result nil))\n    (while (and (not result) (consp tail))\n      (let ((tem (car tail)))\n\t(when (eq elt tem)\n\t  (setq result elt))))\n    result))\n\n(defun memql (elt list)\n  \"Return non-nil if ELT is an element of LIST.  Comparison done with `eql'.\nThe value is actually the tail of LIST whose car is ELT.\"\n  (let ((tail list)\n\t(result nil))\n    (while (and (not result) (consp tail))\n      (let ((tem (car tail)))\n\t(when (eql elt tem)\n\t  (setq result elt))))\n    result))\n\n(defun assq (key list)\n  \"Return non-nil if KEY is `eq' to the car of an element of LIST.\nThe value is actually the first element of LIST whose car is KEY.\nElements of LIST that are not conses are ignored.\"\n  (let ((keep-going t))\n    (while (and keep-going (consp list))\n      (if (and (consp (car list))\n\t       (eq (car (car list)) key))\n\t  (setq keep-going nil)\n\t(setq list (cdr list)))))\n  (car list))\n\n(defun assoc (key list)\n  \"Return non-nil if KEY is `equal' to the car of an element of LIST.\nThe value is actually the first element of LIST whose car is KEY.\"\n  (let ((keep-going t))\n    (while (and keep-going (consp list))\n      (if (and (consp (car list))\n\t       (equal (car (car list)) key))\n\t  (setq keep-going nil)\n\t(setq list (cdr list)))))\n  (car list))\n\n(defun rassq (key list)\n  \"Return non-nil if KEY is `eq' to the cdr of an element of LIST.\nThe value is actually the first element of LIST whose cdr is KEY.\"\n  (let ((keep-going t))\n    (while (and keep-going (consp list))\n      (if (and (consp (car list))\n\t       (eq (cdr (car list)) key))\n\t  (setq keep-going nil)\n\t(setq list (cdr list)))))\n  (car list))\n\n(defun rassoc (key list)\n  \"Return non-nil if KEY is `equal' to the cdr of an element of LIST.b\nThe value is actually the first element of LIST whose cdr is KEY.\"\n  (let ((keep-going t))\n    (while (and keep-going (consp list))\n      (if (and (consp (car list))\n\t       (equal (cdr (car list)) key))\n\t  (setq keep-going nil)\n\t(setq list (cdr list)))))\n  (car list))\n\n(defun nreverse (list)\n  \"Reverse LIST by modifying cdr pointers.\nReturn the reversed list.  Expects a properly nil-terminated list.\"\n  (let ((prev nil)\n\t(tail list))\n    (while tail\n      (let ((next (cdr tail)))\n\t(setcdr tail prev)\n\t(setq prev tail)\n\t(setq tail next)))\n    prev))\n\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n(defun featurep (feature &optional subfeature)\n  (cl-check-type feature symbol)\n  (let ((tem (memq feature features)))\n    (and tem subfeature\n\t (setq tem (member subfeature (get feature 'subfeatures))))\n    (if tem t)))\n\n(defun provide (feature subfeatures)\n  (cl-check-type feature symbol)\n  (cl-check-type subfeatures list)\n  (when autoload-queue\n    (push (cons 0 features) autoload-queue))\n  (unless (memq feature features)\n    (push feature features))\n  (when subfeatures\n    (put feature 'subfeatures subfeatures))\n  ;; if (initialized) <- add back\n  (push (cons 'provide feature) current-load-list)\n  (let ((tem (assq feature after-load-alist)))\n    (if (consp tem)\n\t(mapc #'funcall (cdr tem))))\n  feature)\n\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n(defun plist-member (plist prop)\n  (while (and (consp plist)\n\t      (not (eq (car plist) prop)))\n    (setf plist (cddr plist)))\n  plist)\n\n(defun widget-put (widget property value)\n  (setcdr widget (plist-put (cdr widget) property value)))\n\n(defun widget-get (widget property)\n  (catch 'done\t\t\t\t;FIXME - lexical catch\n    (while t\n      (unless widget\n\t(throw 'done nil))\n      (let ((tmp (plist-member (cdr widget) property)))\n\t(when (consp tmp)\n\t  (setf tmp (cdr tmp))\n\t  (throw 'done (car tmp)))\n\t(setf tmp (car widget))\n\t(unless tmp\n\t  (throw 'done nil))\n\t(setf widget (get tmp 'widget-type))))))\n\n(defun widget-apply (widget property &rest args)\n  (apply (widget-get widget property) widget args))\n"
  },
  {
    "path": "futures.org",
    "content": "* Futures\n\n** Emacs should itself be written in emacs lisp\n\n*** For every part this seems pretty hard!\n*** But:\n\n** This compiler can be used to bootstrap this process\n   With type declarations and inferencing it can be as efficient\n   as the C code\n\n*** Plenty of examples, e.g. provide or copy-alist\n\n** It can also JIT compile parts as needed\n\n** Type-generic operations like + would be better expressed\n   using defgeneric and defmethod.  then the compiler could\n   more easily optimize?  Not clear.\n\n** Meanwhile there should be a rule about use of Fwhatever in Emacs\n\n*** Only \"inlineable\" uses should be permitted\n*** Things like Fload should indirect via Ffuncall\n*** This is very easy to do when translating from lisp\n\n** It is bad that Emacs has 3 interpreters in it:\n*** Emacs Lisp\n*** Regexp\n*** CCL\n"
  },
  {
    "path": "loadup.el",
    "content": "(defconst elcomp--loadup-dir\n  (file-name-directory (or load-file-name\n\t\t\t   ;; In the eval-buffer case.\n\t\t\t   (buffer-file-name))))\n\n(defun elcomp--loadup ()\n  (interactive)\n  (let ((load-path load-path))\n    (push elcomp--loadup-dir load-path)\n    (dolist (file '(\"elcomp\"\n\t\t    \"elcomp/back\"\n\t\t    \"elcomp/c-inl\"\n\t\t    \"elcomp/cmacros\"\n\t\t    \"elcomp/coalesce\"\n\t\t    \"elcomp/comp-debug\"\n\t\t    \"elcomp/cprop\"\n\t\t    \"elcomp/dce\"\n\t\t    \"elcomp/dom\"\n\t\t    \"elcomp/eh-cleanup\"\n\t\t    \"elcomp/eltoc\"\n\t\t    \"elcomp/ffi\"\n\t\t    \"elcomp/iter\"\n\t\t    \"elcomp/jump-thread\"\n\t\t    \"elcomp/linearize\"\n\t\t    \"elcomp/name-map\"\n\t\t    \"elcomp/props\"\n\t\t    \"elcomp/ssa\"\n\t\t    \"elcomp/subst\"\n\t\t    \"elcomp/toplevel\"\n\t\t    \"elcomp/typeinf\"))\n      (load file nil t))))\n"
  },
  {
    "path": "project.org",
    "content": "* Plan\n\n* To Do\n\n** C back end could use AUTO_CONS and AUTO_STRING\n   (info \"(elisp) Stack-allocated Objects\")\n\n** need to handle out-of-ssa for exception edges\n\n** turn elcomp--iterate-over-bbs into a macro to be more elisp-like.\n   add a declare form to fix the indentation\n\n** maybe add a dynamic-module-API back end\n\n** `car` should be `const`, ditto cdr, car-safe, cdr-safe,\n  aref, etc\n  also, in cprop.el, it seems like a const function could be\n  pre-evaluated when all arguments are constant; not just a pure\n  function\n\n** we should be able to notice NILP(Fconsp) and turn it into\n   CONSP.  This requires unboxing\n\n** make an elcomp-debug-output-mode, derived from special-mode,\n   where \"g\" re-runs the command; handy for debugging\n   should store the sexp and the backend function\n\n** arguments need types set to :bottom\n\n** typeinf.el doesn't handle keywordp specially, but should\n\n** make sure calls to a lambda work ok\n   C BE should make a static function\n   the call should resolve to a call to the compiled function somehow\n   -> ?\n\n** clean up the calls to declare-function\n   I think ideally they should not be needed\n\n** A \"catch\" with a non-constant tag will still require\n   special handling in the IR, e.g. when converting to SSA form\n   this isn't done now\n\n** There are various spots where the :func slot of a call\n   is handled improperly\n\n** We need a `lexical-catch' of some kind\n*** Could also mark various subrs as \"cannot throw\" as a special case\n    Except we have Vthrow_on_input ...\n*** Common Lisp uses block and return for lexical catch, so\n    we should do that\n*** see the \"emacs bugs\" section below\n\n** We can merge blocks with different exception handlers\n   if one of them doesn't have any throwing instructions\n   likewise if we have fake-unwind-protect?\n\n** We can remove specbind/unbind if there aren't intervening statements\n   probably unimportant optimization though?\n\n** Can specbind or unbind throw?\n\n** Remove \"defuns\" from compiler?\n\n** We don't handle lambdas at all\n*** Need to do closure-conversion\n*** Probably need to handle \"closure\"\n*** the C core would ideally need updates to handle native closures\n    but there is probably a way to work around this\n\n** Some special forms are still not handled\n\n** \"Ordinary special forms\"\n\n    (let ((result nil))\n      (mapatoms (lambda (sym)\n\t\t  (when (special-form-p (symbol-function sym))\n\t\t    (push sym result))))\n      result)\n\n*** (defconst defvar interactive)\n\n*** (Note track-mouse turned into a macro)\n\n*** save-current-buffer\n*** save-restriction\n*** save-excursion\n\n** can turn throw->catch into a goto\n\n    (catch CONST (... (throw CONST val)))\n    =>\n    R = val; GOTO done\n\n    We do this already but can do better by handling unwind-protect as\n    well\n\n* Passes\n\n** SCCP pass\n\n** GVN pass\n\n** Note that we can copy-propagate into a funcall or apply\n   For apply this is a bit like strength reduction\n\n** Can we always optimize mapc and mapcar with a lambda?\n   If we add a compiler macro can it expand back to 'itself'?\n\n** We can optimize some regexps.\n   for example looking-at-p with a constant can be turned into ordinary code\n   especially if the regexp is very simple this would be a win\n   same with string-match-p\n\n** At least a simple form of TCO is easy\n\n** Look into a smarter form of closure conversion\n   Possibly sometimes we could optimize away closed-over variables, etc\n\n** We could convert `elt' to aref or nth if we deduced the type\n   This could just be done with a compiler macro.\n   Or by rewriting 'elt' entirely into a macro\n\n** We could perhaps inline nth and nthcdr if the argument is a constant\n\n* Back Ends\n\n** Disassembly\n\n** C Code\n\n*** if we're generating code to compile and dlopen then we don't really\n    need DEFUN, and generating a doc comment is the wrong thing to do\n\n*** Currently does not handle QUIT etc.\n\n*** Could use Aurélien's \"FFI\" / DSO thing\n\n*** Type inference would be great here, could do unboxing\n**** this works ok but needs better code generation\n\n** Bytecode\n\n*** bytecode from this compiler would probably be worse than what\n    emacs generates\n*** however, we could instead write a new bytecode interpreter\n    a register-based interpreter would likely be faster anyway\n\n* Emacs Bugs and Changes\n\n** the emacs core needs to support a SUBR in a `closure' list\n\n** we need the number of arguments constant exported\n   see eltoc.el\n   if we write some kind of jit back end, we'll need many more\n   constants, like how to unbox\n\n** we need hacks to emacs for unwinding, see eltoc.el\n\n** in the c code we can get a vector of args\n   but elisp is always going to want a list for &rest\n   we could do better with &vector-rest\n\n** There's no way to recapture the fact that some CL 'throw' constructs\n   are lexical\n   we need our own special hack.  like maybe CL could put a special\n   property on the magic symbols it makes\n\n** concat and mapconcat don't allow characters\n   this seems unfriendly and pointless\n\n** vc-dir \"i\" gives an unhelpful error if any other file is marked\n   this seems somewhat useless\n\n** it seems strange for elisp to have both defstruct and defclass\n   given that it isn't really planning to be CL\n\n** it seems that cl-nreconc would be more efficient as\n   (prog1 (nreverse x) (setcdr x y))\n   ... not if x=nil?\n\n** I wonder if progv is implemented correctly now that\n   macroexpand is done eagerly\n"
  },
  {
    "path": "scripts/get-defuns.el",
    "content": "(defconst emacs-source \"/home/tromey/Emacs/emacs/src/\")\n\n(defconst output-file (expand-file-name \"elcomp/c-renames.el\"))\n\n(defvar defun-names nil)\n\n(dolist (file (directory-files emacs-source t \"\\\\.c\\\\'\"))\n  (message \"Scanning %s\" file)\n  (find-file-read-only file)\n  (goto-char (point-min))\n  (while (re-search-forward\n\t  \"^DEFUN\\\\s-*(\\\"\\\\([^\\\"]+\\\\)\\\",\\\\s-*\\\\([a-zA-Z0-9_]+\\\\)\" nil t)\n    (let ((lisp-name (match-string 1))\n\t  (c-name (match-string 2))\n\t  (replacement nil))\n      (setf replacement (concat \"F\"\n\t\t\t\t(replace-regexp-in-string \"-\" \"_\" lisp-name)))\n      (unless (equal replacement c-name)\n\t(push (cons (intern lisp-name) c-name) defun-names)))))\n\n(find-file output-file)\n(erase-buffer)\n(insert \";; Autogenerated by get-defuns.el\\n\")\n(pp `(defvar elcomp--c-renames ',defun-names) (current-buffer))\n(insert \"(provide 'elcomp/c-renames)\\n\")\n(save-buffer)\n"
  }
]