├── .gitignore ├── BUGS ├── Makefile ├── README.md ├── el-compile ├── elcomp.el ├── elcomp ├── back.el ├── c-inl.el ├── c-renames.el ├── cmacros.el ├── coalesce.el ├── comp-debug.el ├── cprop.el ├── dce.el ├── dom.el ├── eh-cleanup.el ├── eltoc.el ├── ffi.el ├── iter.el ├── jump-thread.el ├── linearize.el ├── name-map.el ├── props.el ├── ssa.el ├── subst.el ├── toplevel.el └── typeinf.el ├── fns.el ├── futures.org ├── loadup.el ├── project.org └── scripts └── get-defuns.el /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.elc 3 | -------------------------------------------------------------------------------- /BUGS: -------------------------------------------------------------------------------- 1 | (elcomp--do '( 2 | (defun qqz () 3 | (let ((f (lambda () 23))) 4 | (funcall f))) 5 | ) 6 | #'elcomp--c-translate 7 | ) 8 | 9 | this should not generate code for the lambda but it does 10 | the equivalent without a binding does not generate it 11 | 12 | ================================================================ 13 | 14 | C back end writes some bogus symbol names 15 | 16 | C back end doesn't do out-of-ssa 17 | [it does but still...] 18 | we probably need to keep edges after all 19 | 20 | ================================================================ 21 | 22 | document the compilation / linkage model 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | EMACS := /home/tromey/Emacs/install/bin/emacs 2 | 3 | HERE := $(shell pwd) 4 | 5 | all: 6 | $(EMACS) --batch --eval '(push "$(HERE)" load-path)' \ 7 | --eval '(byte-recompile-directory "." 0)' 8 | 9 | clean: 10 | -rm *.elc */*.elc 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Welcome to El Compilador, a compiler for Emacs Lisp. 2 | 3 | ## Breaking News 4 | 5 | The compiler can now generate C code that can be compiled as part of 6 | Emacs. Using the bubble sort benchmark from 7 | http://www.emacswiki.org/emacs/EmacsLispBenchmark (with the list 8 | bumped to 1000 elements), with 100 runs, I got some timings: 9 | 10 | Approach | Seconds 11 | :-------- | -------: 12 | interpreted | 54.874574673000005 13 | byte-compiled | 13.390510359999999 14 | el-compilador | 4.312016277000001 15 | 16 | ## Dreams 17 | 18 | I've long wanted to write a compiler for Emacs Lisp. Here it is. 19 | Well, the start of it. In the long term I have a few goals for Emacs 20 | and Emacs Lisp that are served by this project: 21 | 22 | I think Emacs should move more strongly toward self-hosting. Too much 23 | of Emacs is written in C, and in the long term this should be migrated 24 | to lisp. Beyond just being more fun to hack, having Emacs written in 25 | Emacs Lisp would make it simpler to upgrade the language 26 | implementation. 27 | 28 | There are plenty of functions currently written in C which were either 29 | translated for performance (`widget-apply`) or just because some other 30 | part of the core needed to call it. These would stop being acceptable 31 | reasons to write in C. 32 | 33 | The C core is also badly behaved about making direct calls. This is 34 | ok for primitives like `cons`, but not ok for functions that one might 35 | reasonably want to advise or rewrite, like `read`. Normally this lack 36 | of indirection is just because it is a pain to write out in C -- but 37 | automatic translation could eliminate this problem. 38 | 39 | I'm also interested in using the compiler to either write a JIT or a 40 | new register-based bytecode interpreter. These could be done without 41 | modifying Emacs once the new FFI code lands. 42 | 43 | Finally, it is bad and wrong that Emacs has three bytecode 44 | interpreters (the Emacs Lisp one, the regexp engine, and CCL). There 45 | should be only one, and we can use this work to push Emacs toward that 46 | goal. 47 | 48 | ## Use 49 | 50 | You can use the function in `loadup.el` to load the compiler and then 51 | use the two handy entry points: 52 | 53 | * `elcomp--do`. The debugging entry point. This takes a form, 54 | compiles it, and then dumps the resulting IR into a buffer. For 55 | example, you can try this on a reasonably direct translation of 56 | `nthcdr` from `fns.c`: 57 | 58 | ```elisp 59 | (elcomp--do '(defun nthcdr (num list) 60 | (cl-check-type num integer) 61 | (let ((i 0)) 62 | (while (and (< i num) list) 63 | (setq list (cdr list)) 64 | (setq i (1+ i))) 65 | list))) 66 | ``` 67 | 68 | * You can pass `elcomp--c-translate` as the third argument to 69 | `elcomp--do` to use the "C" back end. At least some forms of the 70 | output will compile. It targets the API used by the Emacs source 71 | tree (not the Emacs dynamic module API). Some constructs don't have 72 | the needed back end support yet, so not everything will work. 73 | 74 | ## Implementation 75 | 76 | El Compilador is an 77 | [SSA-based](http://en.wikipedia.org/wiki/Static_single_assignment_form) 78 | compiler. The objects in the IR are described in `elcomp.el`. EIEIO 79 | or `cl-defstruct` are used for most things. 80 | 81 | The compiler provides a number of optimization passes: 82 | 83 | * Jump threading, `elcomp/jump-thread.el`. This also does some simple 84 | optimizations on predicates, like `not` removal. This can sometimes 85 | turn a `throw` into a `goto` when it is caught in the same `defun`. 86 | 87 | * Exception handling cleanup, `elcomp/eh-cleanup.el`. This removes 88 | useless exception edges. 89 | 90 | * Block coalescing, `elcomp/coalesce.el`. This merges basic blocks 91 | when possible. 92 | 93 | * Constant and copy propagation, `elcomp/cprop.el`. This also 94 | evaluates pure functions. 95 | 96 | * Dead code elimination, `elcomp/dce.el`. 97 | 98 | * Type inference, `elcomp/typeinf.el`. This is a flow-sensitive type 99 | inferencer. 100 | 101 | 102 | ## To-Do 103 | 104 | There are any number of bugs. There are some notes about them in 105 | various files. Some are filed in the github issues. 106 | 107 | The into-SSA pass is written in the stupidest possible way. Making 108 | this smarter would be nice. 109 | -------------------------------------------------------------------------------- /el-compile: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | :; exec emacs --quick --script $0 -- "$@" 3 | 4 | (setq debug-on-error t) 5 | ;; FIXME debug.el says it tries to preserve the start of the stack 6 | ;; trace, but in practice I'm not seeing this. 7 | (setq debugger-batch-max-lines 1000) 8 | 9 | (defconst elcomp--dir (file-name-directory load-file-name)) 10 | 11 | (load (expand-file-name "loadup.el" elcomp--dir) nil t) 12 | (elcomp--loadup) 13 | 14 | (defun elcomp--skip-comments () 15 | (while (forward-comment 1))) 16 | 17 | (defun elcomp--read-forms () 18 | (let ((result '())) 19 | (elcomp--skip-comments) 20 | (while (not (eobp)) 21 | (push (read (current-buffer)) result) 22 | (elcomp--skip-comments)) 23 | result)) 24 | 25 | (defun elcomp--read-forms-from-file (lisp-file) 26 | (save-excursion 27 | (find-file lisp-file) 28 | (goto-char (point-min)) 29 | (elcomp--read-forms))) 30 | 31 | (defun elcomp--driver-convert-one (output-file lisp-file) 32 | (message "Reading %s..." lisp-file) 33 | (let ((forms (elcomp--read-forms-from-file lisp-file))) 34 | (let ((unit (make-elcomp--compilation-unit))) 35 | ;; FIXME for now we only handle a file full of defuns 36 | ;; and eval-when-compile. 37 | (dolist (form forms) 38 | (cl-case (car form) 39 | (eval-when-compile 40 | (eval (cons 'progn (cdr form)))) 41 | ((defun define-ffi-library define-ffi-function) 42 | (elcomp--plan-to-compile unit form)) 43 | (t 44 | (message "Skipping form %S" (car form))))) 45 | (elcomp--translate-all unit) 46 | (elcomp--c-translate unit 47 | (if output-file 48 | (file-name-sans-extension 49 | (file-name-nondirectory output-file))))))) 50 | 51 | (defun elcomp--driver-compile (output-file files) 52 | (find-file (or output-file "OUTPUT")) 53 | (setq-local backup-inhibited t) 54 | (erase-buffer) 55 | (dolist (file files) 56 | ;; FIXME this only works for a single file 57 | (elcomp--driver-convert-one output-file file)) 58 | (save-buffer)) 59 | 60 | ;; FIXME it would be nice to have an argument parsing library in 61 | ;; elisp. 62 | (when (equal (car argv) "--") 63 | (pop argv)) 64 | 65 | (if (equal (car argv) "--help") 66 | (message "Usage: el-compile FILE...") 67 | (let ((filename nil)) 68 | (when (equal (car argv) "--output") 69 | (pop argv) 70 | (setf filename (pop argv)) 71 | ;; Arrange for FFI to be available. 72 | (elcomp--use-ffi)) 73 | (elcomp--driver-compile filename 74 | (mapcar #'expand-file-name argv)))) 75 | 76 | (setf argv nil) 77 | 78 | ;; Local variables: 79 | ;; Mode: emacs-lisp 80 | ;; End: 81 | -------------------------------------------------------------------------------- /elcomp.el: -------------------------------------------------------------------------------- 1 | ;;; elcomp.el - Compiler for Emacs Lisp. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This holds basic definitions for the compiler. Everything else is 6 | ;; in the elcomp subdir. 7 | 8 | ;;; Code: 9 | 10 | (require 'cl-macs) 11 | (require 'eieio) 12 | 13 | (cl-defstruct (elcomp (:conc-name elcomp--)) 14 | ;; An alist holding symbol rewrites. The car of each element is a 15 | ;; symbol in the original code. The cdr is the symbol to which it 16 | ;; is rewritten. 17 | rewrite-alist 18 | ;; Next label value. 19 | (next-label 0) 20 | ;; The entry block. 21 | entry-block 22 | ;; The current basic block. 23 | current-block 24 | ;; True if the back-edges in the CFG are considered valid. 25 | ;; FIXME - deal with IDOM being invalid too 26 | back-edges-valid 27 | ;; The current list of exception handlers. 28 | exceptions 29 | ;; The current defun being compiled. 30 | ;; This is a list (NAME ARGLIST DOC INTERACTIVE). 31 | ;; NAME is nil for an anonymous function. 32 | ;; FIXME this should just be separate slots of this struct. 33 | defun 34 | ;; The name of the defun, a symbol. This must be computed using 35 | ;; elcomp--get-name, as this is either set lazily from 'defun', or 36 | ;; generated for lambdas. 37 | name 38 | ;; In SSA mode, a list of the argument objects representing the 39 | ;; arguments to the defun. 40 | arguments 41 | ;; A back link to the compilation unit. This is needed so we can 42 | ;; push new functions into the compilation unit as we go. 43 | unit) 44 | 45 | (cl-defstruct elcomp--compilation-unit 46 | ;; A hash table mapping a cons (a defun or a lambda) to a compiler 47 | ;; object. 48 | (defuns (make-hash-table)) 49 | ;; The work-list. This is separate from `defuns' for convenience. 50 | work-list) 51 | 52 | (cl-defstruct elcomp--basic-block 53 | ;; Block number. 54 | number 55 | ;; The code for this basic block. 56 | code 57 | ;; Last link of linearized code. 58 | code-link 59 | ;; A hash table holding back-links to parent nodes. 60 | ;; Outgoing edges are represented directly by the last instruction 61 | ;; in the code sequence. 62 | parents 63 | ;; The immediate dominator, or nil if not known. 64 | immediate-dominator 65 | ;; The list of exception handlers. 66 | exceptions 67 | ;; The phi nodes for this basic block. This is a hash table whose 68 | ;; keys are original variable names and whose values are phis. This 69 | ;; starts as nil and is initialized when converting to SSA form. 70 | phis 71 | ;; Final type map for this BB. 72 | final-type-map 73 | ;; Entry type map for this BB. This is not needed after type 74 | ;; inferencing. FIXME store on the side. 75 | type-map) 76 | 77 | (defclass elcomp--set nil 78 | ((sym :initform nil :initarg :sym 79 | :accessor elcomp--sym 80 | :documentation "The local variable being assigned to. 81 | Initially this is a symbol. 82 | After transformation to SSA, this will be an SSA name; 83 | see `elcomp--ssa-name-p'.") 84 | (value :initform nil :initarg :value 85 | :accessor elcomp--value 86 | :documentation "The value being assigned. 87 | Initially this is a symbol. 88 | After transformation to SSA, this will be an SSA name.")) 89 | "A `set' instruction. 90 | 91 | This represents a simple assignment to a local variable.") 92 | 93 | (defclass elcomp--call nil 94 | ((sym :initform nil :initarg :sym 95 | :accessor elcomp--sym 96 | :documentation "The local variable being assigned to. 97 | This can be `nil' if the result of the call is not used. 98 | Initially this is a symbol. 99 | After transformation to SSA, this will be an SSA name; 100 | see `elcomp--ssa-name-p'.") 101 | (func :initform nil :initarg :func 102 | :accessor elcomp--func 103 | :documentation "The function to call. 104 | This may be a symbol or a `lambda' list.") 105 | (args :initform nil :initarg :args 106 | :accessor elcomp--args 107 | ;; FIXME - can a symbol wind up in here or do we make 108 | ;; symbol-value explicit? 109 | :documentation "The arguments to the function. 110 | Initially this is a list of symbols. 111 | After transformation to SSA, this will be a list of SSA names.")) 112 | "A function call instruction.") 113 | 114 | (defclass elcomp--goto nil 115 | ((block :initform nil :initarg :block 116 | :accessor elcomp--block 117 | :documentation "The target block.")) 118 | "A `goto' instruction. 119 | This instruction terminates a block.") 120 | 121 | (defclass elcomp--if nil 122 | ((sym :initform nil :initarg :sym 123 | :accessor elcomp--sym 124 | :documentation "The condition to check. 125 | Initially this is a symbol. 126 | After transformation to SSA, this will be an SSA name; 127 | see `elcomp--ssa-name-p'.") 128 | (block-true :initform nil :initarg :block-true 129 | :accessor elcomp--block-true 130 | :documentation "The target block if the value is non-`nil'.") 131 | (block-false :initform nil :initarg :block-false 132 | :accessor elcomp--block-false 133 | :documentation "The target block if the value is `nil'.")) 134 | "An `if' instruction. 135 | This branches to one of two blocks based on whether or not the 136 | argument is `nil'. This instruction terminates a block.") 137 | 138 | 139 | (defclass elcomp--return nil 140 | ((sym :initform nil :initarg :sym 141 | :accessor elcomp--sym 142 | :documentation "The value to return. 143 | Initially this is a symbol. 144 | After transformation to SSA, this will be an SSA name; 145 | see `elcomp--ssa-name-p'.")) 146 | "A `return' instruction.") 147 | 148 | (defclass elcomp--diediedie (elcomp--call) 149 | () 150 | "An instruction which terminates a basic block without leading anywhere. 151 | 152 | This can only be for a call to a `nothrow' function.") 153 | 154 | (defclass elcomp--constant nil 155 | ((value :initform nil :initarg :value 156 | :accessor elcomp--value 157 | :documentation "The value of the constant.")) 158 | "This represents a constant after transformation to SSA form.") 159 | 160 | (defclass elcomp--phi nil 161 | ((original-name :initform nil :initarg :original-name 162 | :accessor elcomp--original-name 163 | :documentation "The original name of this node. 164 | This is handy for debugging.") 165 | (args :initform (make-hash-table) :initarg :args 166 | :accessor elcomp--args 167 | :documentation "Arguments to this node. 168 | This is a hash table whose keys are possible source values for the phi. 169 | The values in the hash table are meaningless.")) 170 | "A `phi' node. 171 | 172 | See any good source of information about SSA to understand this.") 173 | 174 | (defclass elcomp--argument nil 175 | ((original-name :initform nil :initarg :original-name 176 | :accessor elcomp--original-name 177 | :documentation "The original name of this node. 178 | This is handy for debugging.") 179 | (is-rest :initform nil :initarg :is-rest 180 | :accessor elcomp--is-rest 181 | :documentation "True if this argument was from `&rest'.")) 182 | "A function argument. This is only used in SSA form.") 183 | 184 | (defclass elcomp--exception nil 185 | ((handler :initform nil :initarg :handler 186 | :accessor elcomp--handler 187 | :documentation "The target block of this exception edge.")) 188 | "An exception edge. 189 | 190 | A block's `exceptions' slot is a list of all the active exception 191 | handlers, though in most cases only the first one is ever 192 | taken.") 193 | 194 | (defclass elcomp--catch (elcomp--exception) 195 | ((tag :initform nil :initarg :tag 196 | :accessor elcomp--tag 197 | :documentation "The tag of the `catch'.")) 198 | "An exception edge representing a `catch'.") 199 | 200 | (defclass elcomp--condition-case (elcomp--exception) 201 | ((condition-name :initform nil :initarg :condition-name 202 | :accessor elcomp--condition-name 203 | :documentation "The name of the condition being handled. 204 | 205 | This is either a symbol or nil. Note that the variable that can 206 | be bound by `condition-case' is explicit in the target block.")) 207 | "An exception edge representing a single `condition-case' handler.") 208 | 209 | (defclass elcomp--unwind-protect (elcomp--exception) 210 | ;; The original form is used when optimizing "catch". 211 | ;; Well.. it will be someday. FIXME. 212 | ((original-form :initform nil :initarg :original-form 213 | :documentation "The original form. 214 | This is not used now but may be later for `catch' optimization.")) 215 | "An exception edge representing an `unwind-protect'.") 216 | 217 | ;; A fake unwind-protect that is used to represent the unbind 218 | ;; operation from a `let' of a special variable. This is needed to 219 | ;; properly deal with `catch' optimization from inside a `let', like: 220 | ;; (catch 'x (let* ((var1 (something)) (var2 (throw 'x 99))) ...)) 221 | ;; Here, the `throw' has to unbind "var1". 222 | (defclass elcomp--fake-unwind-protect (elcomp--exception) 223 | ((count :initform nil :initarg :count 224 | :accessor elcomp--count 225 | :documentation "The number of unbinds that this represents.")) 226 | "An exception edge representing the unbind operation from a `let' 227 | of a special variable. These unbinds are done implicitly, so this 228 | exception edge does not represent any ordinary code -- but it is needed 229 | to properly deal do the `catch' optimization from inside a `let', like: 230 | 231 | (catch 'x (let* ((var1 (something)) (var2 (throw 'x 99))) ...)) 232 | 233 | Here, the `throw' has to unbind `var1'.") 234 | 235 | (defun elcomp--ssa-name-p (arg) 236 | "Return t if ARG is an SSA name." 237 | (or 238 | (elcomp--set-p arg) 239 | (elcomp--phi-p arg) 240 | (elcomp--call-p arg) 241 | (elcomp--argument-p arg))) 242 | 243 | (defun elcomp--last-instruction (block) 244 | "Return the last instruction in BLOCK. 245 | 246 | This can be used with `setf'." 247 | (car (elcomp--basic-block-code-link block))) 248 | 249 | (gv-define-setter elcomp--last-instruction (val block) 250 | `(setcar (elcomp--basic-block-code-link ,block) ,val)) 251 | 252 | (defun elcomp--first-instruction (block) 253 | "Return the first instruction in BLOCK. 254 | 255 | This can be used with `setf'." 256 | (car (elcomp--basic-block-code block))) 257 | 258 | (gv-define-setter elcomp--first-instruction (val block) 259 | `(setcar (elcomp--basic-block-code ,block) ,val)) 260 | 261 | (defun elcomp--nonreturn-terminator-p (obj) 262 | "Return t if OBJ is a block-terminating instruction other than 263 | `return' or `diediedie'." 264 | (or (elcomp--goto-p obj) 265 | (elcomp--if-p obj))) 266 | 267 | (defun elcomp--terminator-p (obj) 268 | "Return t if OBJ terminates a block." 269 | (or (elcomp--goto-p obj) 270 | (elcomp--if-p obj) 271 | (elcomp--return-p obj) 272 | (elcomp--diediedie-p obj))) 273 | 274 | (cl-defun elcomp--any-hash-key (hash) 275 | "Return any key of the hash table HASH, or nil." 276 | (maphash (lambda (key _ignore) (cl-return-from elcomp--any-hash-key key)) 277 | hash)) 278 | 279 | (defun elcomp--get-name (elcomp) 280 | "Get the name of the function represented by ELCOMP." 281 | (unless (elcomp--name elcomp) 282 | (setf (elcomp--name elcomp) 283 | (if (car (elcomp--defun elcomp)) 284 | (car (elcomp--defun elcomp)) 285 | (cl-gensym "__lambda")))) 286 | (elcomp--name elcomp)) 287 | 288 | (provide 'elcomp) 289 | 290 | ;;; elcomp.el ends here 291 | -------------------------------------------------------------------------------- /elcomp/back.el: -------------------------------------------------------------------------------- 1 | ;;; back.el --- fix up back edges. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Reconstruct the back edges in the CFG. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | (require 'elcomp/iter) 11 | 12 | (defun elcomp--reset-back-edges (compiler init) 13 | "Reset the back edges of all basic blocks in COMPILER. 14 | 15 | This sets all the back edges to nil." 16 | (elcomp--iterate-over-bbs 17 | compiler 18 | (lambda (bb) 19 | (setf (elcomp--basic-block-parents bb) 20 | (if init (make-hash-table) nil))))) 21 | 22 | (cl-defgeneric elcomp--add-links (insn block) 23 | "Add backlinks for the instruction INSN, which appears in BLOCK. 24 | 25 | The base case does nothing. Most instructions don't have links." 26 | ;; Do nothing. 27 | nil) 28 | 29 | (cl-defmethod elcomp--add-links ((insn elcomp--goto) block) 30 | "Add backlinks for a `goto'." 31 | (puthash block t (elcomp--basic-block-parents (elcomp--block insn)))) 32 | 33 | (cl-defmethod elcomp--add-links ((insn elcomp--if) block) 34 | "Add backlinks for an `if'." 35 | (puthash block t (elcomp--basic-block-parents (elcomp--block-true insn))) 36 | (puthash block t (elcomp--basic-block-parents (elcomp--block-false insn)))) 37 | 38 | (defun elcomp--require-back-edges (compiler) 39 | "Require the back links in COMPILER to be valid. 40 | 41 | If the links are already believed to be valid, this does nothing. 42 | Otherwise, it recreates the links." 43 | (unless (elcomp--back-edges-valid compiler) 44 | (elcomp--reset-back-edges compiler t) 45 | (elcomp--iterate-over-bbs 46 | compiler 47 | (lambda (bb) 48 | (dolist (exception (elcomp--basic-block-exceptions bb)) 49 | (when (elcomp--handler exception) 50 | (puthash bb t 51 | (elcomp--basic-block-parents (elcomp--handler exception))))) 52 | (elcomp--add-links (elcomp--last-instruction bb) bb))) 53 | (setf (elcomp--back-edges-valid compiler) t))) 54 | 55 | (defun elcomp--invalidate-back-edges (compiler) 56 | "Invalidate the back links in COMPILER." 57 | (when (elcomp--back-edges-valid compiler) 58 | (elcomp--reset-back-edges compiler nil) 59 | (setf (elcomp--back-edges-valid compiler) nil))) 60 | 61 | (declare-function elcomp--clear-dominators "elcomp/dom") 62 | 63 | (defun elcomp--invalidate-cfg (compiler) 64 | (elcomp--clear-dominators compiler) 65 | (elcomp--invalidate-back-edges compiler)) 66 | 67 | (provide 'elcomp/back) 68 | 69 | ;;; back.el ends here 70 | -------------------------------------------------------------------------------- /elcomp/c-inl.el: -------------------------------------------------------------------------------- 1 | ;; -*- emacs-lisp -*- 2 | 3 | (require 'elcomp) 4 | (require 'elcomp/typeinf) 5 | 6 | (defvar elcomp--c-compare-type-lists (make-hash-table)) 7 | 8 | (defun elcomp--define-c-substitution (name type-list substitution) 9 | (let ((existing (gethash name elcomp--c-compare-type-lists))) 10 | (push (cons substitution type-list) existing) 11 | (puthash name existing elcomp--c-compare-type-lists))) 12 | 13 | (defun elcomp--c-compare-type-lists (declared-types arg-types) 14 | ;; FIXME - for now we require eq but we could do better. 15 | ;; for example an actual type of 'null is ok for 'list. 16 | (cl-every (lambda (declared-type arg-type) 17 | (eq (elcomp--pretend-eval-type-predicate declared-type arg-type) 18 | t)) 19 | declared-types arg-types)) 20 | 21 | (defun elcomp--c-opt (call types) 22 | (let ((call-sym (elcomp--func call))) 23 | (when (symbolp call-sym) 24 | (cl-dolist (entry (gethash call-sym elcomp--c-compare-type-lists)) 25 | (when (elcomp--c-compare-type-lists (cdr entry) types) 26 | ;; Found a match, so optimize. 27 | (cl-return (car entry))))))) 28 | 29 | (dolist (entry '((car (cons) "XCAR") 30 | (cdr (cons) "XCDR") 31 | (setcar (cons :bottom) "XSETCAR") 32 | (setcdr (cons :bottom) "XSETCDR") 33 | (length (vector) "ASIZE") 34 | (length (string) "SCHARS") 35 | (length (bool-vector) "bool_vector_size") 36 | ;; not a function: (length (char-table) "MAX_CHAR") 37 | ;; Also: (length (null) 0) 38 | (symbol-name (symbol) "SYMBOL_NAME"))) 39 | (apply #'elcomp--define-c-substitution entry)) 40 | 41 | ;; there's no need for this once we fix cprop 42 | ;; (elcomp--define-c-substitution car ((arg null)) 43 | ;; "Qnil") 44 | ;; (elcomp--define-c-substitution cdr ((arg null)) 45 | ;; "Qnil") 46 | 47 | ;; (elcomp--define-c-substitution aref ((v vector) (x integer)) 48 | ;; ;; what about bounds? 49 | ;; ;; what about XFASTINT 50 | ;; `("AREF" v x)) 51 | 52 | ;; (elcomp--define-c-substitution null (arg) 53 | ;; (concat "NILP (" arg ")")) 54 | 55 | ;; (dolist (simple '(integerp eq floatp markerp symbolp consp 56 | ;; stringp bool-vector-p bufferp 57 | ;; char-table-p functionp overlayp 58 | ;; processp subrp symbolp windowp)) 59 | ;; ;; fixme this is wack 60 | ;; (elcomp--do-define-c-substitution simple FIXME upper-case...)) 61 | 62 | (provide 'elcomp/c-inl) 63 | -------------------------------------------------------------------------------- /elcomp/c-renames.el: -------------------------------------------------------------------------------- 1 | ;; Autogenerated by get-defuns.el 2 | (defvar elcomp--c-renames 3 | '((internal-event-symbol-parse-modifiers . "Fevent_symbol_parse_modifiers") 4 | (internal--track-mouse . "Ftrack_mouse") 5 | (frame-bottom-divider-width . "Fbottom_divider_width") 6 | (frame-right-divider-width . "Fright_divider_width") 7 | (frame-border-width . "Fborder_width") 8 | (frame-fringe-width . "Ffringe_width") 9 | (frame-scroll-bar-height . "Fscroll_bar_height") 10 | (frame-scroll-bar-width . "Fscroll_bar_width") 11 | (last-nonminibuffer-frame . "Flast_nonminibuf_frame") 12 | (let* . "FletX") 13 | (internal-make-var-non-special . "Fmake_var_non_special") 14 | (insert-before-markers-and-inherit . "Finsert_and_inherit_before_markers") 15 | (preceding-char . "Fprevious_char") 16 | (msdos-memput . "Fdos_memput") 17 | (msdos-memget . "Fdos_memget") 18 | (Snarf-documentation . "Fsnarf_documentation") 19 | (1- . "Fsub1") 20 | (1+ . "Fadd1") 21 | (% . "Frem") 22 | (/ . "Fquo") 23 | (* . "Ftimes") 24 | (- . "Fminus") 25 | (+ . "Fplus") 26 | (/= . "Fneq") 27 | (>= . "Fgeq") 28 | (<= . "Fleq") 29 | (> . "Fgtr") 30 | (< . "Flss") 31 | (= . "Feqlsign"))) 32 | (provide 'elcomp/c-renames) 33 | -------------------------------------------------------------------------------- /elcomp/cmacros.el: -------------------------------------------------------------------------------- 1 | ;;; cmacros.el --- Compiler macros. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Some compiler macros used by this compiler. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | 11 | (defun elcomp--macro-declare (&rest specs) 12 | "A compiler macro for `declare'. 13 | 14 | This just ensures we preserve the declaration so the compiler can 15 | see it." 16 | (cons 'declare specs)) 17 | 18 | (defun elcomp--macro-condition-case (var bodyform &rest handlers) 19 | "A compiler macro for `condition-case'. 20 | 21 | This pushes VAR as a let-binding into HANDLERS, when VAR is not 22 | nil." 23 | ;; Use a special name so we (us humans hacking on this) don't get 24 | ;; confused later on. 25 | (append (list :elcomp-condition-case bodyform) 26 | (if var 27 | (mapcar (lambda (handler) 28 | (list (car handler) 29 | `(let ((,var (:elcomp-fetch-condition))) 30 | ,@(cdr handler)))) 31 | handlers) 32 | handlers))) 33 | 34 | (defun elcomp--macro-save-current-buffer (&rest body) 35 | (let ((sym (cl-gensym))) 36 | `(let ((,sym (current-buffer))) 37 | (unwind-protect 38 | (progn ,@body) 39 | (if (buffer-live-p ,sym) 40 | (set-buffer ,sym)))))) 41 | 42 | (defun elcomp--macro-save-excursion (&rest body) 43 | (let ((sym (cl-gensym))) 44 | `(let ((,sym (:save-excursion-save))) 45 | (unwind-protect 46 | (progn ,@body) 47 | (:save-excursion-restore ,sym))))) 48 | 49 | (defun elcomp--macro-save-restriction (&rest body) 50 | (let ((sym (cl-gensym))) 51 | `(let ((,sym (:save-restriction-save))) 52 | (unwind-protect 53 | (progn ,@body) 54 | (:save-restriction-restore ,sym))))) 55 | 56 | (defvar elcomp--compiler-macros 57 | '((declare . elcomp--macro-declare) 58 | (condition-case . elcomp--macro-condition-case) 59 | (save-current-buffer . elcomp--macro-save-current-buffer) 60 | (save-excursion . elcomp--macro-save-excursion) 61 | (save-restriction . elcomp--macro-save-restriction))) 62 | 63 | (provide 'elcomp/cmacros) 64 | 65 | ;;; cmacros.el ends here 66 | -------------------------------------------------------------------------------- /elcomp/coalesce.el: -------------------------------------------------------------------------------- 1 | ;;; coalesce.el --- Coalesce blocks. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; A simple pass to coalesce blocks when possible. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | (require 'elcomp/back) 11 | 12 | (defun elcomp--coalesce-pass (compiler) 13 | "A compiler pass to coalesce blocks. 14 | 15 | A block can be coalesced with a second block if the second block 16 | is the sole successor of the original, and the original is the 17 | sole predecessor of the second, and if they have compatible 18 | outgoing exception edges." 19 | (elcomp--require-back-edges compiler) 20 | (let ((rewrote-one nil) 21 | (ever-rewrote-one nil)) 22 | (elcomp--iterate-over-bbs 23 | compiler 24 | (lambda (bb) 25 | ;; Loop until we're done with this block. 26 | (setf rewrote-one t) 27 | (while rewrote-one 28 | (setf rewrote-one nil) 29 | (when ;; If there is just one successor... 30 | (elcomp--goto-p (elcomp--last-instruction bb)) 31 | (let ((succ 32 | (elcomp--block (elcomp--last-instruction bb)))) 33 | (when (and 34 | ;; and the successor block has a single predecessor... 35 | (= (hash-table-count (elcomp--basic-block-parents succ)) 1) 36 | ;; and either... 37 | (or 38 | ;; the exception regions are the same -- we can 39 | ;; use `eq' due to how the exception lists are 40 | ;; constructed... 41 | (eq (elcomp--basic-block-exceptions bb) 42 | (elcomp--basic-block-exceptions succ)) 43 | ;; or this block is empty, in which case its 44 | ;; exception regions are immaterial... 45 | (eq (elcomp--basic-block-code bb) 46 | (elcomp--basic-block-code-link bb)))) 47 | ;; ... we can coalesce the blocks. 48 | (setf (elcomp--basic-block-code bb) 49 | (append 50 | (nbutlast (elcomp--basic-block-code bb)) 51 | (elcomp--basic-block-code succ))) 52 | (setf (elcomp--basic-block-code-link bb) 53 | (elcomp--basic-block-code-link succ)) 54 | ;; If the current block was empty, then we need to take 55 | ;; the exceptions from the successor block. It doesn't 56 | ;; hurt to do this unconditionally. 57 | (setf (elcomp--basic-block-exceptions bb) 58 | (elcomp--basic-block-exceptions succ)) 59 | (setf rewrote-one t) 60 | (setf ever-rewrote-one t))))))) 61 | (when ever-rewrote-one 62 | (elcomp--invalidate-cfg compiler)))) 63 | 64 | (provide 'elcomp/coalesce) 65 | 66 | ;;; coalesce.el ends here 67 | -------------------------------------------------------------------------------- /elcomp/comp-debug.el: -------------------------------------------------------------------------------- 1 | ;;; comp-debug.el --- Debugging the compiler. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Debugging helpers for the compiler. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | (require 'elcomp/typeinf) 11 | 12 | (cl-defgeneric elcomp--pp (obj _verbose) 13 | "Pretty-print a compiler object. 14 | 15 | OBJ is the object to pretty-print. 16 | VERBOSE non-nil means to write a more verbose description." 17 | (princ obj)) 18 | 19 | ;; FIXME eldoc for cl-defmethod is messed up 20 | (cl-defmethod elcomp--pp ((obj elcomp--set) verbose) 21 | (if verbose 22 | (progn 23 | (princ "set ") 24 | (elcomp--pp (elcomp--sym obj) nil) 25 | (princ " = ") 26 | (elcomp--pp (elcomp--value obj) nil)) 27 | (elcomp--pp (elcomp--sym obj) nil))) 28 | 29 | (cl-defmethod elcomp--pp ((obj elcomp--call) verbose) 30 | (if verbose 31 | (progn 32 | (princ "call ") 33 | (elcomp--pp (elcomp--sym obj) nil) 34 | (princ " = ") 35 | (elcomp--pp (elcomp--func obj) nil) 36 | (when (elcomp--args obj) 37 | (let ((first t)) 38 | (dolist (arg (elcomp--args obj)) 39 | (princ (if first "(" " ")) 40 | (setf first nil) 41 | (elcomp--pp arg nil)) 42 | (princ ")")))) 43 | (elcomp--pp (elcomp--sym obj) nil))) 44 | 45 | (cl-defmethod elcomp--pp ((obj elcomp--goto) _verbose) 46 | (princ "goto BB ") 47 | (princ (elcomp--basic-block-number (elcomp--block obj)))) 48 | 49 | (cl-defmethod elcomp--pp ((obj elcomp--if) _verbose) 50 | (princ "if ") 51 | (elcomp--pp (elcomp--sym obj) nil) 52 | (princ " BB ") 53 | (princ (elcomp--basic-block-number (elcomp--block-true obj))) 54 | (princ " else BB ") 55 | (princ (elcomp--basic-block-number (elcomp--block-false obj)))) 56 | 57 | (cl-defmethod elcomp--pp ((obj elcomp--return) _verbose) 58 | (princ "return ") 59 | (elcomp--pp (elcomp--sym obj) nil)) 60 | 61 | (cl-defmethod elcomp--pp ((obj elcomp--constant) _verbose) 62 | (princ "<< ") 63 | (princ (elcomp--value obj)) 64 | (princ " >>")) 65 | 66 | (cl-defmethod elcomp--pp ((obj elcomp--phi) verbose) 67 | (princ "ϕ:") 68 | (princ (elcomp--original-name obj)) 69 | (when verbose 70 | (princ " =") 71 | (maphash (lambda (item _ignore) 72 | (princ " ") 73 | (elcomp--pp item nil)) 74 | (elcomp--args obj)))) 75 | 76 | (cl-defmethod elcomp--pp ((obj elcomp--argument) _verbose) 77 | (princ "argument ") 78 | (princ (elcomp--original-name obj))) 79 | 80 | (cl-defmethod elcomp--pp ((obj elcomp--catch) _verbose) 81 | (princ "catch ") 82 | (princ (elcomp--tag obj)) 83 | (princ " => BB ") 84 | (princ (elcomp--basic-block-number (elcomp--handler obj)))) 85 | 86 | (cl-defmethod elcomp--pp ((obj elcomp--condition-case) _verbose) 87 | (princ "condition-case ") 88 | (princ (elcomp--condition-name obj)) 89 | (princ " => BB ") 90 | (princ (elcomp--basic-block-number (elcomp--handler obj)))) 91 | 92 | (cl-defmethod elcomp--pp ((obj elcomp--unwind-protect) _verbose) 93 | (princ "unwind-protect => BB ") 94 | (princ (elcomp--basic-block-number (elcomp--handler obj)))) 95 | 96 | (cl-defmethod elcomp--pp ((obj elcomp--fake-unwind-protect) _verbose) 97 | (princ "fake-unwind-protect ") 98 | (princ (elcomp--count obj))) 99 | 100 | (defun elcomp--pp-insn (text insn verbose) 101 | (princ text) 102 | (princ " ") 103 | (elcomp--pp insn verbose) 104 | (princ "\n")) 105 | 106 | (defun elcomp--pp-basic-block (bb) 107 | (princ (format "\n[BB %d" 108 | (elcomp--basic-block-number bb))) 109 | (when (and (elcomp--basic-block-parents bb) 110 | (> (hash-table-count (elcomp--basic-block-parents bb)) 0)) 111 | (princ " (parents:") 112 | (maphash (lambda (parent-bb _ignore) 113 | (princ (format " %d" (elcomp--basic-block-number parent-bb)))) 114 | (elcomp--basic-block-parents bb)) 115 | (princ ")")) 116 | (princ (format " (idom: %s)" 117 | (if (elcomp--basic-block-immediate-dominator bb) 118 | (elcomp--basic-block-number 119 | (elcomp--basic-block-immediate-dominator bb)) 120 | "nil"))) 121 | (princ "]\n") 122 | (dolist (exception (elcomp--basic-block-exceptions bb)) 123 | (princ " ") 124 | (elcomp--pp exception (current-buffer)) 125 | (princ "\n")) 126 | (when (elcomp--basic-block-phis bb) 127 | (maphash (lambda (_ignore_name phi) 128 | (princ " ") 129 | (elcomp--pp phi t) 130 | (let ((type (elcomp--look-up-type bb phi))) 131 | (when type 132 | (princ " ; TYPE = ") 133 | (princ type))) 134 | (princ "\n")) 135 | (elcomp--basic-block-phis bb))) 136 | (dolist (item (elcomp--basic-block-code bb)) 137 | (elcomp--pp item (current-buffer)) 138 | (let ((type (elcomp--look-up-type bb item))) 139 | (when type 140 | (princ " ; TYPE = ") 141 | (princ type))) 142 | (princ "\n"))) 143 | 144 | (defun elcomp--pp-compiler (compiler &optional title) 145 | "Pretty-print the contents of COMPILER into the current buffer." 146 | (when title 147 | (insert "==== " title "\n")) 148 | (elcomp--iterate-over-bbs compiler #'elcomp--pp-basic-block) 149 | (insert "\n=============================================================\n")) 150 | 151 | (defun elcomp--pp-unit (unit) 152 | (maphash (lambda (_ignore compiler) (elcomp--pp-compiler compiler)) 153 | (elcomp--compilation-unit-defuns unit))) 154 | 155 | (provide 'elcomp/comp-debug) 156 | 157 | ;;; comp-debug.el ends here 158 | -------------------------------------------------------------------------------- /elcomp/cprop.el: -------------------------------------------------------------------------------- 1 | ;;; cprop.el --- Constant propagation. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This pass does constant propagation, copy propagation, and 6 | ;; evaluation of pure functions. 7 | 8 | ;;; Code: 9 | 10 | (require 'elcomp) 11 | (require 'elcomp/dce) 12 | (require 'elcomp/props) 13 | (require 'elcomp/subst) 14 | 15 | (defun elcomp--cprop-insert (rewrite-map from to) 16 | (puthash from (or (gethash to rewrite-map) to) rewrite-map)) 17 | 18 | (defun elcomp--cprop-basic (compiler) 19 | "Do constant and copy propagation. 20 | Return non-nil if anything was changed." 21 | (let ((rewrites nil)) 22 | (elcomp--iterate-over-bbs 23 | compiler 24 | (lambda (bb) 25 | (dolist (insn (elcomp--basic-block-code bb)) 26 | ;; We can eliminate SET instructions in general. This 27 | ;; handles both constant and copy propagation. 28 | (when (elcomp--set-p insn) 29 | (unless rewrites 30 | (setf rewrites (make-hash-table))) 31 | (elcomp--cprop-insert rewrites insn (elcomp--value insn)))))) 32 | 33 | (when rewrites 34 | (elcomp--rewrite-using-map compiler rewrites) 35 | t))) 36 | 37 | (cl-defun elcomp--all-arguments-constant (call) 38 | (dolist (arg (elcomp--args call)) 39 | (unless (elcomp--constant-p arg) 40 | (cl-return-from elcomp--all-arguments-constant nil))) 41 | t) 42 | 43 | (defun elcomp--cprop-pure (compiler) 44 | (let ((rewrites (make-hash-table))) 45 | (elcomp--iterate-over-bbs 46 | compiler 47 | (lambda (bb) 48 | ;; Remove phis that have a single argument. 49 | ;; FIXME with a loop can we see ϕ1 -> ϕ1 ϕ2? 50 | ;; That is a self-reference? 51 | (maphash 52 | (lambda (_ignore phi) 53 | (when (eq (hash-table-count (elcomp--args phi)) 1) 54 | (elcomp--cprop-insert rewrites phi 55 | (elcomp--any-hash-key (elcomp--args phi))))) 56 | (elcomp--basic-block-phis bb)) 57 | ;; Perform other optimizations. 58 | (dolist (insn (elcomp--basic-block-code bb)) 59 | (when (and (elcomp--call-p insn) 60 | (elcomp--func-pure-p (elcomp--func insn)) 61 | (elcomp--all-arguments-constant insn)) 62 | (let ((new-value 63 | (apply (elcomp--func insn) 64 | (mapcar (lambda (arg) 65 | (elcomp--value arg)) 66 | (elcomp--args insn))))) 67 | (elcomp--cprop-insert rewrites insn 68 | (elcomp--constant :value new-value))))))) 69 | 70 | (when (> (hash-table-count rewrites) 0) 71 | (elcomp--rewrite-using-map compiler rewrites) 72 | t))) 73 | 74 | (defun elcomp--cprop-pass (compiler) 75 | "A constant- and copy-propagation pass. 76 | 77 | This pass operates on COMPILER, performing constant- and 78 | copy-propagation. It also evaluates `pure' functions and removes 79 | unnecessary phis." 80 | (while (and (elcomp--cprop-basic compiler) 81 | (prog1 82 | (elcomp--cprop-pure compiler) 83 | (elcomp--dce-pass compiler))) 84 | ;; Nothing. 85 | nil)) 86 | 87 | (provide 'elcomp/cprop) 88 | 89 | ;;; cprop.el ends here 90 | -------------------------------------------------------------------------------- /elcomp/dce.el: -------------------------------------------------------------------------------- 1 | ;;; dce.el --- Dead Code Elimination. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; A simple dead code elimination pass. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | (require 'elcomp/props) 11 | 12 | (cl-defstruct elcomp--dce 13 | "A structure that holds the data for a DCE pass. 14 | 15 | An object of this type is allocated when `elcomp--dce-pass' is working. 16 | It holds data internal to the pass." 17 | ;; WORK-LIST holds a list of instructions to mark as needed. 18 | work-list 19 | ;; HASH is a hash table whose keys are instructions which have been 20 | ;; marked as needed. 21 | (hash (make-hash-table))) 22 | 23 | (defun elcomp--dce-add (insn dce) 24 | "Add INSN to the work list of DCE, unless it is already marked." 25 | (push insn (elcomp--dce-work-list dce))) 26 | 27 | (cl-defgeneric elcomp--mark-necessary (insn dce _just-intrinsic) 28 | "Possibly mark the instruction INSN as necessary. 29 | DCE is the DCE state object for the pass. 30 | 31 | If JUST-INTRINSIC is non-nil, then only mark the instruction if 32 | it is intrinsically needed. If it is nil, then mark the 33 | instruction. 34 | 35 | Marking the instruction means adding it to the hash and then 36 | pushing the instruction's arguments onto the work list. 37 | 38 | The default case is to mark a statement as needed." 39 | (puthash insn t (elcomp--dce-hash dce))) 40 | 41 | (cl-defmethod elcomp--mark-necessary ((insn elcomp--if) dce _just-intrinsic) 42 | "`If' statements are marked as needed and their argument is pushed." 43 | ;; An IF is always needed. 44 | (puthash insn t (elcomp--dce-hash dce)) 45 | ;; And so is its reference. 46 | (elcomp--dce-add (elcomp--sym insn) dce)) 47 | 48 | (cl-defmethod elcomp--mark-necessary ((insn elcomp--goto) dce _just-intrinsic) 49 | "`Goto' statements are marked as needed." 50 | ;; A GOTO is always needed. 51 | (puthash insn t (elcomp--dce-hash dce))) 52 | 53 | (cl-defmethod elcomp--mark-necessary ((insn elcomp--return) dce _just-intrinsic) 54 | "`Return' statements are marked as needed and their argument is pushed." 55 | ;; A RETURN is always needed. 56 | (puthash insn t (elcomp--dce-hash dce)) 57 | ;; And so is its reference. 58 | (elcomp--dce-add (elcomp--sym insn) dce)) 59 | 60 | (cl-defmethod elcomp--mark-necessary ((insn elcomp--set) dce just-intrinsic) 61 | "Mark a `set' statement as necessary. 62 | 63 | In the first pass, do nothing. A `set' is not intrinsically needed. 64 | In the second pass, mark this statement as needed, and then push 65 | its references on the work list." 66 | ;; A SET is not intrinsically needed, so check which pass this is. 67 | (unless just-intrinsic 68 | (puthash insn t (elcomp--dce-hash dce)) 69 | (elcomp--dce-add (elcomp--value insn) dce))) 70 | 71 | (cl-defmethod elcomp--mark-necessary ((insn elcomp--phi) dce just-intrinsic) 72 | "Mark a `phi' statement as necessary. 73 | 74 | In the first pass, do nothing. A `phi' is not intrinsically needed. 75 | In the second pass, mark this statement as needed, and then push 76 | its references on the work list." 77 | ;; A PHI is not intrinsically needed, so check which pass this is. 78 | (unless just-intrinsic 79 | (puthash insn t (elcomp--dce-hash dce)) 80 | (maphash (lambda (arg _ignore) 81 | (elcomp--dce-add arg dce)) 82 | (elcomp--args insn)))) 83 | 84 | (cl-defmethod elcomp--mark-necessary ((insn elcomp--call) dce just-intrinsic) 85 | "Mark a `call' statement as necessary." 86 | (let ((push-args nil)) 87 | (if just-intrinsic 88 | ;; A non-const call is intrinsically needed. However, we mark 89 | ;; it specially so we can determine whether its LHS is needed 90 | ;; as well. Note that the "const" check also picks up the 91 | ;; "diediedie" statements. 92 | (unless (elcomp--func-const-p (elcomp--func insn)) 93 | (puthash insn :call (elcomp--dce-hash dce)) 94 | (setf push-args t)) 95 | ;; Otherwise, we're propagating. 96 | (puthash insn t (elcomp--dce-hash dce)) 97 | (setf push-args t)) 98 | (when push-args 99 | ;; Push the arguments on the work list. 100 | (dolist (arg (elcomp--args insn)) 101 | (elcomp--dce-add arg dce))))) 102 | 103 | (defun elcomp--dce-mark-intrinsically-necessary (compiler dce) 104 | "Mark all intrinsically necessary statements. 105 | 106 | This is the first pass of DCE. 107 | 108 | Any intrinsically necessary statement is entered into the `hash' 109 | field of DCE and its references are pushed onto `work-list'." 110 | (elcomp--iterate-over-bbs 111 | compiler 112 | (lambda (bb) 113 | (dolist (insn (elcomp--basic-block-code bb)) 114 | (elcomp--mark-necessary insn dce t))))) 115 | 116 | (defun elcomp--dce-propagate-necessary (dce) 117 | "Propagate the \"necessary\" property through the function. 118 | 119 | This is the second pass of DCE. 120 | 121 | This iterates over the work list, entering statements into the 122 | DCE's `hash' table and pushing references onto the `work-list'." 123 | (while (elcomp--dce-work-list dce) 124 | (let* ((insn (pop (elcomp--dce-work-list dce))) 125 | (mark (gethash insn (elcomp--dce-hash dce)))) 126 | ;; If it is marked as 't', then we don't need to do any more. 127 | ;; If it is marked as :call, upgrade to 't'. 128 | (if mark 129 | (when (eq mark :call) 130 | ;; Upgrade a call. 131 | (puthash insn t (elcomp--dce-hash dce))) 132 | (elcomp--mark-necessary insn dce nil))))) 133 | 134 | (defun elcomp--dce-delete-dead-statements (compiler dce) 135 | "Delete dead statements. 136 | 137 | Iterate over the statements in the function and remove any 138 | statement that has not been marked as necessary." 139 | (elcomp--iterate-over-bbs 140 | compiler 141 | (lambda (bb) 142 | ;; Delete dead statements. 143 | (let ((iter (elcomp--basic-block-code bb))) 144 | (while iter 145 | (let ((mark (gethash (car iter) (elcomp--dce-hash dce)))) 146 | (cl-case mark 147 | ((:call) 148 | ;; We found a call whose result is not needed. Drop the 149 | ;; result if it is an SSA name. 150 | (when (elcomp--ssa-name-p (car iter)) 151 | (setf (elcomp--sym (car iter)) nil))) 152 | ((nil) 153 | ;; Remove the entire instruction. 154 | (setf (car iter) nil)))) 155 | (setf iter (cdr iter)))) 156 | (setf (elcomp--basic-block-code bb) 157 | (delq nil (elcomp--basic-block-code bb))) 158 | ;; Delete dead phi nodes. 159 | (let ((phi-table (elcomp--basic-block-phis bb))) 160 | (maphash (lambda (name phi) 161 | (unless (gethash phi (elcomp--dce-hash dce)) 162 | (remhash name phi-table))) 163 | phi-table))))) 164 | 165 | (defun elcomp--dce-pass (compiler) 166 | "Delete dead code." 167 | (let ((dce (make-elcomp--dce))) 168 | (elcomp--dce-mark-intrinsically-necessary compiler dce) 169 | (elcomp--dce-propagate-necessary dce) 170 | (elcomp--dce-delete-dead-statements compiler dce))) 171 | 172 | (provide 'elcomp/dce) 173 | 174 | ;;; dce.el ends here 175 | -------------------------------------------------------------------------------- /elcomp/dom.el: -------------------------------------------------------------------------------- 1 | ;;; Dominators. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | (require 'elcomp) 8 | (require 'elcomp/back) 9 | 10 | (cl-defun elcomp--first-processed-predecessor (bb) 11 | (maphash 12 | (lambda (pred _ignore) 13 | (if (elcomp--basic-block-immediate-dominator pred) 14 | (cl-return-from elcomp--first-processed-predecessor pred))) 15 | (elcomp--basic-block-parents bb)) 16 | (error "couldn't find processed predecessor in %S" 17 | (elcomp--basic-block-number bb))) 18 | 19 | (defun elcomp--predecessors (bb) 20 | (let ((result nil)) 21 | (maphash 22 | (lambda (pred _ignore) 23 | (push pred result)) 24 | (elcomp--basic-block-parents bb)) 25 | result)) 26 | 27 | (defun elcomp--intersect (bb1 bb2 postorder-number) 28 | (let ((f1 (gethash bb1 postorder-number)) 29 | (f2 (gethash bb2 postorder-number))) 30 | (while (not (eq f1 f2)) 31 | (while (< f1 f2) 32 | (setf bb1 (elcomp--basic-block-immediate-dominator bb1)) 33 | (setf f1 (gethash bb1 postorder-number))) 34 | (while (< f2 f1) 35 | (setf bb2 (elcomp--basic-block-immediate-dominator bb2)) 36 | (setf f2 (gethash bb2 postorder-number)))) 37 | bb1)) 38 | 39 | (defun elcomp--clear-dominators (compiler) 40 | ;; Clear out the old dominators. 41 | (elcomp--iterate-over-bbs 42 | compiler 43 | (lambda (bb) 44 | (setf (elcomp--basic-block-immediate-dominator bb) nil)))) 45 | 46 | (defun elcomp--compute-dominators (compiler) 47 | ;; Require back edges. 48 | (elcomp--require-back-edges compiler) 49 | (elcomp--clear-dominators compiler) 50 | 51 | (let ((nodes (elcomp--postorder compiler)) 52 | reversed 53 | (postorder-number (make-hash-table))) 54 | 55 | ;; Perhaps POSTORDER-NUMBER should simply be an attribute on the 56 | ;; BB. 57 | (let ((i 0)) 58 | (dolist (bb nodes) 59 | (puthash bb i postorder-number) 60 | (cl-incf i))) 61 | 62 | (setf reversed (delq (elcomp--entry-block compiler) (nreverse nodes))) 63 | (setf nodes nil) ; Paranoia. 64 | (setf (elcomp--basic-block-immediate-dominator 65 | (elcomp--entry-block compiler)) 66 | (elcomp--entry-block compiler)) 67 | 68 | (let ((changed t)) 69 | (while changed 70 | (setf changed nil) 71 | (dolist (bb reversed) 72 | (let ((new-idom (elcomp--first-processed-predecessor bb))) 73 | (dolist (pred (elcomp--predecessors bb)) 74 | (unless (eq new-idom pred) 75 | (if (elcomp--basic-block-immediate-dominator pred) 76 | (setf new-idom (elcomp--intersect pred new-idom 77 | postorder-number))))) 78 | (unless (eq new-idom 79 | (elcomp--basic-block-immediate-dominator bb)) 80 | (setf (elcomp--basic-block-immediate-dominator bb) new-idom) 81 | (setf changed t)))))))) 82 | 83 | (provide 'elcomp/dom) 84 | 85 | ;;; dom.el ends here 86 | -------------------------------------------------------------------------------- /elcomp/eh-cleanup.el: -------------------------------------------------------------------------------- 1 | ;;; eh-cleanup.el --- Clean up exceptions. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; A pass to remove obviously-dead exception edges. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | (require 'elcomp/back) 11 | (require 'elcomp/props) 12 | 13 | (cl-defgeneric elcomp--can-throw (_insn) 14 | "Return t if INSN can `throw' or `signal', otherwise nil. 15 | 16 | The base case is to assume any instruction can throw." 17 | t) 18 | 19 | (cl-defmethod elcomp--can-throw ((_insn elcomp--set)) 20 | "A `set' instruction cannot throw." 21 | nil) 22 | 23 | (cl-defmethod elcomp--can-throw ((_insn elcomp--goto)) 24 | "A `goto' instruction cannot throw." 25 | nil) 26 | 27 | (cl-defmethod elcomp--can-throw ((_insn elcomp--if)) 28 | "An `if' instruction cannot throw." 29 | nil) 30 | 31 | (cl-defmethod elcomp--can-throw ((_insn elcomp--return)) 32 | "A `return' instruction cannot throw." 33 | nil) 34 | 35 | (cl-defmethod elcomp--can-throw ((insn elcomp--call)) 36 | "A `call' instruction usually can throw. 37 | A function marked `nothrow' will not throw." 38 | ;; Note that we can't really be picky about `signal' or `throw' 39 | ;; tags, due to QUIT and `throw-on-input'. 40 | (if (and (symbolp (elcomp--func insn)) 41 | (elcomp--func-nothrow-p (elcomp--func insn))) 42 | nil 43 | t)) 44 | 45 | (cl-defmethod elcomp--can-throw ((_insn elcomp--diediedie)) 46 | "A `diediedie' instruction always throws." 47 | t) 48 | 49 | (cl-defun elcomp--eh-remove-unwinds (bb) 50 | "Remove any empty `unwind-protect' edges from the basic block BB. 51 | 52 | An empty `unwind-protect' edge is one where the target block 53 | consists of just a call to the special `:unwind-protect-continue' 54 | function." 55 | ;; There's probably some cl-loop formulation that isn't so ugly. 56 | (while t 57 | (let ((exception (car (elcomp--basic-block-exceptions bb)))) 58 | ;; Only the outermost exception edge is eligible for removal. 59 | (unless (elcomp--unwind-protect-p exception) 60 | (cl-return-from elcomp--eh-remove-unwinds nil)) 61 | (let ((exc-block (elcomp--handler exception))) 62 | (when exc-block 63 | ;; If the block is just a single instruction, then we know 64 | ;; it is a call to the special :unwind-protect-continue 65 | ;; function, and so the edge can be removed. 66 | (unless (eq (elcomp--basic-block-code exc-block) 67 | (elcomp--basic-block-code-link exc-block)) 68 | (cl-return-from elcomp--eh-remove-unwinds nil)) 69 | (cl-assert (elcomp--diediedie-p 70 | (car (elcomp--basic-block-code exc-block)))) 71 | (pop (elcomp--basic-block-exceptions bb))))))) 72 | 73 | (defun elcomp--eh-cleanup-pass (compiler) 74 | "Remove useless exception handling edges from a function. 75 | 76 | This operates on the function currently being defined in COMPILER. 77 | 78 | This pass will remove useless `unwind-protect' edges. See 79 | `elcomp--eh-remove-unwinds'. 80 | 81 | It will also remove all exception edges from a basic block if 82 | that block has no instructions which may throw." 83 | (let ((found-one nil)) 84 | (elcomp--iterate-over-bbs 85 | compiler 86 | (lambda (bb) 87 | (elcomp--eh-remove-unwinds bb) 88 | ;; Don't bother if there are already no exception handlers. 89 | (when (elcomp--basic-block-exceptions bb) 90 | (unless (cl-dolist (insn (elcomp--basic-block-code bb)) 91 | (when (elcomp--can-throw insn) 92 | (cl-return t))) 93 | ;; Since nothing here can throw, we can remove the 94 | ;; exception handlers. 95 | (setf (elcomp--basic-block-exceptions bb) nil) 96 | (setf found-one t))))) 97 | (when found-one 98 | (elcomp--invalidate-cfg compiler)))) 99 | 100 | (provide 'elcomp/eh-cleanup) 101 | 102 | ;;; eh-cleanup.el ends here 103 | -------------------------------------------------------------------------------- /elcomp/eltoc.el: -------------------------------------------------------------------------------- 1 | ;;; eltoc.el --- compile to C. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; A backend to generate Emacs-flavored C. 6 | 7 | ;; TO DO: 8 | ;; emit constants properly 9 | ;; handle phi nodes 10 | ;; emit lambdas without using DEFUN; call them directly 11 | ;; 12 | ;; We should also allow a declaration that allows a direct C 13 | ;; call, not allowing symbol redefinition. 14 | ;; (declare (direct FUNC)) 15 | 16 | ;;; Code: 17 | 18 | (require 'subr-x) 19 | (require 'elcomp) 20 | (require 'elcomp/c-inl) 21 | (require 'elcomp/c-renames) 22 | (require 'elcomp/dom) 23 | (require 'elcomp/linearize) 24 | (require 'elcomp/name-map) 25 | (require 'elcomp/props) 26 | 27 | ;; FIXME - emacs must supply this value 28 | (defconst elcomp--c-max-args 8) 29 | 30 | (cl-defstruct elcomp--c 31 | decls 32 | decl-marker 33 | ;; Map symbols to their C names. 34 | interned-symbols 35 | ;; Map SSA names to their defining blocks. 36 | ;; This is a hack because we don't have a good out-of-ssa approach 37 | ;; yet. 38 | name-map 39 | (eh-count 0)) 40 | 41 | (defun elcomp--c-quote-string (str) 42 | "Quote a Lisp string according to C rules." 43 | (concat "\"" 44 | (mapconcat (lambda (c) 45 | ;; Not really complete yet. 46 | (cl-case c 47 | ((?\\ ?\") 48 | (string ?\\ c)) 49 | (?\n "\\n") 50 | (?\r "\\r") 51 | (?\t "\\t") 52 | (t (string c)))) 53 | str "") 54 | "\"")) 55 | 56 | (defun elcomp--c-name (symbol) 57 | "Compute the C name for a symbol." 58 | ;; FIXME there can be name clashes, and leading number is not handled. 59 | (replace-regexp-in-string "[^a-zA-Z0-9_]" "_" (symbol-name symbol))) 60 | 61 | (defun elcomp--c-intern-symbol (eltoc symbol) 62 | "Mark a symbol for init-time interning and return its name. 63 | This is used for references to global symbols." 64 | (or (gethash symbol (elcomp--c-interned-symbols eltoc)) 65 | ;; Use LQsym, not Qsym, to avoid clashes with things Emacs 66 | ;; defines itself. 67 | (puthash symbol (concat "LQ" (elcomp--c-name symbol)) 68 | (elcomp--c-interned-symbols eltoc)))) 69 | 70 | (defun elcomp--c-declare (eltoc sym) 71 | (unless (gethash sym (elcomp--c-decls eltoc)) 72 | (save-excursion 73 | (goto-char (elcomp--c-decl-marker eltoc)) 74 | (insert " Lisp_Object " (elcomp--c-name sym) ";\n") 75 | (puthash sym t (elcomp--c-decls eltoc))))) 76 | 77 | (defun elcomp--c-declare-handler (eltoc) 78 | (let ((name (format "h%d" (cl-incf (elcomp--c-eh-count eltoc))))) 79 | (save-excursion 80 | (goto-char (elcomp--c-decl-marker eltoc)) 81 | (insert " struct handler *" name ";\n") 82 | name))) 83 | 84 | (defun elcomp--c-symbol (eltoc sym &optional no-declare) 85 | (unless no-declare 86 | (elcomp--c-declare eltoc sym)) 87 | (insert (elcomp--c-name sym))) 88 | 89 | ;; FIXME - in emacs 25 this can be a generic. 90 | (defun elcomp--c-emit-symref (eltoc insn) 91 | (cond 92 | ((symbolp insn) 93 | (insert (elcomp--c-intern-symbol eltoc insn))) 94 | ((elcomp--set-p insn) 95 | (elcomp--c-symbol eltoc (elcomp--sym insn))) 96 | ((elcomp--call-p insn) 97 | (elcomp--c-symbol eltoc (elcomp--sym insn))) 98 | ((elcomp--phi-p insn) 99 | ;; FIXME?? 100 | (elcomp--c-symbol eltoc (elcomp--original-name insn))) 101 | ((elcomp--argument-p insn) 102 | (elcomp--c-symbol eltoc (elcomp--original-name insn) t)) 103 | ((elcomp--constant-p insn) 104 | (let ((value (elcomp--value insn))) 105 | (cond 106 | ;; FIXME - in emacs 25 this can be a generic. 107 | ((symbolp value) 108 | (insert (elcomp--c-intern-symbol eltoc value))) 109 | ((integerp value) 110 | (insert "make_number (" (number-to-string value) ")")) 111 | ((stringp value) 112 | ;; Could use make_string, but there's little point since GCC 113 | ;; will optimize the strlen anyhow. 114 | (insert "build_string (" (elcomp--c-quote-string value) ")")) 115 | ((cl-typep value 'elcomp) 116 | (insert "K" (elcomp--c-name (elcomp--get-name value)))) 117 | (t 118 | ;: FIXME why does calling error here cause problems? 119 | ;; Anyway this ought to emit some initialization code to 120 | ;; construct non-primitve constants. 121 | ;; (error "unhandled constant of type %S" (type-of value)) 122 | (insert "BUG in elcomp--c-emit-symref"))))) 123 | (t 124 | (error "unhandled case: %S" insn)))) 125 | 126 | (defun elcomp--c-emit-label (block) 127 | (insert (format "BB_%d" (elcomp--basic-block-number block)))) 128 | 129 | (cl-defgeneric elcomp--c-emit (insn _eltoc _bb) 130 | "FIXME" 131 | (error "unhandled case: %S" insn)) 132 | 133 | (cl-defmethod elcomp--c-emit ((insn elcomp--set) eltoc _bb) 134 | (elcomp--c-emit-symref eltoc insn) 135 | (insert " = ") 136 | (elcomp--c-emit-symref eltoc (elcomp--value insn))) 137 | 138 | (defun elcomp--unbind-emitter (insn) 139 | "Emit a call to :elcomp-unbind. 140 | This must be handled specially for now to avoid boxing the 141 | argument." 142 | (let* ((args (elcomp--args insn)) 143 | (first-arg (car args))) 144 | (cl-assert (eq (length args) 1)) 145 | (cl-assert (elcomp--constant-p first-arg)) 146 | (let ((value (elcomp--value first-arg))) 147 | (cl-assert (integerp value)) 148 | (insert "unbind_to (SPECPDL_INDEX - " 149 | (number-to-string value) 150 | ", Qnil)")))) 151 | 152 | (defconst elcomp--c-direct-renames 153 | '((:elcomp-specbind . "specbind") 154 | (:elcomp-fetch-condition . "signal_value") 155 | (:save-excursion-save . "save_excursion_save") 156 | (:save-excursion-restore . "save_excursion_restore") 157 | (:save-restriction-save . "save_restriction_save") 158 | (:save-restriction-restore . "save_restriction_restore") 159 | (:unwind-protect-continue . "unwind_protect_continue") 160 | (:catch-value . "catch_value") 161 | (:pop-exception-handler . "pop_exception_handler") 162 | ;; FIXME 163 | (:ffi-call . "FFI_CALL"))) 164 | 165 | (defconst elcomp--c-numeric-comparisons '(> >= < <= =)) 166 | 167 | (defun elcomp--c-numeric-comparison-p (function args bb) 168 | (and (memq function elcomp--c-numeric-comparisons) 169 | (> (length args) 1) 170 | (cl-every (lambda (arg) 171 | (let ((type (elcomp--look-up-type bb arg))) 172 | (or (eq type 'integer) 173 | (eq type 'float)))) 174 | args))) 175 | 176 | (defun elcomp--c-numeric-comparison (function args eltoc bb) 177 | (let* ((operator (if (eq function '=) 178 | "==" 179 | (symbol-name function))) 180 | (unwrapper (lambda (arg) 181 | (if (elcomp--constant-p arg) 182 | (insert (format "%s" (elcomp--value arg))) 183 | (insert 184 | (if (eq (elcomp--look-up-type bb arg) 'integer) 185 | "XINT" 186 | "XFLOAT_DATA") 187 | " (") 188 | (elcomp--c-emit-symref eltoc arg) 189 | (insert ")")))) 190 | (prev (car args)) 191 | (first t)) 192 | (insert "(") 193 | (dolist (arg (cdr args)) 194 | (if first 195 | (setf first nil) 196 | (insert " && ")) 197 | (funcall unwrapper prev) 198 | (insert " " operator " ") 199 | (funcall unwrapper arg) 200 | (setf prev arg)) 201 | (insert ") ? Qt : Qnil"))) 202 | 203 | (defun elcomp--c-unary-numeric-op-p (function args bb) 204 | (and (memq function '(1+ 1- -)) 205 | (eq (length args) 1) 206 | (cl-every (lambda (arg) 207 | (let ((type (elcomp--look-up-type bb arg))) 208 | (or (eq type 'integer) 209 | (eq type 'float)))) 210 | args))) 211 | 212 | (defun elcomp--c-unary-numeric-op (function args eltoc bb) 213 | (cl-assert (eq (length args) 1)) 214 | (let* ((arg (car args)) 215 | (type (elcomp--look-up-type bb arg)) 216 | (maker (if (eq type 'integer) 217 | "make_number" 218 | "make_float")) 219 | (unwrapper (if (eq type 'integer) 220 | "XINT" 221 | "XFLOAT_DATA"))) 222 | (cl-case function 223 | ((1+) 224 | (insert maker " (" unwrapper " (") 225 | (elcomp--c-emit-symref eltoc arg) 226 | (insert ") + 1)")) 227 | ((1-) 228 | (insert maker " (" unwrapper " (") 229 | (elcomp--c-emit-symref eltoc arg) 230 | (insert ") - 1)")) 231 | ((-) 232 | (insert maker " (-" unwrapper " (") 233 | (elcomp--c-emit-symref eltoc arg) 234 | (insert "))")) 235 | (t 236 | (error "whoops %S" function))))) 237 | 238 | (cl-defmethod elcomp--c-emit ((insn elcomp--call) eltoc bb) 239 | (when (elcomp--sym insn) 240 | (elcomp--c-emit-symref eltoc insn) 241 | (insert " = ")) 242 | (cond 243 | ((eq (elcomp--func insn) :elcomp-unbind) 244 | (elcomp--unbind-emitter insn)) 245 | 246 | ((elcomp--c-numeric-comparison-p (elcomp--func insn) (elcomp--args insn) bb) 247 | (elcomp--c-numeric-comparison (elcomp--func insn) (elcomp--args insn) 248 | eltoc bb)) 249 | 250 | ((elcomp--c-unary-numeric-op-p (elcomp--func insn) (elcomp--args insn) bb) 251 | (elcomp--c-unary-numeric-op (elcomp--func insn) (elcomp--args insn) 252 | eltoc bb)) 253 | 254 | (t 255 | (let* ((function 256 | (or (elcomp--c-opt insn 257 | (mapcar (lambda (arg) 258 | (elcomp--look-up-type bb arg)) 259 | (elcomp--args insn))) 260 | (elcomp--func insn))) 261 | (arg-list (elcomp--args insn)) 262 | (is-direct (elcomp--func-direct-p function)) 263 | (is-vararg nil)) 264 | (cond 265 | ((stringp function) ; Was optimized by elcomp--c-opt. 266 | (insert function " (")) 267 | ((keywordp function) 268 | (insert (or (cdr (assq function elcomp--c-direct-renames)) 269 | (format "BUG«%S»" function)) 270 | " (") 271 | ;; FIXME hack 272 | (when (memq function '(:catch-value :elcomp-fetch-condition 273 | :unwind-protect-continue)) 274 | (insert "&prev_handler"))) 275 | (is-direct 276 | (if-let ((rename (assq function elcomp--c-renames))) 277 | (insert (cdr rename) " (") 278 | (insert "F" (elcomp--c-name function) " (")) 279 | (when (and (symbolp function) 280 | (fboundp function) 281 | (subrp (symbol-function function)) 282 | (eq (cdr (subr-arity (symbol-function function))) 'many)) 283 | (insert (format "%d, ((Lisp_Object[]) { " (length arg-list))) 284 | (setf is-vararg t))) 285 | (t 286 | (push function arg-list) 287 | ;; FIXME - what if not a symbol, etc. 288 | (setf is-vararg t) 289 | (insert (format "Ffuncall (%d, ((Lisp_Object[]) { " 290 | (length arg-list))))) 291 | (let ((first t)) 292 | (dolist (arg arg-list) 293 | (if first 294 | (setf first nil) 295 | (insert ", ")) 296 | (elcomp--c-emit-symref eltoc arg))) 297 | (if is-vararg 298 | (insert " }))") 299 | (insert ")")))))) 300 | 301 | (defun elcomp--c-set-phis-on-entry (eltoc this-bb target-bb) 302 | (maphash 303 | (lambda (_name phi) 304 | (insert " ") 305 | (elcomp--c-emit-symref eltoc phi) 306 | (insert " = ") 307 | (cl-block done 308 | ;; This algorithm sucks. 309 | (let ((check-bb this-bb)) 310 | (while t 311 | (maphash 312 | (lambda (arg _ignore) 313 | (when (eq (gethash arg (elcomp--c-name-map eltoc)) check-bb) 314 | (elcomp--c-emit-symref eltoc arg) 315 | (cl-return-from done))) 316 | (elcomp--args phi)) 317 | (when (eq check-bb 318 | (elcomp--basic-block-immediate-dominator check-bb)) 319 | (cl-return-from done)) 320 | (setf check-bb 321 | (elcomp--basic-block-immediate-dominator check-bb))))) 322 | (insert ";\n")) 323 | (elcomp--basic-block-phis target-bb))) 324 | 325 | (cl-defmethod elcomp--c-emit ((insn elcomp--goto) eltoc bb) 326 | (elcomp--c-set-phis-on-entry eltoc bb (elcomp--block insn)) 327 | (insert " goto ") 328 | (elcomp--c-emit-label (elcomp--block insn))) 329 | 330 | (cl-defmethod elcomp--c-emit ((insn elcomp--if) eltoc bb) 331 | (insert "if (!NILP (") 332 | (elcomp--c-emit-symref eltoc (elcomp--sym insn)) 333 | (insert "))\n") 334 | (insert " {\n") 335 | (elcomp--c-set-phis-on-entry eltoc bb (elcomp--block-true insn)) 336 | (insert " goto ") 337 | (elcomp--c-emit-label (elcomp--block-true insn)) 338 | (insert ";\n") 339 | (insert " }\n") 340 | (insert " else\n") 341 | (insert " {\n") 342 | (elcomp--c-set-phis-on-entry eltoc bb (elcomp--block-false insn)) 343 | (insert " goto ") 344 | (elcomp--c-emit-label (elcomp--block-false insn)) 345 | (insert ";\n") 346 | (insert " }")) 347 | 348 | (cl-defmethod elcomp--c-emit ((insn elcomp--return) eltoc _bb) 349 | (insert "return ") 350 | (elcomp--c-emit-symref eltoc (elcomp--sym insn))) 351 | 352 | (cl-defmethod elcomp--c-emit ((insn elcomp--catch) eltoc _bb) 353 | (let ((name (elcomp--c-declare-handler eltoc))) 354 | (insert " " name " = push_handler (") 355 | (elcomp--c-emit-symref eltoc (elcomp--tag insn)) 356 | (insert ", CATCHER);\n") 357 | (insert " if (sys_setjmp (" name "->jmp))\n") 358 | (insert " {\n") 359 | (insert " eassert (handlerlist == " name ");\n") 360 | (insert " exit_exception_handler ();\n") 361 | (insert " goto ") 362 | (elcomp--c-emit-label (elcomp--handler insn)) 363 | (insert ";\n") 364 | (insert " }\n"))) 365 | 366 | (cl-defmethod elcomp--c-emit ((_insn elcomp--condition-case) _eltoc _bb) 367 | ;; This one is handled specially for efficiency. 368 | (error "should not be called")) 369 | 370 | (cl-defmethod elcomp--c-emit ((insn elcomp--unwind-protect) eltoc _bb) 371 | (let ((name (elcomp--c-declare-handler eltoc))) 372 | ;; Emacs doesn't actually have anything for this yet. 373 | (insert " " name " = push_handler (Qnil, CATCHER_ALL);\n") 374 | (insert " if (sys_setjmp (" name "->jmp))\n") 375 | (insert " {\n") 376 | (insert " eassert (handlerlist == " name ");\n") 377 | (insert " exit_exception_handler ();\n") 378 | (insert " goto ") 379 | (elcomp--c-emit-label (elcomp--handler insn)) 380 | (insert ";\n") 381 | (insert " }\n"))) 382 | 383 | (cl-defmethod elcomp--c-emit ((_insn elcomp--fake-unwind-protect) _eltoc _bb) 384 | ;; Nothing. 385 | ) 386 | 387 | (defun elcomp--c-emit-condition-case (eltoc eh-from eh-to) 388 | (let ((name (elcomp--c-declare-handler eltoc))) 389 | ;; The magic Qt means to stop on all conditions; see 390 | ;; eval.c:find_handler_clause. 391 | (insert " " name " = push_handler (Qt, CONDITION_CASE);\n") 392 | (insert " if (sys_setjmp (" name "->jmp))\n") 393 | (insert " {\n") 394 | (insert " eassert (handlerlist == " name ");\n") 395 | (insert " exit_exception_handler ();\n") 396 | (while (and (not (eq eh-from eh-to)) 397 | (elcomp--condition-case-p (car eh-from))) 398 | (insert " if (!NILP (find_handler_clause (") 399 | (elcomp--c-emit-symref eltoc (elcomp--condition-name (car eh-from))) 400 | (insert ", signal_conditions (&prev_handler))))\n") 401 | (insert " goto ") 402 | (elcomp--c-emit-label (elcomp--handler (car eh-from))) 403 | (insert ";\n") 404 | (setf eh-from (cdr eh-from))) 405 | (insert " }\n")) 406 | eh-from) 407 | 408 | (defun elcomp--c-first-parent (block) 409 | (elcomp--any-hash-key (elcomp--basic-block-parents block))) 410 | 411 | (defun elcomp--c-emit-exceptions (eltoc block) 412 | (let* ((first-parent (elcomp--c-first-parent block)) 413 | (parent-eh (if first-parent 414 | (elcomp--basic-block-exceptions first-parent) 415 | ;; No parent means it is the first block. 416 | nil))) 417 | (let ((bb-eh (elcomp--basic-block-exceptions block))) 418 | (when (and (not (or (memq (car bb-eh) parent-eh) 419 | (and parent-eh (not bb-eh)))) 420 | bb-eh) 421 | ;; If our first exception does not appear in the parent 422 | ;; list, then we have to push at least one. 423 | (while (and bb-eh (not (eq bb-eh parent-eh))) 424 | (if (elcomp--condition-case-p (car bb-eh)) 425 | (setf bb-eh (elcomp--c-emit-condition-case eltoc bb-eh 426 | parent-eh)) 427 | (elcomp--c-emit (car bb-eh) eltoc block) 428 | (setf bb-eh (cdr bb-eh)))))))) 429 | 430 | (defun elcomp--c-emit-block (eltoc bb) 431 | (elcomp--c-emit-label bb) 432 | (insert ":\n") 433 | (elcomp--c-emit-exceptions eltoc bb) 434 | (dolist (insn (elcomp--basic-block-code bb)) 435 | (insert " ") 436 | (elcomp--c-emit insn eltoc bb) 437 | (insert ";\n"))) 438 | 439 | (defun elcomp--c-parse-args (arg-list) 440 | (let ((min-args 0)) 441 | (while (and arg-list (not (memq (car arg-list) '(&optional &rest)))) 442 | (pop arg-list) 443 | (cl-incf min-args)) 444 | (let ((max-args min-args)) 445 | (while (eq (car arg-list) '&optional) 446 | (pop arg-list) 447 | (pop arg-list) 448 | (cl-incf max-args)) 449 | (if (or (eq (car arg-list) '&rest) 450 | (> max-args elcomp--c-max-args)) 451 | (cons min-args "MANY") 452 | (cons min-args max-args))))) 453 | 454 | (defun elcomp--c-generate-defun (compiler) 455 | (let* ((info (elcomp--defun compiler)) 456 | (sym (elcomp--get-name compiler)) 457 | (c-name (elcomp--c-name sym)) 458 | (arg-info (elcomp--c-parse-args (cadr info)))) 459 | (insert 460 | (format "DEFUN (%s, F%s, S%s, %s, %s,\n %s,\n doc: /* %s */)\n" 461 | (elcomp--c-quote-string (symbol-name sym)) 462 | c-name c-name 463 | (car arg-info) (cdr arg-info) 464 | ;; Interactive. 465 | ;; FIXME: quoting for the interactive spec 466 | ;; Note that we can have a whole lisp form here. 467 | (or (nth 3 info) "0") 468 | ;; Doc string. FIXME - comment quoting 469 | (or (nth 2 info) "nothing??"))) ;FIXME anything? 470 | (if (equal (cdr arg-info) "MANY") 471 | (let ((nargs (elcomp--c-name (cl-gensym "nargs"))) 472 | (args (elcomp--c-name (cl-gensym "args")))) 473 | (insert " (ptrdiff_t " nargs ", Lisp_Object *" args ")\n{\n") 474 | ;; We need special parsing for &rest arguments or when the 475 | ;; number of format arguments is greater than the maximum. 476 | ;; First emit the declarations. 477 | (dolist (arg (cadr info)) 478 | (unless (memq arg '(&optional &rest)) 479 | (insert " Lisp_Object " (symbol-name arg) " = Qnil;\n"))) 480 | ;; Now initialize each one. 481 | (let ((is-rest nil)) 482 | (dolist (arg (cadr info)) 483 | (cond 484 | ((eq arg '&rest) 485 | (setf is-rest t)) 486 | ((eq arg '&optional) 487 | ;; Nothing. 488 | ) 489 | (t 490 | (if is-rest 491 | (insert " " (symbol-name arg) " = Flist (" 492 | nargs ", " args ");\n") 493 | (insert " if (" nargs " > 0)\n" 494 | " {\n" 495 | " " (symbol-name arg) " = *" args "++;\n" 496 | " --" nargs ";\n" 497 | " }\n"))))))) 498 | (insert " (") 499 | (let ((first t)) 500 | (dolist (arg (cadr info)) 501 | (unless (eq arg '&optional) 502 | (unless first 503 | (insert ", ")) 504 | (setf first nil) 505 | (insert "Lisp_Object " (symbol-name arg))))) 506 | (insert ")\n{\n")))) 507 | 508 | (defun elcomp--c-translate-one (compiler symbol-hash) 509 | (elcomp--require-back-edges compiler) 510 | (elcomp--compute-dominators compiler) 511 | (let ((eltoc (make-elcomp--c :decls (make-hash-table) 512 | :decl-marker (make-marker) 513 | :interned-symbols symbol-hash 514 | :name-map (elcomp--make-name-map compiler)))) 515 | (elcomp--c-generate-defun compiler) 516 | ;; This approach is pretty hacky. 517 | (insert " struct handler prev_handler;\n") 518 | (set-marker (elcomp--c-decl-marker eltoc) (point)) 519 | (insert "\n") 520 | (set-marker-insertion-type (elcomp--c-decl-marker eltoc) t) 521 | (elcomp--iterate-over-bbs compiler 522 | (lambda (bb) 523 | (elcomp--c-emit-block eltoc bb))) 524 | (insert "}\n\n") 525 | (set-marker (elcomp--c-decl-marker eltoc) nil))) 526 | 527 | ;; If BASE-FILENAME is nil, a module-like file is generated. (But of 528 | ;; course this doesn't work since modules use a JNI-like thing.) 529 | ;; Otherwise, the generated code looks more like the Emacs internals. 530 | (defun elcomp--c-translate (unit &optional base-filename) 531 | (let ((symbol-hash (make-hash-table))) 532 | (maphash 533 | (lambda (_ignore compiler) 534 | (elcomp--c-translate-one compiler symbol-hash)) 535 | (elcomp--compilation-unit-defuns unit)) 536 | ;; Define the symbol variables. 537 | (save-excursion 538 | (goto-char (point-min)) 539 | (insert "#include \n" 540 | "#include \n\n" 541 | ;; FIXME this is less efficient than it could be. 542 | ;; We only need a couple of fields from this. 543 | "#define exit_exception_handler() (prev_handler = *handlerlist, handlerlist = handlerlist->next)\n" 544 | "#define pop_exception_handler() handlerlist = handlerlist->next\n" 545 | "#define catch_value(H) ((H)->val)\n" 546 | "#define signal_conditions(H) (XCAR ((H)->val))\n" 547 | "#define signal_value(H) (XCDR ((H)->val))\n\n") 548 | (unless base-filename 549 | (insert "int plugin_is_GPL_compatible;\n\n")) 550 | (maphash (lambda (_symbol c-name) 551 | (insert "static Lisp_Object " c-name ";\n")) 552 | symbol-hash) 553 | (insert "\n") 554 | 555 | ;; Create "K" values that are are tagged SUBR values for all the 556 | ;; functions. 557 | (maphash 558 | (lambda (_ignore compiler) 559 | (let ((name (elcomp--get-name compiler))) 560 | (insert "static Lisp_Object K" (elcomp--c-name name) ";\n"))) 561 | (elcomp--compilation-unit-defuns unit)) 562 | (insert "\n")) 563 | (insert "\n" 564 | "void\n" 565 | (if base-filename 566 | (concat "syms_of_" base-filename) 567 | "init") 568 | " (void)\n{\n") 569 | ;; Intern all the symbols we refer to. 570 | (maphash (lambda (symbol c-name) 571 | (insert " " c-name " = intern_c_string (" 572 | (elcomp--c-quote-string (symbol-name symbol)) 573 | ");\n") 574 | (insert " staticpro (&" c-name ");\n")) 575 | symbol-hash) 576 | (insert "\n") 577 | ;; Register our exported functions with Lisp. 578 | (maphash 579 | (lambda (_ignore compiler) 580 | (let ((name (car (elcomp--defun compiler)))) 581 | (if name 582 | (insert " defsubr (&S" (elcomp--c-name name) ");\n") 583 | (insert " XSETPVECTYPE (&S" 584 | (symbol-name (elcomp--get-name compiler)) 585 | ", PVEC_SUBR);\n")) 586 | (insert " XSETSUBR (K" (elcomp--c-name (elcomp--get-name compiler)) 587 | ", &S" (elcomp--c-name (elcomp--get-name compiler)) 588 | ");\n"))) 589 | (elcomp--compilation-unit-defuns unit)) 590 | (insert "}\n"))) 591 | 592 | (provide 'elcomp/eltoc) 593 | 594 | ;;; eltoc.el ends here 595 | -------------------------------------------------------------------------------- /elcomp/ffi.el: -------------------------------------------------------------------------------- 1 | 2 | ;; FIXME this should probably instead find a way to compile LIBRARY to 3 | ;; a function-scoped static. 4 | (defun elcomp--define-ffi-library (symbol name) 5 | (let ((library (cl-gensym))) 6 | `(defun ,symbol () 7 | ;; FIXME this is lame but until we handle defvar properly... 8 | (unless (boundp ',library) 9 | ;; FIXME this really ought to be some low-level type anyhow. 10 | (setq ,library (ffi--dlopen ,name)))))) 11 | 12 | (defconst elcomp--ffi-type-map 13 | '((:int8 . integer) 14 | (:uint8 . integer) 15 | (:int16 . integer) 16 | (:uint16 . integer) 17 | (:int32 . integer) 18 | (:uint32 . integer) 19 | (:int64 . integer) 20 | (:uint64 . integer) 21 | (:float . float) 22 | (:double . float) 23 | (:uchar . integer) 24 | (:schar . integer) 25 | (:char . integer) 26 | (:ushort . integer) 27 | (:short . integer) 28 | (:uint . integer) 29 | (:int . integer) 30 | (:ulong . integer) 31 | (:long . integer) 32 | (:ulonglong . integer) 33 | (:longlong . integer) 34 | (:size_t . integer) 35 | (:ssize_t . integer) 36 | (:ptrdiff_t . integer) 37 | (:wchar_t . integer) 38 | (:bool . boolean) 39 | ;; :pointer - but it doesn't really matter that one is missing 40 | ;; here. 41 | )) 42 | 43 | (defun elcomp--define-ffi-function (name c-name return-type arg-types library) 44 | (let* ((arg-names (mapcar (lambda (_ignore) (cl-gensym)) arg-types)) 45 | (type-checks (cl-mapcar 46 | (lambda (arg type) 47 | `(cl-check-type ,arg 48 | ,(cdr (assq type elcomp--ffi-type-map)))) 49 | arg-names arg-types)) 50 | (func-pointer (cl-gensym))) 51 | ;; FIXME this is kind of lying about the return type for :bool 52 | (elcomp-declare name :elcomp-type 53 | (cdr (assq return-type elcomp--ffi-type-map))) 54 | ;; FIXME if we had a lower-level type system, then we could inline 55 | ;; this when we have type information and eliminate checks. 56 | `(defun ,name ,arg-names 57 | ;; FIXME another lameness until we can handle defvar and make a 58 | ;; function- or file-scoped static. 59 | (unless (boundp ',func-pointer) 60 | ;; FIXME this really ought to be some low-level type anyhow. 61 | (setq ,func-pointer (ffi--dlsym ,c-name (,library)))) 62 | ,@type-checks 63 | (:ffi-call ,func-pointer ,@arg-names)))) 64 | 65 | (defun elcomp--use-ffi () 66 | (push '(define-ffi-library . elcomp--define-ffi-library) elcomp--compiler-macros) 67 | (push '(define-ffi-function . elcomp--define-ffi-function) elcomp--compiler-macros)) 68 | -------------------------------------------------------------------------------- /elcomp/iter.el: -------------------------------------------------------------------------------- 1 | ;;; iter.el --- iterate over blocks. -*- lexical-binding:t -*- 2 | 3 | ;;; Code: 4 | 5 | (require 'elcomp) 6 | 7 | (defun elcomp--do-iterate (hash callback bb postorder) 8 | (unless (gethash bb hash) 9 | (puthash bb t hash) 10 | (unless postorder 11 | (funcall callback bb)) 12 | (let ((obj (elcomp--last-instruction bb))) 13 | (cond 14 | ;; FIXME why is the -child- variant needed here? 15 | ((elcomp--goto-p obj) 16 | (elcomp--do-iterate hash callback (elcomp--block obj) postorder)) 17 | ((elcomp--if-p obj) 18 | (elcomp--do-iterate hash callback (elcomp--block-true obj) postorder) 19 | (elcomp--do-iterate hash callback (elcomp--block-false obj) postorder)))) 20 | (dolist (exception (elcomp--basic-block-exceptions bb)) 21 | (when (elcomp--handler exception) 22 | (elcomp--do-iterate hash callback (elcomp--handler exception) 23 | postorder))) 24 | (when postorder 25 | (funcall callback bb)))) 26 | 27 | (defun elcomp--iterate-over-bbs (compiler callback &optional postorder) 28 | (elcomp--do-iterate (make-hash-table) callback 29 | (elcomp--entry-block compiler) 30 | postorder)) 31 | 32 | (defun elcomp--postorder (compiler) 33 | "Return a list of basic blocks from COMPILER, in postorder." 34 | (let ((result)) 35 | (elcomp--iterate-over-bbs compiler (lambda (bb) 36 | (push bb result)) 37 | t) 38 | (nreverse result))) 39 | 40 | (defun elcomp--reverse-postorder (compiler) 41 | "Return a list of basic blocks from COMPILER, in reverse postorder." 42 | (nreverse (elcomp--postorder compiler))) 43 | 44 | (provide 'elcomp/iter) 45 | 46 | ;;; iter.el ends here 47 | -------------------------------------------------------------------------------- /elcomp/jump-thread.el: -------------------------------------------------------------------------------- 1 | ;;; Jump-threading pass. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This implements a simple jump-threading pass. See the doc string 6 | ;; of elcomp--thread-jumps-pass for details. 7 | 8 | ;;; Code: 9 | 10 | (require 'elcomp) 11 | (require 'elcomp/back) 12 | (require 'elcomp/linearize) 13 | 14 | (defun elcomp--get-not-argument (insn) 15 | "Check if INSN uses a 'not' condition. 16 | 17 | INSN is an 'if' instruction. If the condition was defined by a 18 | call to 'not' (or 'null'), return the argument to the 'not'. 19 | Otherwise return nil." 20 | (let ((call (elcomp--sym insn))) 21 | (if (and (elcomp--call-p call) 22 | (memq (elcomp--func call) '(not null))) 23 | (car (elcomp--args call))))) 24 | 25 | (defun elcomp--constant-nil-p (cst) 26 | "Return t if CST is an `elcomp--constant' whose value is nil." 27 | (and (elcomp--constant-p cst) 28 | (eq (elcomp--value cst) nil))) 29 | 30 | (defun elcomp--get-eq-argument (insn) 31 | "Check if INSN uses an `eq' condition. 32 | 33 | INSN is an `if' instruction. If the condition is of the 34 | form `(eq V nil)' or `(eq nil V)', return V. Otherwise return 35 | nil." 36 | (cl-assert (elcomp--if-p insn)) 37 | (let ((call (elcomp--sym insn))) 38 | (if (and (elcomp--call-p call) 39 | (memq (elcomp--func call) '(eq equal))) 40 | (let ((args (elcomp--args call))) 41 | (cond 42 | ((elcomp--constant-nil-p (car args)) 43 | (cadr args)) 44 | ((elcomp--constant-nil-p (cadr args)) 45 | (car args)) 46 | (t nil)))))) 47 | 48 | (defun elcomp--peel-condition (insn) 49 | "Peel `not' and other obviously unnecessary calls from INSN. 50 | INSN is the variable used by an `if'." 51 | (let ((changed-one t)) 52 | (while changed-one 53 | (setf changed-one nil) 54 | ;; Peel a 'not'. 55 | (let ((arg-to-not (elcomp--get-not-argument insn))) 56 | (when arg-to-not 57 | (setf changed-one t) 58 | (cl-rotatef (elcomp--block-true insn) 59 | (elcomp--block-false insn)) 60 | (setf (elcomp--sym insn) arg-to-not))) 61 | ;; Change (eq V nil) or (eq nil V) to plain V. 62 | (let ((arg-to-eq (elcomp--get-eq-argument insn))) 63 | (when arg-to-eq 64 | (setf changed-one t) 65 | (setf (elcomp--sym insn) arg-to-eq)))))) 66 | 67 | (defun elcomp--block-has-catch (block tag) 68 | "If the block has a `catch' exception handler, return it. 69 | Otherwise return nil. 70 | TAG is a constant that must be matched by the handler." 71 | (cl-dolist (exception (elcomp--basic-block-exceptions block)) 72 | (cond 73 | ((elcomp--catch-p exception) 74 | (if (elcomp--constant-p (elcomp--tag exception)) 75 | (if (equal tag (elcomp--tag exception)) 76 | (cl-return exception) 77 | ;; The tag is a different constant, so we can ignore 78 | ;; this one and keep going. 79 | nil) 80 | ;; Non-constant tag could match anything. 81 | (cl-return nil))) 82 | ((elcomp--fake-unwind-protect-p exception) 83 | ;; Keep going; we can handle these properly. 84 | ) 85 | ((elcomp--condition-case-p exception) 86 | ;; Keep going; we can ignore these. 87 | ) 88 | ;; This requires re-linearizing the unwind-protect 89 | ;; original-form. However we can't do this at present because 90 | ;; we've already lost information about the variable 91 | ;; remappings. Perhaps it would be simpler to just go directly 92 | ;; into SSA when linearizing? 93 | ;; ((elcomp--unwind-protect-p exception) 94 | ;; ;; Keep going. 95 | ;; ) 96 | (t 97 | (cl-return nil))))) 98 | 99 | (defun elcomp--get-catch-symbol (exception) 100 | "Given a `catch' exception object, return the symbol holding the `throw' value." 101 | (cl-assert (elcomp--catch-p exception)) 102 | (let ((insn (car (elcomp--basic-block-code (elcomp--handler exception))))) 103 | (cl-assert (elcomp--call-p insn)) 104 | (cl-assert (eq (elcomp--func insn) :catch-value)) 105 | (elcomp--sym insn))) 106 | 107 | (defun elcomp--get-catch-target (exception) 108 | "Given a `catch' exception object, return the basic block of the `catch' itself." 109 | (cl-assert (elcomp--catch-p exception)) 110 | (let ((insn (cadr (elcomp--basic-block-code (elcomp--handler exception))))) 111 | (cl-assert (elcomp--goto-p insn)) 112 | (elcomp--block insn))) 113 | 114 | (defun elcomp--maybe-replace-catch (block insn) 115 | ;; A `throw' with a constant tag can be transformed into an 116 | ;; assignment and a GOTO when the current block's outermost handler 117 | ;; is a `catch' of the same tag. 118 | (when (and (elcomp--diediedie-p insn) 119 | (eq (elcomp--func insn) 'throw) 120 | ;; Argument to throw is a const. 121 | (elcomp--constant-p 122 | (car (elcomp--args insn)))) 123 | (let ((exception (elcomp--block-has-catch block 124 | (car (elcomp--args insn))))) 125 | (when exception 126 | ;; Whew. First drop the last instruction from the block. 127 | (setf (elcomp--basic-block-code block) 128 | (nbutlast (elcomp--basic-block-code block) 1)) 129 | (setf (elcomp--basic-block-code-link block) 130 | (last (elcomp--basic-block-code block))) 131 | ;; Emit `unbind' calls. (Note that when we can handle real 132 | ;; unwind-protects we will re-linearize those here as well.) 133 | (let ((iter (elcomp--basic-block-exceptions block))) 134 | (while (not (elcomp--catch-p (car iter))) 135 | (when (elcomp--fake-unwind-protect-p (car iter)) 136 | (elcomp--add-to-basic-block 137 | block 138 | (elcomp--call :sym nil 139 | :func :elcomp-unbind 140 | :args (list 141 | (elcomp--constant :value 142 | (elcomp--count 143 | (car iter))))))) 144 | (setf iter (cdr iter)))) 145 | ;; Now add an instruction with an assignment and a goto, and 146 | ;; zap the `diediedie' instruction. 147 | (elcomp--add-to-basic-block 148 | block 149 | (elcomp--set :sym (elcomp--get-catch-symbol exception) 150 | :value (cadr (elcomp--args insn)))) 151 | (elcomp--add-to-basic-block 152 | block 153 | (elcomp--goto :block (elcomp--get-catch-target exception))) 154 | t)))) 155 | 156 | (defun elcomp--thread-jumps-pass (compiler in-ssa-form) 157 | "A pass to perform jump threading on COMPILER. 158 | 159 | This pass simplifies the CFG by eliminating redundant jumps. In 160 | particular, it: 161 | 162 | * Converts redundant gotos like 163 | GOTO A; 164 | A: GOTO B; 165 | => 166 | GOTO B; 167 | 168 | * Likewise for either branch of an IF: 169 | IF E A; else B; 170 | A: GOTO C; 171 | => 172 | IF E C; else B; 173 | 174 | * Converts a redundant IF into a GOTO: 175 | IF E A; else A; 176 | => 177 | GOTO A 178 | 179 | * Threads jumps that have the same condition: 180 | IF E A; else B; 181 | A: IF E C; else D; 182 | => 183 | IF E C; else B; 184 | This happens for either branch of an IF. 185 | 186 | * Eliminates dependencies on 'not': 187 | E = (not X) 188 | if E A; else B; 189 | => 190 | if X B; else A; 191 | Note that this leaves the computation of E in the code. This may 192 | be eliminated later by DCE. 193 | 194 | * Similarly, removes (eq X nil) or (eq nil X) 195 | 196 | * Converts IF with a constant to a GOTO: 197 | if <> A; else B; 198 | => 199 | goto B; 200 | 201 | * Converts a `throw' to a `goto' when it is provably correct. 202 | This can be done when the `catch' and the `throw' both have a 203 | constant tag argument, and when there are no intervening 204 | `unwind-protect' calls (this latter restriction could be lifted 205 | with some more work). 206 | 207 | Note that nothing here explicitly removes blocks. This is not 208 | needed because the only links to blocks are the various branches; 209 | when a block is not needed it will be reclaimed by the garbage 210 | collector." 211 | (let ((rewrote-one t)) 212 | (while rewrote-one 213 | (setf rewrote-one nil) 214 | (elcomp--iterate-over-bbs 215 | compiler 216 | (lambda (block) 217 | (let ((insn (elcomp--last-instruction block))) 218 | ;; See if we can turn a `throw' into a `goto'. This only 219 | ;; works when not in SSA form, because it reuses variable 220 | ;; names from the `catch' handler. 221 | (unless in-ssa-form 222 | (when (elcomp--maybe-replace-catch block insn) 223 | (setf rewrote-one t))) 224 | ;; A GOTO to a block holding just another branch (of any kind) 225 | ;; can be replaced by the instruction at the target. 226 | ;; FIXME In SSA mode we would have to deal with the phis. 227 | (when (and (not in-ssa-form) 228 | (elcomp--goto-p insn) 229 | ;; Exclude a self-goto. 230 | (not (eq block 231 | (elcomp--block insn))) 232 | (elcomp--nonreturn-terminator-p 233 | (elcomp--first-instruction (elcomp--block insn)))) 234 | ;; Note we also set INSN for subsequent optimizations 235 | ;; here. 236 | (setf insn (elcomp--first-instruction (elcomp--block insn))) 237 | (setf (elcomp--last-instruction block) insn) 238 | (setf rewrote-one t)) 239 | 240 | ;; If a target of an IF is a GOTO, the destination can be 241 | ;; hoisted. 242 | (when (and (elcomp--if-p insn) 243 | (elcomp--goto-p (elcomp--first-instruction 244 | (elcomp--block-true insn)))) 245 | (setf (elcomp--block-true insn) 246 | (elcomp--block 247 | (elcomp--first-instruction (elcomp--block-true insn)))) 248 | (setf rewrote-one t)) 249 | (when (and (elcomp--if-p insn) 250 | (elcomp--goto-p (elcomp--first-instruction 251 | (elcomp--block-false insn)))) 252 | (setf (elcomp--block-false insn) 253 | (elcomp--block 254 | (elcomp--first-instruction (elcomp--block-false insn)))) 255 | (setf rewrote-one t)) 256 | 257 | ;; If both branches of an IF point to the same spot, turn 258 | ;; it into a GOTO. 259 | (when (and (elcomp--if-p insn) 260 | (eq (elcomp--block-true insn) 261 | (elcomp--block-false insn))) 262 | (setf insn (elcomp--goto :block (elcomp--block-true insn))) 263 | (setf (elcomp--last-instruction block) insn) 264 | (setf rewrote-one t)) 265 | 266 | ;; If the condition for an IF was a call to 'not', then the 267 | ;; call can be bypassed and the targets swapped. 268 | (when (and in-ssa-form (elcomp--if-p insn)) 269 | (elcomp--peel-condition insn)) 270 | 271 | ;; If the argument to the IF is a constant, turn the IF 272 | ;; into a GOTO. 273 | (when (and in-ssa-form (elcomp--if-p insn)) 274 | (let ((condition (elcomp--sym insn))) 275 | ;; FIXME could also check for calls known not to return 276 | ;; nil. 277 | (when (elcomp--constant-p condition) 278 | (let ((goto-block (if (elcomp--value condition) 279 | (elcomp--block-true insn) 280 | (elcomp--block-false insn)))) 281 | (setf insn (elcomp--goto :block goto-block)) 282 | (setf (elcomp--last-instruction block) insn) 283 | (setf rewrote-one t))))) 284 | 285 | ;; If a target of an IF is another IF, and the conditions are the 286 | ;; same, then the target IF can be hoisted. 287 | (when (elcomp--if-p insn) 288 | ;; Thread the true branch. 289 | (when (and (elcomp--if-p (elcomp--first-instruction 290 | (elcomp--block-true insn))) 291 | (eq (elcomp--sym insn) 292 | (elcomp--sym (elcomp--first-instruction 293 | (elcomp--block-true insn))))) 294 | (setf (elcomp--block-true insn) 295 | (elcomp--block-true (elcomp--first-instruction 296 | (elcomp--block-true insn))))) 297 | ;; Thread the false branch. 298 | (when (and (elcomp--if-p (elcomp--first-instruction 299 | (elcomp--block-false insn))) 300 | (eq (elcomp--sym insn) 301 | (elcomp--sym (elcomp--first-instruction 302 | (elcomp--block-false insn))))) 303 | (setf (elcomp--block-false insn) 304 | (elcomp--block-false (elcomp--first-instruction 305 | (elcomp--block-false insn))))))))) 306 | 307 | (when rewrote-one 308 | (elcomp--invalidate-cfg compiler))))) 309 | 310 | (provide 'elcomp/jump-thread) 311 | 312 | ;;; jump-thread.el ends here 313 | -------------------------------------------------------------------------------- /elcomp/linearize.el: -------------------------------------------------------------------------------- 1 | ;;; linearize.el --- linearize lisp forms. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Turn Emacs Lisp forms into compiler objects. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp) 10 | (require 'elcomp/props) 11 | 12 | (defun elcomp--push-fake-unwind-protect (compiler num) 13 | (let* ((first-exception (car (elcomp--exceptions compiler))) 14 | (new-exception 15 | (if (elcomp--fake-unwind-protect-p first-exception) 16 | (progn 17 | (pop (elcomp--exceptions compiler)) 18 | (elcomp--fake-unwind-protect 19 | :count (+ (elcomp--count first-exception) num))) 20 | (elcomp--fake-unwind-protect :count num)))) 21 | (push new-exception (elcomp--exceptions compiler))) 22 | (elcomp--make-block-current compiler (elcomp--label compiler))) 23 | 24 | (defun elcomp--pop-fake-unwind-protects (compiler num) 25 | (let* ((first-exception (pop (elcomp--exceptions compiler)))) 26 | (cl-assert (elcomp--fake-unwind-protect-p first-exception)) 27 | (cl-assert (>= (elcomp--count first-exception) num)) 28 | (if (> (elcomp--count first-exception) num) 29 | (push (elcomp--fake-unwind-protect 30 | :count (- (elcomp--count first-exception) num)) 31 | (elcomp--exceptions compiler)))) 32 | (elcomp--make-block-current compiler (elcomp--label compiler))) 33 | 34 | (defun elcomp--new-var (compiler &optional symname) 35 | (let* ((cell (memq symname (elcomp--rewrite-alist compiler)))) 36 | (if cell 37 | (cl-gensym) 38 | (or symname 39 | (cl-gensym))))) 40 | 41 | (defun elcomp--rewrite-one-ref (compiler ref) 42 | "Rewrite REF. 43 | REF can be a symbol, in which case it is rewritten following 44 | `elcomp--rewrite-alist' and returned. 45 | Or REF can be a constant, in which case it is returned unchanged." 46 | (cond 47 | ((elcomp--constant-p ref) 48 | ref) 49 | ((special-variable-p ref) 50 | (let ((var (elcomp--new-var compiler))) 51 | (elcomp--add-call compiler var 52 | 'symbol-value 53 | (list (elcomp--constant :value ref))) 54 | var)) 55 | (t 56 | (let ((tem (assq ref (elcomp--rewrite-alist compiler)))) 57 | (if tem 58 | (cdr tem) 59 | ;; If there is no rewrite for the name, then it is a global. 60 | (let ((var (elcomp--new-var compiler))) 61 | (elcomp--add-call compiler var 62 | 'symbol-value 63 | (list (elcomp--constant :value ref))) 64 | var)))))) 65 | 66 | (defun elcomp--label (compiler) 67 | (prog1 68 | (make-elcomp--basic-block :number (elcomp--next-label compiler) 69 | :exceptions (elcomp--exceptions compiler)) 70 | (cl-incf (elcomp--next-label compiler)))) 71 | 72 | (defun elcomp--add-to-basic-block (block obj) 73 | (let ((new-cell (cons obj nil))) 74 | (if (elcomp--basic-block-code-link block) 75 | (setf (cdr (elcomp--basic-block-code-link block)) new-cell) 76 | (setf (elcomp--basic-block-code block) new-cell)) 77 | (setf (elcomp--basic-block-code-link block) new-cell))) 78 | 79 | (defun elcomp--add-basic (compiler obj) 80 | (elcomp--add-to-basic-block (elcomp--current-block compiler) obj)) 81 | 82 | (defun elcomp--add-set (compiler sym value) 83 | (elcomp--add-basic compiler (elcomp--set :sym sym :value value))) 84 | 85 | (defun elcomp--add-call (compiler sym func args) 86 | (if (and (symbolp func) 87 | (elcomp--func-noreturn-p func)) 88 | (progn 89 | ;; Add the terminator instruction and push a new basic block 90 | ;; -- this block will be discarded later, but that's ok. Also 91 | ;; discard the assignment. 92 | (elcomp--add-basic compiler 93 | (elcomp--diediedie :sym nil :func func 94 | :args args)) 95 | (setf (elcomp--current-block compiler) (elcomp--label compiler))) 96 | (elcomp--add-basic compiler (elcomp--call :sym sym :func func 97 | :args args)))) 98 | 99 | (defun elcomp--add-return (compiler sym) 100 | (elcomp--add-basic compiler (elcomp--return :sym sym))) 101 | 102 | (defun elcomp--add-goto (compiler block) 103 | (elcomp--add-basic compiler (elcomp--goto :block block)) 104 | ;; Push a new block. 105 | (setf (elcomp--current-block compiler) (elcomp--label compiler))) 106 | 107 | (defun elcomp--add-if (compiler sym block-true block-false) 108 | (cl-assert (or block-true block-false)) 109 | (let ((next-block)) 110 | (unless block-true 111 | (setf block-true (elcomp--label compiler)) 112 | (setf next-block block-true)) 113 | (unless block-false 114 | (setf block-false (elcomp--label compiler)) 115 | (setf next-block block-false)) 116 | (elcomp--add-basic compiler (elcomp--if :sym sym 117 | :block-true block-true 118 | :block-false block-false)) 119 | ;; Push a new block. 120 | (setf (elcomp--current-block compiler) next-block))) 121 | 122 | (defun elcomp--variable-p (obj) 123 | "Return t if OBJ is a variable when linearizing. 124 | A variable is a symbol that is not a keyword." 125 | (and (symbolp obj) 126 | (not (keywordp obj)) 127 | (not (memq obj '(t nil))))) 128 | 129 | (defun elcomp--make-block-current (compiler block) 130 | ;; Terminate the previous basic block. 131 | (let ((insn (elcomp--last-instruction (elcomp--current-block compiler)))) 132 | (if (not (elcomp--terminator-p insn)) 133 | (elcomp--add-basic compiler (elcomp--goto :block block))) 134 | (setf (elcomp--current-block compiler) block))) 135 | 136 | (defun elcomp--linearize-body (compiler body result-location 137 | &optional result-index) 138 | (let ((i 1)) 139 | (while body 140 | (elcomp--linearize compiler (car body) 141 | (if (or (eq i result-index) 142 | (and (eq result-index nil) 143 | (not (cdr body)))) 144 | result-location 145 | nil)) 146 | (setf body (cdr body)) 147 | (cl-incf i)))) 148 | 149 | ;; (defun elcomp--handler-name (name) 150 | ;; (intern (concat "elcomp--compiler--" (symbol-name name)))) 151 | 152 | ;; (defmacro define-elcomp-handler (name arg-list &rest body) 153 | ;; `(defun ,(elcomp--handler-name name) arg-list body)) 154 | 155 | (defun elcomp--operand (compiler form) 156 | (cond 157 | ((elcomp--variable-p form) 158 | (elcomp--rewrite-one-ref compiler form)) 159 | ((atom form) 160 | (elcomp--constant :value form)) 161 | ((eq (car form) 'quote) 162 | (elcomp--constant :value (cadr form))) 163 | (t 164 | (let ((var (elcomp--new-var compiler))) 165 | (elcomp--linearize compiler form var) 166 | var)))) 167 | 168 | (declare-function elcomp--plan-to-compile "elcomp/toplevel") 169 | 170 | (defun elcomp--linearize (compiler form result-location) 171 | "Linearize FORM and return the result. 172 | 173 | Linearization turns a form from an ordinary Lisp form into a 174 | sequence of objects. FIXME ref the class docs" 175 | (if (atom form) 176 | (if result-location 177 | (elcomp--add-set compiler result-location 178 | (elcomp--operand compiler form))) 179 | (let ((fn (car form))) 180 | (cond 181 | ((eq fn 'quote) 182 | (if result-location 183 | (elcomp--add-set compiler result-location 184 | (elcomp--operand compiler form)))) 185 | ((eq 'lambda (car-safe fn)) 186 | ;; Shouldn't this use 'function? 187 | (error "lambda not supported")) 188 | ((eq fn 'let) 189 | ;; Arrange to reset the rewriting table outside the 'let'. 190 | (cl-letf (((elcomp--rewrite-alist compiler) 191 | (elcomp--rewrite-alist compiler)) 192 | (let-symbols nil) 193 | (spec-vars nil)) 194 | ;; Compute the values. 195 | (dolist (sexp (cadr form)) 196 | (let* ((sym (if (symbolp sexp) 197 | sexp 198 | (car sexp))) 199 | (sym-initializer (if (consp sexp) 200 | (cadr sexp) 201 | nil)) 202 | (sym-result (elcomp--new-var compiler sym))) 203 | ;; If there is a body, compute it. 204 | (elcomp--linearize compiler sym-initializer sym-result) 205 | (if (special-variable-p sym) 206 | (push (cons sym sym-result) spec-vars) 207 | (push (cons sym sym-result) let-symbols)))) 208 | ;; Push the new values onto the rewrite list. 209 | (setf (elcomp--rewrite-alist compiler) 210 | (nconc let-symbols (elcomp--rewrite-alist compiler))) 211 | (when spec-vars 212 | ;; Specbind all the special variables. 213 | (dolist (spec-var spec-vars) 214 | (elcomp--add-call compiler nil :elcomp-specbind 215 | (list 216 | (elcomp--constant :value (car spec-var)) 217 | (cdr spec-var)))) 218 | (elcomp--push-fake-unwind-protect compiler (length spec-vars))) 219 | ;; Now evaluate the body of the let. 220 | (elcomp--linearize-body compiler (cddr form) result-location) 221 | ;; And finally unbind. 222 | (when spec-vars 223 | (elcomp--pop-fake-unwind-protects compiler (length spec-vars)) 224 | (elcomp--add-call compiler nil :elcomp-unbind 225 | (list 226 | (elcomp--constant :value (length spec-vars))))))) 227 | 228 | ((eq fn 'let*) 229 | ;; Arrange to reset the rewriting table outside the 'let*'. 230 | (cl-letf (((elcomp--rewrite-alist compiler) 231 | (elcomp--rewrite-alist compiler)) 232 | (num-specbinds 0)) 233 | ;; Compute the values. 234 | (dolist (sexp (cadr form)) 235 | (let* ((sym (if (symbolp sexp) 236 | sexp 237 | (car sexp))) 238 | (sym-initializer (if (consp sexp) 239 | (cadr sexp) 240 | nil)) 241 | (sym-result (elcomp--new-var compiler sym))) 242 | ;; If there is a body, compute it. 243 | (elcomp--linearize compiler sym-initializer sym-result) 244 | ;; Make it visible to subsequent blocks. 245 | (if (special-variable-p sym) 246 | (progn 247 | (elcomp--add-call compiler nil :elcomp-specbind 248 | (list 249 | (elcomp--constant :value sym) 250 | sym-result)) 251 | (elcomp--push-fake-unwind-protect compiler 1) 252 | (cl-incf num-specbinds)) 253 | (push (cons sym sym-result) (elcomp--rewrite-alist compiler))))) 254 | ;; Evaluate the body of the let*. 255 | (elcomp--linearize-body compiler (cddr form) result-location) 256 | ;; And finally unbind. 257 | (when (> num-specbinds 0) 258 | (elcomp--pop-fake-unwind-protects compiler num-specbinds) 259 | (elcomp--add-call compiler nil :elcomp-unbind 260 | (list 261 | (elcomp--constant :value num-specbinds)))))) 262 | 263 | ((eq fn 'setq-default) 264 | (setf form (cdr form)) 265 | (while form 266 | (let* ((sym (pop form)) 267 | (val (pop form)) 268 | ;; We store the last result but drop the others. 269 | (stored-variable (if form nil result-location)) 270 | (intermediate (elcomp--new-var compiler))) 271 | ;; This is translated straightforwardly as a call to 272 | ;; `set-default'. 273 | (elcomp--linearize compiler val intermediate) 274 | (elcomp--add-call compiler stored-variable 275 | 'set-default 276 | (list (elcomp--constant :value sym) 277 | intermediate))))) 278 | 279 | ((eq fn 'setq) 280 | (setf form (cdr form)) 281 | (while form 282 | (let* ((sym (pop form)) 283 | (val (pop form)) 284 | ;; We store the last `setq' but drop the results of 285 | ;; the rest. 286 | (stored-variable (if form nil result-location))) 287 | (if (special-variable-p sym) 288 | (let ((intermediate (elcomp--new-var compiler))) 289 | ;; A setq of a special variable is turned into a 290 | ;; call to `set'. Our "set" instruction is reserved 291 | ;; for ordinary variables. 292 | (elcomp--linearize compiler val intermediate) 293 | (elcomp--add-call compiler stored-variable 294 | 'set 295 | (list (elcomp--constant :value sym) 296 | intermediate))) 297 | ;; An ordinary `setq' is turned into a "set" 298 | ;; instruction. 299 | (let ((rewritten-sym (elcomp--rewrite-one-ref compiler sym))) 300 | (elcomp--linearize compiler val rewritten-sym) 301 | (when stored-variable 302 | ;; Return the value. 303 | (elcomp--add-set compiler stored-variable rewritten-sym))))))) 304 | 305 | ((eq fn 'cond) 306 | (let ((label-done (elcomp--label compiler))) 307 | (dolist (clause (cdr form)) 308 | (let ((this-cond-var (if (cdr clause) 309 | (elcomp--new-var compiler) 310 | result-location)) 311 | (next-label (elcomp--label compiler))) 312 | ;; Emit the condition. 313 | (elcomp--linearize compiler (car clause) this-cond-var) 314 | ;; The test. 315 | (elcomp--add-if compiler this-cond-var nil next-label) 316 | ;; The body. 317 | (if (cdr clause) 318 | (elcomp--linearize-body compiler 319 | (cdr clause) result-location)) 320 | ;; Done. Cleaning up unnecessary labels happens in 321 | ;; another pass, so we can be a bit lazy here. 322 | (elcomp--add-goto compiler label-done) 323 | (elcomp--make-block-current compiler next-label))) 324 | ;; Emit a final case for the cond. This will be optimized 325 | ;; away as needed. 326 | (when result-location 327 | (elcomp--add-set compiler result-location 328 | (elcomp--constant :value nil))) 329 | (elcomp--make-block-current compiler label-done))) 330 | 331 | ((memq fn '(progn inline)) 332 | (elcomp--linearize-body compiler (cdr form) result-location)) 333 | ((eq fn 'prog1) 334 | (elcomp--linearize-body compiler (cdr form) result-location 1)) 335 | ((eq fn 'prog2) 336 | (elcomp--linearize-body compiler (cdr form) result-location 2)) 337 | 338 | ((eq fn 'while) 339 | (let ((label-top (elcomp--label compiler)) 340 | (label-done (elcomp--label compiler)) 341 | (cond-var (elcomp--new-var compiler))) 342 | (if result-location 343 | (elcomp--add-set compiler result-location 344 | (elcomp--operand compiler nil))) 345 | (elcomp--make-block-current compiler label-top) 346 | ;; The condition expression and goto. 347 | (elcomp--linearize compiler (cadr form) cond-var) 348 | (elcomp--add-if compiler cond-var nil label-done) 349 | ;; The body. 350 | (elcomp--linearize-body compiler (cddr form) nil) 351 | (elcomp--add-goto compiler label-top) 352 | (elcomp--make-block-current compiler label-done))) 353 | 354 | ((eq fn 'if) 355 | (let ((label-false (elcomp--label compiler)) 356 | (label-done (elcomp--label compiler)) 357 | (cond-var (elcomp--new-var compiler))) 358 | ;; The condition expression and goto. 359 | (elcomp--linearize compiler (cadr form) cond-var) 360 | (elcomp--add-if compiler cond-var nil label-false) 361 | ;; The true branch. 362 | (elcomp--linearize compiler (cl-caddr form) result-location) 363 | ;; The end of the true branch. 364 | (elcomp--add-goto compiler label-done) 365 | ;; The false branch. 366 | (elcomp--make-block-current compiler label-false) 367 | (if (cl-cdddr form) 368 | (elcomp--linearize-body compiler (cl-cdddr form) result-location) 369 | (when result-location 370 | (elcomp--add-set compiler result-location 371 | (elcomp--constant :value nil)))) 372 | ;; The end of the statement. 373 | (elcomp--make-block-current compiler label-done))) 374 | 375 | ((eq fn 'and) 376 | (let ((label-done (elcomp--label compiler))) 377 | (dolist (condition (cdr form)) 378 | (let ((result-location (or result-location 379 | (elcomp--new-var compiler)))) 380 | (elcomp--linearize compiler condition result-location) 381 | ;; We don't need this "if" for the last iteration, and 382 | ;; "and" in conditionals could be handled better -- but 383 | ;; all this is fixed up by the optimizers. 384 | (elcomp--add-if compiler result-location nil label-done))) 385 | (elcomp--make-block-current compiler label-done))) 386 | 387 | ((eq fn 'or) 388 | (let ((label-done (elcomp--label compiler))) 389 | (dolist (condition (cdr form)) 390 | (let ((result-location (or result-location 391 | (elcomp--new-var compiler)))) 392 | (elcomp--linearize compiler condition result-location) 393 | (elcomp--add-if compiler result-location label-done nil))) 394 | (elcomp--make-block-current compiler label-done))) 395 | 396 | ((eq fn 'catch) 397 | (let* ((tag (elcomp--operand compiler (cadr form))) 398 | (handler-label (elcomp--label compiler)) 399 | (done-label (elcomp--label compiler)) 400 | (exception (elcomp--catch :handler handler-label 401 | :tag tag))) 402 | (push exception (elcomp--exceptions compiler)) 403 | ;; We need a new block because we have modified the 404 | ;; exception handler list. 405 | (elcomp--make-block-current compiler (elcomp--label compiler)) 406 | (elcomp--linearize-body compiler (cddr form) result-location) 407 | ;; The catch doesn't cover the handler; but pop before the 408 | ;; "goto" so the new block has the correct exception list. 409 | (pop (elcomp--exceptions compiler)) 410 | ;; And make sure to pop the exception handler at runtime. 411 | (elcomp--add-call compiler nil :pop-exception-handler nil) 412 | (elcomp--add-goto compiler done-label) 413 | (elcomp--make-block-current compiler handler-label) 414 | ;; A magic call to get the value. 415 | (elcomp--add-call compiler result-location :catch-value nil) 416 | (elcomp--add-goto compiler done-label) 417 | (elcomp--make-block-current compiler done-label))) 418 | 419 | ((eq fn 'unwind-protect) 420 | (let ((handler-label (elcomp--label compiler)) 421 | (done-label (elcomp--label compiler)) 422 | (normal-label (elcomp--label compiler))) 423 | (push (elcomp--unwind-protect :handler handler-label 424 | :original-form (cons 'progn 425 | (cddr form))) 426 | (elcomp--exceptions compiler)) 427 | ;; We need a new block because we have modified the 428 | ;; exception handler list. 429 | (elcomp--make-block-current compiler (elcomp--label compiler)) 430 | (elcomp--linearize compiler (cadr form) result-location) 431 | ;; The catch doesn't cover the handler; but pop before the 432 | ;; "goto" so the new block has the correct exception list. 433 | (pop (elcomp--exceptions compiler)) 434 | ;; And make sure to pop the exception handler at runtime. 435 | (elcomp--add-call compiler nil :pop-exception-handler nil) 436 | (elcomp--add-goto compiler normal-label) 437 | (elcomp--make-block-current compiler normal-label) 438 | ;; We double-linearize the handlers because this is simpler 439 | ;; and usually better. 440 | (elcomp--linearize-body compiler (cddr form) 441 | (elcomp--new-var compiler)) 442 | (elcomp--add-goto compiler done-label) 443 | (elcomp--make-block-current compiler handler-label) 444 | ;; The second linearization. 445 | (elcomp--linearize-body compiler (cddr form) 446 | (elcomp--new-var compiler)) 447 | (elcomp--add-call compiler nil :unwind-protect-continue nil) 448 | (elcomp--make-block-current compiler done-label))) 449 | 450 | ((eq fn 'condition-case) 451 | (error "somehow a condition-case made it through macro expansion")) 452 | 453 | ((eq fn :elcomp-condition-case) 454 | (let ((new-exceptions nil) 455 | (body-label (elcomp--label compiler)) 456 | (done-label (elcomp--label compiler)) 457 | (saved-exceptions (elcomp--exceptions compiler))) 458 | ;; We emit the handlers first because it is a bit simpler 459 | ;; here, and it doesn't matter for the result. 460 | (elcomp--add-goto compiler body-label) 461 | (dolist (handler (cddr form)) 462 | (let ((this-label (elcomp--label compiler))) 463 | (push (elcomp--condition-case :handler this-label 464 | :condition-name (car handler)) 465 | new-exceptions) 466 | (elcomp--make-block-current compiler this-label) 467 | ;; Note that here we probably pretend that the handler 468 | ;; block is surrounded by '(let ((var ...))...)'. This 469 | ;; is done by a compiler macro, which explains why 470 | ;; there's no special handling here. 471 | (elcomp--linearize-body compiler (cdr handler) result-location) 472 | (elcomp--add-goto compiler done-label))) 473 | ;; Careful with the ordering. 474 | (setf new-exceptions (nreverse new-exceptions)) 475 | (dolist (exception new-exceptions) 476 | (push exception (elcomp--exceptions compiler))) 477 | ;; Update the body label's list of exceptions. 478 | (setf (elcomp--basic-block-exceptions body-label) 479 | (elcomp--exceptions compiler)) 480 | (elcomp--make-block-current compiler body-label) 481 | (elcomp--linearize compiler (cadr form) result-location) 482 | ;; The catch doesn't cover the handler; but pop before the 483 | ;; "goto" so the new block has the correct exception list. 484 | (setf (elcomp--exceptions compiler) saved-exceptions) 485 | ;; And make sure to pop the exception handler at runtime. 486 | (elcomp--add-call compiler nil :pop-exception-handler nil) 487 | (elcomp--add-goto compiler done-label) 488 | (elcomp--make-block-current compiler done-label))) 489 | 490 | ((eq fn 'interactive) 491 | nil) 492 | 493 | ((eq fn 'function) 494 | (let ((the-function (cadr form))) 495 | ;; For (function (lambda ...)), arrange to compile it and 496 | ;; put use the new compiler object as the constant. 497 | (when (listp (cadr form)) 498 | (setf the-function (elcomp--plan-to-compile (elcomp--unit compiler) 499 | the-function))) 500 | (when result-location 501 | (elcomp--add-set compiler result-location 502 | (elcomp--constant :value the-function))))) 503 | 504 | ((not (symbolp fn)) 505 | (error "not supported: %S" fn)) 506 | 507 | ((special-form-p (symbol-function fn)) 508 | (error "unhandled special form: %s" (symbol-name fn))) 509 | 510 | (t 511 | ;; An ordinary function call. 512 | (let ((these-args 513 | ;; Compute each argument. 514 | (mapcar (lambda (arg) (elcomp--operand compiler arg)) 515 | (cdr form)))) 516 | ;; Make the call. 517 | (elcomp--add-call compiler result-location fn these-args))))))) 518 | 519 | (defun elcomp--linearize-defun (compiler form result-location) 520 | (let ((arg-list (cl-copy-list (cadr (elcomp--defun compiler))))) 521 | (cl-delete-if (lambda (elt) (memq elt '(&rest &optional))) 522 | arg-list) 523 | ;; Let each argument map to itself. 524 | (cl-letf (((elcomp--rewrite-alist compiler) 525 | (mapcar (lambda (elt) (cons elt elt)) 526 | arg-list))) 527 | (elcomp--linearize compiler form result-location)))) 528 | 529 | (provide 'elcomp/linearize) 530 | 531 | ;;; linearize.el ends here 532 | -------------------------------------------------------------------------------- /elcomp/name-map.el: -------------------------------------------------------------------------------- 1 | ;;; name-map.el - Map names to blocks. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This has some utility functions to construct a map that maps SSA 6 | ;; names to their defining blocks. This is only needed due to IR 7 | ;; deficiencies and should probably be fixed a different way. 8 | 9 | ;;; Code: 10 | 11 | (require 'elcomp) 12 | 13 | (cl-defgeneric elcomp--update-name-map (_insn _bb _map) 14 | ;; Ignore most instructions. 15 | nil) 16 | 17 | (cl-defmethod elcomp--update-name-map ((insn elcomp--set) bb map) 18 | (puthash insn bb map)) 19 | 20 | (cl-defmethod elcomp--update-name-map ((insn elcomp--call) bb map) 21 | (when (elcomp--sym insn) 22 | (puthash insn bb map))) 23 | 24 | (defun elcomp--make-name-map (compiler) 25 | (let ((name-map (make-hash-table))) 26 | (dolist (arg (elcomp--arguments compiler)) 27 | (puthash arg (elcomp--entry-block compiler) name-map)) 28 | (elcomp--iterate-over-bbs 29 | compiler 30 | (lambda (bb) 31 | (maphash (lambda (_name phi) (puthash phi bb name-map)) 32 | (elcomp--basic-block-phis bb)) 33 | (dolist (insn (elcomp--basic-block-code bb)) 34 | (elcomp--update-name-map insn bb name-map)))) 35 | name-map)) 36 | 37 | (provide 'elcomp/name-map) 38 | 39 | ;;; name-map.el ends here 40 | -------------------------------------------------------------------------------- /elcomp/props.el: -------------------------------------------------------------------------------- 1 | ;;; props.el --- Function properties. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This module has code to note properties of functions. The 6 | ;; properties in question are those which are of interest to the 7 | ;; compiler, and which are considered immutable -- currently it is 8 | ;; only possible for the compiler to handle properties of functions 9 | ;; that the user cannot reasonably redefine. 10 | 11 | ;; byte-compile-negated-op is not quite useful 12 | ;; but the idea could be applied 13 | ;; normalizing is valuable for generic optimizations 14 | 15 | ;;; Code: 16 | 17 | (require 'elcomp) 18 | 19 | (defun elcomp-declare (func &rest props) 20 | "Apply PROPS, a plist of attributes, to FUNC, a symbol. 21 | 22 | Defined properties are: 23 | 24 | :elcomp-const t|nil If t, FUNC does not have side effects. 25 | This means a call to it can be removed if 26 | its return value is not used. 27 | :elcomp-pure t|nil Like :elcomp-const, but also does not 28 | refer to memory. 29 | :elcomp-type TYPE The return type of FUNC. 30 | :elcomp-simple-numeric t|n If t, FUNC is a simple numeric function. This 31 | means that it accepts a number of 32 | integer, marker, or float arguments, 33 | and that the type of the result 34 | follows the usual contagion rules. Such a 35 | function can never return `nil'. 36 | :elcomp-predicate TYPE This function is a type predicate that 37 | tests for TYPE. 38 | :elcomp-noreturn t|nil If t, FUNC does not return normally. 39 | :elcomp-nothrow t|nil If t, FUNC cannot `throw' or `signal'. 40 | :elcomp-direct t|nil If t, generated C code can call this directly." 41 | ;; add more? 42 | ;; :malloc - allocates new object 43 | ;; :commutative - then we could sort arguments somehow and 44 | ;; have more CSE opportunities 45 | (while props 46 | (put func (car props) (cadr props)) 47 | (setf props (cddr props)))) 48 | 49 | (defun elcomp--func-const-p (func) 50 | "Return t if FUNC can be considered 'const'." 51 | (or (elcomp--func-pure-p func) 52 | (get func :elcomp-const) 53 | (get func 'side-effect-free))) 54 | 55 | (defun elcomp--func-pure-p (func) 56 | "Return t if FUNC can be considered 'pure'." 57 | (or (get func :elcomp-pure) 58 | (get func 'pure))) 59 | 60 | (defun elcomp--func-type (func) 61 | "Return the type of FUNC, if known, or nil." 62 | (get func :elcomp-type)) 63 | 64 | (defun elcomp--func-simple-numeric-p (func) 65 | "Return t if FUNC can be considered 'simple-numeric'." 66 | (get func :elcomp-simple-numeric)) 67 | 68 | (defun elcomp--func-type-predicate (func) 69 | "If FUNC is a type predicate, return the corresponding type, else nil." 70 | (get func :elcomp-predicate)) 71 | 72 | (defun elcomp--func-noreturn-p (func) 73 | "Return t if FUNC can be considered 'noreturn'." 74 | (get func :elcomp-noreturn)) 75 | 76 | (defun elcomp--func-nothrow-p (func) 77 | "Return t if FUNC can be considered 'nothrow'." 78 | (or (get func :elcomp-nothrow) 79 | (eq (get func 'side-effect-free) 'error-free))) 80 | 81 | (defun elcomp--func-direct-p (func) 82 | "Return t if FUNC is `direct'-capable from C code. 83 | 84 | This is used to limit how many direct calls are emitted. 85 | Indirect calls are generally preferable for `non-trivial' 86 | things, so that advice continues to work." 87 | (and (symbolp func) 88 | (get func :elcomp-direct) 89 | (subrp (symbol-function func)))) 90 | 91 | (dolist (func '(+ - * / % 1+ 1- mod max min abs expt)) 92 | (elcomp-declare func :elcomp-const t :elcomp-simple-numeric t)) 93 | 94 | (dolist (func '(isnan floatp integerp numberp natnump zerop = eql eq equal 95 | /= < <= > >=)) 96 | (elcomp-declare func :elcomp-const t :elcomp-type 'boolean)) 97 | 98 | (dolist (func '(ldexp copysign logb float truncate floor ceiling round 99 | ffloor fceiling ftruncate fround 100 | sin cos tan asin acos atan exp log 101 | sqrt)) 102 | (elcomp-declare func :elcomp-const t :elcomp-type 'float :elcomp-direct t)) 103 | 104 | (dolist (func '(lsh ash logand logior logxor lognot byteorder sxhash length)) 105 | (elcomp-declare func :elcomp-const t :elcomp-type 'integer :elcomp-direct t)) 106 | 107 | (elcomp-declare 'cons :elcomp-type 'cons) 108 | (elcomp-declare 'list :elcomp-type 'list) 109 | (elcomp-declare 'make-list :elcomp-type 'list) 110 | (elcomp-declare 'vector :elcomp-type 'vector) 111 | (elcomp-declare 'vconcat :elcomp-type 'vector) 112 | (elcomp-declare 'make-vector :elcomp-type 'vector) 113 | (elcomp-declare 'string :elcomp-type 'string) 114 | (elcomp-declare 'make-string :elcomp-type 'string) 115 | (elcomp-declare 'make-hash-table :elcomp-type 'hash-table) 116 | (elcomp-declare 'intern :elcomp-type 'symbol) 117 | (elcomp-declare 'make-symbol :elcomp-type 'symbol) 118 | 119 | ;; There are a few type predicates not on the list. They could be 120 | ;; added if needed. See (elisp) Type Predicates. 121 | (dolist (iter '((atom . list) 122 | (arrayp . array) 123 | (bool-vector-p . bool-vector) 124 | (booleanp . boolean) 125 | (bufferp . buffer) 126 | (characterp . integer) ; not clear if this is best 127 | (consp . cons) 128 | (floatp . float) 129 | (hash-table-p . hash-table) 130 | (integerp . integer) 131 | (listp . list) 132 | (markerp . marker) 133 | (sequencep . sequence) 134 | (stringp . string) 135 | (symbolp . symbol) 136 | (vectorp . vector) 137 | (wholenump . integer))) 138 | (elcomp-declare (car iter) 139 | :elcomp-predicate (cdr iter) 140 | :elcomp-type 'boolean)) 141 | 142 | (dolist (iter '(throw signal error user-error :unwind-protect-continue)) 143 | (elcomp-declare iter :elcomp-noreturn t)) 144 | 145 | (dolist (iter '(car-safe cdr-safe sxhash)) 146 | (elcomp-declare iter :elcomp-nothrow t)) 147 | 148 | (elcomp-declare :elcomp-fetch-condition :elcomp-const t) 149 | 150 | ;; This first part of this list comes from the bytecode interpreter. 151 | ;; Then there are some useful additions. It's important not to add 152 | ;; things here which the user might want to advise. 153 | (dolist (iter '(nth symbolp consp stringp listp eq memq not car cdr 154 | cons list length aref aset symbol-value 155 | symbol-function set fset get substring concat 156 | 1- 1+ = > < <= >= - + max min * point 157 | goto-char insert point-max point-min char-after 158 | following-char preceding-char current-column 159 | indent-to eolp eobp bolp bobp current-buffer 160 | set-buffer interactive-p forward-char forward-word 161 | skip-chars-forward skip-chars-backward forward-line 162 | char-syntax buffer-substring delete-region 163 | narrow-to-region widen end-of-line 164 | set-marker match-beginning match-end upcase 165 | downcase string= string< equal nthcdr elt 166 | member assq nreverse setcar setcdr car-safe cdr-safe 167 | nconc / % numberp integerp 168 | ;; These aren't from bytecode.c. 169 | funcall apply sxhash)) 170 | (elcomp-declare iter :elcomp-direct t)) 171 | 172 | (provide 'elcomp/props) 173 | 174 | ;;; props.el ends here 175 | -------------------------------------------------------------------------------- /elcomp/ssa.el: -------------------------------------------------------------------------------- 1 | ;;; ssa.el --- change to SSA form. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This is a simple and dumb approach to converting the function into 6 | ;; SSA form. In particular it inserts way too many phi nodes, relying 7 | ;; on a later pass to prune them. 8 | 9 | ;; I think it would be better to replace this with an algorithm using 10 | ;; the dominance frontiers, though I haven't examined this too deeply. 11 | 12 | ;;; Code: 13 | 14 | (require 'elcomp) 15 | (require 'elcomp/eh-cleanup) 16 | 17 | (defun elcomp--ssa-require-phis-for-block (_compiler bb) 18 | "Ensure that the `phis' slot for BB has been initialized." 19 | (unless (elcomp--basic-block-phis bb) 20 | (setf (elcomp--basic-block-phis bb) (make-hash-table)))) 21 | 22 | (defun elcomp--ssa-new-name (symbol) 23 | (cl-gensym (concat (symbol-name symbol) "_"))) 24 | 25 | (defun elcomp--ssa-propagate (compiler to-block current-map) 26 | "Propagate name mappings for phi nodes. 27 | 28 | This adds the name mappings in CURRENT-MAP to the incoming name 29 | map of TO-BLOCK. All this does is add the incoming mappings to 30 | the existing phi nodes." 31 | (elcomp--ssa-require-phis-for-block compiler to-block) 32 | (let ((to-block-phis (elcomp--basic-block-phis to-block))) 33 | (maphash 34 | (lambda (name value) 35 | (let ((phi (gethash name to-block-phis))) 36 | (unless phi 37 | (setf phi (elcomp--phi ;; FIXME "original-" is a misnomer 38 | :original-name (elcomp--ssa-new-name name))) 39 | (puthash name phi to-block-phis)) 40 | (puthash value t (elcomp--args phi)))) 41 | current-map))) 42 | 43 | (defun elcomp--ssa-note-lhs (insn current-map) 44 | "Note the left-hand side of an assignment. 45 | 46 | If the left-hand-side of the assignment instruction INSN is 47 | non-nil, then the instruction is added to CURRENT-MAP. 48 | 49 | Returns t if CURRENT-MAP was updated, or nil if not." 50 | (let ((name (elcomp--sym insn))) 51 | (if name 52 | (let ((new-name (elcomp--ssa-new-name name))) 53 | (setf (elcomp--sym insn) new-name) 54 | (puthash name insn current-map) 55 | t) 56 | nil))) 57 | 58 | (defsubst elcomp--ssa-rename-arg (arg current-map) 59 | "Rename ARG using CURRENT-MAP." 60 | ;; FIXME - error if not found 61 | (gethash arg current-map arg)) 62 | 63 | (cl-defgeneric elcomp--ssa-rename (insn compiler current-map) 64 | "Update the instruction INSN to account for SSA renamings. 65 | 66 | Operands of INSN are looked up in CURRENT-MAP and replaced. If 67 | INSN is an assignment, then the left-hand-side is also updated. 68 | 69 | This returns t if CURRENT-MAP was modified by this renaming, and 70 | nil otherwise.") 71 | 72 | (cl-defmethod elcomp--ssa-rename ((insn elcomp--set) _compiler current-map) 73 | (setf (elcomp--value insn) (elcomp--ssa-rename-arg (elcomp--value insn) 74 | current-map)) 75 | (elcomp--ssa-note-lhs insn current-map)) 76 | 77 | (cl-defmethod elcomp--ssa-rename ((insn elcomp--call) _compiler current-map) 78 | ;; FIXME the :func slot. 79 | (let ((cell (elcomp--args insn))) 80 | (while cell 81 | (setf (car cell) (elcomp--ssa-rename-arg (car cell) current-map)) 82 | (setf cell (cdr cell)))) 83 | (elcomp--ssa-note-lhs insn current-map)) 84 | 85 | (cl-defmethod elcomp--ssa-rename ((insn elcomp--goto) compiler current-map) 86 | (elcomp--ssa-propagate compiler (elcomp--block insn) current-map) 87 | nil) 88 | 89 | (cl-defmethod elcomp--ssa-rename ((insn elcomp--if) compiler current-map) 90 | (setf (elcomp--sym insn) (elcomp--ssa-rename-arg (elcomp--sym insn) 91 | current-map)) 92 | (elcomp--ssa-propagate compiler (elcomp--block-true insn) current-map) 93 | (elcomp--ssa-propagate compiler (elcomp--block-false insn) current-map) 94 | nil) 95 | 96 | (cl-defmethod elcomp--ssa-rename ((insn elcomp--return) _compiler current-map) 97 | (setf (elcomp--sym insn) (elcomp--ssa-rename-arg (elcomp--sym insn) 98 | current-map)) 99 | nil) 100 | 101 | (cl-defmethod elcomp--ssa-rename ((insn elcomp--return) _compiler current-map) 102 | (setf (elcomp--sym insn) (elcomp--ssa-rename-arg (elcomp--sym insn) 103 | current-map)) 104 | nil) 105 | 106 | (defun elcomp--topmost-exception (bb) 107 | (cl-dolist (topmost-exception (elcomp--basic-block-exceptions bb)) 108 | (when (elcomp--handler topmost-exception) 109 | (cl-return topmost-exception)))) 110 | 111 | (defun elcomp--into-ssa-parse-args (compiler current-map) 112 | (let ((arg-list (cadr (elcomp--defun compiler)))) 113 | (while arg-list 114 | (let ((this-arg (pop arg-list)) 115 | (is-rest nil)) 116 | (cond 117 | ((eq this-arg '&rest) 118 | (setf is-rest t) 119 | (setf this-arg (pop arg-list))) 120 | ((eq this-arg '&optional) 121 | (setf this-arg (pop arg-list)))) 122 | (let ((arg-obj (elcomp--argument :original-name this-arg 123 | :is-rest is-rest))) 124 | (push arg-obj (elcomp--arguments compiler)) 125 | (puthash this-arg arg-obj current-map)))))) 126 | 127 | (defun elcomp--block-into-ssa (compiler bb) 128 | "Convert a single basic block into SSA form." 129 | (elcomp--ssa-require-phis-for-block compiler bb) 130 | ;; FIXME how to handle renaming for catch edges with a built-in 131 | ;; variable? those variables are defined in that scope... 132 | (let ((current-map (copy-hash-table (elcomp--basic-block-phis bb)))) 133 | ;; Set up the initial block with renamings of the arguments. 134 | (when (eq bb (elcomp--entry-block compiler)) 135 | (elcomp--into-ssa-parse-args compiler current-map)) 136 | (let ((changed-since-exception t) 137 | (topmost-exception (elcomp--topmost-exception bb))) 138 | (dolist (insn (elcomp--basic-block-code bb)) 139 | ;; If this instruction can throw, and if there have been any 140 | ;; changes since the last throwing instruction, then propagate 141 | ;; any state changes to the exception handler. 142 | (when (and topmost-exception 143 | changed-since-exception 144 | (elcomp--can-throw insn)) 145 | (elcomp--ssa-propagate compiler (elcomp--handler topmost-exception) 146 | current-map) 147 | (setf changed-since-exception nil)) 148 | ;; Rename the operands and also see whether the map has 149 | ;; changed. 150 | (when (elcomp--ssa-rename insn compiler current-map) 151 | (setf changed-since-exception t)))))) 152 | 153 | (defun elcomp--into-ssa-pass (compiler) 154 | "A pass to convert the function in COMPILER into SSA form." 155 | (dolist (bb (elcomp--reverse-postorder compiler)) 156 | (elcomp--block-into-ssa compiler bb))) 157 | 158 | (provide 'elcomp/ssa) 159 | 160 | ;;; ssa.el ends here 161 | -------------------------------------------------------------------------------- /elcomp/subst.el: -------------------------------------------------------------------------------- 1 | ;;; subst.el --- simple substitutions. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; This is some utility code to rewrite SSA names in a compiler 6 | ;; instance. The caller provides a map and all the instructions are 7 | ;; updated according to the map. 8 | 9 | ;;; Code: 10 | 11 | (require 'elcomp) 12 | 13 | (cl-defgeneric elcomp--rewrite-insn (insn _map) 14 | "Rewrite INSN according to MAP. 15 | 16 | MAP is a hash table mapping old instructions to new ones. 17 | 18 | Unhandled cases call `error'." 19 | (error "unhandled case: %S" insn)) 20 | 21 | (cl-defmethod elcomp--rewrite-insn ((insn elcomp--set) map) 22 | (let ((new-insn (gethash (elcomp--value insn) map))) 23 | (when new-insn 24 | (setf (elcomp--value insn) new-insn)))) 25 | 26 | (cl-defmethod elcomp--rewrite-insn ((insn elcomp--call) map) 27 | ;; FIXME: the :func slot? 28 | (cl-mapl 29 | (lambda (cell) 30 | (let ((new-insn (gethash (car cell) map))) 31 | (when new-insn 32 | (setf (car cell) new-insn)))) 33 | (elcomp--args insn))) 34 | 35 | (cl-defmethod elcomp--rewrite-insn ((_insn elcomp--goto) _map) 36 | nil) 37 | 38 | (cl-defmethod elcomp--rewrite-insn ((insn elcomp--if) map) 39 | (let ((new-insn (gethash (elcomp--sym insn) map))) 40 | (when new-insn 41 | (setf (elcomp--sym insn) new-insn)))) 42 | 43 | (cl-defmethod elcomp--rewrite-insn ((insn elcomp--return) map) 44 | (let ((new-insn (gethash (elcomp--sym insn) map))) 45 | (when new-insn 46 | (setf (elcomp--sym insn) new-insn)))) 47 | 48 | (cl-defmethod elcomp--rewrite-insn ((insn elcomp--phi) map) 49 | ;; Ugh. 50 | (let ((new-hash (make-hash-table))) 51 | (maphash 52 | (lambda (phi _ignore) 53 | (let ((subst (gethash phi map))) 54 | (puthash 55 | ;; It never makes sense to propagate a constant into a phi. 56 | (if (elcomp--constant-p subst) 57 | phi 58 | (or subst phi)) 59 | t new-hash))) 60 | (elcomp--args insn)) 61 | (setf (elcomp--args insn) new-hash))) 62 | 63 | ;; FIXME `elcomp--catch's :tag? 64 | 65 | (defun elcomp--rewrite-using-map (compiler map) 66 | "Rewrite all the instructions in COMPILER according to MAP. 67 | 68 | MAP is a hash table that maps old operands to new ones." 69 | (elcomp--iterate-over-bbs 70 | compiler 71 | (lambda (bb) 72 | (maphash (lambda (_ignore phi) 73 | (elcomp--rewrite-insn phi map)) 74 | (elcomp--basic-block-phis bb)) 75 | (dolist (insn (elcomp--basic-block-code bb)) 76 | (elcomp--rewrite-insn insn map))))) 77 | 78 | (provide 'elcomp/subst) 79 | 80 | ;;; subst.el ends here 81 | -------------------------------------------------------------------------------- /elcomp/toplevel.el: -------------------------------------------------------------------------------- 1 | ;;; toplevel.el --- compiler top level. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; Top level interface to compiler. 6 | 7 | ;;; Code: 8 | 9 | (require 'elcomp/coalesce) 10 | (require 'elcomp/cmacros) 11 | (require 'elcomp/cprop) 12 | (require 'elcomp/dom) 13 | (require 'elcomp/eh-cleanup) 14 | (require 'elcomp/jump-thread) 15 | (require 'elcomp/ssa) 16 | (require 'elcomp/typeinf) 17 | (require 'bytecomp) 18 | 19 | (defun elcomp--extract-defun (compiler form) 20 | (cond 21 | ((eq (car form) 'defun) 22 | (setf (elcomp--defun compiler) 23 | (list (cadr form) (cl-caddr form))) 24 | (setf form (cl-cdddr form))) 25 | ((eq (car form) 'defalias) 26 | (pcase form 27 | ;; Lame but I couldn't find a way to get pcase to match the 28 | ;; contents of the lambda as well. 29 | (`(defalias (quote ,name) (function ,body)) 30 | (unless (eq (car body) 'lambda) 31 | (error "defalias form missing lambda")) 32 | (setf (elcomp--defun compiler) 33 | (list name (cadr body))) 34 | (setf form (cddr body))) 35 | (_ (error "unrecognized defalias form")))) 36 | ((eq (car form) 'lambda) 37 | (setf (elcomp--defun compiler) 38 | (list nil (cadr form))) 39 | (setf form (cddr form))) 40 | (t 41 | (error "invalid form: currently only defalias, defun, lambda supported"))) 42 | 43 | ;; The doc string. 44 | (if (stringp (car form)) 45 | (progn 46 | (setf (elcomp--defun compiler) 47 | (nconc (elcomp--defun compiler) (list (car form)))) 48 | (setf form (cdr form))) 49 | (setf (elcomp--defun compiler) (nconc (elcomp--defun compiler) nil))) 50 | ;; Skip declarations. 51 | (while (and (consp (car form)) 52 | (eq (caar form) 'declare)) 53 | (setf form (cdr form))) 54 | ;; Interactive spec. 55 | (if (and (consp (car form)) 56 | (eq (caar form) 'interactive)) 57 | (progn 58 | (setf (elcomp--defun compiler) 59 | (nconc (elcomp--defun compiler) (list (cl-cadar form)))) 60 | (setf form (cdr form))) 61 | (setf (elcomp--defun compiler) (nconc (elcomp--defun compiler) nil))) 62 | (cons 'progn form)) 63 | 64 | (defun elcomp--optimize (compiler) 65 | (elcomp--thread-jumps-pass compiler nil) 66 | (elcomp--eh-cleanup-pass compiler) 67 | (elcomp--coalesce-pass compiler) 68 | (elcomp--into-ssa-pass compiler) 69 | (elcomp--cprop-pass compiler) 70 | (elcomp--thread-jumps-pass compiler t) 71 | (elcomp--coalesce-pass compiler) 72 | (elcomp--dce-pass compiler) 73 | (elcomp--infer-types-pass compiler)) 74 | 75 | ;; See bug #18971. 76 | (defvar byte-compile-free-assignments) 77 | (defvar byte-compile-free-references) 78 | (defvar byte-compile--outbuffer) 79 | 80 | (defun elcomp--translate (unit compiler form) 81 | (byte-compile-close-variables 82 | (let* ((byte-compile-macro-environment 83 | (append elcomp--compiler-macros 84 | byte-compile-macro-environment)) 85 | (result-var (elcomp--new-var compiler))) 86 | (setf form (macroexpand-all form byte-compile-macro-environment)) 87 | (setf (elcomp--unit compiler) unit) 88 | (setf (elcomp--entry-block compiler) (elcomp--label compiler)) 89 | (setf (elcomp--current-block compiler) (elcomp--entry-block compiler)) 90 | (setf form (elcomp--extract-defun compiler form)) 91 | (elcomp--linearize-defun 92 | compiler 93 | (byte-optimize-form form) 94 | result-var) 95 | (elcomp--add-return compiler result-var) 96 | (elcomp--optimize compiler)))) 97 | 98 | (defun elcomp--translate-all (unit) 99 | (while (elcomp--compilation-unit-work-list unit) 100 | (let ((args (pop (elcomp--compilation-unit-work-list unit)))) 101 | (apply #'elcomp--translate unit args)))) 102 | 103 | (defun elcomp--plan-to-compile (unit form) 104 | "Add FORM to the list of functions to be compiled by UNIT. 105 | 106 | FORM is a function definition. 107 | UNIT is a compilation unit object. 108 | 109 | This returns the new compiler object." 110 | (unless (gethash form (elcomp--compilation-unit-defuns unit)) 111 | (let ((compiler (make-elcomp))) 112 | (puthash form compiler (elcomp--compilation-unit-defuns unit)) 113 | (push (list compiler form) (elcomp--compilation-unit-work-list unit)) 114 | compiler))) 115 | 116 | (declare-function elcomp--pp-unit "elcomp/comp-debug") 117 | 118 | (defun elcomp--do (form-or-forms &optional backend) 119 | (unless backend 120 | (setf backend #'elcomp--pp-unit)) 121 | (let ((buf (get-buffer-create "*ELCOMP*"))) 122 | (with-current-buffer buf 123 | (erase-buffer) 124 | ;; Use "let*" so we can hack debugging prints into the compiler 125 | ;; and have them show up in the temporary buffer. 126 | (let* ((standard-output buf) 127 | (unit (make-elcomp--compilation-unit))) 128 | (if (memq (car form-or-forms) '(defun lambda)) 129 | (elcomp--plan-to-compile unit form-or-forms) 130 | (dolist (form form-or-forms) 131 | (elcomp--plan-to-compile unit form))) 132 | (elcomp--translate-all unit) 133 | (funcall backend unit)) 134 | (pop-to-buffer buf)))) 135 | 136 | (provide 'elcomp/toplevel) 137 | 138 | ;;; toplevel.el ends here 139 | -------------------------------------------------------------------------------- /elcomp/typeinf.el: -------------------------------------------------------------------------------- 1 | ;;; typeinf.el --- Type inference code. -*- lexical-binding:t -*- 2 | 3 | ;;; Commentary: 4 | 5 | ;; The type inference pass attempts to assign types to SSA names. 6 | 7 | ;; A type is just a symbol. The symbols used are largely just those 8 | ;; returned by `type-of', but there are a few differences. 9 | 10 | ;; First, (type-of nil) and (type-of t) yield 'symbol, but we 11 | ;; represent them as 'null and t. It's nice to treat these specially 12 | ;; as it enables some optimizations. 13 | 14 | ;; We also recognize some "merged" types that won't ever be returned 15 | ;; by `type-of'. For instance, we have a 'boolean type, which 16 | ;; corresponds to the booleanp predicate; a 'list type, which 17 | ;; indicates either a cons or nil; and a 'number type. 18 | 19 | ;; Types can be inferred in a few ways: 20 | 21 | ;; 1. A constant's type is immediately known. 22 | ;; 2. Some functions are annotated as returning a known type. 23 | ;; 3. Some functions are annotated as being 'simple-numeric' functions, 24 | ;; and have special treatment. See props.el. 25 | ;; 4. Type predicates such as integerp are used to annotate 26 | ;; variables. For example in: 27 | ;; (if (integerp x) (1+ x)) 28 | ;; the type of 'x' in the '1+' expression is known to be 'integer. 29 | 30 | ;; This one isn't implemented: 31 | ;; 5. Type declarations can be used to annotate variables, e.g.: 32 | ;; (let ((x 0)) (declare (type integer i)) ...) 33 | ;; Note that these are not checked, so for argument checking it 34 | ;; is better to use cl-check-type, as its expansion falls under 35 | ;; case 4 above. 36 | 37 | ;;; Code: 38 | 39 | (require 'elcomp) 40 | (require 'elcomp/coalesce) 41 | (require 'elcomp/dce) 42 | (require 'elcomp/jump-thread) 43 | (require 'elcomp/props) 44 | (require 'elcomp/subst) 45 | 46 | (cl-defstruct elcomp--typeinf 47 | "A structure that holds the data for a type-inference pass." 48 | worklist) 49 | 50 | (defun elcomp--nullable-type-p (type) 51 | "Return t if value of type TYPE can be nil." 52 | (memq type '(cons list symbol boolean :bottom))) 53 | 54 | (defun elcomp--sequence-type-p (type) 55 | "Return t if TYPE is a sequence type." 56 | (memq type '(list cons null bool-vector char-table string 57 | vector sequence))) 58 | 59 | (defun elcomp--numeric-type-p (type) 60 | "Return t if TYPE is a numeric type." 61 | (memq type '(float integer marker number))) 62 | 63 | (defun elcomp--boolean-type-p (type) 64 | "Return t if TYPE is a boolean type." 65 | (memq type '(null t boolean))) 66 | 67 | (defun elcomp--list-type-p (type) 68 | "Return t is TYPE is a list type." 69 | (memq type '(null cons list))) 70 | 71 | (defun elcomp--merge-types (&rest types) 72 | ;; Start with Top type. 73 | (let ((result :top)) 74 | (dolist (type types) 75 | (cond 76 | ((eq result :top) 77 | ;; Top + TYPE = TYPE. 78 | (setf result type)) 79 | 80 | ((eq type :top) 81 | ;; TYPE + Top = TYPE. 82 | ) 83 | 84 | ((eq result :bottom) 85 | ;; Nothing - already at bottom. 86 | ) 87 | 88 | ((eq type :bottom) 89 | (setf result :bottom)) 90 | 91 | ((eq result type) 92 | ;; Already the same. 93 | ) 94 | 95 | ((and (elcomp--sequence-type-p result) 96 | (elcomp--sequence-type-p type)) 97 | (setf result 'sequence)) 98 | 99 | ((and (elcomp--numeric-type-p result) 100 | (elcomp--numeric-type-p type)) 101 | (setf result 'number)) 102 | 103 | ((and (elcomp--boolean-type-p result) 104 | (elcomp--boolean-type-p type)) 105 | ;; does this even matter? 106 | (setf result 'boolean)) 107 | 108 | ((and (elcomp--list-type-p result) 109 | (elcomp--list-type-p type)) 110 | (setf result 'list)) 111 | 112 | (t 113 | ;; Merging any two random types results in bottom. 114 | (setf result :bottom)))) 115 | result)) 116 | 117 | (cl-defgeneric elcomp--compute-type (_obj _map) 118 | "Compute the type of OBJ in a basic block, given a type map. 119 | 120 | The type is generally the result of `type-of'. 121 | However `:top' is used to represent the 'top' type, 122 | `:bottom' is used to represent the 'bottom' type, 123 | and `nil' is used to mean a typeless instruction." 124 | ;; Default. 125 | nil) 126 | 127 | (cl-defmethod elcomp--compute-type ((obj elcomp--constant) _map) 128 | (let ((value (elcomp--value obj))) 129 | (cl-case value 130 | ;; nil has a type of its own. 131 | ((nil) 'null) 132 | ;; As does t. 133 | ((t) t) 134 | (t (type-of value))))) 135 | 136 | (cl-defmethod elcomp--compute-type ((obj elcomp--set) map) 137 | (elcomp--find-type (elcomp--value obj) map)) 138 | 139 | (defun elcomp--merge-math-types (arguments map) 140 | ;; With no arguments we return integer: 141 | ;; (type-of (+)) => integer. 142 | (let ((result 'integer)) 143 | (dolist (arg arguments) 144 | (let ((next-type (elcomp--find-type arg map))) 145 | (cond 146 | ((eq next-type :top) 147 | ;; Nothing. 148 | ) 149 | 150 | ((eq result 'float) 151 | ;; If we know we've seen a float, the result will be float. 152 | ) 153 | 154 | ;; Note here that this is true for even one argument. 155 | ;; (type-of (+ (point))) => integer 156 | ((and (memq result '(integer marker)) 157 | (memq next-type '(integer marker))) 158 | (setf result 'integer)) 159 | 160 | ((eq result next-type) 161 | ;; Nothing. 162 | ) 163 | 164 | ((eq next-type 'float) 165 | (setf result 'float)) 166 | 167 | (t 168 | ;; We know nothing. We could be even smarter and arrange 169 | ;; for type errors to be detected, and turn the current 170 | ;; instruction into a `diediedie'. 171 | (setf result 'number))))) 172 | 173 | result)) 174 | 175 | (cl-defmethod elcomp--compute-type ((obj elcomp--call) map) 176 | (if (not (elcomp--sym obj)) 177 | ;; No symbol means no type. 178 | nil 179 | (let ((func (elcomp--func obj))) 180 | (cond 181 | ;; If the function has a defined type, use it. 182 | ((elcomp--func-type func) 183 | (elcomp--func-type func)) 184 | 185 | ;; Handle simple numerics. 186 | ((elcomp--func-simple-numeric-p func) 187 | (elcomp--merge-math-types (elcomp--args obj) map)) 188 | 189 | (t 190 | ;; Nothing special. 191 | :bottom))))) 192 | 193 | (cl-defmethod elcomp--compute-type ((obj elcomp--phi) map) 194 | (let ((arg-list nil)) 195 | (maphash (lambda (var _ignore) 196 | ;; We treat phis specially: any input that isn't found 197 | ;; is just defaulted to :top, except for arguments, 198 | ;; which are :bottom. 199 | (push (if (elcomp--argument-p var) 200 | :bottom 201 | (gethash var map :top)) 202 | arg-list)) 203 | (elcomp--args obj)) 204 | (apply #'elcomp--merge-types arg-list))) 205 | 206 | (cl-defmethod elcomp--compute-type ((obj elcomp--argument) _map) 207 | (if (elcomp--is-rest obj) 208 | 'list 209 | :bottom)) 210 | 211 | (defun elcomp--find-type (obj map) 212 | (let ((value (gethash obj map))) 213 | (unless value 214 | (setf value (elcomp--compute-type obj map)) 215 | (when value 216 | (puthash obj value map))) 217 | value)) 218 | 219 | (defun elcomp--type-map-merge (bb from) 220 | "Merge type-map FROM into the type-map for basic block BB. 221 | 222 | Return non-nil if any changes were made." 223 | (if (elcomp--basic-block-type-map bb) 224 | ;; Merge. 225 | (let ((to-map (elcomp--basic-block-type-map bb)) 226 | (changed nil) 227 | phi-set) 228 | ;; First make a list of all the phis. We don't update phis 229 | ;; defined locally by direct propagation. FIXME this is not 230 | ;; super efficient. 231 | (maphash (lambda (_name phi) (push phi phi-set)) 232 | (elcomp--basic-block-phis bb)) 233 | (maphash 234 | (lambda (name type) 235 | (when (not (memq name phi-set)) 236 | (let* ((to-type (gethash name to-map :top)) 237 | (merge-type (elcomp--merge-types to-type type))) 238 | (unless (eq to-type merge-type) 239 | (puthash name merge-type to-map) 240 | (setf changed t))))) 241 | from) 242 | changed) 243 | ;; Else. 244 | (setf (elcomp--basic-block-type-map bb) (copy-hash-table from)) 245 | t)) 246 | 247 | (defun elcomp--type-map-propagate-one (infobj bb type-map) 248 | (when (elcomp--type-map-merge bb type-map) 249 | ;; Only push the BB if it isn't already on the work-list. 250 | (unless (memq bb (elcomp--typeinf-worklist infobj)) 251 | (push bb (elcomp--typeinf-worklist infobj))))) 252 | 253 | (cl-defgeneric elcomp--type-map-propagate (_insn _infobj _type-map) 254 | "FIXME" 255 | nil) 256 | 257 | (cl-defmethod elcomp--type-map-propagate ((insn elcomp--goto) infobj type-map) 258 | (elcomp--type-map-propagate-one infobj (elcomp--block insn) type-map)) 259 | 260 | (defun elcomp--find-type-predicate (sym) 261 | "Return type tested by the statement INSN, or nil." 262 | (when (elcomp--call-p sym) 263 | (elcomp--func-type-predicate (elcomp--func sym)))) 264 | 265 | (defun elcomp--pretend-eval-type-predicate (predicate-type arg-type) 266 | (cl-assert (not (eq predicate-type :top))) 267 | ;; (cl-assert (not (eq arg-type :top))) 268 | (cond 269 | ;; This is a "shouldn't happen", but it does happen when compiling 270 | ;; plist-member. FIXME. My guess is this is due to not marking 271 | ;; arguments as :bottom. 272 | ((eq arg-type :top) 273 | :both) 274 | 275 | ((eq predicate-type arg-type) 276 | t) 277 | 278 | ((eq arg-type :bottom) 279 | :both) 280 | 281 | ((eq arg-type 'null) 282 | (elcomp--nullable-type-p predicate-type)) 283 | 284 | ((and (eq arg-type t) 285 | (memq predicate-type '(boolean symbol))) 286 | t) 287 | 288 | ((and (eq predicate-type 'sequence) 289 | (elcomp--sequence-type-p arg-type)) 290 | t) 291 | 292 | ((and (eq predicate-type 'number) 293 | (elcomp--numeric-type-p arg-type)) 294 | t) 295 | 296 | ((and (eq predicate-type 'boolean) 297 | (elcomp--boolean-type-p arg-type)) 298 | t) 299 | 300 | ((and (eq predicate-type 'list) 301 | (elcomp--list-type-p arg-type)) 302 | t) 303 | 304 | (t 305 | ;; Anything is compatible with :bottom. 306 | (eq predicate-type :bottom)))) 307 | 308 | (cl-defmethod elcomp--type-map-propagate ((insn elcomp--if) infobj type-map) 309 | (let* ((sym (elcomp--sym insn)) 310 | (predicated-type (elcomp--find-type-predicate sym)) 311 | (predicate-arg (if predicated-type 312 | (car (elcomp--args sym)) 313 | nil)) 314 | ;; See whether the type predicate is known to be always true 315 | ;; or always false here. 316 | (branches (if predicated-type 317 | (elcomp--pretend-eval-type-predicate 318 | predicated-type 319 | (elcomp--find-type predicate-arg type-map)) 320 | :both))) 321 | 322 | ;; Handle inferencing by pretending the variable has a certain 323 | ;; type in the true branch. 324 | (when (memq branches '(t :both)) 325 | (if predicated-type 326 | (let ((predicate-arg (car (elcomp--args sym)))) 327 | (cl-letf (((gethash predicate-arg type-map) predicated-type)) 328 | (elcomp--type-map-propagate-one infobj (elcomp--block-true insn) 329 | type-map))) 330 | (elcomp--type-map-propagate-one infobj (elcomp--block-true insn) 331 | type-map))) 332 | 333 | ;; In theory we could use an "inverted type" here, but my guess is 334 | ;; that it isn't worthwhile. 335 | (when (memq branches '(nil :both)) 336 | (elcomp--type-map-propagate-one infobj (elcomp--block-false insn) 337 | type-map)))) 338 | 339 | (defun elcomp--type-map-propagate-exception (infobj bb type-map) 340 | (cl-dolist (exception (elcomp--basic-block-exceptions bb)) 341 | (cond 342 | ((elcomp--fake-unwind-protect-p exception) 343 | ;; Keep going. 344 | ) 345 | 346 | (t 347 | (elcomp--type-map-propagate-one infobj (elcomp--handler exception) 348 | type-map) 349 | (cl-return nil))))) 350 | 351 | (defun elcomp--infer-types-for-bb (bb infobj) 352 | ;; Work on a local copy. We're consing too much but it's for 353 | ;; another day. 354 | (let ((local-types (copy-hash-table (elcomp--basic-block-type-map bb)))) 355 | ;; Always reset the final map for the BB. 356 | (setf (elcomp--basic-block-final-type-map bb) local-types) 357 | 358 | ;; Compute the types for each phi node. 359 | (maphash 360 | (lambda (_ignore phi) 361 | (elcomp--find-type phi local-types)) 362 | (elcomp--basic-block-phis bb)) 363 | 364 | ;; Compute the type for each statement. 365 | (dolist (insn (elcomp--basic-block-code bb)) 366 | (elcomp--find-type insn local-types)) 367 | 368 | ;; Propagate the results and possibly add to the work list. 369 | (elcomp--type-map-propagate (elcomp--last-instruction bb) infobj 370 | local-types) 371 | (elcomp--type-map-propagate-exception infobj bb local-types))) 372 | 373 | (defun elcomp--look-up-type (bb var) 374 | (if (elcomp--constant-p var) 375 | (elcomp--compute-type var nil) 376 | (when (elcomp--basic-block-final-type-map bb) 377 | (gethash var (elcomp--basic-block-final-type-map bb))))) 378 | 379 | (defun elcomp--do-infer-types (compiler) 380 | (let ((infobj (make-elcomp--typeinf))) 381 | ;; Make sure the entry block has an initial type map. 382 | (let ((entry-block (elcomp--entry-block compiler))) 383 | (cl-assert (not (elcomp--basic-block-type-map entry-block))) 384 | (setf (elcomp--basic-block-type-map entry-block) (make-hash-table)) 385 | (dolist (arg (elcomp--arguments compiler)) 386 | (puthash arg :bottom (elcomp--basic-block-type-map entry-block))) 387 | (push entry-block (elcomp--typeinf-worklist infobj))) 388 | ;; Now keep inferring types until we're out of blocks. 389 | ;; FIXME where do we store the final maps? 390 | (while (elcomp--typeinf-worklist infobj) 391 | (let ((bb (pop (elcomp--typeinf-worklist infobj)))) 392 | (elcomp--infer-types-for-bb bb infobj))))) 393 | 394 | (defun elcomp--rewrite-type-predicates (compiler map) 395 | "Convert `if's to `goto's using type information. 396 | 397 | Update MAP with mappings from old to new instructions." 398 | (elcomp--iterate-over-bbs 399 | compiler 400 | (lambda (bb) 401 | (let ((iter (elcomp--basic-block-code bb))) 402 | (while iter 403 | (let ((insn (car iter))) 404 | (when (elcomp--call-p insn) 405 | (let* ((predicated-type (elcomp--find-type-predicate insn)) 406 | (predicate-arg (if predicated-type 407 | (car (elcomp--args insn)) 408 | nil)) 409 | (branches (if predicated-type 410 | (elcomp--pretend-eval-type-predicate 411 | predicated-type 412 | (elcomp--look-up-type bb 413 | predicate-arg)) 414 | :both))) 415 | ;; When this is true we have a call to a type 416 | ;; predicate, so we can replace it with a constant. 417 | (unless (eq branches :both) 418 | (let ((new-insn 419 | (elcomp--set :sym (elcomp--sym insn) 420 | :value 421 | (elcomp--constant :value branches)))) 422 | (setf (car iter) new-insn) 423 | (puthash insn new-insn map)))))) 424 | (setf iter (cdr iter))))))) 425 | 426 | (defun elcomp--infer-types-pass (compiler) 427 | (elcomp--do-infer-types compiler) 428 | (let ((rewrite-map (make-hash-table))) 429 | (elcomp--rewrite-type-predicates compiler rewrite-map) 430 | (elcomp--rewrite-using-map compiler rewrite-map)) 431 | (elcomp--cprop-pass compiler) 432 | (elcomp--thread-jumps-pass compiler t) 433 | (elcomp--coalesce-pass compiler) 434 | (elcomp--dce-pass compiler)) 435 | 436 | (provide 'elcomp/typeinf) 437 | 438 | ;;; typeinf.el ends here 439 | -------------------------------------------------------------------------------- /fns.el: -------------------------------------------------------------------------------- 1 | (defvar autoload-queue) 2 | 3 | (defun identity (arg) 4 | "Return the argument unchanged." 5 | arg) 6 | 7 | (defun copy-alist (alist) 8 | "Return a copy of ALIST. 9 | This is an alist which represents the same mapping from objects to objects, 10 | but does not share the alist structure with ALIST. 11 | The objects mapped (cars and cdrs of elements of the alist) 12 | are shared, however. 13 | Elements of ALIST that are not conses are also shared." 14 | (cl-check-type alist list) 15 | (cl-loop for elt in alist 16 | collect (if (consp elt) 17 | (cons (car elt) (cdr elt)) 18 | elt))) 19 | 20 | (defun nthcdr (num list) 21 | (cl-check-type num integer) 22 | (let ((i 0)) 23 | (while (and (< i num) list) 24 | (setq list (cdr list)) 25 | (setq i (1+ i))) 26 | list)) 27 | 28 | (defun nth (n list) 29 | "Return the Nth element of LIST. 30 | N counts from zero. If LIST is not that long, nil is returned." 31 | (car (nthcdr n list))) 32 | 33 | (defun elt (sequence n) 34 | (cl-check-type n integer) 35 | (if (listp sequence) 36 | (car (nthcdr n sequence)) 37 | (aref sequence n))) 38 | 39 | (defun member (elt list) 40 | "Return non-nil if ELT is an element of LIST. Comparison done with `equal'. 41 | The value is actually the tail of LIST whose car is ELT." 42 | (let ((tail list) 43 | (result nil)) 44 | (while (and (not result) (consp tail)) 45 | (let ((tem (car tail))) 46 | (when (equal elt tem) 47 | (setq result elt)))) 48 | result)) 49 | 50 | (defun memq (elt list) 51 | "Return non-nil if ELT is an element of LIST. Comparison done with `eq'. 52 | The value is actually the tail of LIST whose car is ELT." 53 | (let ((tail list) 54 | (result nil)) 55 | (while (and (not result) (consp tail)) 56 | (let ((tem (car tail))) 57 | (when (eq elt tem) 58 | (setq result elt)))) 59 | result)) 60 | 61 | (defun memql (elt list) 62 | "Return non-nil if ELT is an element of LIST. Comparison done with `eql'. 63 | The value is actually the tail of LIST whose car is ELT." 64 | (let ((tail list) 65 | (result nil)) 66 | (while (and (not result) (consp tail)) 67 | (let ((tem (car tail))) 68 | (when (eql elt tem) 69 | (setq result elt)))) 70 | result)) 71 | 72 | (defun assq (key list) 73 | "Return non-nil if KEY is `eq' to the car of an element of LIST. 74 | The value is actually the first element of LIST whose car is KEY. 75 | Elements of LIST that are not conses are ignored." 76 | (let ((keep-going t)) 77 | (while (and keep-going (consp list)) 78 | (if (and (consp (car list)) 79 | (eq (car (car list)) key)) 80 | (setq keep-going nil) 81 | (setq list (cdr list))))) 82 | (car list)) 83 | 84 | (defun assoc (key list) 85 | "Return non-nil if KEY is `equal' to the car of an element of LIST. 86 | The value is actually the first element of LIST whose car is KEY." 87 | (let ((keep-going t)) 88 | (while (and keep-going (consp list)) 89 | (if (and (consp (car list)) 90 | (equal (car (car list)) key)) 91 | (setq keep-going nil) 92 | (setq list (cdr list))))) 93 | (car list)) 94 | 95 | (defun rassq (key list) 96 | "Return non-nil if KEY is `eq' to the cdr of an element of LIST. 97 | The value is actually the first element of LIST whose cdr is KEY." 98 | (let ((keep-going t)) 99 | (while (and keep-going (consp list)) 100 | (if (and (consp (car list)) 101 | (eq (cdr (car list)) key)) 102 | (setq keep-going nil) 103 | (setq list (cdr list))))) 104 | (car list)) 105 | 106 | (defun rassoc (key list) 107 | "Return non-nil if KEY is `equal' to the cdr of an element of LIST.b 108 | The value is actually the first element of LIST whose cdr is KEY." 109 | (let ((keep-going t)) 110 | (while (and keep-going (consp list)) 111 | (if (and (consp (car list)) 112 | (equal (cdr (car list)) key)) 113 | (setq keep-going nil) 114 | (setq list (cdr list))))) 115 | (car list)) 116 | 117 | (defun nreverse (list) 118 | "Reverse LIST by modifying cdr pointers. 119 | Return the reversed list. Expects a properly nil-terminated list." 120 | (let ((prev nil) 121 | (tail list)) 122 | (while tail 123 | (let ((next (cdr tail))) 124 | (setcdr tail prev) 125 | (setq prev tail) 126 | (setq tail next))) 127 | prev)) 128 | 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | 131 | (defun featurep (feature &optional subfeature) 132 | (cl-check-type feature symbol) 133 | (let ((tem (memq feature features))) 134 | (and tem subfeature 135 | (setq tem (member subfeature (get feature 'subfeatures)))) 136 | (if tem t))) 137 | 138 | (defun provide (feature subfeatures) 139 | (cl-check-type feature symbol) 140 | (cl-check-type subfeatures list) 141 | (when autoload-queue 142 | (push (cons 0 features) autoload-queue)) 143 | (unless (memq feature features) 144 | (push feature features)) 145 | (when subfeatures 146 | (put feature 'subfeatures subfeatures)) 147 | ;; if (initialized) <- add back 148 | (push (cons 'provide feature) current-load-list) 149 | (let ((tem (assq feature after-load-alist))) 150 | (if (consp tem) 151 | (mapc #'funcall (cdr tem)))) 152 | feature) 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | 156 | (defun plist-member (plist prop) 157 | (while (and (consp plist) 158 | (not (eq (car plist) prop))) 159 | (setf plist (cddr plist))) 160 | plist) 161 | 162 | (defun widget-put (widget property value) 163 | (setcdr widget (plist-put (cdr widget) property value))) 164 | 165 | (defun widget-get (widget property) 166 | (catch 'done ;FIXME - lexical catch 167 | (while t 168 | (unless widget 169 | (throw 'done nil)) 170 | (let ((tmp (plist-member (cdr widget) property))) 171 | (when (consp tmp) 172 | (setf tmp (cdr tmp)) 173 | (throw 'done (car tmp))) 174 | (setf tmp (car widget)) 175 | (unless tmp 176 | (throw 'done nil)) 177 | (setf widget (get tmp 'widget-type)))))) 178 | 179 | (defun widget-apply (widget property &rest args) 180 | (apply (widget-get widget property) widget args)) 181 | -------------------------------------------------------------------------------- /futures.org: -------------------------------------------------------------------------------- 1 | * Futures 2 | 3 | ** Emacs should itself be written in emacs lisp 4 | 5 | *** For every part this seems pretty hard! 6 | *** But: 7 | 8 | ** This compiler can be used to bootstrap this process 9 | With type declarations and inferencing it can be as efficient 10 | as the C code 11 | 12 | *** Plenty of examples, e.g. provide or copy-alist 13 | 14 | ** It can also JIT compile parts as needed 15 | 16 | ** Type-generic operations like + would be better expressed 17 | using defgeneric and defmethod. then the compiler could 18 | more easily optimize? Not clear. 19 | 20 | ** Meanwhile there should be a rule about use of Fwhatever in Emacs 21 | 22 | *** Only "inlineable" uses should be permitted 23 | *** Things like Fload should indirect via Ffuncall 24 | *** This is very easy to do when translating from lisp 25 | 26 | ** It is bad that Emacs has 3 interpreters in it: 27 | *** Emacs Lisp 28 | *** Regexp 29 | *** CCL 30 | -------------------------------------------------------------------------------- /loadup.el: -------------------------------------------------------------------------------- 1 | (defconst elcomp--loadup-dir 2 | (file-name-directory (or load-file-name 3 | ;; In the eval-buffer case. 4 | (buffer-file-name)))) 5 | 6 | (defun elcomp--loadup () 7 | (interactive) 8 | (let ((load-path load-path)) 9 | (push elcomp--loadup-dir load-path) 10 | (dolist (file '("elcomp" 11 | "elcomp/back" 12 | "elcomp/c-inl" 13 | "elcomp/cmacros" 14 | "elcomp/coalesce" 15 | "elcomp/comp-debug" 16 | "elcomp/cprop" 17 | "elcomp/dce" 18 | "elcomp/dom" 19 | "elcomp/eh-cleanup" 20 | "elcomp/eltoc" 21 | "elcomp/ffi" 22 | "elcomp/iter" 23 | "elcomp/jump-thread" 24 | "elcomp/linearize" 25 | "elcomp/name-map" 26 | "elcomp/props" 27 | "elcomp/ssa" 28 | "elcomp/subst" 29 | "elcomp/toplevel" 30 | "elcomp/typeinf")) 31 | (load file nil t)))) 32 | -------------------------------------------------------------------------------- /project.org: -------------------------------------------------------------------------------- 1 | * Plan 2 | 3 | * To Do 4 | 5 | ** C back end could use AUTO_CONS and AUTO_STRING 6 | (info "(elisp) Stack-allocated Objects") 7 | 8 | ** need to handle out-of-ssa for exception edges 9 | 10 | ** turn elcomp--iterate-over-bbs into a macro to be more elisp-like. 11 | add a declare form to fix the indentation 12 | 13 | ** maybe add a dynamic-module-API back end 14 | 15 | ** `car` should be `const`, ditto cdr, car-safe, cdr-safe, 16 | aref, etc 17 | also, in cprop.el, it seems like a const function could be 18 | pre-evaluated when all arguments are constant; not just a pure 19 | function 20 | 21 | ** we should be able to notice NILP(Fconsp) and turn it into 22 | CONSP. This requires unboxing 23 | 24 | ** make an elcomp-debug-output-mode, derived from special-mode, 25 | where "g" re-runs the command; handy for debugging 26 | should store the sexp and the backend function 27 | 28 | ** arguments need types set to :bottom 29 | 30 | ** typeinf.el doesn't handle keywordp specially, but should 31 | 32 | ** make sure calls to a lambda work ok 33 | C BE should make a static function 34 | the call should resolve to a call to the compiled function somehow 35 | -> ? 36 | 37 | ** clean up the calls to declare-function 38 | I think ideally they should not be needed 39 | 40 | ** A "catch" with a non-constant tag will still require 41 | special handling in the IR, e.g. when converting to SSA form 42 | this isn't done now 43 | 44 | ** There are various spots where the :func slot of a call 45 | is handled improperly 46 | 47 | ** We need a `lexical-catch' of some kind 48 | *** Could also mark various subrs as "cannot throw" as a special case 49 | Except we have Vthrow_on_input ... 50 | *** Common Lisp uses block and return for lexical catch, so 51 | we should do that 52 | *** see the "emacs bugs" section below 53 | 54 | ** We can merge blocks with different exception handlers 55 | if one of them doesn't have any throwing instructions 56 | likewise if we have fake-unwind-protect? 57 | 58 | ** We can remove specbind/unbind if there aren't intervening statements 59 | probably unimportant optimization though? 60 | 61 | ** Can specbind or unbind throw? 62 | 63 | ** Remove "defuns" from compiler? 64 | 65 | ** We don't handle lambdas at all 66 | *** Need to do closure-conversion 67 | *** Probably need to handle "closure" 68 | *** the C core would ideally need updates to handle native closures 69 | but there is probably a way to work around this 70 | 71 | ** Some special forms are still not handled 72 | 73 | ** "Ordinary special forms" 74 | 75 | (let ((result nil)) 76 | (mapatoms (lambda (sym) 77 | (when (special-form-p (symbol-function sym)) 78 | (push sym result)))) 79 | result) 80 | 81 | *** (defconst defvar interactive) 82 | 83 | *** (Note track-mouse turned into a macro) 84 | 85 | *** save-current-buffer 86 | *** save-restriction 87 | *** save-excursion 88 | 89 | ** can turn throw->catch into a goto 90 | 91 | (catch CONST (... (throw CONST val))) 92 | => 93 | R = val; GOTO done 94 | 95 | We do this already but can do better by handling unwind-protect as 96 | well 97 | 98 | * Passes 99 | 100 | ** SCCP pass 101 | 102 | ** GVN pass 103 | 104 | ** Note that we can copy-propagate into a funcall or apply 105 | For apply this is a bit like strength reduction 106 | 107 | ** Can we always optimize mapc and mapcar with a lambda? 108 | If we add a compiler macro can it expand back to 'itself'? 109 | 110 | ** We can optimize some regexps. 111 | for example looking-at-p with a constant can be turned into ordinary code 112 | especially if the regexp is very simple this would be a win 113 | same with string-match-p 114 | 115 | ** At least a simple form of TCO is easy 116 | 117 | ** Look into a smarter form of closure conversion 118 | Possibly sometimes we could optimize away closed-over variables, etc 119 | 120 | ** We could convert `elt' to aref or nth if we deduced the type 121 | This could just be done with a compiler macro. 122 | Or by rewriting 'elt' entirely into a macro 123 | 124 | ** We could perhaps inline nth and nthcdr if the argument is a constant 125 | 126 | * Back Ends 127 | 128 | ** Disassembly 129 | 130 | ** C Code 131 | 132 | *** if we're generating code to compile and dlopen then we don't really 133 | need DEFUN, and generating a doc comment is the wrong thing to do 134 | 135 | *** Currently does not handle QUIT etc. 136 | 137 | *** Could use Aurélien's "FFI" / DSO thing 138 | 139 | *** Type inference would be great here, could do unboxing 140 | **** this works ok but needs better code generation 141 | 142 | ** Bytecode 143 | 144 | *** bytecode from this compiler would probably be worse than what 145 | emacs generates 146 | *** however, we could instead write a new bytecode interpreter 147 | a register-based interpreter would likely be faster anyway 148 | 149 | * Emacs Bugs and Changes 150 | 151 | ** the emacs core needs to support a SUBR in a `closure' list 152 | 153 | ** we need the number of arguments constant exported 154 | see eltoc.el 155 | if we write some kind of jit back end, we'll need many more 156 | constants, like how to unbox 157 | 158 | ** we need hacks to emacs for unwinding, see eltoc.el 159 | 160 | ** in the c code we can get a vector of args 161 | but elisp is always going to want a list for &rest 162 | we could do better with &vector-rest 163 | 164 | ** There's no way to recapture the fact that some CL 'throw' constructs 165 | are lexical 166 | we need our own special hack. like maybe CL could put a special 167 | property on the magic symbols it makes 168 | 169 | ** concat and mapconcat don't allow characters 170 | this seems unfriendly and pointless 171 | 172 | ** vc-dir "i" gives an unhelpful error if any other file is marked 173 | this seems somewhat useless 174 | 175 | ** it seems strange for elisp to have both defstruct and defclass 176 | given that it isn't really planning to be CL 177 | 178 | ** it seems that cl-nreconc would be more efficient as 179 | (prog1 (nreverse x) (setcdr x y)) 180 | ... not if x=nil? 181 | 182 | ** I wonder if progv is implemented correctly now that 183 | macroexpand is done eagerly 184 | -------------------------------------------------------------------------------- /scripts/get-defuns.el: -------------------------------------------------------------------------------- 1 | (defconst emacs-source "/home/tromey/Emacs/emacs/src/") 2 | 3 | (defconst output-file (expand-file-name "elcomp/c-renames.el")) 4 | 5 | (defvar defun-names nil) 6 | 7 | (dolist (file (directory-files emacs-source t "\\.c\\'")) 8 | (message "Scanning %s" file) 9 | (find-file-read-only file) 10 | (goto-char (point-min)) 11 | (while (re-search-forward 12 | "^DEFUN\\s-*(\"\\([^\"]+\\)\",\\s-*\\([a-zA-Z0-9_]+\\)" nil t) 13 | (let ((lisp-name (match-string 1)) 14 | (c-name (match-string 2)) 15 | (replacement nil)) 16 | (setf replacement (concat "F" 17 | (replace-regexp-in-string "-" "_" lisp-name))) 18 | (unless (equal replacement c-name) 19 | (push (cons (intern lisp-name) c-name) defun-names))))) 20 | 21 | (find-file output-file) 22 | (erase-buffer) 23 | (insert ";; Autogenerated by get-defuns.el\n") 24 | (pp `(defvar elcomp--c-renames ',defun-names) (current-buffer)) 25 | (insert "(provide 'elcomp/c-renames)\n") 26 | (save-buffer) 27 | --------------------------------------------------------------------------------