From 02f30c68b7d4c6c4a8c40fdb4d8e7f8ade3681c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 22 Nov 2019 12:50:20 +0100 Subject: [PATCH 1/9] cmp: improve notes --- src/cmp/notes.org | 708 +++++++++++++++++++++++++++++++++++++++++++ src/newcmp/notes.org | 369 ---------------------- 2 files changed, 708 insertions(+), 369 deletions(-) create mode 100644 src/cmp/notes.org delete mode 100644 src/newcmp/notes.org diff --git a/src/cmp/notes.org b/src/cmp/notes.org new file mode 100644 index 000000000..4926bbf79 --- /dev/null +++ b/src/cmp/notes.org @@ -0,0 +1,708 @@ + +* ECL compiler + +ECL's comipler source code may be little hard to read. It relies +heavily on global variables and the code has grown over many years of +fixes and improvements. These notes are meant to serve the purpose of +a guide (not a reference manual or a documentation). If you notice +that they are not up to date then please submit a patch with +corrections. + +** Abstract syntax tree + +Syntax tree nodes are represented as instances of the ~c1form~ +structure. Each node has a slot ~name~ which is a symbol denoting the +operator and information about the file and position in it. + +Operators are dispatched to functions with appropriate tables +associated with a functionality (i.e ~*p1-dispatch-table*~ is a +dispatch table for type propagators associated with ~c1form~'s). + +** References + +Object references are used for numerous optimizations. They are +represented as instances of ~ref~ structure descendants: + +- var :: variable reference +- fun :: function reference +- blk :: block reference (block/return) +- tag :: tag reference (tagbody/go) + +Each reference has an identifier, number of references, flags for +cross-closure-boundary and cross-local-function-boundary references +and a list of nodes (c1forms) which refer to the object. + +** Compilation algorithm (simlified) + +When compiling a file (simplified ovierview): + +First pass: + +1. Check if the file exists and that we can perform the compilation +2. Estabilish the compilation environment +3. Load ~cmpinit.lsp~ if present in the same directory +4. Initialize a data section and construct the AST (~compiler-pass1~) + +Second pass: + +1. Compute initialization function name (entry point of the object) +2. Propagate types through the AST +2. Compile AST to a C source files ~.c~ and ~.eclh~ (~compiler-pass2~) +3. Dump a data segment in a ~.data~ file (symbol ~compiler_data_text~) +4. Compile artifacts with the C compiler (~compiler-cc~ and ~bundle-cc~)) + +*** compiler-pass1 + +1. Initialize a data section + +Data section contains permanent and temporary objects which are later +serialized in a data segment of the complaition artifacts after the +second pass. Objects put in data section are constants, symbols, +~load-time-value~'s etc. The same object may be added few times, then +it is stored as a location. Not object types can be dumped to C file. + +2. Construct the AST + +Each form which is read is passed to t1expr creates a ~c1form~ which +are stored in ~*top-level-forms*~ which are later used in the second +pass. ~c1form~ is created as follows (simplified pseudocode): + +#+BEGIN_SRC common-lisp + (defun t1expr* (form) + (setq form (maybe-expand-symbol-macro form)) + (when (atom form) + ;; ignore the form + (return)) + (destructuring-bind (op args) form + (typecase op + (cons + (t1ordinary form)) + ((not symbol) + (error "illegal function")) + ((eq quote) + ;; should we ignore the form(?) + (t1ordinary 'NIL)) + (t1-dispatch-entry + (top-level-dispatch form)) + (c1-dispatch-entry + (not-top-level-dispatch form)) + (expandable-compiler-macro + (add 'macroexpand *current-toplevel-form*) + (t1expr* (expand-macro form))) + (expandable-macro + (add 'macroexpand *current-toplevel-form*) + (t1expr* (expand-macro form))) + (otherwise + (t1ordinary form))))) +#+END_SRC + +Forms are processed recursively with appropriate operator +handlers. Funcations named ~t1xxx~ are a top level form handlers while +~c1xxx~ are handlers for the rest. When operator is not special it is +processed according to normal rules i.e with ~c1call~. + +Function ~t1ordinary~ handles top-level forms which do not have +special semantics associated with them by binding top-levelness flag +to NIL and adding a c1form with a name ~ordinary~ and storing result +of ~(c1expr form)~ in load-time values. Top level forms may have side +effects (i.e registering a macro in a global compiler environment). + +Function ~c1expr~ is used to handle forms which are not +top-level. Dispatched operator handler may eliminate dead code, +perform constant folding and propagate constants and rewrite the form +which is processed again. Handler may modify the compiler environment +(i.e register a local function or a local variable) and add new +objects to a data section. Already created c1forms may be updated i.e +to note that there is a cross-closure reference. + +*** compiler-pass2 + +Second pass is responsible for producing files which are then compiled +by the C compiler. For top level forms we have ~t2xxx~ handlers and +for the rest ~c2xxx~ handlers. Additionally there are other helper +tables (~p1xxx~ for type propagation and location dispatch tables +~set-loc~ and ~wt-loc~ with varying handler names). + +#+BEGIN_SRC lisp + (defun pass2 () + (produce-headers) + (eclh/produce-data-section-declarations) + (with-initialization-code () ; this is put at the end of c file + (include-data-file) + (produce-initialize-cblock) + (produce-setf-function-definitions) + (do-type-propagation *top-level-forms*) + ;; compiler-phase "t2" starts now + ;; + ;; This part is tricky. When we emit top-level form part of it + ;; lands in the c-file before the initialization code (C function + ;; definitions) and part is put in the initialization code. + (emit-top-level-forms *make-forms*) + (emit-top-level-forms *top-level-forms*)) + (eclh/produce-data-segment-declarations) + (eclh/produce-setf-function-definers) ; should be inlined in c file? + (eclh/add-static-constants) ; CHECKME never triggered? + (eclh/declare-c-funciton-table) ; static table with function data + ;; compiler-phase "t3" starts now + (eclh/declare-callback-functions) ; calls t3-callback + (data/dump-data-section)) + + (defun emit-top-level-form (form) + (with-init () + (emit (t2expr form))) + (do-local-funs (fun) + ;; t3local-fun may add new local funs to process. + (emit (t3local-fun fun)))) +#+END_SRC + +**** Example output + +Example output in pseudocode follows. I've put some comments to +indicate potential issues and improvement opportunities. + +- .eclh :: static data, declarations and symbol mappings +#+BEGIN_SRC c (.eclh pseudocode) + static cl_object *VV; /* declare data section */ + static cl_object Cblock; + + #define VM size_of_data_permanent_storage; + #define VMtemp size_of_data_temporary_storage; + + /* Declare functions in this file. They are declared static and hold + in Cblock to assure that we can recompile the fasl and load it. */ + static cl_object L1ordinary_function(cl_object , cl_object ); + static cl_object LC2foobar(cl_object , cl_object ); + static cl_object LC3__g0(cl_object , cl_object ); + + /* In safe code we always go through ecl_fdefinition and then this + macro definition expands to nothing. */ + #define ECL_DEFINE_SETF_FUNCTIONS \\ + VV[10]=ecl_setf_definition(VV[11],ECL_T); \\ + VV[12]=ecl_setf_definition(VV[13],ECL_T); + + /* Statically defined constants. + + XXX I'm not sure how to trigger constant builders. Needs + investigation if it is not a dead code, and if so whether we should + resurrect it or remove. */ + + /* exported lisp functions -- installed in Cblock */ + #define compiler_cfuns_size 1 + static const struct ecl_cfunfixed compiler_cfuns[] = { + /*t,m,narg,padding,name=function-location,block=name-location,entry,entry_fixed,file,file_position*/ + {0,0,2,0,ecl_make_fixnum(6),ecl_make_fixnum(0),(cl_objectfn)L1ordinary_function,NULL,ECL_NIL,ecl_make_fixnum(23)}, + }; + + /* callback declarations (functions defined with defcallback). */ + #include + static int ecl_callback_0(int var0,int var1); +#+END_SRC + +- .data :: data segment +#+BEGIN_SRC c (.data pseudocode) + static const struct ecl_base_string compiler_data_text1[] = { + (int8_t)t_base_string, 0, ecl_aet_bc, 0, + ECL_NIL, (cl_index)1065, (cl_index)1065, + (ecl_base_char*) + "common-lisp-user::make-closure common-lisp-user::ordinary-function common-lisp-u" + "ser::+ordinary_constant+ common-lisp-user::*foobar* common-lisp-user::foobar :de" + "lete-methods clossy-package::bam 0 0 si::dodefpackage clos::install-method clos:" + ":associate-methods-to-gfun \"CL-USER\" ((optimize (debug 1))) (defun common-lisp-u" + "ser::make-closure) (#1=#P\"/home/jack/test/foobar.lisp\" . 55) (defun common-lisp-" + "user::ordinary-function) (#1# . 132) (common-lisp-user::a common-lisp-user::b) 4" + "2.32 (defconstant common-lisp-user::+ordinary_constant+) (#1# . 175) (defvar com" + "mon-lisp-user::*foobar*) (#1# . 216) (defun common-lisp-user::foobar) (#1# . 237" + ") \"CLOSSY-PACKAGE\" (\"CL\") (\"BAM\" \"GENERIC-FUNCTION\") (defgeneric generic-functio" + "n) (#1# . 451) (clossy-package::a clossy-package::b) (defmethod generic-function" + " (clossy-package::a real) (clossy-package::b real)) (real real) (defmethod gener" + "ic-function (clossy-package::a integer) (clossy-package::b integer)) (integer in" + "teger) (defclass clossy-package::bam) (#1# . 582) ((:initform 42 :initargs (:a) " + ":name clossy-package::a))" }; + + static const cl_object compiler_data_text[] = { + (cl_object)compiler_data_text1, + NULL}; +#+END_SRC + +- .c :: function definitions and the initialization code +#+BEGIN_SRC c (.c pseudocode) + #include + #include "/absolute/path/to/.eclh" + + /* Normal functions are defined with DEFUN. Local functions may be + lambdas, closures, methods, callbacks etc. + + XXX callback function implementations should be inlined to avoid + indirection. + + XXX method function names are named like LCn__g0 and on lisp side + they have names like g0 -- gensymed part of the name should be + produced from the generic function name for easier debugging. */ + + /* normal function definitions */ + static cl_object L1fun (cl_object v1a, cl_object v2b) { /*...*/ } + /* local function definitions */ + static cl_object LC2__g0 (cl_object v1a) { /* method */ } + static cl_object LC3__g0 (cl_narg narg, ...) { /* closure */ } + static cl_object LC4foobar (cl_object v1a, cl_object v2b) { /* callback */ } + + /* callbacks */ + static int ecl_callback_0 (int var0, int var1) { /* calls LC2foobar */ } + + #include "/absolute/path/to/.data" + ECL_DLLEXPORT void init_fas_CODE(cl_object flag) { + /* Function is designed to work in two passes. */ + if (flag != OBJNULL) { + /* The loader passes a cblock as flag for us to initialize. */ + Cblock = flag->cblock; + flag->cblock.data = VV; + flag->cblock.data_text = compiler_data_text; + /* ... */ + return; + } + /* The loader initializes the module (calls READ on data segment + elements and initializes cblock.data with results, then installs + functions and their source information. */ + + /* 2. Execute top level code. */ + VVtemp = Cblock->cblock.temp_data; + ECL_DEFINE_SETF_FUNCTIONS; + + /* Note that mere annotation in a simple file requires plenty of + function calls so that impacts FASL load time. We should make + annotations part of the objects themself (instead of keeping a + central registry), then maybe we could keep this data static. */ + + si_select_package(VVtemp[0]); + (cl_env_copy->function=(ECL_SYM("MAPC",545)->symbol.gfdef))->cfun.entry(2, ECL_SYM("PROCLAIM",668), VVtemp[1]) /* MAPC */; + ecl_function_dispatch(cl_env_copy,ECL_SYM("ANNOTATE",1823))(4, VV[0], ECL_SYM("LOCATION",1829), VVtemp[2], VVtemp[3]) /* ANNOTATE */; + ecl_function_dispatch(cl_env_copy,ECL_SYM("ANNOTATE",1823))(4, VV[0], ECL_SYM("LAMBDA-LIST",1000), ECL_NIL, ECL_NIL) /* ANNOTATE */; + ecl_cmp_defun(VV[7]); /* MAKE-CLOSURE */ + /* ... */ + si_select_package(VVtemp[14]); + + /* XXX defgeneric should be compiled. */ + (cl_env_copy->function=(ECL_SYM("ENSURE-GENERIC-FUNCTION",944)->symbol.gfdef))->cfun.entry(5, ECL_SYM("GENERIC-FUNCTION",947), VV[5], ECL_T, ECL_SYM("LAMBDA-LIST",1000), VVtemp[19]) /* ENSURE-GENERIC-FUNCTION */; + clos_load_defclass(VV[6], ECL_NIL, VVtemp[26], ECL_NIL); + /* ... */ + } +#+END_SRC + +Generic functions are not compiled. + +** Representation types +Compilation target machine is described in terms of types supported by +the target compiler. ~+representation-types+~ cover primitives types +which are representable in C (:byte, :fixnum, :float-sse-pack, :bool, +:pointer-void etc.). Each type has a corresponding Lisp type, C type +and ways to convert between Lisp and C types (a separate column shows +how to perform an unsafe convertion on unboxed values). List is +ordered from the most specific to the least specific. + +To describe a concreete machine two variables are used: +~+all-machines-c-types+~ containing common types for all C compilers +(without integers) and ~+this-machine-c-types+~ adding integers and +types which vary between C compilers (i.e ~long long int~). Optionally +each type has information about number of bits used (for bit +fiddling), that information should be kept separate (imo). Variable +~*default-machine*~ use constructed from these both +tables. Alternative machine representations may be created for cross +compilation. + +Each representation type is represented by an instance of a structure +~rep-type~. That information is used when the C code is generated to +manipulate data of certain type. + +** Environments + +*** Compilation environment +*** The Global environment +*** Dynamic environments +*** Lexical environments +**** Debug Lexical Environment + +Environment objects + +http://www.lispworks.com/documentation/HyperSpec/Body/03_aa.htm + +** Loading FASL files + +** Cross compilation +* old notes +** si:cmp-env-register-macrolet should be part of cmpenv-api +** extract type propagation pass, see 7e8d0985155 + +** cmpdata, cmpdata-bk +*** Frontend +vv structure is a single data section entry. We have two data stores – +permanent and temporary. + +- vv-location :: index in data-store (a number) +- vv-permanent-p :: store flag (t -> permanent, nil -> temporary) +- vv-used-p :: flag indicating if entry is referenced, if not it gets + optimized away (same goes for *load-objects*). To keep indexing + and data size intact we put 0 in place of optimized objects. +- vv-value :: holds the entry actual value + +- *load-objects* :: collection of all objects which are created by a + lisp form – we don't include them in datasection. We need to keep + track of them to filter them out. + +- data-size :: size of data stores combined + +- data-init :: initalizes data stores. If filename parameter is + present, then it objects are read from the file. Otherwise store + is empty. + +- data-dump-array :: dumps data stores + +*** Backend +- add-static-constant :: called from data frontend. +- data-c-dump :: called from cmpmain, creates data section in a + separate C file +- wt-vv :: used by cmploc, accesses element in data section +- set-vv :: used in cmploc, modifies element in data section + +** pass1 extract 1st attempt: +#+BEGIN_SRC lisp + (defpackage ecl-cmp/int + (:use #:ffi #:ext #:cl) + (:export + ;; BACKEND REFERENCES IN FRONTEND!!! + #:lisp-type->rep-type #:c1make-var #:check-vref #:lisp-type-p + #:rep-type->lisp-type #:expand-type-assertion #:machine-c-type-p + ;; opts (SHOULDN'T BE) + #:constant-value-p + ;; things which should be local to the module + #:*compile-toplevel* + #:*top-level-forms* ; referenced in cmp1top, bound in cmptop (and not used?) + #:*load-time-values* ; referenced in cmp1top, bound in cmpmain (and not used?) + #:clos-compiler-macro-expand ; used only in pass1 + #:*optimizable-constants* ; used only in pass1 and cmpopt-constant + #:*setjmps* ; local to pass1 + #:*use-c-global* ; local to pass1 + #:*clines-string-list* ; shared by ffi of both passses (and 1ct) + #:c1body ; should be brought back to cmpenv-declaim! + #:*next-cfun* ; used only in cmp1lam, but part of cmpenv + #:lisp-to-c-name ; used in cmpvar, cmp1lam + ;; common utilities + #:make-dispatch-table #:check-args-number #:print-current-form + ;; cmputil (conditions) + #:cmpck #:cmpassert #:cmperr #:cmpdebug #:cmpnote + ;; types (arith and propagation) + #:object-type #:trivial-type-p #:values-type-and #:values-type-primary-type + #:type-and #:type-or #:values-type-or #:valid-type-specifier + #:propagate-types + ;; locations + #:add-object #:add-symbol #:loc-in-c1form-movable-p + #:*make-forms* + ;; internal representation + #:call-global #:ordinary #:var #:fmla-and #:fmla-or #:fmla-not + #:locals #:stack-push-values #:with-stack #:call-local + ;; + #:make-c1form* #:*current-toplevel-form* + #:c1form-p #:c1form-type + #:c1form-primary-type + #:c1form-name + #:c1form-constant-p + #:c1form-arg + #:c1form-args + #:c1form-replace-with + #:c1form-side-effects + #:c1form-volatile + #:delete-c1forms + #:and-form-type ; not sure if it belogns here + #:local-function-ref ; XXX: defined in env + #:*current-function* + #:make-fun + #:fun-name + #:fun-parent + #:fun-lambda-expression + #:fun-cmp-env + #:fun-global + #:fun-cfun + #:fun-exported + #:fun-closure + #:fun-minarg + #:fun-maxarg + #:fun-description + #:fun-no-entry + #:fun-referenced-funs + #:fun-child-funs + #:fun-lambda + #:fun-var + #:fun-ref + #:fun-referenced-vars + #:fun-referencing-funs + #:add-to-fun-referenced-vars + #:add-to-fun-referenced-funs + #:update-fun-closure-type + #:get-arg-types + #:make-var + #:make-global-variable + #:var-type + #:var-ignorable + #:var-p + #:var-ref + #:var-ref-ccb + #:var-ref-clb + #:var-kind + #:var-name + #:var-loc + #:var-set-nodes + #:var-read-nodes + #:var-functions-reading + #:var-functions-setting + #:var-read-forms + #:var-changed-in-form-list + #:update-variable-type ; ref only in 1let + #:global-var-p + #:add-to-set-nodes + #:add-to-set-nodes-of-var-list + #:add-to-read-nodes + #:add-to-read-nodes-of-var-list + #:delete-from-set-nodes + #:delete-from-read-nodes + #:make-blk + #:blk-ref-ccb + #:blk-ref-clb + #:blk-ref + #:blk-type + #:make-tag + #:tag-name + #:tag-p + #:tag-var + #:tag-ref + ;; environment + #:*global-funs* ; in cmpglobals + #:*cmp-env* #:cmp-env-root #:cmp-env-copy #:cmp-env-mark + #:cmp-env-search-macro + #:cmp-env-search-block + #:cmp-env-register-function + #:cmp-env-register-global-macro + #:cmp-env-register-symbol-macro + #:cmp-env-search-symbol-macro + #:cmp-env-register-block + #:cmp-env-search-var + #:cmp-env-declare-special + #:cmp-env-new-variables + #:cmp-env-register-tag + #:cmp-env-search-tag + #:get-return-type + #:inline-possible ; queries for notinline decl + #:declared-inline-p + #:function-may-change-sp + #:function-may-have-side-effects + #:special-variable-p + #:push-vars + #:add-one-declaration + #:check-arguments-type + #:variable-type-in-env + #:alien-declaration-p + #:get-local-return-type + #:get-local-arg-types + #:policy-check-arguments-type #:policy-type-assertions #:policy-evaluate-forms + #:policy-declaration-name-p #:policy-debug-ihs-frame + ;; first pass interface + #:t1expr #:c1expr #:c1args* #:cmp-eval)) + + (defpackage ecl-cmp/pass1 + (:use #:ffi #:ext #:cl #:c #:ecl-cmp/int)) + + (defpackage "C" + (:nicknames "COMPILER") + (:use "FFI" "EXT" "CL" #:ecl-cmp/int) + (:shadow #:disassemble + #:compile + #:compile-file + #:compile-file-pathname + ;;; These functions will be common in our frontend + ;; #:proclaim #:declaim #:with-compilation-unit + ) + (:export "*COMPILER-BREAK-ENABLE*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*COMPILER-FEATURES*" + "*CC*" + "*CC-OPTIMIZE*" + "*USER-CC-FLAGS*" + "*USER-LD-FLAGS*" + "*SUPPRESS-COMPILER-MESSAGES*" + "BUILD-ECL" + "BUILD-PROGRAM" + "BUILD-FASL" + "BUILD-STATIC-LIBRARY" + "BUILD-SHARED-LIBRARY" + "COMPILER-WARNING" + "COMPILER-NOTE" + "COMPILER-MESSAGE" + "COMPILER-ERROR" + "COMPILER-FATAL-ERROR" + "COMPILER-INTERNAL-ERROR" + "COMPILER-UNDEFINED-VARIABLE" + "COMPILER-MESSAGE-FILE" + "COMPILER-MESSAGE-FILE-POSITION" + "COMPILER-MESSAGE-FORM" + "*SUPPRESS-COMPILER-MESSAGES*" + "INSTALL-C-COMPILER" + "UPDATE-COMPILER-FEATURES") + (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" + "*COMPILER-CONSTANTS*" "COMPILER-LET")) +#+END_SRC +** TODO be explicit in dispatch symbol packages (i.e cl:progn) +** TODO 'UNWIND-PROTECT tag should be made a keyword +** TODO use package agnostic marks '(CB LB CLB CCB UNWIND-PROTECT CLOSURE) +** TODO declared-inline-p, inline-possible and declared-notinline-p should have one common interface +** cmpdata should be merged with cmpwt (which has only data accessors) +** TODO wt-structure-ref doesn't exist! +This is a removal from CLOS merge probably, fixme! + +** TODO some compiler macros belong to the backend! + +** generic function potential optimizations +*** ecl has one dispatcher and one cache for *all* generic functions - many misses +*** each generic function needs to have its own cache and dispatcher (for instance if there is one method it may be way faster) +*** effective method may be compiled into one function unless one of the methods is a closure (or has eql specializer) + +** Lambdas +#+BEGIN_SRC lisp +;;; lambda expression + +;;; During Pass1, a lambda-list +;;; +;;; ( { var }* +;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] +;;; [ &rest var ] +;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* +;;; [&allow-other-keys]] +;;; [ &aux {var | (var [initform])}*] +;;; ) +;;; +;;; is transformed into +;;; +;;; ( ( { var }* ) ; required +;;; ( { var initform svar }* ) ; optional +;;; { var | nil } ; rest +;;; allow-other-keys-flag +;;; ( { kwd-vv-index var initform svar }* ) ; key +;;; ) +;;; +;;; where +;;; svar: NIL ; means svar is not supplied +;;; | var +;;; +;;; &aux parameters will be embedded into LET*. +;;; +;;; c1lambda-expr receives +;;; ( lambda-list { doc | decl }* . body ) +;;; and returns +;;; ( lambda info-object lambda-list' doc body' ) +;;; +;;; Doc is NIL if no doc string is supplied. +;;; Body' is body possibly surrounded by a LET* (if &aux parameters are +;;; supplied) and an implicit block. +#+END_SRC + +** cmp-env- interface + +*** cmppolicy.lsp:cmp-env-policy :local: +*** cmppolicy.lsp:cmp-env-add-optimizations :internal: +*** cmppolicy.lsp:cmp-env-optimization :external: +*** cmppolicy.lsp:add-default-optimizations :internal: + +*** cmpenv-api.lsp:cmp-env-root :external: +*** cmpenv-api.lsp:cmp-env-copy :external: +*** cmpenv-api.lsp:cmp-env-cleanups :unused: +*** cmpenv-api.lsp:cmp-env-register-var :used: +*** cmpenv-api.lsp:cmp-env-declare-special :used: +*** cmpenv-api.lsp:cmp-env-add-declaration :internal: +*** cmpenv-api.lsp:cmp-env-extend-declaration :internal: + +*** cmpenv-api.lsp:cmp-env-register-function :used: +*** cmpenv-api.lsp:cmp-env-register-global-macro :used: +*** cmpenv-api.lsp:cmp-env-register-macro :used: +*** cmpenv-api.lsp:cmp-env-register-ftype :internal: +*** cmpenv-api.lsp:cmp-env-register-symbol-macro :external: +*** cmpenv-api.lsp:cmp-env-register-block :used: +*** cmpenv-api.lsp:cmp-env-register-tag :used: +*** cmpenv-api.lsp:cmp-env-register-cleanup :unused: + +*** cmpenv-api.lsp:cmp-env-search-function :external: +*** cmpenv-api.lsp:cmp-env-search-variables :local: +*** cmpenv-api.lsp:cmp-env-search-block :used: +*** cmpenv-api.lsp:cmp-env-search-tag :used: +*** cmpenv-api.lsp:cmp-env-search-symbol-macro :external: +*** cmpenv-api.lsp:cmp-env-search-var :external: +*** cmpenv-api.lsp:cmp-env-search-macro :used: +*** cmpenv-api.lsp:cmp-env-search-ftype :internal: + +*** cmpenv-api.lsp:cmp-env-mark :external: +*** cmpenv-api.lsp:cmp-env-new-variables :used: +*** cmpenv-api.lsp:cmp-env-search-declaration :internal: + +** cmpenv-fun.lsp +*** proclaim-function :external: +*** add-function-declaration :internal: +*** get-arg-types :external: +*** get-return-type :external: +*** get-local-arg-types :used: +*** get-local-return-type :used: +*** get-proclaimed-narg :external: +*** declare-inline :internal: +*** declare-notinline :internal: +*** proclaim-inline :internal: +*** proclaim-notinline :internal: +*** declared-inline-p :external: +*** declared-notinline-p :local: +*** inline-possible :external: +*** maybe-install-inline-function :hook: + +** cmpform +*** c1form-local-type :info:unused: +*** c1form-local-vars :info: +*** c1form-sp-change :info: +*** c1form-volatile :info: + +*** c1form-name +*** c1form-parents :local: +*** c1form-env +*** c1form-args +*** c1form-side-effects +*** c1form-form +*** c1form-toplevel-form +*** c1form-file +*** c1form-file-position + +*** print-c1form +*** make-c1form +*** make-c1form* +*** c1form-arg +*** c1form-volatile* :backend: +*** c1form-primary-type +*** location-primary-type (same as above) + +*** find-form-in-node-list +*** add-form-to-node-list +*** delete-form-from-node-list +used only in cmpvar +*** traverse-c1form-tree +*** c1form-movable-p +*** c1form-values-number +*** c1form-single-valued-p +*** with-c1form-env +*** relocate-parents-list :local: +*** c1form-replace-with +*** delete-c1forms +*** c1form-constant-p + +* khm + +** TODO try to investigate how to produce statically defined constants +** TODO analyze foobar.lisp output and describe it + +* links +** Nimble type inferencer +http://home.pipeline.com/~hbaker1/TInference.html +** Gccemacs writeup (simialar compiler to ecl) +http://akrl.sdf.org/gccemacs.html diff --git a/src/newcmp/notes.org b/src/newcmp/notes.org deleted file mode 100644 index 4760adb18..000000000 --- a/src/newcmp/notes.org +++ /dev/null @@ -1,369 +0,0 @@ - -** si:cmp-env-register-macrolet should be part of cmpenv-api -** extract type propagation pass, see 7e8d0985155 - -** cmpdata, cmpdata-bk -*** Frontend -vv structure is a single data section entry. We have two data stores – -permanent and temporary. - -- vv-location :: index in data-store (a number) -- vv-permanent-p :: store flag (t -> permanent, nil -> temporary) -- vv-used-p :: flag indicating if entry is referenced, if not it gets - optimized away (same goes for *load-objects*). To keep indexing - and data size intact we put 0 in place of optimized objects. -- vv-value :: holds the entry actual value - -- *load-objects* :: collection of all objects which are created by a - lisp form – we don't include them in datasection. We need to keep - track of them to filter them out. - -- data-size :: size of data stores combined - -- data-init :: initalizes data stores. If filename parameter is - present, then it objects are read from the file. Otherwise store - is empty. - -- data-dump-array :: dumps data stores - -*** Backend -- add-static-constant :: called from data frontend. -- data-c-dump :: called from cmpmain, creates data section in a - separate C file -- wt-vv :: used by cmploc, accesses element in data section -- set-vv :: used in cmploc, modifies element in data section - -** pass1 extract 1st attempt: -#+BEGIN_SRC lisp - (defpackage ecl-cmp/int - (:use #:ffi #:ext #:cl) - (:export - ;; BACKEND REFERENCES IN FRONTEND!!! - #:lisp-type->rep-type #:c1make-var #:check-vref #:lisp-type-p - #:rep-type->lisp-type #:expand-type-assertion #:machine-c-type-p - ;; opts (SHOULDN'T BE) - #:constant-value-p - ;; things which should be local to the module - #:*compile-toplevel* ; referenced in cmp1top, bound in cmptop (and not used?) - #:*compile-time-too* ; referenced in cmp1top, bound in cmptop (and not used?) - #:*top-level-forms* ; referenced in cmp1top, bound in cmptop (and not used?) - #:*load-time-values* ; referenced in cmp1top, bound in cmpmain (and not used?) - #:clos-compiler-macro-expand ; used only in pass1 - #:*optimizable-constants* ; used only in pass1 and cmpopt-constant - #:*setjmps* ; local to pass1 - #:*use-c-global* ; local to pass1 - #:*clines-string-list* ; shared by ffi of both passses (and 1ct) - #:c1body ; should be brought back to cmpenv-declaim! - #:*next-cfun* ; used only in cmp1lam, but part of cmpenv - #:lisp-to-c-name ; used in cmpvar, cmp1lam - ;; common utilities - #:make-dispatch-table #:check-args-number #:print-current-form - ;; cmputil (conditions) - #:cmpck #:cmpassert #:cmperr #:cmpdebug #:cmpnote - ;; types (arith and propagation) - #:object-type #:trivial-type-p #:values-type-and #:values-type-primary-type - #:type-and #:type-or #:values-type-or #:valid-type-specifier - #:propagate-types - ;; locations - #:add-object #:add-symbol #:loc-in-c1form-movable-p - #:*make-forms* - ;; internal representation - #:call-global #:ordinary #:var #:fmla-and #:fmla-or #:fmla-not - #:locals #:stack-push-values #:with-stack #:call-local - ;; - #:make-c1form* #:*current-toplevel-form* - #:c1form-p #:c1form-type - #:c1form-primary-type - #:c1form-name - #:c1form-constant-p - #:c1form-arg - #:c1form-args - #:c1form-replace-with - #:c1form-side-effects - #:c1form-volatile - #:delete-c1forms - #:and-form-type ; not sure if it belogns here - #:local-function-ref ; XXX: defined in env - #:*current-function* - #:make-fun - #:fun-name - #:fun-parent - #:fun-lambda-expression - #:fun-cmp-env - #:fun-global - #:fun-cfun - #:fun-exported - #:fun-closure - #:fun-minarg - #:fun-maxarg - #:fun-description - #:fun-no-entry - #:fun-referenced-funs - #:fun-child-funs - #:fun-lambda - #:fun-var - #:fun-ref - #:fun-referenced-vars - #:fun-referencing-funs - #:add-to-fun-referenced-vars - #:add-to-fun-referenced-funs - #:update-fun-closure-type - #:get-arg-types - #:make-var - #:make-global-variable - #:var-type - #:var-ignorable - #:var-p - #:var-ref - #:var-ref-ccb - #:var-ref-clb - #:var-kind - #:var-name - #:var-loc - #:var-set-nodes - #:var-read-nodes - #:var-functions-reading - #:var-functions-setting - #:var-read-forms - #:var-changed-in-form-list - #:update-variable-type ; ref only in 1let - #:global-var-p - #:add-to-set-nodes - #:add-to-set-nodes-of-var-list - #:add-to-read-nodes - #:add-to-read-nodes-of-var-list - #:delete-from-set-nodes - #:delete-from-read-nodes - #:make-blk - #:blk-ref-ccb - #:blk-ref-clb - #:blk-ref - #:blk-type - #:make-tag - #:tag-name - #:tag-p - #:tag-var - #:tag-ref - ;; environment - #:*global-funs* ; in cmpglobals - #:*cmp-env* #:cmp-env-root #:cmp-env-copy #:cmp-env-mark - #:cmp-env-search-macro - #:cmp-env-search-block - #:cmp-env-register-function - #:cmp-env-register-global-macro - #:cmp-env-register-symbol-macro - #:cmp-env-search-symbol-macro - #:cmp-env-register-block - #:cmp-env-search-var - #:cmp-env-declare-special - #:cmp-env-new-variables - #:cmp-env-register-tag - #:cmp-env-search-tag - #:get-return-type - #:inline-possible ; queries for notinline decl - #:declared-inline-p - #:function-may-change-sp - #:function-may-have-side-effects - #:special-variable-p - #:push-vars - #:add-one-declaration - #:check-arguments-type - #:variable-type-in-env - #:alien-declaration-p - #:get-local-return-type - #:get-local-arg-types - #:policy-check-arguments-type #:policy-type-assertions #:policy-evaluate-forms - #:policy-declaration-name-p #:policy-debug-ihs-frame - ;; first pass interface - #:t1expr #:c1expr #:c1args* #:cmp-eval)) - - (defpackage ecl-cmp/pass1 - (:use #:ffi #:ext #:cl #:c #:ecl-cmp/int)) - - (defpackage "C" - (:nicknames "COMPILER") - (:use "FFI" "EXT" "CL" #:ecl-cmp/int) - (:shadow #:disassemble - #:compile - #:compile-file - #:compile-file-pathname - ;;; These functions will be common in our frontend - ;; #:proclaim #:declaim #:with-compilation-unit - ) - (:export "*COMPILER-BREAK-ENABLE*" - "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" - "*COMPILE-VERBOSE*" - "*COMPILER-FEATURES*" - "*CC*" - "*CC-OPTIMIZE*" - "*USER-CC-FLAGS*" - "*USER-LD-FLAGS*" - "*SUPPRESS-COMPILER-MESSAGES*" - "BUILD-ECL" - "BUILD-PROGRAM" - "BUILD-FASL" - "BUILD-STATIC-LIBRARY" - "BUILD-SHARED-LIBRARY" - "COMPILER-WARNING" - "COMPILER-NOTE" - "COMPILER-MESSAGE" - "COMPILER-ERROR" - "COMPILER-FATAL-ERROR" - "COMPILER-INTERNAL-ERROR" - "COMPILER-UNDEFINED-VARIABLE" - "COMPILER-MESSAGE-FILE" - "COMPILER-MESSAGE-FILE-POSITION" - "COMPILER-MESSAGE-FORM" - "*SUPPRESS-COMPILER-MESSAGES*" - "INSTALL-C-COMPILER" - "UPDATE-COMPILER-FEATURES") - (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" - "*COMPILER-CONSTANTS*" "COMPILER-LET")) -#+END_SRC -** TODO be explicit in dispatch symbol packages (i.e cl:progn) -** TODO 'UNWIND-PROTECT tag should be made a keyword -** TODO use package agnostic marks '(CB LB CLB CCB UNWIND-PROTECT CLOSURE) -** TODO declared-inline-p, inline-possible and declared-notinline-p should have one common interface -** cmpdata should be merged with cmpwt (which has only data accessors) -** TODO wt-structure-ref doesn't exist! -This is a removal from CLOS merge probably, fixme! - -** TODO some compiler macros belong to the backend! - -** generic function potential optimizations -*** ecl has one dispatcher and one cache for *all* generic functions - many misses -*** each generic function needs to have its own cache and dispatcher (for instance if there is one method it may be way faster) -*** effective method may be compiled into one function unless one of the methods is a closure (or has eql specializer) - -** Lambdas -#+BEGIN_SRC lisp -;;; lambda expression - -;;; During Pass1, a lambda-list -;;; -;;; ( { var }* -;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] -;;; [ &rest var ] -;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* -;;; [&allow-other-keys]] -;;; [ &aux {var | (var [initform])}*] -;;; ) -;;; -;;; is transformed into -;;; -;;; ( ( { var }* ) ; required -;;; ( { var initform svar }* ) ; optional -;;; { var | nil } ; rest -;;; allow-other-keys-flag -;;; ( { kwd-vv-index var initform svar }* ) ; key -;;; ) -;;; -;;; where -;;; svar: NIL ; means svar is not supplied -;;; | var -;;; -;;; &aux parameters will be embedded into LET*. -;;; -;;; c1lambda-expr receives -;;; ( lambda-list { doc | decl }* . body ) -;;; and returns -;;; ( lambda info-object lambda-list' doc body' ) -;;; -;;; Doc is NIL if no doc string is supplied. -;;; Body' is body possibly surrounded by a LET* (if &aux parameters are -;;; supplied) and an implicit block. -#+END_SRC - -** cmp-env- interface - -*** cmppolicy.lsp:cmp-env-policy :local: -*** cmppolicy.lsp:cmp-env-add-optimizations :internal: -*** cmppolicy.lsp:cmp-env-optimization :external: -*** cmppolicy.lsp:add-default-optimizations :internal: - -*** cmpenv-api.lsp:cmp-env-root :external: -*** cmpenv-api.lsp:cmp-env-copy :external: -*** cmpenv-api.lsp:cmp-env-cleanups :unused: -*** cmpenv-api.lsp:cmp-env-register-var :used: -*** cmpenv-api.lsp:cmp-env-declare-special :used: -*** cmpenv-api.lsp:cmp-env-add-declaration :internal: -*** cmpenv-api.lsp:cmp-env-extend-declaration :internal: - -*** cmpenv-api.lsp:cmp-env-register-function :used: -*** cmpenv-api.lsp:cmp-env-register-global-macro :used: -*** cmpenv-api.lsp:cmp-env-register-macro :used: -*** cmpenv-api.lsp:cmp-env-register-ftype :internal: -*** cmpenv-api.lsp:cmp-env-register-symbol-macro :external: -*** cmpenv-api.lsp:cmp-env-register-block :used: -*** cmpenv-api.lsp:cmp-env-register-tag :used: -*** cmpenv-api.lsp:cmp-env-register-cleanup :unused: - -*** cmpenv-api.lsp:cmp-env-search-function :external: -*** cmpenv-api.lsp:cmp-env-search-variables :local: -*** cmpenv-api.lsp:cmp-env-search-block :used: -*** cmpenv-api.lsp:cmp-env-search-tag :used: -*** cmpenv-api.lsp:cmp-env-search-symbol-macro :external: -*** cmpenv-api.lsp:cmp-env-search-var :external: -*** cmpenv-api.lsp:cmp-env-search-macro :used: -*** cmpenv-api.lsp:cmp-env-search-ftype :internal: - -*** cmpenv-api.lsp:cmp-env-mark :external: -*** cmpenv-api.lsp:cmp-env-new-variables :used: -*** cmpenv-api.lsp:cmp-env-search-declaration :internal: - -** cmpenv-fun.lsp -*** proclaim-function :external: -*** add-function-declaration :internal: -*** get-arg-types :external: -*** get-return-type :external: -*** get-local-arg-types :used: -*** get-local-return-type :used: -*** get-proclaimed-narg :external: -*** declare-inline :internal: -*** declare-notinline :internal: -*** proclaim-inline :internal: -*** proclaim-notinline :internal: -*** declared-inline-p :external: -*** declared-notinline-p :local: -*** inline-possible :external: -*** maybe-install-inline-function :hook: - -** cmpform -*** c1form-local-type :info:unused: -*** c1form-local-vars :info: -*** c1form-sp-change :info: -*** c1form-volatile :info: - -*** c1form-name -*** c1form-parents :local: -*** c1form-env -*** c1form-args -*** c1form-side-effects -*** c1form-form -*** c1form-toplevel-form -*** c1form-file -*** c1form-file-position - -*** print-c1form -*** make-c1form -*** make-c1form* -*** c1form-arg -*** c1form-volatile* :backend: -*** c1form-primary-type -*** location-primary-type (same as above) - -*** find-form-in-node-list -*** add-form-to-node-list -*** delete-form-from-node-list -used only in cmpvar -*** traverse-c1form-tree -*** c1form-movable-p -*** c1form-values-number -*** c1form-single-valued-p -*** with-c1form-env -*** relocate-parents-list :local: -*** c1form-replace-with -*** delete-c1forms -*** c1form-constant-p - From cab4917d86a8733392874dc9e1881817ee22f7b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 22 Nov 2019 12:45:21 +0100 Subject: [PATCH 2/9] cmp: cmpmain first pass: put the pass in a separate function Function behaves differently for streams and for other objects. This makes the code more consistent. --- src/cmp/cmpmain.lsp | 44 ++++++++++++++++++++++++++------------------ 1 file changed, 26 insertions(+), 18 deletions(-) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index ae4620d38..a374fd2cf 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -644,8 +644,7 @@ compiled successfully, returns the pathname of the compiled file" (cmpprogress "~&;;;~%;;; Compiling ~a." (namestring input-pathname)) - (let* ((eof '(NIL)) - (*compiler-in-use* *compiler-in-use*) + (let* ((*compiler-in-use* *compiler-in-use*) (*load-time-values* nil) ;; Load time values are compiled (output-file (apply #'compile-file-pathname input-file args)) (true-output-file nil) ;; Will be set at the end @@ -667,20 +666,11 @@ compiled successfully, returns the pathname of the compiled file" (when (probe-file "./cmpinit.lsp") (load "./cmpinit.lsp" :verbose *compile-verbose*)) - (data-init) - (with-open-file (*compiler-input* *compile-file-pathname* :external-format external-format) (unless source-truename (setf (car ext:*source-location*) *compile-file-pathname*)) - (do* ((*compile-file-position* 0 (file-position *compiler-input*)) - (form (si::read-object-or-ignore *compiler-input* eof) - (si::read-object-or-ignore *compiler-input* eof))) - ((eq form eof)) - (when form - (setf (cdr ext:*source-location*) - (+ source-offset *compile-file-position*)) - (t1expr form)))) + (compiler-pass1 *compiler-input* source-offset)) (cmpprogress "~&;;; End of Pass 1.") (setf init-name (compute-init-name output-file :kind @@ -800,8 +790,7 @@ after compilation." (with-compiler-env (compiler-conditions) (setf form (set-closure-env form lexenv *cmp-env-root*)) (print-compiler-info) - (data-init) - (t1expr form) + (compiler-pass1 form) (cmpprogress "~&;;; End of Pass 1.") (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) (compiler-pass2 c-pathname h-pathname data-pathname init-name @@ -897,8 +886,7 @@ from the C language code. NIL means \"do not create the file\"." #'(lambda (&rest args) (let ((*compiler-output1* *standard-output*)) (apply t3local-fun args)))) - (data-init) - (t1expr disassembled-form) + (compiler-pass1 disassembled-form) (ctop-write (compute-init-name "foo" :kind :fasl) (if h-file h-file "") (if data-file data-file "")) @@ -908,10 +896,29 @@ from the C language code. NIL means \"do not create the file\"." (when h-file (close *compiler-output2*))))) nil) +;;; FIXME source-offset and source-truename are used by swanks string +;;; compilation. Revisit if it is truly needed. SBCL deals with that +;;; using WITH-COMPILATION-UNIT macro what seems to be a much better +;;; place to customize the source location. -- jd 2019-11-25 +(defun compiler-pass1 (object &optional source-offset) + (data-init) + (if (streamp object) + (do* ((eof '(NIL)) + (*compile-file-position* 0 (file-position *compiler-input*)) + (form (si::read-object-or-ignore *compiler-input* eof) + (si::read-object-or-ignore *compiler-input* eof))) + ((eq form eof)) + (when form + (setf (cdr ext:*source-location*) + (+ source-offset *compile-file-position*)) + (t1expr form))) + (t1expr object))) + (defun compiler-pass2 (c-pathname h-pathname data-pathname init-name &key input-designator) (with-open-file (*compiler-output1* c-pathname :direction :output - :if-does-not-exist :create :if-exists :supersede) + :if-does-not-exist :create + :if-exists :supersede) (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) #-ecl-min (multiple-value-bind (second minute hour day month year) @@ -921,7 +928,8 @@ from the C language code. NIL means \"do not create the file\"." (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) (wt-comment-nl "Source: ~A" input-designator) (with-open-file (*compiler-output2* h-pathname :direction :output - :if-does-not-exist :create :if-exists :supersede) + :if-does-not-exist :create + :if-exists :supersede) (wt-nl1 "#include " *cmpinclude*) (ctop-write init-name h-pathname data-pathname) (terpri *compiler-output1*) From 57e09c89b18317bc968f7c7a66948e8a79f7372a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 22 Nov 2019 19:26:49 +0100 Subject: [PATCH 3/9] cmp: t1expr*: expand symbol macros They were silently ignored before in compiled files. The were not ignored in files which were just loaded. (define-symbol-macro foo (error "HI")) foo ; ignored --- src/cmp/cmptop.lsp | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index e0e4cda3f..56aaa9449 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -31,6 +31,7 @@ (*current-form* form) (*first-error* t) (*setjmps* 0)) + (setq form (chk-symbol-macrolet form)) (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (when (member fun *toplevel-forms-to-print*) From 241f3ed17299914632b4c57b482823dfec61edf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 24 Nov 2019 11:01:16 +0100 Subject: [PATCH 4/9] cmp: remove unused variables: *compile-time-too*, *not-compile-time* First one is never bound to T and second one is not referenced at all. *compilation-time-too* when T was interpreted to evaluate forms before compiling them (independent of eval-when). --- src/cmp/cmpglobals.lsp | 4 ---- src/cmp/cmptop.lsp | 26 +++++++++++--------------- 2 files changed, 11 insertions(+), 19 deletions(-) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 5f0f9afed..ea5ad902b 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -235,9 +235,6 @@ slashes before special characters.") in the translated C/C++ file. Notice that it is unspecified where these lines are inserted, but the order is preserved") -(defvar *compile-time-too* nil) -(defvar *not-compile-time* nil) - (defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* ; or *temporary-objects* (defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* @@ -326,7 +323,6 @@ be deleted if they have been opened with LoadLibrary.") (*global-entries* nil) (*undefined-vars* nil) (*top-level-forms* nil) - (*compile-time-too* nil) (*clines-string-list* '()) (*inline-blocks* 0) (*open-c-braces* 0) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 56aaa9449..7fc59df39 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -37,7 +37,8 @@ (when (member fun *toplevel-forms-to-print*) (print-current-form)) (cond - ((consp fun) (t1ordinary form)) + ((consp fun) + (t1ordinary form)) ((not (symbolp fun)) (cmperr "~s is illegal function." fun)) ((eq fun 'QUOTE) @@ -94,8 +95,7 @@ (defun emit-local-funs () (declare (si::c-local)) ;; Local functions and closure functions - (do ((*compile-time-too* nil) - (*compile-toplevel* nil)) + (do ((*compile-toplevel* nil)) ;; repeat until t3local-fun generates no more ((eq *emitted-local-funs* *local-funs*)) ;; scan *local-funs* backwards @@ -273,12 +273,13 @@ (execute-flag nil)) (dolist (situation (car args)) (case situation - ((CL:LOAD :LOAD-TOPLEVEL) (setq load-flag t)) - ((CL:COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) + ((CL:LOAD :LOAD-TOPLEVEL) + (setq load-flag t)) + ((CL:COMPILE :COMPILE-TOPLEVEL) + (setq compile-flag t)) ((CL:EVAL :EXECUTE) - (if *compile-toplevel* - (setq compile-flag (or *compile-time-too* compile-flag)) - (setq execute-flag t))) + (unless *compile-toplevel* + (setq execute-flag t))) (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." situation)))) (cond ((not *compile-toplevel*) @@ -484,9 +485,7 @@ (otherwise "cl_object "))) (defun t1ordinary (form) - (when *compile-time-too* (cmp-eval form)) - (let ((*compile-toplevel* nil) - (*compile-time-too* nil)) + (let ((*compile-toplevel* nil)) (add-load-time-values (make-c1form* 'ORDINARY :args (c1expr form))))) (defun p1ordinary (c1form assumptions form) @@ -797,10 +796,7 @@ ;;; (defun t1fset (args) (let ((form `(si::fset ,@args))) - (when *compile-time-too* - (cmp-eval form)) - (let ((*compile-toplevel* nil) - (*compile-time-too* nil)) + (let ((*compile-toplevel* nil)) (add-load-time-values (c1fset form))))) (defun c1fset (form) From 83ec2c86c71c846b4642588ef9f1a4587a8187ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 27 Nov 2019 12:00:41 +0100 Subject: [PATCH 5/9] cmpcbk: improve +foreign-elt-type-codes+ - move the constant and a function foreign-elt-type-code to the top - re-align the constant data - fix the feature reader conditionals (they were misplaced) - add reader conditionals for complex floats --- src/cmp/cmpcbk.lsp | 76 ++++++++++++++++++++++------------------------ 1 file changed, 36 insertions(+), 40 deletions(-) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 13910d7ba..79e8a2773 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -15,6 +15,42 @@ (in-package "COMPILER") +(defconstant +foreign-elt-type-codes+ + '( (:char . "ECL_FFI_CHAR") + (:unsigned-char . "ECL_FFI_UNSIGNED_CHAR") + (:byte . "ECL_FFI_BYTE") + (:unsigned-byte . "ECL_FFI_UNSIGNED_BYTE") + (:short . "ECL_FFI_SHORT") + (:unsigned-short . "ECL_FFI_UNSIGNED_SHORT") + (:int . "ECL_FFI_INT") + (:unsigned-int . "ECL_FFI_UNSIGNED_INT") + (:long . "ECL_FFI_LONG") + (:unsigned-long . "ECL_FFI_UNSIGNED_LONG") + #+:uint16-t (:int16-t . "ECL_FFI_INT16_T") + #+:uint16-t (:uint16-t . "ECL_FFI_UINT16_T") + #+:uint32-t (:int32-t . "ECL_FFI_INT32_T") + #+:uint32-t (:uint32-t . "ECL_FFI_UINT32_T") + #+:uint64-t (:int64-t . "ECL_FFI_INT64_T") + #+:uint64-t (:uint64-t . "ECL_FFI_UINT64_T") + #+:long-long (:long-long . "ECL_FFI_LONG_LONG") + #+:long-long (:unsigned-long-long . "ECL_FFI_UNSIGNED_LONG_LONG") + (:pointer-void . "ECL_FFI_POINTER_VOID") + (:cstring . "ECL_FFI_CSTRING") + (:object . "ECL_FFI_OBJECT") + (:float . "ECL_FFI_FLOAT") + (:double . "ECL_FFI_DOUBLE") + (:long-double . "ECL_FFI_LONG_DOUBLE") + #+complex-float (:csfloat . "ECL_FFI_CSFLOAT") + #+complex-float (:cdfloat . "ECL_FFI_CDFLOAT") + #+complex-float (:clfloat . "ECL_FFI_CLFLOAT") + (:void . "ECL_FFI_VOID"))) + +(defun foreign-elt-type-code (type) + (let ((x (assoc type +foreign-elt-type-codes+))) + (unless x + (cmperr "~a is not a valid elementary FFI type" type)) + (cdr x))) + (defun c1-defcallback (args) (destructuring-bind (name return-type arg-list &rest body) args @@ -45,46 +81,6 @@ ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) :one-liner t))))))) -(defconstant +foreign-elt-type-codes+ - '((:char . "ECL_FFI_CHAR") - (:unsigned-char . "ECL_FFI_UNSIGNED_CHAR") - (:byte . "ECL_FFI_BYTE") - (:unsigned-byte . "ECL_FFI_UNSIGNED_BYTE") - (:short . "ECL_FFI_SHORT") - (:unsigned-short . "ECL_FFI_UNSIGNED_SHORT") - (:int . "ECL_FFI_INT") - (:unsigned-int . "ECL_FFI_UNSIGNED_INT") - (:long . "ECL_FFI_LONG") - (:unsigned-long . "ECL_FFI_UNSIGNED_LONG") - #+:uint16-t #+:uint16-t - (:int16-t . "ECL_FFI_INT16_T") - (:uint16-t . "ECL_FFI_UINT16_T") - #+:uint32-t #+:uint32-t - (:int32-t . "ECL_FFI_INT32_T") - (:uint32-t . "ECL_FFI_UINT32_T") - #+:uint64-t #+:uint64-t - (:int64-t . "ECL_FFI_INT64_T") - (:uint64-t . "ECL_FFI_UINT64_T") - #+:long-long #+:long-long - (:long-long . "ECL_FFI_LONG_LONG") - (:unsigned-long-long . "ECL_FFI_UNSIGNED_LONG_LONG") - (:pointer-void . "ECL_FFI_POINTER_VOID") - (:cstring . "ECL_FFI_CSTRING") - (:object . "ECL_FFI_OBJECT") - (:float . "ECL_FFI_FLOAT") - (:double . "ECL_FFI_DOUBLE") - (:long-double . "ECL_FFI_LONG_DOUBLE") - ;; complex floats - (:csfloat . "ECL_FFI_CSFLOAT") - (:cdfloat . "ECL_FFI_CDFLOAT") - (:clfloat . "ECL_FFI_CLFLOAT") - (:void . "ECL_FFI_VOID"))) - -(defun foreign-elt-type-code (type) - (let ((x (assoc type +foreign-elt-type-codes+))) - (unless x - (cmperr "~a is not a valid elementary FFI type" type)) - (cdr x))) (defun t3-defcallback (lisp-name c-name c-name-constant return-type arg-types arg-type-constants call-type &aux (return-p t)) From 7dbde99b7cf38814a3862ff1a8647fcfd3ae7fdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 27 Nov 2019 15:33:24 +0100 Subject: [PATCH 6/9] ffi: defcallback: unify behavior of dffi and compiled versions - normalize return-type from NIL to :void, ARRAY and '* in interpreted dffi implementation -- it is already normalized in sffi - remove invalid path where argument type was not a valid elementary FFI type when it was not c1-defcallback pushed result of add-object to arg-type-constants and tried to pass the data as opaque pointers. That said it could never work, because: 1. add-object could return a string (i.e for known symbols expanding to ECL_SYM) and they were fed as elementary FFI type leading to errors during compilation by C compiler (invalid enum type) 2. when ecl_make_foreign_data was called to pass opaque objects a function FFI:SIZE-OF-FOREIGN-TYPE was called which resulted in error (because return type is not a valid elementary FFI type what this code path was meant to be) Moreover we validate both return type and argument types during the first compiler to fail as early as possible (previously only argument types were validated early). - some cosmetic fixes like indentation or redundant PROGN --- src/cmp/cmpcbk.lsp | 73 +++++++++++++++++++++------------------------- src/lsp/ffi.lsp | 6 +++- 2 files changed, 38 insertions(+), 41 deletions(-) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 79e8a2773..2cb1d9396 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -48,12 +48,17 @@ (defun foreign-elt-type-code (type) (let ((x (assoc type +foreign-elt-type-codes+))) (unless x - (cmperr "~a is not a valid elementary FFI type" type)) + (cmperr "DEFCALLBACK: ~a is not a valid elementary FFI type." type)) (cdr x))) (defun c1-defcallback (args) (destructuring-bind (name return-type arg-list &rest body) args + (cond ((eql return-type nil) + (setf return-type :void)) + ((and (consp return-type) + (member (first return-type) '(* array))) + (setf return-type :pointer-void))) (let ((arg-types '()) (arg-type-constants '()) (arg-variables '()) @@ -65,34 +70,27 @@ (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) (push (first i) arg-variables) (let ((type (second i))) - (push (second i) arg-types) - (push (if (ffi::foreign-elt-type-p type) - (foreign-elt-type-code type) - (add-object type)) - arg-type-constants))) + (push type arg-types) + (push (foreign-elt-type-code type) arg-type-constants))) (push (list name c-name (add-object name) - return-type (reverse arg-types) (reverse arg-type-constants) call-type) + return-type + (foreign-elt-type-code return-type) + (reverse arg-types) + (reverse arg-type-constants) + call-type) *callbacks*) (c1expr `(progn - (defun ,name ,(reverse arg-variables) ,@body) - (si:put-sysprop ',name :callback - (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) - :one-liner t))))))) + (defun ,name ,(reverse arg-variables) ,@body) + (si:put-sysprop ',name :callback + (ffi:c-inline () () :object + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) + :one-liner t))))))) - -(defun t3-defcallback (lisp-name c-name c-name-constant return-type +(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code arg-types arg-type-constants call-type &aux (return-p t)) - (cond ((member return-type '(nil :void)) - (setf return-p nil)) - ((ffi::foreign-elt-type-p return-type)) - ((and (consp return-type) - (member (first return-type) '(* array))) - (setf return-type :pointer-void)) - (t - (cmperr "DEFCALLBACK does not support complex return types such as ~A" - return-type))) + (when (eql return-type :void) + (setf return-p nil)) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) (fmod (case call-type ((:cdecl :default) "") @@ -100,15 +98,14 @@ (t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type))))) (wt-nl-h "static " return-type-name " " fmod c-name "(") - (wt-nl1 "static " return-type-name " " fmod c-name "(") - (loop for n from 0 - and type in arg-types - with comma = "" - do - (progn - (wt-h comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (wt comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (setf comma ","))) + (wt-nl1 "static " return-type-name " " fmod c-name "(") + (loop with comma = "" + for n from 0 + for type in arg-types + for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type)) + do (wt-h comma arg-type-name " var" n) + (wt comma arg-type-name " var" n) + (setf comma ",")) (wt ")") (wt-h ");") (wt-nl-open-brace) @@ -120,17 +117,13 @@ (loop for n from 0 and type in arg-types and ct in arg-type-constants - do - (if (stringp ct) - (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" - n "," ct "));") - (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" - n "," ct ", (void*)" (ffi:size-of-foreign-type type) "));"))) + do (wt-nl "ecl_stack_frame_push(" + "frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")" + ");")) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") (when return-p - (wt-nl "ecl_foreign_data_set_elt(&output," - (foreign-elt-type-code return-type) ",aux);") + (wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);") (wt-nl "return output;")) (wt-nl-close-brace))) diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index d4e289e2c..670797bfa 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -761,7 +761,11 @@ Loads a foreign library." (values-list name) (values name :default)) (let ((arg-types (mapcar #'second arg-desc)) - (arg-names (mapcar #'first arg-desc))) + (arg-names (mapcar #'first arg-desc)) + (ret-type (typecase ret-type + ((member nil :void) :void) + ((cons (member * array)) :pointer-void) + (otherwise ret-type)))) `(si::make-dynamic-callback #'(ext::lambda-block ,name ,arg-names ,@body) ',name ',ret-type ',arg-types ,call-type))) From 01e49c845a27b312de3bd40c26fc661624ff02e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 27 Nov 2019 22:16:10 +0100 Subject: [PATCH 7/9] cmp: cmpc-machine: cosmetic: put tables in columns It is easier to read this code this way. It goes well beyond 80 character limit but the alternative is not readable for human. --- src/cmp/cmpc-machine.lsp | 154 +++++++++++++++++++-------------------- src/cmp/cmpcbk.lsp | 6 ++ 2 files changed, 79 insertions(+), 81 deletions(-) diff --git a/src/cmp/cmpc-machine.lsp b/src/cmp/cmpc-machine.lsp index 83925c46f..95e9d024b 100644 --- a/src/cmp/cmpc-machine.lsp +++ b/src/cmp/cmpc-machine.lsp @@ -16,92 +16,84 @@ (in-package "COMPILER") +;; These types can be used by ECL to unbox data They are sorted from +;; the most specific, to the least specific one. All functions must +;; be declared in external.h (not internal.h) header file. (defconstant +representation-types+ - '(;; These types can be used by ECL to unbox data - ;; They are sorted from the most specific, to the least specific one. - ;; All functions must be declared in externa.h (not internal.h) header file. - (:byte . - #1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fixnum")) - (:unsigned-byte . - #2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum")) - (:fixnum integer "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum") - (:int integer "int" "ecl_make_int" "ecl_to_int" "ecl_to_int") - (:unsigned-int integer "unsigned int" "ecl_make_uint" "ecl_to_uint" "ecl_to_uint") - (:long integer "long" "ecl_make_long" "ecl_to_long" "ecl_to_long") - (:unsigned-long integer "unsigned long" "ecl_make_ulong" "ecl_to_ulong" "ecl_to_ulong") - (:cl-index integer "cl_index" "ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fixnum") - (:long-long integer "ecl_long_long_t" "ecl_make_long_long" "ecl_to_long_long" "ecl_to_long_long") - (:unsigned-long-long integer "ecl_ulong_long_t" "ecl_make_ulong_long" "ecl_to_ulong_long" "ecl_to_ulong_long") - (:float single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float") - (:double double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float") - (:long-double long-float "long double" "ecl_make_long_float" "ecl_to_long_double" "ecl_long_float") - (:csfloat si::complex-single-float "_Complex float" "ecl_make_csfloat" "ecl_to_csfloat" "ecl_csfloat") - (:cdfloat si::complex-double-float "_Complex double" "ecl_make_cdfloat" "ecl_to_cdfloat" "ecl_cdfloat") - (:clfloat si::complex-long-float "_Complex long double" "ecl_make_clfloat" "ecl_to_clfloat" "ecl_clfloat") - (:unsigned-char base-char "unsigned char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") - (:char base-char "char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") - (:wchar character "ecl_character" "CODE_CHAR" "ecl_char_code" "CHAR_CODE") - (:float-sse-pack ext::float-sse-pack "__m128" "ecl_make_float_sse_pack" - "ecl_unbox_float_sse_pack" "ecl_unbox_float_sse_pack_unsafe") - (:double-sse-pack ext::double-sse-pack "__m128d" "ecl_make_double_sse_pack" - "ecl_unbox_double_sse_pack" "ecl_unbox_double_sse_pack_unsafe") - (:int-sse-pack ext::sse-pack #|<-intentional|# "__m128i" "ecl_make_int_sse_pack" - "ecl_unbox_int_sse_pack" "ecl_unbox_int_sse_pack_unsafe") - (:object t "cl_object") - (:bool t "bool" "ecl_make_bool" "ecl_to_bool" "ecl_to_bool") + ;; ffi-type lisp type c type convert C->Lisp convert Lisp->C unbox Lisp->C (unsafe) + '((:byte . #1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fixnum")) + (:unsigned-byte . #2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum")) + (:fixnum integer "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum") + (:int integer "int" "ecl_make_int" "ecl_to_int" "ecl_to_int") + (:unsigned-int integer "unsigned int" "ecl_make_uint" "ecl_to_uint" "ecl_to_uint") + (:long integer "long" "ecl_make_long" "ecl_to_long" "ecl_to_long") + (:unsigned-long integer "unsigned long" "ecl_make_ulong" "ecl_to_ulong" "ecl_to_ulong") + (:cl-index integer "cl_index" "ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fixnum") + (:long-long integer "ecl_long_long_t" "ecl_make_long_long" "ecl_to_long_long" "ecl_to_long_long") + (:unsigned-long-long integer "ecl_ulong_long_t" "ecl_make_ulong_long" "ecl_to_ulong_long" "ecl_to_ulong_long") + (:float single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float") + (:double double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float") + (:long-double long-float "long double" "ecl_make_long_float" "ecl_to_long_double" "ecl_long_float") + (:csfloat si::complex-single-float "_Complex float" "ecl_make_csfloat" "ecl_to_csfloat" "ecl_csfloat") + (:cdfloat si::complex-double-float "_Complex double" "ecl_make_cdfloat" "ecl_to_cdfloat" "ecl_cdfloat") + (:clfloat si::complex-long-float "_Complex long double" "ecl_make_clfloat" "ecl_to_clfloat" "ecl_clfloat") + (:unsigned-char base-char "unsigned char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") + (:char base-char "char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") + (:wchar character "ecl_character" "CODE_CHAR" "ecl_char_code" "CHAR_CODE") + (:float-sse-pack ext::float-sse-pack "__m128" "ecl_make_float_sse_pack" "ecl_unbox_float_sse_pack" "ecl_unbox_float_sse_pack_unsafe") + (:double-sse-pack ext::double-sse-pack "__m128d" "ecl_make_double_sse_pack" "ecl_unbox_double_sse_pack" "ecl_unbox_double_sse_pack_unsafe") + ;; intentional v + (:int-sse-pack ext::sse-pack "__m128i" "ecl_make_int_sse_pack" "ecl_unbox_int_sse_pack" "ecl_unbox_int_sse_pack_unsafe") + (:object t "cl_object" nil nil nil) + (:bool t "bool" "ecl_make_bool" "ecl_to_bool" "ecl_to_bool") ;; These types are never selected to unbox data. ;; They are here, because we need to know how to print them. - (:void nil "void") - (:pointer-void si::foreign-data "void*" "ecl_make_pointer" "ecl_to_pointer" "ecl_to_pointer") - (:cstring string "char*" "ecl_cstring_to_base_string_or_nil") - (:char* string "char*") - (:int8-t . #1#) - (:uint8-t . #2#) - (:int16-t integer "ecl_int16_t" "ecl_make_int16_t" "ecl_to_int16_t" "ecl_to_int16_t") - (:uint16-t integer "ecl_uint16_t" "ecl_make_uint16_t" "ecl_to_uint16_t" "ecl_to_unt16_t") - (:int32-t integer "ecl_int32_t" "ecl_make_int32_t" "ecl_to_int32_t" "ecl_to_int32_t") - (:uint32-t integer "ecl_uint32_t" "ecl_make_uint32_t" "ecl_to_uint32_t" "ecl_to_uint32_t") - (:int64-t integer "ecl_int64_t" "ecl_make_int64_t" "ecl_to_int64_t" "ecl_to_int64_t") - (:uint64-t integer "ecl_uint64_t" "ecl_make_uint64_t" "ecl_to_uint64_t" "ecl_to_uint64_t") - (:short integer "short" "ecl_make_short" "ecl_to_short" "ecl_fixnum") - (:unsigned-short integer "unsigned short" "ecl_make_ushort" "ecl_to_ushort" "ecl_fixnum") - )) + (:void nil "void" nil nil nil) + (:pointer-void si::foreign-data "void*" "ecl_make_pointer" "ecl_to_pointer" "ecl_to_pointer") + (:cstring string "char*" "ecl_cstring_to_base_string_or_nil" nil nil) + (:char* string "char*" nil nil nil) + (:int8-t . #1#) + (:uint8-t . #2#) + (:int16-t integer "ecl_int16_t" "ecl_make_int16_t" "ecl_to_int16_t" "ecl_to_int16_t") + (:uint16-t integer "ecl_uint16_t" "ecl_make_uint16_t" "ecl_to_uint16_t" "ecl_to_unt16_t") + (:int32-t integer "ecl_int32_t" "ecl_make_int32_t" "ecl_to_int32_t" "ecl_to_int32_t") + (:uint32-t integer "ecl_uint32_t" "ecl_make_uint32_t" "ecl_to_uint32_t" "ecl_to_uint32_t") + (:int64-t integer "ecl_int64_t" "ecl_make_int64_t" "ecl_to_int64_t" "ecl_to_int64_t") + (:uint64-t integer "ecl_uint64_t" "ecl_make_uint64_t" "ecl_to_uint64_t" "ecl_to_uint64_t") + (:short integer "short" "ecl_make_short" "ecl_to_short" "ecl_fixnum") + (:unsigned-short integer "unsigned short" "ecl_make_ushort" "ecl_to_ushort" "ecl_fixnum"))) + +;; FIXME number of bits is used for bit fiddling optimizations. That +;; information should be defined separately. -- jd 2019-11-27 (defconstant +this-machine-c-types+ - '((:byte . -8) - (:unsigned-byte . 8) - (:unsigned-short . #.(- (logcount ffi:c-ushort-max))) - (:short . #.(- (logcount ffi:c-ushort-max))) - (:unsigned-int . #.(logcount ffi:c-uint-max)) - (:int . #.(- (logcount ffi:c-uint-max))) - (:unsigned-long . #.(logcount ffi:c-ulong-max)) - (:long . #.(- (logcount ffi:c-ulong-max))) - #+long-long - (:unsigned-long-long . #.(logcount ffi:c-ulong-long-max)) - #+long-long - (:long-long . #.(- (logcount ffi:c-ulong-long-max))) - (:cl-index . #.(logcount most-positive-fixnum)) - (:fixnum . #.(- -1 (logcount most-positive-fixnum))) - (:uint8-t . 8) - (:int8-t . -8) - #+:uint16-t - (:uint16-t . 16) - #+:uint16-t - (:int16-t . -16) - #+:uint32-t - (:uint32-t . 32) - #+:uint32-t - (:int32-t . -32) - #+:uint64-t - (:uint64-t . 64) - #+:uint64-t - (:int64-t . -64) - #+:sse2 (:float-sse-pack . nil) - #+:sse2 (:double-sse-pack . nil) - #+:sse2 (:int-sse-pack . nil) - #+complex-float (:csfloat . nil) - #+complex-float (:cdfloat . nil) - #+complex-float (:clfloat . nil))) + ;; type integer bits (negative means "signed") + '((:byte . -8) + (:unsigned-byte . 8) + (:unsigned-short . #.(- (logcount ffi:c-ushort-max))) + (:short . #.(- (logcount ffi:c-ushort-max))) + (:unsigned-int . #.(logcount ffi:c-uint-max)) + (:int . #.(- (logcount ffi:c-uint-max))) + (:unsigned-long . #.(logcount ffi:c-ulong-max)) + (:long . #.(- (logcount ffi:c-ulong-max))) + #+long-long (:unsigned-long-long . #.(logcount ffi:c-ulong-long-max)) + #+long-long (:long-long . #.(- (logcount ffi:c-ulong-long-max))) + (:cl-index . #.(logcount most-positive-fixnum)) + (:fixnum . #.(- -1 (logcount most-positive-fixnum))) + (:uint8-t . 8) + (:int8-t . -8) + #+:uint16-t (:uint16-t . 16) + #+:uint16-t (:int16-t . -16) + #+:uint32-t (:uint32-t . 32) + #+:uint32-t (:int32-t . -32) + #+:uint64-t (:uint64-t . 64) + #+:uint64-t (:int64-t . -64) + #+:sse2 (:float-sse-pack . nil) + #+:sse2 (:double-sse-pack . nil) + #+:sse2 (:int-sse-pack . nil) + #+complex-float (:csfloat . nil) + #+complex-float (:cdfloat . nil) + #+complex-float (:clfloat . nil))) (defconstant +all-machines-c-types+ '((:object) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 2cb1d9396..1404eff0b 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -51,6 +51,12 @@ (cmperr "DEFCALLBACK: ~a is not a valid elementary FFI type." type)) (cdr x))) +;;; We could have made FFI:DEFCALLBACK to accept any ffi type defined +;;; for the current machine (see cmpc-machine.lisp), but it wouldn't +;;; be useful because it only extends FFI types with ECL-specific +;;; types like :fixnum or :sse2. Another argument against such +;;; approach is semantic equivalence between interpreted and compiled +;;; versions of the special form. -- jd 2019-11-27 (defun c1-defcallback (args) (destructuring-bind (name return-type arg-list &rest body) args From 05cc54a75e50f80ac9397866ec00b021a6602033 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 28 Nov 2019 15:57:43 +0100 Subject: [PATCH 8/9] cmp: remove global entries machinery This is a dead code which is not used in the compiler. It was meant for providing entry points from Common Lisp code to ECL functions written in C, but it was replaced by more robust machinery. --- src/cmp/cmpglobals.lsp | 11 ----------- src/cmp/cmptop.lsp | 44 ------------------------------------------ 2 files changed, 55 deletions(-) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index ea5ad902b..7159b6a52 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -276,16 +276,6 @@ lines are inserted, but the order is preserved") ;;; | ( 'CLINES' string* ) ;;; | ( 'LOAD-TIME-VALUE' vv ) -;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). - -;;; FIXME: global-entries mechanism seems to be completely abandoned -;;; (always NIL). Either remove compiler code which uses it and remove -;;; variable itself or properly document it and use where -;;; applicable. -- jd 2019-05-07 -(defvar *global-entries* nil) - -(defvar *global-macros* nil) - (defvar *self-destructing-fasl* '() "A value T means that, when a FASL module is being unloaded (for instance during garbage collection), the associated file will be @@ -320,7 +310,6 @@ be deleted if they have been opened with LoadLibrary.") (*global-vars* nil) (*global-funs* nil) (*global-cfuns-array* nil) - (*global-entries* nil) (*undefined-vars* nil) (*top-level-forms* nil) (*clines-string-list* '()) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 7fc59df39..30389867d 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -200,10 +200,6 @@ (wt-nl-h "#define VM " (data-permanent-storage-size)) (wt-nl-h "#define VMtemp " (data-temporary-storage-size))))) - ;;; Global entries for directly called functions. - (dolist (x *global-entries*) - (apply 'wt-global-entry x)) - (wt-nl-h "#define ECL_DEFINE_SETF_FUNCTIONS ") (loop for (name setf-vv name-vv) in *setf-definitions* do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);")) @@ -436,46 +432,6 @@ do (wt comma "CLV" i) finally (wt ";")))) -(defun wt-global-entry (fname cfun arg-types return-type) - (when (and (symbolp fname) (si:get-sysprop fname 'NO-GLOBAL-ENTRY)) - (return-from wt-global-entry nil)) - (wt-comment-nl "global entry for the function ~a" fname) - (wt-nl "static cl_object L" cfun "(cl_narg narg") - (wt-nl-h "static cl_object L" cfun "(cl_narg") - (do ((vl arg-types (cdr vl)) - (lcl (1+ *lcl*) (1+ lcl))) - ((endp vl) (wt1 ")")) - (declare (fixnum lcl)) - (wt1 ", cl_object ") (wt-lcl lcl) - (wt-h ", cl_object")) - (wt-h1 ");") - (wt-nl-open-brace) - (when (compiler-check-args) - (wt-nl "_ecl_check_narg(" (length arg-types) ");")) - (wt-nl "cl_env_copy->nvalues = 1;") - (wt-nl "return " (ecase return-type - (FIXNUM "ecl_make_fixnum") - (CHARACTER "CODE_CHAR") - (DOUBLE-FLOAT "ecl_make_double_float") - (SINGLE-FLOAT "ecl_make_single_float") - (LONG-FLOAT "ecl_make_long_float")) - "(LI" cfun "(") - (do ((types arg-types (cdr types)) - (n 1 (1+ n))) - ((endp types)) - (declare (fixnum n)) - (wt (case (car types) - (FIXNUM "fix") - (CHARACTER "ecl_char_code") - (DOUBLE-FLOAT "df") - (SINGLE-FLOAT "sf") - (LONG-FLOAT "ecl_long_float") - (otherwise "")) "(") - (wt-lcl n) (wt ")") - (unless (endp (cdr types)) (wt ","))) - (wt "));") - (wt-nl-close-many-braces 0)) - (defun rep-type (type) (case type (FIXNUM "cl_fixnum ") From 69af89422488c4629f13531b2c8e689e6abcea28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 16 Dec 2019 10:14:57 +0100 Subject: [PATCH 9/9] cmp: remove dynamic variable *compiler-input* *compiler-input* was only passed to the first-pass, there is no need for a dynamic binding. --- src/cmp/cmpglobals.lsp | 1 - src/cmp/cmpmain.lsp | 12 ++++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 7159b6a52..abec2466d 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -69,7 +69,6 @@ running the compiler. It may be updated by running ") (defvar *compiler-break-enable* nil) (defvar *compiler-in-use* nil) -(defvar *compiler-input*) (defvar *compiler-output1*) (defvar *compiler-output2*) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index a374fd2cf..954690682 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -666,11 +666,11 @@ compiled successfully, returns the pathname of the compiled file" (when (probe-file "./cmpinit.lsp") (load "./cmpinit.lsp" :verbose *compile-verbose*)) - (with-open-file (*compiler-input* *compile-file-pathname* - :external-format external-format) + (with-open-file (stream *compile-file-pathname* + :external-format external-format) (unless source-truename (setf (car ext:*source-location*) *compile-file-pathname*)) - (compiler-pass1 *compiler-input* source-offset)) + (compiler-pass1 stream source-offset)) (cmpprogress "~&;;; End of Pass 1.") (setf init-name (compute-init-name output-file :kind @@ -904,9 +904,9 @@ from the C language code. NIL means \"do not create the file\"." (data-init) (if (streamp object) (do* ((eof '(NIL)) - (*compile-file-position* 0 (file-position *compiler-input*)) - (form (si::read-object-or-ignore *compiler-input* eof) - (si::read-object-or-ignore *compiler-input* eof))) + (*compile-file-position* 0 (file-position object)) + (form (si::read-object-or-ignore object eof) + (si::read-object-or-ignore object eof))) ((eq form eof)) (when form (setf (cdr ext:*source-location*)