From 4ab12a4077bcf29064e8ac35705685447e1ebce3 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 20 Dec 2009 16:04:59 +0100 Subject: [PATCH] Incorporate the new compiler into the source tree. --- src/Makefile.in | 9 +- src/bare.lsp.in | 2 +- src/compile.lsp.in | 3 +- src/configure | 23 +- src/configure.in | 17 +- src/new-cmp/TODO | 91 ++ src/new-cmp/cmparray.lsp | 84 ++ src/new-cmp/cmpbackend.lsp | 689 +++++++++++ src/new-cmp/cmpbind.lsp | 76 ++ src/new-cmp/cmpblock.lsp | 105 ++ src/new-cmp/cmpcall.lsp | 83 ++ src/new-cmp/cmpcatch.lsp | 92 ++ src/new-cmp/cmpcbk.lsp | 120 ++ src/new-cmp/cmpclos.lsp | 118 ++ src/new-cmp/cmpct.lsp | 123 ++ src/new-cmp/cmpdefs.lsp | 548 ++++++++ src/new-cmp/cmpenv.lsp | 726 +++++++++++ src/new-cmp/cmpeval.lsp | 153 +++ src/new-cmp/cmpexit.lsp | 186 +++ src/new-cmp/cmpffi.lsp | 451 +++++++ src/new-cmp/cmpflet.lsp | 244 ++++ src/new-cmp/cmpfun.lsp | 164 +++ src/new-cmp/cmpif.lsp | 118 ++ src/new-cmp/cmpinit.lsp | 25 + src/new-cmp/cmpinline.lsp | 185 +++ src/new-cmp/cmplam.lsp | 529 ++++++++ src/new-cmp/cmplet.lsp | 140 +++ src/new-cmp/cmploc.lsp | 248 ++++ src/new-cmp/cmpmac.lsp | 211 ++++ src/new-cmp/cmpmain.lsp | 878 +++++++++++++ src/new-cmp/cmpmap.lsp | 74 ++ src/new-cmp/cmpmulti.lsp | 135 ++ src/new-cmp/cmpname.lsp | 125 ++ src/new-cmp/cmpnum.lsp | 190 +++ src/new-cmp/cmpopt.lsp | 419 +++++++ src/new-cmp/cmpprop.lsp | 535 ++++++++ src/new-cmp/cmpspecial.lsp | 119 ++ src/new-cmp/cmpstack.lsp | 63 + src/new-cmp/cmpstructures.lsp | 141 +++ src/new-cmp/cmptables.lsp | 257 ++++ src/new-cmp/cmptag.lsp | 184 +++ src/new-cmp/cmptest.lsp | 253 ++++ src/new-cmp/cmptop.lsp | 426 +++++++ src/new-cmp/cmptranslate.lsp | 426 +++++++ src/new-cmp/cmptype.lsp | 637 ++++++++++ src/new-cmp/cmputil.lsp | 298 +++++ src/new-cmp/cmpvar.lsp | 353 ++++++ src/new-cmp/cmpwt.lsp | 298 +++++ src/new-cmp/defsys.lsp.in | 46 + src/new-cmp/load.lsp.in | 48 + src/new-cmp/sysfun.lsp | 2197 +++++++++++++++++++++++++++++++++ 51 files changed, 13657 insertions(+), 8 deletions(-) create mode 100644 src/new-cmp/TODO create mode 100644 src/new-cmp/cmparray.lsp create mode 100644 src/new-cmp/cmpbackend.lsp create mode 100644 src/new-cmp/cmpbind.lsp create mode 100644 src/new-cmp/cmpblock.lsp create mode 100644 src/new-cmp/cmpcall.lsp create mode 100644 src/new-cmp/cmpcatch.lsp create mode 100644 src/new-cmp/cmpcbk.lsp create mode 100644 src/new-cmp/cmpclos.lsp create mode 100644 src/new-cmp/cmpct.lsp create mode 100644 src/new-cmp/cmpdefs.lsp create mode 100644 src/new-cmp/cmpenv.lsp create mode 100644 src/new-cmp/cmpeval.lsp create mode 100644 src/new-cmp/cmpexit.lsp create mode 100644 src/new-cmp/cmpffi.lsp create mode 100644 src/new-cmp/cmpflet.lsp create mode 100644 src/new-cmp/cmpfun.lsp create mode 100644 src/new-cmp/cmpif.lsp create mode 100644 src/new-cmp/cmpinit.lsp create mode 100644 src/new-cmp/cmpinline.lsp create mode 100644 src/new-cmp/cmplam.lsp create mode 100644 src/new-cmp/cmplet.lsp create mode 100644 src/new-cmp/cmploc.lsp create mode 100644 src/new-cmp/cmpmac.lsp create mode 100644 src/new-cmp/cmpmain.lsp create mode 100644 src/new-cmp/cmpmap.lsp create mode 100644 src/new-cmp/cmpmulti.lsp create mode 100644 src/new-cmp/cmpname.lsp create mode 100644 src/new-cmp/cmpnum.lsp create mode 100644 src/new-cmp/cmpopt.lsp create mode 100644 src/new-cmp/cmpprop.lsp create mode 100644 src/new-cmp/cmpspecial.lsp create mode 100644 src/new-cmp/cmpstack.lsp create mode 100644 src/new-cmp/cmpstructures.lsp create mode 100644 src/new-cmp/cmptables.lsp create mode 100644 src/new-cmp/cmptag.lsp create mode 100644 src/new-cmp/cmptest.lsp create mode 100644 src/new-cmp/cmptop.lsp create mode 100644 src/new-cmp/cmptranslate.lsp create mode 100644 src/new-cmp/cmptype.lsp create mode 100644 src/new-cmp/cmputil.lsp create mode 100644 src/new-cmp/cmpvar.lsp create mode 100644 src/new-cmp/cmpwt.lsp create mode 100644 src/new-cmp/defsys.lsp.in create mode 100644 src/new-cmp/load.lsp.in create mode 100644 src/new-cmp/sysfun.lsp diff --git a/src/Makefile.in b/src/Makefile.in index 26f459d7b..36087357d 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -46,6 +46,7 @@ SUBDIRS = @SUBDIRS@ LIBRARIES = @LIBRARIES@ LSP_LIBRARIES = @LSP_LIBRARIES@ TARGETS = @TARGETS@ +ECL_CMPDIR = @ECL_CMPDIR@ all: $(TARGETS) bin/ecl-config .PHONY: all @@ -84,10 +85,10 @@ ecl_min$(EXE): $(LIBRARIES) .gdbinit @LIBPREFIX@eclmin.@LIBEXT@ lsp/config.lsp: lsp/config.pre sed -e 's,@ecldir\\@,$(ecldir),g' < lsp/config.pre > lsp/config.lsp -cmp/cmpdefs.lsp: cmp/cmpdefs.pre +$(ECL_CMPDIR)/cmpdefs.lsp: $(ECL_CMPDIR)/cmpdefs.pre sed -e 's,@ecldir\\@,"$(ecldir)",g' \ -e 's,@libdir\\@,"$(libdir)",g' \ - -e 's,@includedir\\@,"$(includedir)",g' < cmp/cmpdefs.pre > $@ + -e 's,@includedir\\@,"$(includedir)",g' < $(ECL_CMPDIR)/cmpdefs.pre > $@ compile.lsp: compile.pre sed -e 's,@ecldir\\@,$(ecldir),g' \ -e 's,@libdir\\@,$(libdir),g' < compile.pre > compile.lsp @@ -96,7 +97,7 @@ bin/ecl-config: bin/ecl-config.pre -e 's,@includedir\\@,$(includedir),' bin/ecl-config.pre > bin/ecl-config -@LIBPREFIX@eclmin.@LIBEXT@: @LIBPREFIX@eclgmp.@LIBEXT@ @LIBPREFIX@eclgc.@LIBEXT@ lsp/config.lsp cmp/cmpdefs.lsp ecl/external.h +@LIBPREFIX@eclmin.@LIBEXT@: @LIBPREFIX@eclgmp.@LIBEXT@ @LIBPREFIX@eclgc.@LIBEXT@ lsp/config.lsp $(ECL_CMPDIR)/cmpdefs.lsp ecl/external.h cd c; $(MAKE) @LIBPREFIX@eclgc.@LIBEXT@: test -d ecl/gc || mkdir ecl/gc @@ -113,7 +114,7 @@ bin/ecl-config: bin/ecl-config.pre mv ./@LIBPREFIX@gmp.@LIBEXT@ ./@LIBPREFIX@eclgmp.@LIBEXT@; \ fi sysfun.lsp: - $(LN_S) $(srcdir)/cmp/sysfun.lsp ./ + $(LN_S) $(srcdir)/$(ECL_CMPDIR)/sysfun.lsp ./ rt.lisp: cp $(srcdir)/../contrib/rt/rt.lisp ./ diff --git a/src/bare.lsp.in b/src/bare.lsp.in index ed4e63414..444adc88d 100644 --- a/src/bare.lsp.in +++ b/src/bare.lsp.in @@ -67,7 +67,7 @@ (princ #+(or cross ecl-min) ";;; About to load cmp/load.lsp" #-(or cross ecl-min) ";;; About to load cmp.so") -(load #+(or cross ecl-min) "cmp/load.lsp" +(load #+(or cross ecl-min) "@ECL_CMPDIR@/load.lsp" #-(or cross ecl-min) "cmp.so") ;;; diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 047a3bcb2..e699de929 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -134,7 +134,8 @@ #+WANTS-CMP (build-module "cmp" +cmp-module-files+ - :dir "build:cmp;" :prefix "CMP" :additional-files '("sysfun.lsp") + :dir "build:@ECL_CMPDIR@;" :prefix "CMP" + :additional-files '("sysfun.lsp") :builtin #+:BUILTIN-CMP t #-:BUILTIN-CMP nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/configure b/src/configure index b68517405..53a1ac46b 100755 --- a/src/configure +++ b/src/configure @@ -660,6 +660,7 @@ SONAME SONAME1 SONAME2 SONAME3 +ECL_CMPDIR ECL_GMP_HEADER EGREP GREP @@ -803,6 +804,7 @@ enable_smallcons enable_gengc with_debug_cflags with_profile_cflags +with_newcmp with_x ' ac_precious_vars='build_alias @@ -1516,6 +1518,7 @@ Optional Packages: (yes,no,actual flags,default=YES) --with-profile-cflags add profiling flags to the compiler invocation (yes,no,actual flags,default=NO) + --with-newcmp new compiler (yes|no, default=NO) --with-x use the X Window System Some influential environment variables: @@ -2369,6 +2372,15 @@ else fi + +# Check whether --with-newcmp was given. +if test "${with_newcmp+set}" = set; then + withval=$with_newcmp; +else + with_newcmp=no +fi + + ecldir="${libdir}/ecl-${PACKAGE_VERSION}" test -z "${docdir}" && docdir="${datadir}/doc/ecl-${PACKAGE_VERSION}" @@ -5726,6 +5738,13 @@ if test "$with_profile_cflags" != "no"; then LDFLAGS="$with_profile_cflags $LDFLAGS" fi +if test "${with_newcmp}" = "yes"; then + ECL_CMPDIR=new-cmp +else + ECL_CMPDIR=cmp +fi + + if test "${enable_threads}" = "auto"; then { $as_echo "$as_me:$LINENO: checking for threads support" >&5 $as_echo_n "checking for threads support... " >&6; } @@ -14104,7 +14123,7 @@ $as_echo "$as_me: error: Not a valid argument for --enable-boehm $enable_boehm" { (exit 1); exit 1; }; };; esac -ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp" +ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp" ac_config_headers="$ac_config_headers ecl/config.h:ecl/configpre.h" # FIXME @@ -14707,6 +14726,7 @@ do "lsp/load.lsp") CONFIG_FILES="$CONFIG_FILES lsp/load.lsp" ;; "clos/load.lsp") CONFIG_FILES="$CONFIG_FILES clos/load.lsp" ;; "cmp/load.lsp") CONFIG_FILES="$CONFIG_FILES cmp/load.lsp" ;; + "new-cmp/load.lsp") CONFIG_FILES="$CONFIG_FILES new-cmp/load.lsp" ;; "../Makefile") CONFIG_FILES="$CONFIG_FILES ../Makefile" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "c/Makefile") CONFIG_FILES="$CONFIG_FILES c/Makefile" ;; @@ -14718,6 +14738,7 @@ do "lsp/config.pre") CONFIG_FILES="$CONFIG_FILES lsp/config.pre:lsp/config.lsp.in" ;; "compile.pre") CONFIG_FILES="$CONFIG_FILES compile.pre:compile.lsp.in" ;; "cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES cmp/cmpdefs.pre:cmp/cmpdefs.lsp" ;; + "new-cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp" ;; "ecl/config.h") CONFIG_HEADERS="$CONFIG_HEADERS ecl/config.h:ecl/configpre.h" ;; *) { { $as_echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 diff --git a/src/configure.in b/src/configure.in index 2bbf65e64..fd749b613 100644 --- a/src/configure.in +++ b/src/configure.in @@ -258,6 +258,11 @@ AC_ARG_WITH(profile-cflags, [(yes,no,actual flags,default=NO)]), [],[with_profile_cflags="no"]) +AC_ARG_WITH(newcmp, + AS_HELP_STRING( [--with-newcmp], + [new compiler (yes|no, default=NO)]), + [], [with_newcmp=no]) + dnl ----------------------------------------------------------------------- dnl Installation directories ecldir="${libdir}/ecl-${PACKAGE_VERSION}" @@ -423,6 +428,15 @@ if test "$with_profile_cflags" != "no"; then LDFLAGS="$with_profile_cflags $LDFLAGS" fi +dnl ---------------------------------------------------------------------- +dnl Version of the compiler +if test "${with_newcmp}" = "yes"; then + ECL_CMPDIR=new-cmp +else + ECL_CMPDIR=cmp +fi +AC_SUBST(ECL_CMPDIR) + dnl ---------------------------------------------------------------------- dnl Native thread support if test "${enable_threads}" = "auto"; then @@ -847,11 +861,12 @@ case "${enable_boehm}" in esac AC_CONFIG_FILES([ - bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp + bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp + new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp ]) AC_CONFIG_HEADERS([ecl/config.h:ecl/configpre.h]) # FIXME AC_OUTPUT diff --git a/src/new-cmp/TODO b/src/new-cmp/TODO new file mode 100644 index 000000000..82178d0ac --- /dev/null +++ b/src/new-cmp/TODO @@ -0,0 +1,91 @@ +* Routine for type propagation in function calls. + +* Region-based computation of *VOLATILE* _after_ compiling the whole function. + +* In SET-TRASH-LOC, we now consider that ALL function calls have side effects + We should be able to distinguish which ones do. + +* Implement tail recursion optimization. + +;;; Tail-recursion optimization for a function F is possible only if +;;; 1. F receives only required parameters, and +;;; 2. no required parameter of F is enclosed in a closure. +;;; +;;; A recursive call (F e1 ... en) may be replaced by a loop only if +;;; 1. F is not declared as NOTINLINE, +;;; 2. n is equal to the number of required parameters of F, +;;; 3. the form is a normal function call (i.e. args are not ARGS-PUSHED), +;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic +;;; binding (such as LET, LET*, PROGV), +;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame +;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are +;;; enclosed in a closure, and CATCH), + +* Only produce functions which are different from each other. + +(defun new-defun (new &optional no-entry) + (unless (fun-exported new) + ;; Check whether this function is similar to a previous one and + ;; share code with it. + (dolist (old *global-funs*) + (when (similar (fun-lambda new) (fun-lambda old)) + (cmpnote "Sharing code among functions ~A and ~A" + (fun-name new) (fun-name old)) + (setf (fun-shares-with new) old + (fun-cfun new) (fun-cfun old) + (fun-minarg new) (fun-minarg old) + (fun-maxarg new) (fun-maxarg old)) + (return)))) + (push new *global-funs*)) + +(defun similar (x y) + ;; FIXME! This could be more accurate + (labels ((similar-ref (x y) + (and (equal (ref-ref-ccb x) (ref-ref-ccb y)) + (equal (ref-ref-clb x) (ref-ref-clb y)) + (equal (ref-ref x) (ref-ref y)))) + (similar-var (x y) + (and (similar-ref x y) + (equal (var-name x) (var-name y)) + (equal (var-kind x) (var-kind y)) + (equal (var-loc x) (var-loc y)) + (equal (var-type x) (var-type y)) + (equal (var-index x) (var-index y)))) + (similar-c1form (x y) + (and (equal (c1form-name x) (c1form-name y)) + (similar (c1form-args x) (c1form-args y)) + (similar (c1form-local-vars x) (c1form-local-vars y)) + (eql (c1form-sp-change x) (c1form-sp-change y)) + (eql (c1form-volatile x) (c1form-volatile y)))) + (similar-fun (x y) + (and (similar-ref x y) + (eql (fun-global x) (fun-global y)) + (eql (fun-exported x) (fun-exported y)) + (eql (fun-closure x) (fun-closure y)) + (similar (fun-var x) (fun-var y)) + (similar (fun-lambda x) (fun-lambda y)) + (= (fun-level x) (fun-level y)) + (= (fun-env x) (fun-env y)) + (= (fun-minarg x) (fun-minarg y)) + (eql (fun-maxarg x) (fun-maxarg y)) + (similar (fun-local-vars x) (fun-local-vars y)) + (similar (fun-referred-vars x) (fun-referred-vars y)) + (similar (fun-referred-funs x) (fun-referred-funs y)) + (similar (fun-child-funs x) (fun-child-funs y))))) + (and (eql (type-of x) (type-of y)) + (typecase x + (CONS (and (similar (car x) (car y)) + (similar (cdr x) (cdr y)))) + (VAR (similar-var x y)) + (FUN (similar-fun x y)) + (REF (similar-ref x y)) + (TAG NIL) + (BLK NIL) + (C1FORM (similar-c1form x y)) + (SEQUENCE (and (every #'similar x y))) + (T (equal x y)))))) + +* Better handle the type of read-only variables without the need for + :READ-ONLY declarations. + +* Restore handling of shared data. \ No newline at end of file diff --git a/src/new-cmp/cmparray.lsp b/src/new-cmp/cmparray.lsp new file mode 100644 index 000000000..66a90c53f --- /dev/null +++ b/src/new-cmp/cmparray.lsp @@ -0,0 +1,84 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPARRAY. Optimizations related to arrays + +;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;; +;;; MAKE-ARRAY +;;; + +(define-compiler-macro make-array (&whole form dimensions &key (element-type t) + (initial-element nil initial-element-supplied-p) + (initial-contents nil initial-contents-supplied-p) + adjustable fill-pointer + displaced-to (displaced-index-offset 0) + &environment env) + ;; This optimization is always done unless we provide content. There + ;; is no speed, debug or space reason not to do it, unless the user + ;; specifies not to inline MAKE-ARRAY, but in that case the compiler + ;; macro should not be used. + (unless (or initial-element-supplied-p + initial-contents-supplied-p) + ;; If the type is known and we can assume it will not change, we + ;; replace it with the upgraded form. + (when (and (constantp element-type env) + (policy-assume-types-dont-change-p env)) + (let ((new-type (cmp-eval element-type))) + (when (known-type-p new-type) + (setf element-type `',(upgraded-array-element-type new-type))))) + ;; Finally, we choose between making a vector or making a general array. + ;; It only saves some time, since MAKE-PURE-ARRAY will call MAKE-VECTOR + ;; if a one-dimensional array is to be created. + (let ((function 'si::make-pure-array)) + (when (constantp dimensions env) + (let ((d (cmp-eval dimensions))) + (when (or (integerp d) (and (listp d) (= (length d) 1) (setf d (first d)))) + (setf function 'si::make-vector + dimensions `',d))) + (setf form + `(,function ,element-type ,dimensions ,adjustable ,fill-pointer + ,displaced-to ,displaced-index-offset))))) + form) + +;;; +;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND +;;; + +(defun expand-vector-push (whole env) + (declare (si::c-local)) + (let* ((extend (eq (first whole) 'vector-push-extend)) + (args (rest whole))) + (unless (or ;; Avoid infinite recursion + (eq (first args) '.val) + (safe-compile) + (>= (cmp-env-optimization 'space env) 2)) + (setf whole + `(let* ((.val ,(car args)) + (.vec ,(second args)) + (.i (fill-pointer .vec)) + (.dim (array-total-size .vec))) + (declare (fixnum .i .dim) + (:read-only .vec .val .i .dim)) + (cond ((< .i .dim) + (sys::fill-pointer-set .vec (the fixnum (+ 1 .i))) + (sys::aset .val .vec .i) + .i) + (t ,(when extend + `(vector-push-extend .val .vec ,@(cddr args))))))))) + whole) + +(define-compiler-macro vector-push (&whole whole &rest args &environment env) + (expand-vector-push whole env)) + +(define-compiler-macro vector-push-extend (&whole whole &rest args &environment env) + (expand-vector-push whole env)) diff --git a/src/new-cmp/cmpbackend.lsp b/src/new-cmp/cmpbackend.lsp new file mode 100644 index 000000000..657bc07af --- /dev/null +++ b/src/new-cmp/cmpbackend.lsp @@ -0,0 +1,689 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; C/C++ BACKEND +;;; + +;;; +;;; VARIABLE BINDINGS +;;; + +(defun c2bind (temps) + (loop with first = "{" + with new-env = nil + with closed-overs = '() + for v in temps + do (case (var-kind v) + ((REPLACED DISCARDED)) + ((SPECIAL GLOBAL) (baboon)) + ((LEXICAL) + (push v closed-overs)) + ((CLOSURE) + (push v closed-overs) + (unless new-env + (let ((env-lvl *env-lvl*)) + (wt-nl) (wt first) (setf first "") + (wt *volatile* "cl_object env" (incf *env-lvl*) " = env" env-lvl ";")) + (setf new-env t))) + (t + (setf (var-loc v) (next-lcl)) + (wt-nl) + (wt first) (setf first "") + (wt *volatile* (rep-type-name (var-kind v)) " " v ";") + (let ((name (var-name v))) (when name (wt-comment (var-name v)))))) + finally (loop for v in closed-overs + do (bind NIL v)))) + +(defun c2bind-special (var value-loc) + (bds-bind value-loc var)) + +(defun c2progv-op (destination vars-loc values-loc) + (wt-nl destination "=ecl_progv(cl_env_copy," vars-loc "," values-loc ");")) + +(defun c2progv-exit-op (ndx-loc) + (wt-nl "ecl_bds_unwind(cl_env_copy," ndx-loc ");")) + +(defun c2unbind-specials (nspecials) + (case nspecials + (0) + (1 (wt-nl "ecl_bds_unwind1(cl_env_copy);")) + (t (wt-nl "ecl_bds_unwind(cl_env_copy," nspecials ");")))) + +(defun c2unbind (temps &optional (close-block t)) + (loop with nspecials = 0 + with closure = 0 + with opened-block = nil + for v in temps + for kind = (var-kind v) + do (case kind + (CLOSURE (setf opened-block t) (incf closure)) + ((SPECIAL GLOBAL) (incf nspecials)) + ((REPLACED DISCARDED LEXICAL)) + (otherwise (setf opened-block t))) + finally (progn + (c2unbind-specials nspecials) + (unless (zerop closure) + (decf *env-lvl*) + (decf *env* closure)) + (when (and close-block opened-block) + (wt-nl "}"))))) + +;;; +;;; ASSIGNMENTS +;;; + +(defun c2set (loc value) + (cond ((eq loc value) + (cmpnote "Dummy SET statement ~A <- ~A" loc value) + (unless (equal loc *destination*) + (format t "~&;;; In dummy SET, destination ~A /= loc ~A" *destination* loc))) + (t + (set-loc value loc)))) + +(defun c2set-mv (locations min-args max-args) + (let* ((extras (nthcdr max-args locations)) + (locations (ldiff locations extras))) + (loop for v in extras + do (bind nil v)) + (if (plusp min-args) + (wt-nl "{int _nvalues = cl_env_copy->nvalues - " min-args ";") + (wt-nl "{int _nvalues = cl_env_copy->nvalues;")) + (loop for i from 0 below min-args + for v = (pop locations) + do (set-loc `(VALUE ,i) v)) + (loop with last-label = (next-label) + with labels = '() + for v in locations + for i from min-args + for l = (next-label) + do (progn + (push l labels) + (wt-nl "if (_nvalues-- <= 0) ") (wt-go l) + (set-loc `(VALUE ,i) v)) + finally (progn + (wt-nl) (wt-go last-label) + (loop for l in (nreverse labels) + for v in (reverse locations) + do (wt-label l) + do (set-loc nil v)) + (wt-label last-label) + (wt " }"))))) + +(defun c2values-op (locations) + (loop for i from 0 + for v in locations + do (wt-nl "cl_env_copy->values[" i "]=" v ";") + finally (wt-nl "cl_env_copy->nvalues=" i ";"))) + +;;; +;;; FUNCTION ARGUMENTS +;;; + +(defun c2bind-required (var n) + (bind n var)) + +(defun c2varargs-bind-op (nargs-loc varargs-loc minargs maxargs nkeywords check) + (wt-nl "{") + (wt-comment "Arguments parsing - begin") + (when (plusp nkeywords) + (wt-nl "cl_object keyvars[" (* 2 nkeywords) "];")) + (if (simple-varargs-loc-p varargs-loc) + (progn + (wt-nl "va_list args;") + (wt-comment "Remaining arguments list") + (wt-nl "va_start(args,__ecl_last_arg);")) + (progn + (wt-nl "cl_va_list cl_args;") + (wt-comment "Optional arguments list") + (wt-nl "cl_va_start(cl_args,__ecl_last_arg,narg," minargs ");"))) + (when check + (when (plusp minargs) + (wt-nl "if (narg<" minargs ") FEwrong_num_arguments_anonym();")) + (unless (>= maxargs call-arguments-limit) + (wt-nl "if (narg>" maxargs ") FEwrong_num_arguments_anonym();"))) + (when (plusp minargs) + (wt-nl "narg -= " minargs ";"))) + +(defun c2varargs-pop-op (destination nargs-loc varargs-loc) + (set-loc (if (simple-varargs-loc-p varargs-loc) 'VA-ARG 'CL-VA-ARG) + destination)) + +(defun c2varargs-rest-op (dest-loc nargs-loc varargs-loc nkeys + keywords-loc allow-other-keys) + (if (not (or keywords-loc allow-other-keys)) + (if (simple-varargs-loc-p varargs-loc) + (wt-nl dest-loc "=cl_grab_rest_args(args);") + (wt-nl dest-loc "=cl_grab_rest_args(cl_args);")) + (progn + (if keywords-loc + (wt-nl "cl_parse_key(cl_args," nkeys "," keywords-loc ",keyvars") + (wt-nl "cl_parse_key(cl_args,0,NULL,NULL")) + (if dest-loc + (wt ",(cl_object*)&" dest-loc) + (wt ",NULL")) + (wt (if allow-other-keys ",TRUE);" ",FALSE);"))))) + +(defun c2varargs-unbind-op (nargs-loc varargs-loc minargs maxargs nkeywords) + (when (simple-varargs-loc-p varargs-loc) + (wt-nl "va_end(args);")) + (wt-nl "}") + (wt-comment "Arguments parsing - end")) + +;;; +;;; JUMP FRAMES +;;; + +(defun c2frame-set (var no-label) + (if (eq var 'UNWIND-PROTECT) + (wt-nl "if (ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG)==0) ") + (wt-nl "if (ecl_frs_push(cl_env_copy," var ")==0) ")) + (wt-go (tag-label no-label))) + +(defun c2frame-pop (&optional var) + (unless (and var (var-p var) (zerop (var-ref var))) + (wt-nl "ecl_frs_pop(cl_env_copy);"))) + +(defun c2frame-save-next (var) + (bind "(cl_object)(cl_env_copy->nlj_fr)" var)) + +(defun c2frame-jmp-next (var) + (wt-nl "ecl_unwind(cl_env_copy," var ");")) + +(defun c2frame-id (var) + (bind "ECL_NEW_FRAME_ID(cl_env_copy)" var)) + +;;; +;;; STACK FRAMES +;;; + +(defun c2stack-frame-open (var) + (wt-nl "{struct ecl_stack_frame _ecl_inner_frame_aux;") + (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);") + (bind "_ecl_inner_frame" var)) + +(defun c2stack-frame-push (frame-var value-loc) + (wt-nl "ecl_stack_frame_push(" frame-var "," value-loc ");")) + +(defun c2stack-frame-push-values (frame-var) + (wt-nl "ecl_stack_frame_push_values(" frame-var ");")) + +(defun c2stack-frame-pop-values (frame-var dest) + (wt-nl "cl_env_copy->values[0]=ecl_stack_frame_pop_values(" frame-var ");") + (unless (eq dest 'trash) + (set-loc 'VALUES dest))) + +(defun c2stack-frame-apply (frame-var function-loc) + (wt-nl "cl_env_copy->values[0]=ecl_apply_from_stack_frame(" frame-var + "," function-loc ");")) + +(defun c2stack-frame-close (frame-var) + (wt-nl "ecl_stack_frame_close(" frame-var ");") + (wt-nl "}")) + +;;; +;;; LOCAL AND NONLOCAL CONTROL TRANSFER +;;; + +(defun c2jmp (tag) + (wt-nl) (wt-go (tag-label tag))) + +(defun set-loc-jmp-true (loc tag) + (wt-nl "if (" loc ") ") + (wt-go (tag-label tag))) + +(defun set-loc-jmp-false (loc tag) + (wt-nl "if (!(" loc ")) ") + (wt-go (tag-label tag))) + +(defun set-loc-jmp-zero (loc tag) + (wt-nl "if (!(" loc ")) ") + (wt-go (tag-label tag))) + +(defun c2return-from-op (var name) + (wt-nl "cl_return_from(" var "," (add-symbol name) ");")) + +(defun c2throw-op (tag) + (wt-nl "cl_throw(" tag ");")) + +(defun c2go-op (tag) + (let ((var (tag-var tag))) + (wt-nl "cl_go(" var ",MAKE_FIXNUM(" (tag-index tag) "));"))) + +;;; +;;; FUNCTION CALLS, CLOSURES AND THE LIKE +;;; + +(defun c2do-flet/labels (local-funs) + ;; FIXME! We change the order for compatibility to make "diff" + ;; with previous sources easier + (mapc #'new-local (reverse local-funs))) + +(defun c2funcall-op (destination args) + (let* ((loc (pop args)) + (form-type (c1form-or-loc-primary-type loc)) + (function-p (and (subtypep form-type 'function) + (policy-assume-right-type)))) + (set-loc (call-unknown-global-loc nil loc args function-p) + destination))) + +(defun c2call-local (destination fun args) + (set-loc (call-normal-loc destination fun args) destination)) + +(defun c2call-global (destination fname args &optional (return-type T)) + (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))) + (set-loc (call-global-loc destination fname fun args return-type + (loc-type destination)) + destination))) + +(defun call-global-loc (destination fname fun args return-type expected-type) + ;; Check whether it is a global function that we cannot call directly. + (when (and (or (null fun) (fun-global fun)) (not (inline-possible fname))) + (return-from call-global-loc + (call-unknown-global-loc fname nil args))) + + ;; Open-codable function. + (let* ((arg-types (mapcar #'c1form-or-loc-primary-type args)) + (ii (inline-function destination fname arg-types + (type-and return-type expected-type)))) + (when ii + (setf args (coerce-locations args (inline-info-arg-types ii))) + (return-from call-global-loc (apply-inline-info ii args)))) + + ;; Call to a function defined in the same file. Direct calls are + ;; only emitted for low or neutral values of DEBUG is >= 2. + (when (and (<= (cmp-env-optimization 'debug) 1) + (or (fun-p fun) + (and (null fun) + (setf fun (find fname *global-funs* :test #'same-fname-p + :key #'fun-name))))) + (return-from call-global-loc (call-normal-loc fname fun args))) + + ;; Call to a global (SETF ...) function + (when (not (symbolp fname)) + (return-from call-global-loc (call-unknown-global-loc fname nil args))) + + ;; Call to a function whose C language function name is known, + ;; either because it has been proclaimed so, or because it belongs + ;; to the runtime. + (when (and (<= (cmp-env-optimization 'debug) 1) + (setf fd (get-sysprop fname 'Lfun))) + (multiple-value-bind (minarg maxarg) (get-proclaimed-narg fname) + (return-from call-global-loc + (call-exported-function-loc + fname args fd minarg maxarg + (member fname *in-all-symbols-functions*))))) + + (multiple-value-bind (found fd minarg maxarg) + (si::mangle-name fname t) + (when found + (return-from call-global-loc + (call-exported-function-loc fname args fd minarg maxarg t)))) + + (call-unknown-global-loc fname nil args)) + +(defun coerce-locations (locations types &optional args-to-be-saved) + (loop for i from 0 + for loc in locations + for type = (if types (pop types) :object) + for rep-type = (lisp-type->rep-type type) + when (and args-to-be-saved (member i args-to-be-saved) + (not (var-p loc))) + do (cmpnote "Ignoring '~{@~A;~}' in a c-inline form" args-to-be-saved) + collect (if (eq rep-type (loc-representation-type loc)) + loc + `(COERCE-LOC ,rep-type ,loc)))) + +(defun call-normal-loc (fname fun args) + `(CALL-NORMAL ,fun ,args)) + +(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core) + (unless in-core + ;; We only write declarations for functions which are not in lisp_external.h + (multiple-value-bind (val declared) + (gethash fun-c-name *compiler-declared-globals*) + (unless declared + (if (= maxarg minarg) + (progn + (wt-nl-h "extern cl_object " fun-c-name "(") + (dotimes (i maxarg) + (when (> i 0) (wt-h1 ",")) + (wt-h1 "cl_object")) + (wt-h1 ");")) + (progn + (wt-nl-h "#ifdef __cplusplus") + (wt-nl-h "extern cl_object " fun-c-name "(...);") + (wt-nl-h "#else") + (wt-nl-h "extern cl_object " fun-c-name "();") + (wt-nl-h "#endif"))) + (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) + (let ((fun (make-fun :name fname :global t :cfun fun-c-name :lambda 'NIL + :minarg minarg :maxarg maxarg))) + (call-normal-loc fname fun args))) + +(defun call-unknown-global-loc (fname loc args &optional function-p) + (unless loc + (if (and (symbolp fname) + (not (eql (symbol-package fname) + (find-package "CL")))) + (setf loc (add-symbol fname) + function-p nil) + (setf loc (list 'FDEFINITION fname) + function-p t))) + `(CALL-INDIRECT ,loc ,args ,fname ,function-p)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; FUNCTION CALL LOCATIONS +;;; + +(defun wt-call-indirect (fun-loc args fname function-p) + (let ((narg (length args))) + (if function-p + (wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg) + (wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg)) + (dolist (arg args) + (wt "," arg)) + (wt ")") + (when fname (wt-comment fname)))) + +(defun wt-call-normal (fun args) + (unless (fun-cfun fun) + (baboon "Function without a C name: ~A" (fun-name fun))) + (let* ((minarg (fun-minarg fun)) + (maxarg (fun-maxarg fun)) + (fun-c-name (fun-cfun fun)) + (fun-lisp-name (fun-name fun)) + (narg (length args)) + (env nil)) + (case (fun-closure fun) + (CLOSURE + (setf env (environment-accessor fun))) + (LEXICAL + (let ((lex-lvl (fun-level fun))) + (dotimes (n lex-lvl) + (let* ((j (- lex-lvl n 1)) + (x (lex-env-var-name j))) + (push x args)))))) + (unless (<= minarg narg maxarg) + (cmperr "Wrong number of arguments for function ~S" + (or fun-lisp-name 'ANONYMOUS))) + (when (fun-narg-p fun) + (push narg args)) + (wt-call fun-c-name args fun-lisp-name env))) + +(defun wt-call (fun args &optional fname env) + (if env + (progn + (push-new :aux-closure (fun-code-gen-props *current-function*)) + (wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,") + (wt-call fun args) + (wt ")")) + (progn + (wt fun "(") + (let ((comma "")) + (dolist (arg args) + (wt comma arg) + (setf comma ","))) + (wt ")"))) + (when fname (wt-comment fname))) + +;;; +;;; DEBUG INFORMATION +;;; + +(defun c2debug-env-open (fname) + (wt-nl "{struct ihs_frame _ecl_ihs;") + (wt-comment "Debug info for:") + (wt-nl "const cl_object _ecl_debug_env = Cnil;") + (wt-comment fname) + (wt-nl "ecl_ihs_push(cl_env_copy,&_ecl_ihs," (add-symbol fname) ",_ecl_debug_env);") + (wt-nl)) + +(defun c2debug-env-close (fname) + (wt-nl) + (wt-nl "ecl_ihs_pop(cl_env_copy);") + (wt-comment "Debug info removed") + (wt-nl "}")) + +(defun c2debug-env-push-vars (variables) + #-:msvc ;; FIXME! Problem with initialization of statically defined vectors + (let* ((filtered-locations '()) + (filtered-codes '())) + (wt-nl "{") + (wt-comment "Debug bindings - register") + ;; Filter out variables that we know how to store in the + ;; debug information table. This excludes among other things + ;; closures and special variables. + (loop for var in variables + for name = (let ((*package* (find-package "KEYWORD"))) + (format nil "\"~S\"" (var-name var))) + for code = (locative-type-from-var-kind (var-kind var)) + for loc = (var-loc var) + when (and code (consp loc) (eq (first loc) 'LCL)) + do (progn + (push (cons name code) filtered-codes) + (push (second loc) filtered-locations))) + ;; Generate two tables, a static one with information about the + ;; variables, including name and type, and dynamic one, which is + ;; a vector of pointer to the variables. + (when filtered-codes + (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={") + (loop for (name . code) in filtered-codes + for i from 0 + do (wt-nl (if (zerop i) "{" ",{") name "," code "}")) + (wt "};") + (wt-nl "const cl_index _ecl_debug_info_raw[]={") + (wt-nl "(cl_index)(_ecl_debug_env),(cl_index)(_ecl_descriptors)") + (loop for var-loc in filtered-locations + do (wt ",(cl_index)(&" (lcl-name var-loc) ")")) + (wt "};") + (wt-nl "ecl_def_ct_vector(_ecl_debug_env,aet_index,_ecl_debug_info_raw," + (+ 2 (length filtered-locations)) + ",,);")) + (when filtered-codes + (wt-nl "ihs.lex_env=_ecl_debug_env;")) + (wt-nl))) + +(defun c2debug-env-pop-vars (variables close-block) + #-:msvc + (progn + (wt-nl) + (wt-comment "Debug bindings - remove") + (wt-nl "ihs.lex_env=_ecl_debug_env->vector.self.t[0];") + (when close-block (wt-nl "}")))) + +;;; +;;; FUNCTION PROLOGUE AND EPILOGUE +;;; + +(defun c2emit-function-declaration (fun) + (let* ((cfun (fun-cfun fun)) + (comma "") + (narg-p (fun-narg-p fun))) + (cond ((fun-exported fun) + (wt-nl-h "ECL_DLLEXPORT cl_object " cfun "(") + (wt-nl1 "cl_object " cfun "(")) + (t + (wt-nl-h "static cl_object " cfun "(") + (wt-nl1 "static cl_object " cfun "("))) + (when narg-p + (wt-h *volatile* "cl_narg") + (wt *volatile* "cl_narg narg") + (setf comma ", ")) + (when (eq (fun-closure fun) 'LEXICAL) + (dotimes (n (fun-level fun)) + (wt-h comma *volatile* "cl_object *") + (wt comma *volatile* "cl_object *lex" n) + (setf comma ", "))) + (loop for lcl from 1 to (fun-minarg fun) + do (progn + (wt-h comma "cl_object " *volatile*) + (wt comma "cl_object " *volatile*) (wt-lcl lcl) + (setf comma ", "))) + (when narg-p + (wt-h ", ...") + (wt ", ...")) + (wt-h ");") + (wt ")"))) + +(defun c2emit-local-variables (fun) + ;; The following are macros containing the local variables that will + ;; be needed. They are defined at the end. + (let ((cname (fun-cfun fun))) + (wt-nl "XTR_" cname)) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") + (when (eq (fun-closure fun) 'CLOSURE) + (wt "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) + (wt-nl "cl_object " *volatile* "value0;") + (when (policy-check-stack-overflow) + (wt-nl "ecl_cs_check(cl_env_copy,value0);") + (wt-comment "C stack overflow?"))) + +(defun c2emit-closure-scan (fun) + (when (eq (fun-closure fun) 'CLOSURE) + (let ((clv-used (remove-if + #'(lambda (x) + (or + ;; non closure variable + (not (ref-ref-ccb x)) + ;; special variable + (eq (var-kind x) 'special) + ;; not actually referenced + (and (not (var-referenced-in-form x (fun-lambda fun))) + (not (var-changed-in-form x (fun-lambda fun)))) + ;; parameter of this closure + ;; (not yet bound, therefore var-loc is OBJECT) + (eq (var-loc x) 'OBJECT))) + (fun-referred-vars fun))) + l) + (when clv-used + (setf clv-used (sort clv-used #'> :key #'var-loc)) + l (var-loc (first clv-used))) + (wt-nl "/* Scanning closure data ... */") + (do ((n (1- (fun-env fun)) (1- n)) + (bs clv-used) + (first t)) + ((or (minusp n) (null bs))) + (wt-nl "cl_object CLV" n) + (if first + (progn (wt "=env0;") (setf first nil)) + (wt "=CDR(CLV" (1+ n) ");")) + (when (= n (var-loc (first bs))) + (wt-comment (var-name (first clv-used))) + (pop clv-used))) + (wt-nl "/* ... closure scanning finished */")))) + +(defun c2emit-last-arg-macro (fun) + (when (fun-narg-p fun) + (let ((nreq (fun-minarg fun))) + (wt-nl "#define __ecl_last_arg " + (cond ((plusp nreq) + (format nil "V~d" nreq)) + ((eq (fun-closure fun) 'LEXICAL) + (format nil "lex~D" (1- (fun-level fun)))) + (t "narg"))) + (wt-comment "Last argument before '...'")))) + +(defun c2entry-function-prologue (fun &key shared-data) + (wt-nl1 "#define flag V1") + (wt-nl "{cl_object *VVtemp;") + (wt-comment "Entry point of ECL module / FASL") + (when shared-data + (wt-nl "Cblock=flag;") + (wt-nl "VV = flag->cblock.data;")) + (unless shared-data + (wt-nl "if (!FIXNUMP(flag)){") + (wt-comment "Creation of lisp data") + (wt-nl "Cblock=flag;") + (wt-nl1 "#ifndef ECL_DYNAMIC_VV") + (wt-nl "flag->cblock.data = VV;") + (wt-nl1 "#endif") + (when *self-destructing-fasl* + (wt-nl "flag->cblock.self_destruct=1;")) + (wt-nl "flag->cblock.data_size = VM;") + (wt-nl "flag->cblock.temp_data_size = VMtemp;") + (wt-nl "flag->cblock.data_text = compiler_data_text;") + (wt-nl "flag->cblock.data_text_size = compiler_data_text_size;") + (wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;") + (wt-nl "flag->cblock.cfuns = compiler_cfuns;") + (when *compile-file-truename* + (wt-nl "flag->cblock.source = make_constant_base_string(\"" + (namestring *compile-file-truename*) "\");")) + (wt-nl "return;}") + (wt-nl "#ifdef ECL_DYNAMIC_VV") + (wt-nl "VV = Cblock->cblock.data;") + (wt-nl "#endif") + ;; With this we ensure creating a constant with the tag + ;; and the initialization file + (wt-nl "Cblock->cblock.data_text = \"" (init-name-tag (fun-cfun fun)) "\";") + ) + (when si::*compiler-constants* + (wt-nl "{cl_object data = ecl_symbol_value(" + (nth-value 1 (si::mangle-name '*compiler-constants* nil)) + ");") + (wt-nl "memcpy(VV, data->vector.self.t, VM*sizeof(cl_object));}")) + (wt-nl "VVtemp = Cblock->cblock.temp_data;") + (wt-comment "Here all lisp data has been created") + (wt-nl) + (wt-comment "It follows all toplevel forms")) + +(defun c2function-prologue (fun) + (wt-comment-nl (cond ((fun-global fun) "function definition for ~a") + ((eq (fun-closure fun) 'CLOSURE) "closure ~a") + (t "local function ~a")) + (or (fun-name fun) (fun-description fun) 'CLOSURE)) + (c2emit-function-declaration fun) + (wt-nl1 "{") + (c2emit-local-variables fun) + (c2emit-last-arg-macro fun) + (c2emit-closure-scan fun) + (when (eq (fun-name fun) +init-function-name+) + (c2entry-function-prologue fun))) + +(defun c2function-epilogue (fun) + (let* ((name (fun-cfun fun)) + (closure (fun-closure fun))) + ;; There should be no need to mark lex as volatile, since we + ;; are going to pass pointers of this array around and the compiler + ;; should definitely keep this in memory. + (wt-nl-h "#define XTR_" name) + (when (plusp *max-lex*) + (wt-h " \\") + (wt-nl-h " volatile cl_object lex" *level* "[" *max-lex* "];")) + (when (member :aux-closure (fun-code-gen-props fun)) + (wt-h " \\") + (wt-nl-h " struct ecl_cclosure aux_closure;")) + ;; Close C blocks + (when (eq (fun-name fun) +init-function-name+) + (wt-nl "}")) + (when (fun-narg-p fun) + (wt-nl "#undef __ecl_last_arg")) + (wt-nl1 "}"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; OUTPUT C1FORMS +;;; + +(defun pprint-c1form (f) + (cond ((c1form-p f) + (format t "~&~4T~16A~4T~{~A ~}" (c1form-name f) (c1form-args f))) + ((tag-p f) + (format t "~&~A / ~A:" (tag-name f) (tag-label f))) + (t + (format t "~&;;; Unknown form ~A" f)))) + +(defun pprint-c1forms (forms) + (mapc #'pprint-c1form forms)) diff --git a/src/new-cmp/cmpbind.lsp b/src/new-cmp/cmpbind.lsp new file mode 100644 index 000000000..a28a30c76 --- /dev/null +++ b/src/new-cmp/cmpbind.lsp @@ -0,0 +1,76 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPBIND Variable Binding. +;;;; +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This file is part of ECoLisp, herein referred to as ECL. +;;;; +;;;; ECL is free software; you can redistribute it and/or modify it under +;;;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;; bind must be called for each variable in a lambda or let, once the value +;;; to be bound has been placed in loc. +;;; bind takes care of setting var-loc. + +(defun bind (loc var) + ;; loc can be either (LCL n), 'VA-ARGS, (KEYVARS n), (CAR n), + ;; a constant, or (VAR var) from a let binding. ; ccb + (declare (type var var)) + (case (var-kind var) + (CLOSURE + (let ((var-loc (var-loc var))) + (unless (sys:fixnump var-loc) + ;; first binding: assign location + (setq var-loc (next-env)) + (setf (var-loc var) var-loc)) + (wt-nl "cl_object CLV" var-loc "=env" *env-lvl* "=CONS(") + (wt-coerce-loc :object loc) + (if (zerop var-loc) + (wt ",Cnil);") + (wt ",env" *env-lvl* ");")) + (wt-comment (var-name var)))) + (LEXICAL + (let ((var-loc (var-loc var))) + (unless (consp var-loc) + ;; first binding: assign location + (setq var-loc (next-lex)) + (setf (var-loc var) var-loc)) + (wt-nl) (wt-lex var-loc) (wt "= ") + (wt-coerce-loc :object loc) + (wt ";")) + (wt-comment (var-name var))) + ((SPECIAL GLOBAL) + (bds-bind loc var)) + (t + (cond ((not (eq (var-loc var) 'OBJECT)) + ;; already has location (e.g. optional in lambda list) + ;; check they are not the same + (unless (equal (var-loc var) loc) + (wt-nl var "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt ";"))) + ((and (consp loc) (eql (car loc) 'LCL)) + ;; set location for lambda list requireds + (setf (var-loc var) loc)) + (t + (baboon))) + ))) + +(defun bds-bind (loc var) + ;; Optimize the case (let ((*special-var* *special-var*)) ...) + (cond ((and (var-p loc) + (member (var-kind loc) '(global special)) + (eq (var-name loc) (var-name var))) + (wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");")) + (t + (wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",") + (wt-coerce-loc :object loc) + (wt ");"))) + (wt-comment (var-name var))) diff --git a/src/new-cmp/cmpblock.lsp b/src/new-cmp/cmpblock.lsp new file mode 100644 index 000000000..a913f6a62 --- /dev/null +++ b/src/new-cmp/cmpblock.lsp @@ -0,0 +1,105 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPBLOCK Block and Return-from. + +(in-package "COMPILER") + +;;; A dummy variable is created to hold the block identifier. When a +;;; reference to the block (via return-from) is found, the var-ref +;;; count for that variable is incremented only if the reference +;;; appears across a boundary (CB, LB or UNWIND-PROTECT), while the +;;; blk-ref is always incremented. Therefore blk-ref represents +;;; whether the block is used at all and var-ref for the dummy +;;; variable represents whether a block identifier must be created and +;;; stored in such variable. + +(defun c1block (destination args) + (check-args-number 'BLOCK args 1) + (let ((block-name (first args))) + (unless (symbolp block-name) + (cmperr "The block name ~s is not a symbol." block-name)) + (let* ((blk-var (make-var :name (gensym (symbol-name block-name)) :kind 'LEXICAL)) + (cleanup-form (c1frame-pop blk-var)) + (*cmp-env* (cmp-env-copy *cmp-env*)) + (exit (make-tag :name (gensym "BLOCK") :label (next-label))) + (blk (make-blk :var blk-var :name block-name :destination destination + :exit exit))) + (cmp-env-register-var blk-var *cmp-env*) + (cmp-env-register-block blk *cmp-env*) + (cmp-env-register-tag (tag-name exit) exit *cmp-env*) + (cmp-env-register-cleanup cleanup-form *cmp-env*) + (setf (blk-env blk) *cmp-env*) + (c1with-saved-output (prefix postfix new-destination destination) + (let ((body (c1translate new-destination `(progn ,@(rest args))))) + (setf (blk-destination blk) new-destination) + (if (plusp (var-ref blk-var)) + (progn + (nconc prefix + (c1bind (list blk-var)) + (c1frame-id blk-var) + (c1frame-set blk-var exit) + (c1set-from-values new-destination) + (c1jmp exit) + body + (list exit) + (c1set-loc destination new-destination) + (c1unbind (list blk-var)) + cleanup-form + postfix)) + (nconc prefix + body + (list exit) + (c1set-loc destination new-destination) + postfix))))))) + +(defun c1return-from (destination args) + (check-args-number 'RETURN-FROM args 1 2) + (let ((name (first args))) + (unless (symbolp name) + (cmperr "The block name ~s is not a symbol." name)) + (multiple-value-bind (blk ccb clb unw) + (cmp-env-search-block name) + (unless blk + (cmperr "The block ~s is undefined." name)) + (let* ((destination (blk-destination blk)) + (var (blk-var blk)) + (type T) + output) + (cond (ccb (setf (blk-ref-ccb blk) t + (var-kind var) 'CLOSURE + (var-ref-ccb var) T)) + (clb (setf (blk-ref-clb blk) t + (var-ref-clb var) t + (var-kind var) 'LEXICAL)) + (unw (setf type 'UNWIND-PROTECT) + (unless (var-kind var) + (setf (var-kind var) :OBJECT)))) + (if (or ccb clb unw) + (let* ((val (c1translate 'VALUES (second args))) + (return-stmt (c1return-from-op var (blk-name blk)))) + (setf type (translated-form-values-type 'VALUES val) + output (nconc val (c1cleanup-forms (blk-env blk)) return-stmt)) + (add-to-read-nodes var return-stmt)) + (c1with-saved-output (prefix postfix new-destination (blk-destination blk)) + (let* ((val (c1translate new-destination (second args))) + (cleanup (c1cleanup-forms (blk-env blk))) + (exit-tag (blk-exit blk))) + (setf type (translated-form-values-type new-destination val) + output (nconc prefix + val + cleanup + (c1jmp exit-tag) + postfix))))) + (setf (blk-type blk) (values-type-or (blk-type blk) type) + (blk-ref blk) (1+ (blk-ref blk))) + output)))) diff --git a/src/new-cmp/cmpcall.lsp b/src/new-cmp/cmpcall.lsp new file mode 100644 index 000000000..cc8c4288a --- /dev/null +++ b/src/new-cmp/cmpcall.lsp @@ -0,0 +1,83 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPCALL Function call. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + + +(in-package "COMPILER") + +;;; Like macro-function except it searches the lexical environment, +;;; to determine if the macro is shadowed by a function or a macro. +(defun cmp-macro-function (name) + (or (cmp-env-search-macro name) + (macro-function name))) + +(defun unoptimized-long-call (destination fun arguments) + (let ((frame (gensym))) + (c1translate destination + `(with-stack ,frame + ,@(loop for i in arguments collect `(stack-push ,frame ,i)) + (si::apply-from-stack-frame ,frame ,fun))))) + +(defun unoptimized-funcall (destination fun arguments) + (let ((l (length arguments))) + (if (<= l si::c-arguments-limit) + (c1with-saved-values (prefix postfix temps (list* fun arguments)) + (nconc prefix + (c1funcall-op destination temps) + postfix)) + (unoptimized-long-call destination fun arguments)))) + +(defun c1funcall (destination args) + (check-args-number 'FUNCALL args 1) + (let ((fun (first args)) + (arguments (rest args)) + fd) + (cond ;; (FUNCALL (LAMBDA ...) ...) + ((and (consp fun) + (eq (first fun) 'LAMBDA)) + (c1translate destination + (optimize-funcall/apply-lambda (cdr fun) arguments nil))) + ;; (FUNCALL (EXT::LAMBDA-BLOCK ...) ...) + ((and (consp fun) + (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1translate destination + (optimize-funcall/apply-lambda (cdr fun) arguments nil))) + ;; (FUNCALL atomic-expression ...) + ((atom fun) + (unoptimized-funcall destination fun arguments)) + ;; (FUNCALL macro-expression ...) + ((let ((name (first fun))) + (setq fd (and (symbolp name) + ;; We do not want to macroexpand 'THE + (not (eq name 'THE)) + (cmp-macro-function name)))) + (c1funcall destination (list* (cmp-expand-macro fd fun) arguments))) + ;; (FUNCALL lisp-expression ...) + ((not (eq (first fun) 'FUNCTION)) + (unoptimized-funcall destination fun arguments)) + ;; (FUNCALL #'GENERALIZED-FUNCTION-NAME ...) + ((si::valid-function-name-p (setq fun (second fun))) + (or (c1call-local destination fun arguments) + (c1call-global destination fun arguments))) + ;; (FUNCALL #'(LAMBDA ...) ...) + ((and (consp fun) (eq (first fun) 'LAMBDA)) + (c1translate destination + (optimize-funcall/apply-lambda (rest fun) arguments nil))) + ;; (FUNCALL #'(EXT::LAMBDA-BLOCK ...) ...) + ((and (consp fun) (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1translate destination + (optimize-funcall/apply-lambda (rest fun) arguments nil))) + (t + (cmperr "Malformed function name: ~A" fun))))) diff --git a/src/new-cmp/cmpcatch.lsp b/src/new-cmp/cmpcatch.lsp new file mode 100644 index 000000000..338aaef37 --- /dev/null +++ b/src/new-cmp/cmpcatch.lsp @@ -0,0 +1,92 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPCATCH Catch, Unwind-protect, and Throw. + +(in-package "COMPILER") + +(defun c1catch (destination args) + (check-args-number 'CATCH args 1) + ;; First we decide where to store the output + (c1with-saved-output (values-prefix values-postfix new-destination destination) + (let* ((cleanup-form (c1frame-pop)) + (old-env *cmp-env*) + (*cmp-env* (cmp-env-register-cleanup cleanup-form (cmp-env-copy old-env))) + (normal (make-tag :name (gensym "CATCH-NORMAL") :label (next-label))) + (exit (make-tag :name (gensym "CATCH-EXIT") :label (next-label)))) + (nconc values-prefix + (c1with-saved-one-value (prefix postfix location (pop args)) + (nconc prefix + (c1frame-set location normal) + postfix)) + (c1set-loc new-destination 'VALUES) + (c1jmp exit) + (list normal) + (c1translate new-destination `(progn ,@args)) + (list exit) + cleanup-form + (c1set-loc destination new-destination) + values-postfix)))) + +(defun c1unwind-protect (destination args) + (check-args-number 'UNWIND-PROTECT args 1) + (unless (rest args) + (return-from c1unwind-protect (c1translate destination (first args)))) + (let* ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT (cmp-env-copy))) + (exit (make-tag :name (gensym "UWP-EXIT") :label (next-label))) + (main-form (make-tag :name (gensym "UWP-MAIN") :label (next-label))) + (protect-form (make-tag :name (gensym "UWP-PROTECT") :label (next-label)))) + (c1with-temps (prefix postfix unwound frame) + (cmp-env-register-cleanup (nconc (c1stack-frame-close frame) + (c1frame-pop))) + (nconc prefix + ;; Create a point to stop when unwinding. + (c1stack-frame-open frame) + (c1set-loc unwound `(VV "OBJNULL")) + (c1frame-set 'unwind-protect main-form) + + ;; We reach here when we intercepted a nonlocal control transfer. + ;; UNWOUND is set to the original destination. + (c1frame-save-next unwound) + (c1jmp protect-form) + + ;; This is the form that is protected by UNWIND-PROTECT. We + ;; store the output in the VALUES array. + (list main-form) + (c1translate 'VALUES (pop args)) + + ;; These are the forms that have to be executed always. Note + ;; that we save the values in the above created stack frame. + (list protect-form) + (c1stack-frame-push-values frame) + (c1translate 'TRASH `(progn ,@args)) + (c1stack-frame-pop-values frame 'VALUES+VALUE0) + (c1stack-frame-close frame) + + ;; After those forms, we decide whether we have to transfer control + ;; elsewhere + (c1jmp-false exit unwound) + (c1frame-jmp-next unwound) + + ;; Otherwise we just send the values where they should. + (list exit) + (c1set-loc destination 'VALUES+VALUE0) + postfix)))) + +(defun c1throw (destination args) + (check-args-number 'THROW args 2 2) + (c1with-temps (prefix postfix tag) + (nconc prefix + (c1translate tag (first args)) + (c1translate 'VALUES (second args)) + (c1throw-op tag) + postfix))) diff --git a/src/new-cmp/cmpcbk.lsp b/src/new-cmp/cmpcbk.lsp new file mode 100644 index 000000000..821970051 --- /dev/null +++ b/src/new-cmp/cmpcbk.lsp @@ -0,0 +1,120 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPCBK -- Callbacks: lisp functions that can be called from the C world + +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defun c1-defcallback (destination args) + (destructuring-bind (name return-type arg-list &rest body) + args + (let ((arg-types '()) + (arg-type-constants '()) + (arg-variables '()) + (c-name (format nil "ecl_callback_~d" (length *callbacks*))) + (name (if (consp name) (first name) name)) + (call-type (if (consp name) (second name) :cdecl))) + (dolist (i arg-list) + (unless (consp i) + (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 (list name c-name (add-object name) + return-type (reverse arg-types) (reverse arg-type-constants) call-type) + *callbacks*) + (c1translate destination + `(progn + (defun ,name ,(reverse arg-variables) ,@body) + (si::put-sysprop ',name :callback + (list + (ffi:c-inline () () :object + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~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") + (:pointer-void . "ECL_FFI_POINTER_VOID") + (:cstring . "ECL_FFI_CSTRING") + (:object . "ECL_FFI_OBJECT") + (:float . "ECL_FFI_FLOAT") + (:double . "ECL_FFI_DOUBLE") + (: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" x)) + (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)) + (cond ((ffi::foreign-elt-type-p return-type)) + ((member return-type '(nil :void)) + (setf return-p nil)) + ((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))) + (let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type))) + (fmod (case call-type + (:cdecl "") + (:stdcall "__stdcall ") + (t (cmperr "DEFCALLBACK does not support ~A as calling convention" + call-type))))) + (wt-nl1 "static " return-type-name " " fmod c-name "(") + (loop for n from 0 + and type in arg-types + with comma = "" + do + (progn + (wt comma (rep-type-name (ffi::%convert-to-arg-type type)) " var" n) + (setf comma ","))) + (wt ")") + (wt-nl1 "{") + (when return-p + (wt-nl return-type-name " output;")) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") + (wt-nl "cl_object aux;") + (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)") + (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 "," (ffi:size-of-foreign-type type) "));"))) + (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 "return output;")) + (wt-nl1 "}"))) diff --git a/src/new-cmp/cmpclos.lsp b/src/new-cmp/cmpclos.lsp new file mode 100644 index 000000000..5890bec54 --- /dev/null +++ b/src/new-cmp/cmpclos.lsp @@ -0,0 +1,118 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPCLOS. CLOS related optimizations. + +;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;; +;;; GENERIC OPTIMIZATION +;;; + +(defun maybe-optimize-generic-function (destination fname args) + (when (fboundp fname) + (let ((gf (fdefinition fname))) + (when (typep gf 'standard-generic-function) + ;;(check-generic-function-args gf args) + (when (policy-inline-slot-access-p) + (maybe-optimize-slot-accessor destination fname gf args)))))) + +;;; +;;; PRECOMPUTE APPLICABLE METHODS +;;; +;;; Computes a list of methods that would apply given what we know +;;; about their arguments. Since the types are not exact, we have to +;;; use subtypep. We could speed this up if we could precompute the +;;; classes for the c-args. +;;; + +(defun precompute-applicable-methods (methods c-args) + (flet ((applicable-method-p (m) + (loop for specializer in (clos:method-specializers m) + for arg in c-args + always (let ((arg-type (c1form-primary-type arg))) + (subtypep arg-type (if (consp specializer) + `(member ,(second specializer)) + specializer)))))) + (delete-if-not #'applicable-method-p methods))) + +;;; +;;; SLOT ACCESSORS +;;; +;;; The following functions deal with an ECL extension, which are +;;; sealed slots. These slots have a fixed location which is +;;; inherited by subclasses. They normally appear when you add the +;;; option (:sealedp t) to a class definition. +;;; +;;; When ECL detects that you call an accessor to such a slot, it can +;;; optimize the operation, using a direct access based on the +;;; position of the slot. This optimization is only active when the +;;; safety levels are low, because it prevents you from changing the +;;; class hierarchy. +;;; + +(defun find-slot-accessors (gf) + (loop for method in (clos:generic-function-methods gf) + with readers = '() + with writers = '() + with reader-class = (find-class 'clos:standard-reader-method) + with writer-class = (find-class 'clos:standard-writer-method) + do (let ((method-class (class-of method))) + (cond ((si::subclassp method-class reader-class) + (push method readers)) + ((si::subclassp method-class writer-class) + (push method writers)))) + finally (return (values readers writers)))) + +(defun maybe-optimize-slot-accessor (destination fname gf args) + (multiple-value-bind (readers writers) + (find-slot-accessors gf) + ;(format t "~%;;; Found ~D readers and ~D writers for ~A" (length readers) (length writers) fname) + (cond ((and readers writers) + (cmpwarn "When analyzing generic function ~A found both slot reader and writer methods" + fname)) + ((or (not gf) (not (or readers writers))) + nil) + ((/= (length args) (length (clos::generic-function-spec-list gf))) + (cmpwarn "Too many arguments for generic function ~A" fname) + nil) + (readers + (try-optimize-slot-reader destination readers args)) + (writers + (try-optimize-slot-writer destination writers args))))) + +(defun try-optimize-slot-reader (destination readers args) + (let* ((object (first args)) + (c-object (c1expr 'SHOULD-BE-TEMP object)) + (readers (precompute-applicable-methods readers (list c-object)))) + ;(format t "~%;;; Found ~D really applicable reader" (length readers)) + (when (= (length readers) 1) + (let ((reader (first readers))) + (when (typep reader 'clos:standard-reader-method) + (let* ((slotd (clos:accessor-method-slot-definition reader)) + (index (clos::safe-slot-definition-location slotd))) + (when (si::fixnump index) + (c1expr destination `(clos::safe-instance-ref ,object ,index))))))))) + +(defun try-optimize-slot-writer (destination orig-writers args) + (let* ((c-args (loop for f in args + collect (c1expr 'SHOULD-BE-TEMPS args))) + (writers (precompute-applicable-methods orig-writers c-args))) + ;(format t "~%;;; Found ~D really applicable writer" (length writers)) + (when (= (length writers) 1) + (let ((writer (first writers))) + (when (typep writer 'clos:standard-writer-method) + (let* ((slotd (clos:accessor-method-slot-definition writer)) + (index (clos::safe-slot-definition-location slotd))) + (when (si::fixnump index) + (c1expr destination `(si::instance-set ,(second args) + ,index ,(first args)))))))))) + diff --git a/src/new-cmp/cmpct.lsp b/src/new-cmp/cmpct.lsp new file mode 100644 index 000000000..0ae78b36b --- /dev/null +++ b/src/new-cmp/cmpct.lsp @@ -0,0 +1,123 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPCT -- Optimizer for several constant values + +;;;; Copyright (c) 2003, Juan Jose Garcia Ripoll. +;;;; +;;;; ECoLisp is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defparameter +optimizable-constants+ '()) + +(defun build-constant-value-loc (val &key always only-small-values) + (cond + ((let ((x (assoc val +optimizable-constants+))) + (when x + (pushnew "#include " *clines-string-list*) + (values (cdr x) t)))) + ((eq val nil) (values nil t)) + ((eq val t) (values t t)) + ((sys::fixnump val) (values (list 'FIXNUM-VALUE val) t)) + ((characterp val) (values (list 'CHARACTER-VALUE (char-code val)) t)) + ((typep val 'DOUBLE-FLOAT) + (values (list 'DOUBLE-FLOAT-VALUE val (add-object val)) t)) + ((typep val 'SINGLE-FLOAT) + (values (list 'SINGLE-FLOAT-VALUE val (add-object val)) t)) + ((typep val 'LONG-FLOAT) + (values (list 'LONG-FLOAT-VALUE val (add-object val)) t)) + (always + (values (list 'VV (add-object val) val) t)) + (t (values nil nil)))) + +(defun c1constant-value (destination val &key always only-small-values) + (when (eq destination 'TRASH) + (return-from c1constant-value (c1nil destination))) + (multiple-value-bind (loc found-p) + (build-constant-value-loc val :always always :only-small-values only-small-values) + (when found-p + (c1set-loc destination loc)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; KNOWN OPTIMIZABLE CONSTANTS +;;; + +(mapc + #'(lambda (record) + (let* ((name (first record)) + (c-value (second record))) + (push + (cond ((symbolp name) + (let* ((value (symbol-value name)) + (type (lisp-type->rep-type (type-of value)))) + (cons value `(VV ,c-value value)))) + ((floatp name) + (let* ((value name) + (type (type-of value)) + (loc-type (case type + (single-float 'single-float-value) + (double-float 'double-float-value) + (long-float 'long-float-value))) + (location `(VV ,c-value))) + (cons value (list loc-type value location)))) + (t + (cons name`(VV ,c-value)))) + +optimizable-constants+))) + (reverse + `((MOST-POSITIVE-SHORT-FLOAT "FLT_MAX") + (MOST-POSITIVE-SINGLE-FLOAT "FLT_MAX") + + (MOST-NEGATIVE-SHORT-FLOAT "-FLT_MAX") + (MOST-NEGATIVE-SINGLE-FLOAT "-FLT_MAX") + + (LEAST-POSITIVE-SHORT-FLOAT "FLT_MIN") + (LEAST-POSITIVE-SINGLE-FLOAT "FLT_MIN") + (LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT "FLT_MIN") + (LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" FLT_MIN") + + (LEAST-NEGATIVE-SHORT-FLOAT "-FLT_MIN") + (LEAST-NEGATIVE-SINGLE-FLOAT "-FLT_MIN") + (LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT "-FLT_MIN") + (LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT "-FLT_MIN") + + (MOST-POSITIVE-DOUBLE-FLOAT "DBL_MAX") + (MOST-NEGATIVE-DOUBLE-FLOAT "-DBL_MAX") + (LEAST-POSITIVE-DOUBLE-FLOAT "DBL_MIN") + (LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT "DBL_MIN") + (LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_MIN") + (LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN") + + ;; Order is important: on platforms where 0.0 and -0.0 are the same + ;; the last one is prioritized. + (#.(coerce 0 'single-float) "cl_core.singlefloat_zero") + (#.(coerce 0 'double-float) "cl_core.doublefloat_zero") + (#.(coerce -0.0 'single-float) "cl_core.singlefloat_minus_zero") + (#.(coerce -0.0 'double-float) "cl_core.doublefloat_minus_zero") + + (#.(si::standard-readtable) "cl_core.standard_readtable") + + (#.(find-package :cl) "cl_core.lisp_package") + (#.(find-package :cl-user) "cl_core.user_package") + (#.(find-package :keyword) "cl_core.keyword_package") + (#.(find-package :clos) "cl_core.clos_package") + #+threads + (#.(find-package :mp) "cl_core.mp_package") + + #+long-float + ,@'( + (MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") + (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX") + (LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN") + (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN") + (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN") + (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN") + (#.(coerce -0.0 'long-float) "cl_core.longfloat_minus_zero") + (#.(coerce 0 'long-float) "cl_core.longfloat_zero") + ) + ))) diff --git a/src/new-cmp/cmpdefs.lsp b/src/new-cmp/cmpdefs.lsp new file mode 100644 index 000000000..d4ecaaa55 --- /dev/null +++ b/src/new-cmp/cmpdefs.lsp @@ -0,0 +1,548 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPDEF Definitions + +(si::package-lock "CL" nil) + +(defpackage "C" + (:nicknames "COMPILER") + (:use "FFI" "CL" #+threads "MP") + (:export "*COMPILER-BREAK-ENABLE*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*CC*" + "*CC-OPTIMIZE*" + "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-WARNINGS*" + "*SUPPRESS-COMPILER-NOTES*" + "*SUPPRESS-COMPILER-MESSAGES*") + (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" + "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" + "COMPILER-LET")) + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; COMPILER STRUCTURES +;;; + +;;; +;;; REF OBJECT +;;; +;;; Base object for functions, variables and statements. We use it to +;;; keep track of references to objects, how many times the object is +;;; referenced, by whom, and whether the references cross some closure +;;; boundaries. +;;; + +(defstruct (ref (:print-object print-ref)) + name ;;; Identifier of reference. + (ref 0 :type fixnum) ;;; Number of references. + ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the index into the closure env + ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the lex-address for the + ;;; block id, or NIL. + read-nodes ;;; Nodes (c1forms) in which the reference occurs +) + +(deftype OBJECT () `(not (or fixnum character float))) + +(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var)) +; name ;;; Variable name. +; (ref 0 :type fixnum) + ;;; Number of references to the variable (-1 means IGNORE). +; ref-ccb ;;; Cross closure reference: T or NIL. +; ref-clb ;;; Cross local function reference: T or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + set-nodes ;;; Nodes in which the variable is modified + kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, + ;;; :CHAR, :DOUBLE, :FLOAT, REPLACED or DISCARDED + (function *current-function*) + ;;; For local variables, in which function it was created. + ;;; For global variables, it doesn't have a meaning. + (functions-setting nil) + (functions-reading nil) + ;;; Functions in which the variable has been modified or read. + (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can + ;;; be allocated on the c-stack: OBJECT means + ;;; the variable is declared as OBJECT, and CLB means + ;;; the variable is referenced across Level Boundary and thus + ;;; cannot be allocated on the C stack. Note that OBJECT is + ;;; set during variable binding and CLB is set when the + ;;; variable is used later, and therefore CLB may supersede + ;;; OBJECT. + ;;; During Pass 2: + ;;; For REPLACED: the actual location of the variable. + ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: + ;;; the cvar for the C variable that holds the value. + ;;; For LEXICAL or CLOSURE: the frame-relative address for + ;;; the variable in the form of a cons '(lex-levl . lex-ndx) + ;;; lex-levl is the level of lexical environment + ;;; lex-ndx is the index within the array for this env. + ;;; For SPECIAL and GLOBAL: the vv-index for variable name. + (type t) ;;; Type of the variable. + read-only-p ;;; T for variables that are assigned only once. + ) + +;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE +;;; Here are examples of function FOO for the 3 cases: +;;; 1. (flet ((foo () (bar))) (foo)) CFUN +;;; 2. (flet ((foo () (bar))) #'foo) CFUN+LISP_CFUN +;;; 3. (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE +;;; 4. (flet ((foo () x)) #'foo) CCLOSURE+LISP_CLOSURE + +;;; A function can be referred across a ccb without being a closure, e.g: +;;; (flet ((foo () (bar))) #'(lambda () (foo))) +;;; [the lambda also need not be a closure] +;;; and it can be a closure without being referred across ccb, e.g.: +;;; (flet ((foo () x)) #'foo) [ is this a mistake in local-function-ref?] +;;; Here instead the lambda must be a closure, but no closure is needed for foo +;;; (flet ((foo () x)) #'(lambda () (foo))) +;;; So we use two separate fields: ref-ccb and closure. +;;; A CCLOSURE must be created for a function when: +;;; 1. it appears within a FUNCTION construct and +;;; 2. it uses some ccb references (directly or indirectly). +;;; ref-ccb corresponds to the first condition, i.e. function is referred +;;; across CCB. It is computed during Pass 1. A value of 'RETURNED means +;;; that it is immediately within FUNCTION. +;;; closure corresponds to second condition and is computed in Pass 2 by +;;; looking at the info-referred-vars and info-local-referred of its body. + +;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned. +;;; The LISP funob may then be referred locally or across LB or CB: +;;; (flet ((foo (z) (bar z))) (list #'foo))) +;;; (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar))) +;;; (flet ((foo (z) (bar z))) #'(lambda () #'foo))) +;;; therefore we need field funob. + +(defstruct (fun (:include ref)) +; name ;;; Function name. +; (ref 0 :type fixnum) ;;; Number of references. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; function closure, or NIL. +; ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL, depending on whether a + ;;; function object will be built. + ;;; During Pass2, the vs-address for the function + ;;; closure, or NIL. +; ref-clb ;;; Unused. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + cfun ;;; The cfun for the function. + (last-lcl 0) ;;; Number of local variables (just to bookkeep names) + (last-label 0) ;;; Number of generated labels (same as last-lcl) + (level 0) ;;; Level of lexical nesting for a function. + (env 0) ;;; Size of env of closure. + (global nil) ;;; Global lisp function. + (exported nil) ;;; Its C name can be seen outside the module. + (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no + ;;; function object and the C function is called + ;;; directly + (shares-with nil) ;;; T if this function shares the C code with another one. + ;;; In that case we need not emit this one. + closure ;;; During Pass2, T if env is used inside the function + var ;;; the variable holding the funob + description ;;; Text for the object, in case NAME == NIL. + lambda-list ;;; List of (requireds optionals rest-var keywords-p + ;;; keywords allow-other-keys-p) + (minarg 0) ;;; Min. number arguments that the function receives. + (maxarg call-arguments-limit) + ;;; Max. number arguments that the function receives. + lambda ;;; Lambda c1-form for this function. + doc ;;; Documentation + (parent *current-function*) + ;;; Parent function, NIL if global. + (local-vars nil) ;;; List of local variables created here. + (referred-vars nil) ;;; List of external variables referenced here. + (referred-funs nil) ;;; List of external functions called in this one. + ;;; We only register direct calls, not calls via object. + (child-funs nil) ;;; List of local functions defined here. + (debug 0) ;;; Debug quality + (file *compile-file-truename*) + ;;; Source file or NIL + (file-position *compile-file-position*) + ;;; Top-level form number in source file + code-gen-props ;;; Extra properties for code generation + ) + +(defstruct (blk (:include ref)) +; name ;;; Block name. +; (ref 0 :type fixnum) ;;; Number of references. +; ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the ccb-lex for the + ;;; block id, or NIL. +; ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the lex-address for the + ;;; block id, or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + exit ;;; Where to return. A label. + destination ;;; Where the value of the block to go. + var ;;; Variable containing the block ID. + (type 'NIL) ;;; Estimated type. + env ;;; Block environment + ) + +(defstruct (tag (:include ref)) +; name ;;; Tag name. +; (ref 0 :type fixnum) ;;; Number of references. +; ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. +; ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + label ;;; Where to jump: a label. + unwind-exit ;;; Where to unwind-no-exit. + var ;;; Variable containing frame ID. + index ;;; An integer denoting the label. + env ;;; Tag environment + ) + +(defstruct (info) + (local-vars nil) ;;; List of var-objects created directly in the form. + (type t) ;;; Type of the form. + (sp-change nil) ;;; Whether execution of the form may change + ;;; the value of a special variable. + (volatile nil) ;;; whether there is a possible setjmp. Beppe + ) + +(defstruct (inline-info) + name ;;; Function name + arg-rep-types ;;; List of representation types for the arguments + return-rep-type ;;; Representation type for the output + arg-types ;;; List of lisp types for the arguments + return-type ;;; Lisp type for the output + exact-return-type ;;; Only use this expansion when the output is + ;;; declared to have a subtype of RETURN-TYPE + expansion ;;; C template containing the expansion + one-liner ;;; Whether the expansion spans more than one line +) + +;;; +;;; VARIABLES +;;; + +;;; --cmpinline.lsp-- +;;; +;;; Empty info struct +;;; +(defvar *info* (make-info)) + +(defvar *inline-functions* nil) +(defvar *inline-blocks* 0) +;;; *inline-functions* holds: +;;; (...( function-name . inline-info )...) +;;; +;;; *inline-blocks* holds the number of C blocks opened for declaring +;;; temporaries for intermediate results of the evaluation of inlined +;;; function calls. + +;;; --cmputil.lsp-- +;;; +;;; Variables and constants for error handling +;;; +(defvar *current-toplevel-form* '|compiler preprocess|) +(defvar *current-form* '|compiler preprocess|) +(defvar *current-c2form* nil) +(defvar *compile-file-position* -1) +(defvar *first-error* t) +(defconstant *cmperr-tag* (cons nil nil)) + +(defvar *active-handlers* nil) +(defvar *active-protection* nil) +(defvar *pending-actions* nil) + +(defvar *compiler-conditions* '() + "This variable determines whether conditions are printed or just accumulated.") + +(defvar *compile-print* nil + "This variable controls whether the compiler displays messages about +each form it processes. The default value is NIL.") + +(defvar *compile-verbose* nil + "This variable controls whether the compiler should display messages about its +progress. The default value is T.") + +(defvar *suppress-compiler-messages* nil + "A type denoting which compiler messages and conditions are _not_ displayed.") + +(defvar *suppress-compiler-notes* nil) ; Deprecated +(defvar *suppress-compiler-warnings* nil) ; Deprecated + +(defvar *compiler-break-enable* nil) + +(defvar *compiler-in-use* nil) +(defvar *compiler-input*) +(defvar *compiler-output1*) +(defvar *compiler-output2*) + +;;; --cmpcbk.lsp-- +;;; +;;; List of callbacks to be generated +;;; +(defvar *callbacks* nil) + +;;; --cmpcall.lsp-- +;;; +;;; Whether to use linking calls. +;;; +(defvar *compile-to-linking-call* t) +(defvar *compiler-declared-globals*) + +;;; --cmpenv.lsp-- +;;; +;;; These default settings are equivalent to (optimize (speed 3) (space 0) (safety 2)) +;;; +(defvar *safety* 2) +(defvar *speed* 3) +(defvar *space* 0) +(defvar *debug* 0) + +;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms. +(defvar *automatic-check-type-in-lambda* t) + +;;; +;;; Compiled code uses the following kinds of variables: +;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) +;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp) +;;; 4. lexi[j], for lexical variables in local functions +;;; 5. CLVi, for lexical variables in closures + +(defvar *lcl* 0) ; number of local variables + +(defvar *level* 0) ; nesting level for local functions + +(defvar *lex* 0) ; number of lexical variables in local functions +(defvar *max-lex* 0) ; maximum *lex* reached + +(defvar *env* 0) ; number of variables in current form +(defvar *max-env* 0) ; maximum *env* in whole function +(defvar *env-lvl* 0) ; number of levels of environments + +(defvar *next-cfun* 0) ; holds the last cfun used. + +;;; +;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. +;;; If possible, *tail-recursion-info* holds +;; ( c1-lambda-form required-arg .... required-arg ), +;;; where each required-arg is a var-object. +;;; +(defvar *tail-recursion-info* nil) + +(defvar *allow-c-local-declaration* t) +(defvar *notinline* nil) + +;;; --cmpexit.lsp-- +;;; +;;; *last-label* holds the label# of the last used label. +;;; *exit* holds an 'exit', which is +;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, +;; RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or +;; RETURN-OBJECT). +;;; *unwind-exit* holds a list consisting of: +;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, +;; JUMP, BDS-BIND (each pushed for a single special binding), or a +;; LCL (which holds the bind stack pointer used to unbind). +;;; +(defvar *last-label* 0) +(defvar *exit*) +(defvar *unwind-exit*) + +(defvar *current-function* nil) + +(defvar *cmp-env* (cons nil nil) +"The compiler environment consists of a pair or cons of two +lists, one containing variable records, the other one macro and +function recors: + +variable-record = (:block block-name) | + (:tag ({tag-name}*)) | + (:function function-name) | + (var-name {:special | nil} bound-p) | + (symbol si::symbol-macro macro-function) | + CB | LB | UNWIND-PROTECT +macro-record = (function-name function) | + (macro-name si::macro macro-function) + CB | LB | UNWIND-PROTECT + +A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A +MACRO-FUNCTION is a function that provides us with the expansion +for that local macro or symbol macro. BOUND-P is true when the +variable has been bound by an enclosing form, while it is NIL if +the variable-record corresponds just to a special declaration. +CB, LB and UNWIND-PROTECT are only used by the C compiler and +they denote closure, lexical environment and unwind-protect +boundaries. Note that compared with the bytecodes compiler, these +records contain an additional variable, block, tag or function +object at the end.") + +;;; --cmplog.lsp-- +;;; +;;; Destination of output of different forms. See cmploc.lsp for types +;;; of destinations. +;;; +(defvar *destination*) + +;;; --cmpmain.lsp-- +;;; +;;; Do we debug the compiler? Then we need files not to be deleted. + +(defvar *debug-compiler* nil) +(defvar *delete-files* t) +(defvar *files-to-be-deleted* '()) + +;;; This is copied into each .h file generated, EXCEPT for system-p calls. +;;; The constant string *include-string* is the content of file "ecl.h". +;;; Here we use just a placeholder: it will be replaced with sed. +(defvar *cmpinclude* "") + +(defvar *cc* "@ECL_CC@" +"This variable controls how the C compiler is invoked by ECL. +The default value is \"cc -I. -I/usr/local/include/\". +The second -I option names the directory where the file ECL.h has been installed. +One can set the variable appropriately adding for instance flags which the +C compiler may need to exploit special hardware features (e.g. a floating point +coprocessor).") + +(defvar *ld* "@ECL_CC@" +"This variable controls the linker which is used by ECL.") + +(defvar *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@") + +(defvar *cc-optimize* #-msvc "-O" + #+msvc "@CFLAGS_OPTIMIZE@") + +(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@?" + #+msvc "~A -Fe~S~* ~{~S ~} ~@?") + +(defvar *cc-format* #-msvc "~A ~A ~:[~*~;~A~] \"-I~A\" -w -c \"~A\" -o \"~A\"" + #+msvc "~A ~A ~:[~*~;~A~] -I\"~A\" -w -c \"~A\" -Fo\"~A\"") + +#-dlopen +(defvar *ld-flags* "@LDFLAGS@ -lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@") +#+dlopen +(defvar *ld-flags* #-msvc "@LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" + #+msvc "@LDFLAGS@ ecl.lib @CLIBS@") +#+dlopen +(defvar *ld-shared-flags* #-msvc "@SHARED_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" + #+msvc "@SHARED_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@") +#+dlopen +(defvar *ld-bundle-flags* #-msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" + #+msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@") + +(defvar +shared-library-prefix+ "@SHAREDPREFIX@") +(defvar +shared-library-extension+ "@SHAREDEXT@") +(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@") +(defvar +static-library-prefix+ "@LIBPREFIX@") +(defvar +static-library-extension+ "@LIBEXT@") +(defvar +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@") +(defvar +object-file-extension+ "@OBJEXT@") +(defvar +executable-file-format+ "~a@EXEEXT@") + +(defvar *ecl-include-directory* @includedir\@) +(defvar *ecl-library-directory* @libdir\@) + +;;; +;;; Compiler program and flags. +;;; + +;;; --cmptop.lsp-- +;;; +(defvar *do-type-propagation* nil + "Flag for switching on the type propagation phase. Use with care, experimental.") + +(defvar *compiler-phase* nil) + +(defvar *volatile*) + +(defvar *compile-toplevel* T + "Holds NIL or T depending on whether we are compiling a toplevel form.") +(defvar *compile-time-too* nil) + +(defvar *clines-string-list* '() + "List of strings containing C/C++ statements which are directly inserted +in the translated C/C++ file. Notice that it is unspecified where these +lines are inserted, but the order is preserved") + +(defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* + ; or *temporary-objects* +(defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* +(defvar *temporary-objects* nil) ; holds { ( object (VV vv-index) ) }* +(defvar *load-objects* nil) ; hash with association object -> vv-location +(defvar *load-time-values* nil) ; holds { ( vv-index form ) }*, +;;; where each vv-index should be given an object before +;;; defining the current function during loading process. + +(defvar *use-static-constants-p* nil) ; T/NIL flag to determine whether one may + ; generate lisp constant values as C structs +(defvar *static-constants* nil) ; constants that can be built as C values + ; holds { ( object c-variable constant ) }* + +(defvar *compiler-constants* nil) ; a vector with all constants + ; only used in COMPILE + +(defvar *proclaim-fixed-args* nil) ; proclaim automatically functions + ; with fixed number of arguments. + ; watch out for multiple values. + +(defvar *global-var-objects* nil) ; var objects for global/special vars +(defvar *global-vars* nil) ; variables declared special +(defvar *global-funs* nil) ; holds { fun }* +(defvar *global-cfuns-array* nil) ; holds { fun }* +(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }* +(defvar *local-funs* nil) ; holds { fun }* +(defvar *top-level-forms* nil) ; holds { top-level-form }* +(defvar *make-forms* nil) ; holds { top-level-form }* + +;;; +;;; top-level-form: +;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp ) +;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp ) +;;; | ( 'ORDINARY' expr ) +;;; | ( 'DECLARE' var-name-vv ) +;;; | ( 'DEFVAR' var-name-vv expr doc-vv ) +;;; | ( 'CLINES' string* ) +;;; | ( 'LOAD-TIME-VALUE' vv ) + +(defvar *reservation-cmacro* nil) + +;;; *reservations* holds (... ( cmacro . value ) ...). +;;; *reservation-cmacro* holds the cmacro current used as vs reservation. + +(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 +deleted. We need this for #'COMPILE because windows DLLs cannot +be deleted if they have been opened with LoadLibrary.") + +(defvar *undefined-vars* nil) diff --git a/src/new-cmp/cmpenv.lsp b/src/new-cmp/cmpenv.lsp new file mode 100644 index 000000000..c4d86346e --- /dev/null +++ b/src/new-cmp/cmpenv.lsp @@ -0,0 +1,726 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPENV Environments of the Compiler. + +(in-package "COMPILER") + +;;; Only these flags are set by the user. +;;; If (safe-compile) is ON, some kind of run-time checks are not +;;; included in the compiled code. The default value is OFF. + +(defconstant +init-env-form+ + '((*gensym-counter* 0) + (*compiler-in-use* t) + (*compiler-phase* 't1) + (*callbacks* nil) + (*next-cfun* 0) + (*lcl* 0) + (*last-label* 0) + (*load-objects* (make-hash-table :size 128 :test #'equal)) + (*make-forms* nil) + (*static-constants* nil) + (*permanent-objects* nil) + (*temporary-objects* nil) + (*local-funs* nil) + (*global-var-objects* nil) + (*global-vars* nil) + (*global-funs* nil) + (*global-cfuns-array* nil) + (*linking-calls* nil) + (*global-entries* nil) + (*undefined-vars* nil) + (*top-level-forms* nil) + (*clines-string-list* '()) + (*inline-functions* nil) + (*inline-blocks* 0) + (*debugger-hook* 'compiler-debugger) + (*type-and-cache* (type-and-empty-cache)) + (*type-or-cache* (type-or-empty-cache)) + (*values-type-or-cache* (values-type-or-empty-cache)) + (*values-type-and-cache* (values-type-and-empty-cache)) + (*values-type-primary-type-cache* (values-type-primary-type-empty-cache)) + (*values-type-to-n-types-cache* (values-type-to-n-types-empty-cache)) + )) + +(defun next-lcl () (list 'LCL (incf *lcl*))) + +(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) + (let ((code (incf *next-cfun*))) + (format nil prefix code (lisp-to-c-name lisp-name)))) + +(defun next-lex () + (prog1 (cons *level* *lex*) + (incf *lex*) + (setq *max-lex* (max *lex* *max-lex*)))) + +(defun next-env () (prog1 *env* + (incf *env*) + (setq *max-env* (max *env* *max-env*)))) + +(defun function-arg-types (arg-types &aux (types nil)) + (do ((al arg-types (cdr al))) + ((or (endp al) + (member (car al) '(&optional &rest &key))) + (nreverse types)) + (declare (object al)) + (push (type-filter (car al)) types))) + +;;; The valid return type declaration is: +;;; (( VALUES {type}* )) or ( {type}* ). + +(defun function-return-type (return-types) + (cond ((endp return-types) t) + ((and (consp (car return-types)) + (eq (caar return-types) 'VALUES)) + (cond ((not (endp (cdr return-types))) + (warn "The function return types ~s is illegal." return-types) + t) + ((or (endp (cdar return-types)) + (member (cadar return-types) '(&optional &rest &key))) + t) + (t (type-filter (cadar return-types))))) + (t (type-filter (car return-types))))) + +(defun add-function-proclamation (fname decl) + (if (symbolp fname) + (let* ((arg-types '*) + (return-types '*) + (l decl)) + (cond ((null l)) + ((consp l) + (setf arg-types (pop l))) + (t (warn "The function proclamation ~s ~s is not valid." + fname decl))) + (cond ((null l)) + ((and (consp l) (null (rest l))) + (setf return-types (function-return-type l))) + (t (warn "The function proclamation ~s ~s is not valid." + fname decl))) + (if (eq arg-types '*) + (rem-sysprop fname 'PROCLAIMED-ARG-TYPES) + (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)) + (if (eq return-types '*) + (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE) + (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types))) + (warn "The function proclamation ~s ~s is not valid." fname decl))) + +(defun add-function-declaration (fname arg-types return-types env) + (if (si::valid-function-name-p fname) + (cmp-env-register-ftype fname (list arg-types return-types) env) + (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)) + env) + +(defun get-arg-types (fname &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype fname env))) + (if x + (values (first x) t) + (get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) + +(defun get-return-type (fname &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype fname env))) + (if x + (values (second x) t) + (get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) + +(defun get-local-arg-types (fun &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype (fun-name fun)))) + (if x + (values (first x) t) + (values nil nil)))) + +(defun get-local-return-type (fun &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype (fun-name fun)))) + (if x + (values (second x) t) + (values nil nil)))) + +(defun get-proclaimed-narg (fun &optional (env *cmp-env*)) + (multiple-value-bind (arg-list found) + (get-arg-types fun env) + (if found + (loop for type in arg-list + with minarg = 0 + and maxarg = 0 + and in-optionals = nil + do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq) + (return (values minarg call-arguments-limit))) + ((eq type '&optional) + (setf in-optionals t maxarg minarg)) + (in-optionals + (incf maxarg)) + (t + (incf minarg) + (incf maxarg))) + finally (return (values minarg maxarg))) + (values 0 call-arguments-limit)))) + +;;; Proclamation and declaration handling. + +(defun inline-possible (fname &optional (env *cmp-env*)) + (not (or ; (compiler-= *debug* 2) Breaks compilation of STACK-PUSH-VALUES + (let ((x (cmp-env-search-declaration 'notinline env))) + (and x (member fname x :test #'same-fname-p))) + (member fname *notinline* :test #'same-fname-p) + (get-sysprop fname 'CMP-NOTINLINE)))) + +#-:CCL +(defun proclaim (decl &aux decl-name) + (unless (listp decl) + (error "The proclamation specification ~s is not a list" decl)) + (case (setf decl-name (car decl)) + (SPECIAL + (dolist (var (cdr decl)) + (if (symbolp var) + (sys:*make-special var) + (error "Syntax error in proclamation ~s" decl)))) + (OPTIMIZE + (dolist (x (cdr decl)) + (when (symbolp x) (setq x (list x 3))) + (if (or (not (consp x)) + (not (consp (cdr x))) + (not (numberp (second x))) + (not (<= 0 (second x) 3))) + (warn "The OPTIMIZE proclamation ~s is illegal." x) + (case (car x) + (DEBUG (setq *debug* (second x))) + (SAFETY (setq *safety* (second x))) + (SPACE (setq *space* (second x))) + (SPEED (setq *speed* (second x))) + (COMPILATION-SPEED (setq *speed* (- 3 (second x)))) + (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) + (TYPE + (if (consp (cdr decl)) + (proclaim-var (second decl) (cddr decl)) + (error "Syntax error in proclamation ~s" decl))) + (FTYPE + (if (atom (rest decl)) + (error "Syntax error in proclamation ~a" decl) + (multiple-value-bind (type-name args) + (si::normalize-type (second decl)) + (if (eq type-name 'FUNCTION) + (dolist (v (cddr decl)) + (add-function-proclamation v args)) + (error "In an FTYPE proclamation, found ~A which is not a function type." + (second decl)))))) + (INLINE + (dolist (fun (cdr decl)) + (if (si::valid-function-name-p fun) + (rem-sysprop fun 'CMP-NOTINLINE) + (error "Not a valid function name ~s in proclamation ~s" fun decl)))) + (NOTINLINE + (dolist (fun (cdr decl)) + (if (si::valid-function-name-p fun) + (put-sysprop fun 'CMP-NOTINLINE t) + (error "Not a valid function name ~s in proclamation ~s" fun decl)))) + ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE) + ;; FIXME! IGNORED! + (dolist (var (cdr decl)) + (unless (si::valid-function-name-p var) + (error "Not a valid function name ~s in ~s proclamation" fun decl-name)))) + (DECLARATION + (validate-alien-declaration (rest decl) #'error) + (setf si::*alien-declarations* + (nconc (copy-list (rest decl)) si::*alien-declarations*))) + (SI::C-EXPORT-FNAME + (dolist (x (cdr decl)) + (cond ((symbolp x) + (multiple-value-bind (found c-name) + (si::mangle-name x t) + (if found + (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x) + (put-sysprop x 'Lfun c-name)))) + ((consp x) + (destructuring-bind (c-name lisp-name) x + (if (si::mangle-name lisp-name) + (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name) + (put-sysprop lisp-name 'Lfun c-name)))) + (t + (error "Syntax error in proclamation ~s" decl))))) + ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION + COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST + LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL + READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR + SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING + SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION) + (proclaim-var decl-name (cdr decl))) + (otherwise + (cond ((multiple-value-bind (ok type) + (valid-type-specifier decl-name) + (when ok + (proclaim-var type (rest decl)) + t))) + ((let ((proclaimer (get-sysprop (car decl) :proclaim))) + (when (functionp proclaimer) + (mapc proclaimer (rest decl)) + t))) + ((alien-declaration-p (first decl))) + (t + (warn "The declaration specifier ~s is unknown." decl-name)))))) + +(defun type-name-p (name) + (or (get-sysprop name 'SI::DEFTYPE-DEFINITION) + (find-class name nil) + (get-sysprop name 'SI::STRUCTURE-TYPE))) + +(defun validate-alien-declaration (names-list error) + (declare (si::c-local)) + (dolist (new-declaration names-list) + (unless (symbolp new-declaration) + (funcall error "The declaration ~s is not a symbol" new-declaration)) + (when (type-name-p new-declaration) + (funcall error "Symbol ~S cannot be both the name of a type and of a declaration" + new-declaration)))) + +(defun proclaim-var (type vl) + (setq type (type-filter type)) + (dolist (var vl) + (if (symbolp var) + (let ((type1 (get-sysprop var 'CMP-TYPE)) + (v (sch-global var))) + (setq type1 (if type1 (type-and type1 type) type)) + (when v (setq type1 (type-and type1 (var-type v)))) + (unless type1 + (warn + "Inconsistent type declaration was found for the variable ~s." + var) + (setq type1 T)) + (put-sysprop var 'CMP-TYPE type1) + (when v (setf (var-type v) type1))) + (warn "The variable name ~s is not a symbol." var)))) + +(defun c1body (body doc-p &aux + (all-declarations nil) + (ss nil) ; special vars + (is nil) ; ignored vars + (ts nil) ; typed vars (var . type) + (others nil) ; all other vars + doc form) + (loop + (when (endp body) (return)) + (setq form (cmp-macroexpand (car body))) + (cond + ((stringp form) + (when (or (null doc-p) (endp (cdr body)) doc) (return)) + (setq doc form)) + ((and (consp form) (eq (car form) 'DECLARE)) + (push form all-declarations) + (dolist (decl (cdr form)) + (cmpassert (and (proper-list-p decl) (symbolp (first decl))) + "Syntax error in declaration ~s" form) + (let* ((decl-name (first decl)) + (decl-args (rest decl))) + (flet ((declare-variables (type var-list) + (cmpassert (proper-list-p var-list #'symbolp) + "Syntax error in declaration ~s" decl) + (when type + (dolist (var var-list) + (push (cons var type) ts))))) + (case decl-name + (SPECIAL + (cmpassert (proper-list-p decl-args #'symbolp) + "Syntax error in declaration ~s" decl) + (setf ss (append decl-args ss))) + (IGNORE + (cmpassert (proper-list-p decl-args #'symbolp) + "Syntax error in declaration ~s" decl) + (setf is (append decl-args is))) + (TYPE + (cmpassert decl-args "Syntax error in declaration ~s" decl) + (declare-variables (first decl-args) (rest decl-args))) + (OBJECT + (declare-variables 'OBJECT decl-args)) + ;; read-only variable treatment. obsolete! + (:READ-ONLY + (push decl others)) + ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL + DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE) + (push decl others)) + (otherwise + (multiple-value-bind (ok type) + (valid-type-specifier decl-name) + (cmpassert ok "The declaration specifier ~s is unknown." decl-name) + (declare-variables type decl-args))) + ))))) + (t (return))) + (pop body)) + (values body ss ts is others doc all-declarations)) + +(defun default-optimization (optimization) + (ecase optimization + (speed *speed*) + (safety *safety*) + (space *space*) + (debug *debug*))) + +(defun search-optimization-quality (declarations what) + (dolist (i (reverse declarations) + (default-optimization what)) + (when (and (consp i) (eq (first i) 'optimize)) + (dolist (j (rest i)) + (cond ((consp j) + (when (eq (first j) what) + (return-from search-optimization-quality (second j)))) + ((eq j what) + (return-from search-optimization-quality 3))))))) + +(defun compute-optimizations (arguments env) + (let ((optimizations (cmp-env-all-optimizations env))) + (dolist (x arguments) + (when (symbolp x) (setq x (list x 3))) + (unless optimizations + (setq optimizations (cmp-env-all-optimizations))) + (if (or (not (consp x)) + (not (consp (cdr x))) + (not (numberp (second x))) + (not (<= 0 (second x) 3))) + (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x) + (let ((value (second x))) + (case (car x) + (DEBUG (setf (first optimizations) value)) + (SAFETY (setf (second optimizations) value)) + (SPACE (setf (third optimizations) value)) + (SPEED (setf (fourth optimizations) value)) + (COMPILATION-SPEED) + (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))) + optimizations)) + +(defun add-declarations (decls &optional (env *cmp-env*)) + (dolist (decl decls) + (case (car decl) + (OPTIMIZE + (let ((optimizations (compute-optimizations (rest decl) env))) + (setf env (cmp-env-add-declaration 'optimize optimizations)))) + (FTYPE + (if (atom (rest decl)) + (cmpwarn "Syntax error in declaration ~a" decl) + (multiple-value-bind (type-name args) + (si::normalize-type (second decl)) + (if (eq type-name 'FUNCTION) + (dolist (v (cddr decl)) + (setf env (add-function-declaration v (first args) (rest args) env))) + (cmpwarn "In an FTYPE declaration, found ~A which is not a function type." + (second decl)))))) + (INLINE + (let* ((x (copy-list (cmp-env-search-declaration 'notinline))) + (names (rest decl))) + (dolist (fun names) + (unless (si::valid-function-name-p fun) + (cmperr "Not a valid function name ~s in declaration ~s" fun decl)) + (setf x (delete fun x :test #'same-fname-p))) + (setf env (cmp-env-add-declaration 'notinline x)))) + (NOTINLINE + (let* ((x (cmp-env-search-declaration 'notinline)) + (names (rest decl))) + (dolist (fun names) + (if (si::valid-function-name-p fun) + (push fun x) + (cmperr "Not a valid function name ~s in declaration ~s" fun decl))) + (setf env (cmp-env-add-declaration 'notinline x)))) + (DECLARATION + (validate-alien-declaration (rest decl) #'cmperr) + (cmp-env-extend-declarations 'alien (rest decl))) + ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE)) + ((DYNAMIC-EXTENT IGNORABLE) + ;; FIXME! SOME ARE IGNORED! + ) + (:READ-ONLY) + (otherwise + (unless (alien-declaration-p (first decl)) + (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) + env) + +(defun c1decl-body (destination decls body) + (if (null decls) + (c1progn destination body) + (let* ((*cmp-env* (add-declarations decls (cmp-env-copy *cmp-env*)))) + (c1progn destination body)))) + +(defun check-vdecl (vnames ts is) + (dolist (x ts) + (unless (member (car x) vnames) + (cmpwarn "Type declaration was found for not bound variable ~s." + (car x)))) + (dolist (x is) + (unless (member x vnames) + (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; COMPILER ENVIRONMENT +;;; + +(defmacro cmp-env-new () + '(cons nil nil)) + +(defun cmp-env-copy (&optional (env *cmp-env*)) + (cons (car env) (cdr env))) + +(defmacro cmp-env-variables (&optional (env '*cmp-env*)) + `(car ,env)) + +(defmacro cmp-env-functions (&optional (env '*cmp-env*)) + `(cdr ,env)) + +(defun c1cleanup-forms (env) + (loop with specials = '() + with end = (cmp-env-variables env) + with cleanup-forms = '() + with aux + for records-list on (cmp-env-variables *cmp-env*) + until (eq records-list end) + do (let ((record (first records-list))) + (cond ((atom record)) + ((and (symbolp (first record)) + (eq (second record) :special)) + (push (fourth record) specials)) + ((eq (first record) :cleanup) + (push (second record) cleanup-forms)))) + finally (progn + (unless (eq records-list end) + (error "Inconsistency in environment.")) + (return-from c1cleanup-forms + (nconc (c1unbind specials nil) + (apply #'append cleanup-forms)))))) + +(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t)) + (push (list (var-name var) + (if (member (var-kind var) '(special global)) + :special + t) + boundp + var) + (cmp-env-variables env)) + env) + +(defun cmp-env-declare-special (name &optional (env *cmp-env*)) + (cmp-env-register-var (c1make-global-variable name :warn nil :kind 'SPECIAL) + env nil) + env) + +(defun cmp-env-add-declaration (type arguments &optional (env *cmp-env*)) + (push (list* :declare type arguments) + (cmp-env-variables env)) + env) + +(defun cmp-env-extend-declaration (type arguments &optional (env *cmp-env*)) + (let ((x (cmp-env-search-declaration type))) + (cmp-env-add-declaration type (append arguments x) env) + env)) + +(defun cmp-env-register-function (fun &optional (env *cmp-env*)) + (push (list (fun-name fun) 'function fun) + (cmp-env-functions env)) + env) + +(defun cmp-env-register-macro (name function &optional (env *cmp-env*)) + (push (list name 'si::macro function) + (cmp-env-functions env)) + env) + +(defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*)) + (push (list* :declare name declaration) + (cmp-env-functions env)) + env) + +(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*)) + (push (list name 'si::symbol-macro #'(lambda (whole env) form)) + (cmp-env-variables env)) + env) + +(defun cmp-env-register-block (blk &optional (env *cmp-env*)) + (push (list :block (blk-name blk) blk) + (cmp-env-variables env)) + env) + +(defun cmp-env-register-tag (name tag &optional (env *cmp-env*)) + (push (list :tag (list name) tag) + (cmp-env-variables env)) + env) + +(defun cmp-env-register-cleanup (form &optional (env *cmp-env*)) + (push (list :cleanup form) (cmp-env-variables env)) + env) + +(defun cmp-env-search-function (name &optional (env *cmp-env*)) + (let ((ccb nil) + (clb nil) + (unw nil) + (found nil)) + (dolist (record (cmp-env-functions env)) + (cond ((eq record 'CB) + (setf ccbb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon)) + ;; We have to use EQUAL because the name can be a list (SETF whatever) + ((equal (first record) name) + (setf found (first (last record))) + (return)))) + (values found ccb clb unw))) + +(defun cmp-env-search-variables (type name env) + (let ((ccb nil) + (clb nil) + (unw nil) + (found nil)) + (dolist (record (cmp-env-variables env)) + (cond ((eq record 'CB) + (setf ccb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon)) + ((not (eq (first record) type))) + ((eq type :block) + (when (eq name (second record)) + (setf found record) + (return))) + ((eq type :tag) + (when (member name (second record) :test #'eql) + (setf found record) + (return))) + ((eq (second record) 'si::symbol-macro) + (when (eq name 'si::symbol-macro) + (setf found record)) + (return)) + (t + (setf found record) + (return)))) + (values (first (last found)) ccb clb unw))) + +(defun cmp-env-search-block (name &optional (env *cmp-env*)) + (cmp-env-search-variables :block name env)) + +(defun cmp-env-search-tag (name &optional (env *cmp-env*)) + (cmp-env-search-variables :tag name env)) + +(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*)) + (cmp-env-search-variables name 'si::symbol-macro env)) + +(defun cmp-env-search-var (name &optional (env *cmp-env*)) + (cmp-env-search-variables name t env)) + +(defun cmp-env-search-macro (name &optional (env *cmp-env*)) + (let ((f (cmp-env-search-function name env))) + (if (functionp f) f nil))) + +(defun cmp-env-search-ftype (name &optional (env *cmp-env*)) + (dolist (i env nil) + (when (and (consp i) + (eq (pop i) :declare) + (same-fname-p (pop i) name)) + (return i)))) + +(defun cmp-env-mark (mark &optional (env *cmp-env*)) + (cons (cons mark (car env)) + (cons mark (cdr env)))) + +(defun cmp-env-new-variables (new-env old-env) + (loop for i in (ldiff (cmp-env-variables *cmp-env*) + (cmp-env-variables old-env)) + when (and (consp i) (var-p (fourth i))) + collect (fourth i))) + +(defun cmp-env-search-declaration (kind &optional (env *cmp-env*)) + (loop for i in (car env) + when (and (consp i) + (eq (first i) :declare) + (eq (second i) kind)) + return (cddr i))) + +(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) + (or (cmp-env-search-declaration 'optimize) + (list *debug* *safety* *space* *speed*))) + +(defun cmp-env-optimization (property &optional (env *cmp-env*)) + (let ((x (cmp-env-all-optimizations env))) + (case property + (debug (first x)) + (safety (second x)) + (space (third x)) + (speed (fourth x))))) + +(defun policy-assume-right-type (&optional (env *cmp-env*)) + (< (cmp-env-optimization 'safety env) 2)) + +(defun policy-check-stack-overflow (&optional (env *cmp-env*)) + "Do we add a stack check to every function?" + (>= (cmp-env-optimization 'safety env) 2)) + +(defun policy-inline-slot-access-p (&optional (env *cmp-env*)) + "Do we inline access to structures and sealed classes?" + (or (< (cmp-env-optimization 'safety env) 2) + (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env)))) + +(defun policy-check-all-arguments-p (&optional (env *cmp-env*)) + "Do we assume that arguments are the right type?" + (> (cmp-env-optimization 'safety env) 1)) + +(defun policy-automatic-check-type-p (&optional (env *cmp-env*)) + "Do we generate CHECK-TYPE forms for function arguments with type declarations?" + (and *automatic-check-type-in-lambda* + (>= (cmp-env-optimization 'safety env) 1))) + +(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*)) + "Do we assume that type and class definitions will not change?" + (<= (cmp-env-optimization 'safety env) 1)) + +(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*)) + "Do we inline access to arrays?" + (< (cmp-env-optimization 'debug env) 2)) + +(defun policy-open-code-accessors (&optional (env *cmp-env*)) + "Do we inline access to object slots, including conses and arrays?" + (< (cmp-env-optimization 'debug env) 2)) + +(defun policy-array-bounds-check-p (&optional (env *cmp-env*)) + "Check access to array bounds?" + (>= (cmp-env-optimization 'safety env) 1)) + +(defun policy-evaluate-forms (&optional (env *cmp-env*)) + "Pre-evaluate a function that takes constant arguments?" + (<= (cmp-env-optimization 'debug env) 1)) + +(defun alien-declaration-p (name) + (or (member name (cmp-env-search-declaration 'alien) :test #'eq) + (member name si:*alien-declarations*))) + +(defun policy-global-var-checking (&optional (env *cmp-env*)) + "Do we have to read the value of a global variable even if it is discarded? +Also, when reading the value of a global variable, should we ensure it is bound?" + (>= (cmp-env-optimization 'safety env) 1)) + +(defun policy-global-function-checking (&optional (env *cmp-env*)) + "Do we have to read the binding of a global function even if it is discarded?" + (>= (cmp-env-optimization 'safety env) 1)) + +(defun policy-debug-variable-bindings (&optional (env *cmp-env*)) + "Shall we create a vector with the bindings of each LET/LET*/LAMBDA form?" + ;; We can only create variable bindings when the function has an IHS frame!!! + (and (policy-debug-ihs-frame env) + (>= (cmp-env-optimization 'debug env) 3))) + +(defun policy-debug-ihs-frame (&optional (env *cmp-env*)) + "Shall we create an IHS frame so that this function shows up in backtraces?" + ;; Note that this is a prerequisite for registering variable bindings. Hence, + ;; it has to be recorded in a special variable. + (>= (fun-debug *current-function*) 2)) + +(defun policy-check-nargs (&optional (env *cmp-env*)) + (>= (cmp-env-optimization 'safety) 1)) diff --git a/src/new-cmp/cmpeval.lsp b/src/new-cmp/cmpeval.lsp new file mode 100644 index 000000000..64c243cc8 --- /dev/null +++ b/src/new-cmp/cmpeval.lsp @@ -0,0 +1,153 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPEVAL -- The Expression Dispatcher. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; ECoLisp is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defun c1expr (destination form) + (setq form (catch *cmperr-tag* + (cond ((symbolp form) + (setq form (chk-symbol-macrolet form)) + (cond ((not (symbolp form)) + (c1expr destination form)) + ((eq form nil) (c1nil destination)) + ((eq form t) (c1t destination)) + ((keywordp form) + (c1set-loc destination (add-symbol form))) + ((constantp form) + (or (c1constant-value destination (symbol-value form) + :only-small-values t) + (c1var destination form))) + (t (c1var destination form)))) + ((tag-p form) + form) + ((consp form) + (let* ((fun (car form)) + (*current-form* form)) + (cond ((symbolp fun) + (c1call-symbol destination fun (cdr form))) + ((and (consp fun) (eq (car fun) 'LAMBDA)) + (c1funcall destination form)) + (t (cmperr "~s is not a legal function name." fun))))) + (t (c1constant-value destination form :always t))))) + (if (eq form '*cmperr-tag*) + (c1nil destination) + form)) + +(defun c1nil (destination) + (c1set-loc destination nil)) +(defun c1t (destination) + (c1set-loc destination t)) + +(defun c1call-symbol (destination fname args &aux fd basic-fd) + (cond ((and (setq basic-fd (gethash fname +c1-dispatch-table+)) + (special-operator-p fname)) + (funcall basic-fd destination args)) + ((c1call-local destination fname args)) + ((setq fd (cmp-env-search-macro fname)) + (c1expr destination (cmp-expand-macro fd (list* fname args)))) + ((and basic-fd (inline-possible fname)) + (funcall basic-fd destination args)) + ((and (setq fd (compiler-macro-function fname)) + (inline-possible fname) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd (list* fname args))) + success)) + (c1expr destination fd)) + ((setq fd (macro-function fname)) + (c1expr destination (cmp-expand-macro fd (list* fname args)))) + (t (c1call-global destination fname args)))) + +(defun c1call-local (destination fname args) + (let ((fun (local-function-ref fname))) + (when fun + (when (> (length args) si::c-arguments-limit) + (return-from c1call-local + (unoptimized-long-call destination `#',fname args))) + (c1with-saved-values (prefix postfix temps args) + (nconc prefix + (c1call-local-op destination fun temps) + postfix))))) + +(defun c1call-global (destination fname args) + (let ((l (length args)) + forms) + (cond ((> l si::c-arguments-limit) + (unoptimized-long-call destination `#',fname args)) +#| + ((maybe-optimize-structure-access destination fname args)) + #+clos + ((maybe-optimize-generic-function destination fname args)) +|# + (t + (c1with-saved-values (prefix postfix temps args) + (nconc prefix + (c1call-global-op destination fname temps) + postfix)))))) + +(defun c2expr (form) + (cond ((consp form) + (loop for f in form + do (c2expr f))) + ((tag-p form) + (pprint-c1form form) + (when (plusp (tag-ref form)) + (let ((label (tag-label form))) + (unless label + (setf (tag-label form) (setf label (next-label)))) + (wt-label (tag-label form))))) + ((c1form-p form) + (pprint-c1form form) + (let* ((*file* (c1form-file form)) + (*file-position* (c1form-file form)) + (*current-form* (c1form-form form)) + (*current-c2form* form) + (*cmp-env* (c1form-env form)) + (name (c1form-name form)) + (args (c1form-args form)) + (dispatch (gethash name +c2-dispatch-table+))) + (unless dispatch + (error "Unknown C1 form ~A" form)) + (apply dispatch args))) + (t + (error "In C2EXPR, invalid C1 form ~A" form)))) + +(defun c1progn (destination forms) + (or (loop for fl on forms + nconc (t1/c1expr (if (rest fl) 'TRASH destination) + (first fl))) + (t1/c1expr destination 'NIL))) + +;;; ---------------------------------------------------------------------- + +(defvar *compiler-temps* + '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) + +(defmacro sys::define-inline-function (name vars &body body) + (let ((temps nil) + (*compiler-temps* *compiler-temps*)) + (dolist (var vars) + (if (and (symbolp var) + (not (member var '(&OPTIONAL &REST &KEY &AUX) :test #'eq))) + (push (or (pop *compiler-temps*) + (gentemp "TMP" (find-package 'COMPILER))) + temps) + (error "The parameter ~s for the inline function ~s is illegal." + var name))) + (let ((binding (cons 'LIST (mapcar + #'(lambda (var temp) `(list ',var ,temp)) + vars temps)))) + `(progn + (defun ,name ,vars ,@body) + (define-compiler-macro ,name ,temps (list* 'LET ,binding ',body)))))) diff --git a/src/new-cmp/cmpexit.lsp b/src/new-cmp/cmpexit.lsp new file mode 100644 index 000000000..f7d2f7ca3 --- /dev/null +++ b/src/new-cmp/cmpexit.lsp @@ -0,0 +1,186 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPEXIT Exit manager. + +(in-package "COMPILER") + +(defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p) + (declare (fixnum bds-bind)) + (when stack-frame + (if (stringp stack-frame) + (wt-nl "ecl_stack_frame_close(" stack-frame ");") + (wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");"))) + (when bds-lcl + (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");")) + (if (< bds-bind 4) + (dotimes (n bds-bind) + (declare (fixnum n)) + (wt-nl "ecl_bds_unwind1(cl_env_copy);")) + (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");")) + (case ihs-p + (IHS (wt-nl "ecl_ihs_pop(cl_env_copy);")) + (IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;")))) + +(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) + (declare (fixnum bds-bind)) + (when (consp *destination*) + (case (car *destination*) + (JUMP-TRUE + (set-jump-true loc (second *destination*)) + (when (eq loc t) (return-from unwind-exit))) + (JUMP-FALSE + (set-jump-false loc (second *destination*)) + (when (eq loc nil) (return-from unwind-exit))))) + (dolist (ue *unwind-exit* (baboon)) + ;; perform all unwind-exit's which precede *exit* + (cond + ((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n) + (cond ((eq (car ue) 'STACK) + (setf stack-frame (second ue))) + ((eq (car ue) 'LCL) + (setq bds-lcl ue bds-bind 0)) + ((eq ue *exit*) + ;; all body forms except the last (returning) are dealt here + (cond ((and (consp *destination*) + (or (eq (car *destination*) 'JUMP-TRUE) + (eq (car *destination*) 'JUMP-FALSE))) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p)) + ((not (or bds-lcl (plusp bds-bind) stack-frame)) + (set-loc loc)) + ;; Save the value if LOC may possibly refer + ;; to special binding. + ((or (loc-refers-to-special loc) + (loc-refers-to-special *destination*)) + (let* ((*temp* *temp*) + (temp (make-temp-var))) + (let ((*destination* temp)) + (set-loc loc)) ; temp <- loc + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (set-loc temp))) ; *destination* <- temp + (t + (set-loc loc) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p))) + (when jump-p (wt-nl) (wt-go *exit*)) + (return)) + (t (setq jump-p t)))) + ((numberp ue) (baboon) + (setq bds-lcl ue bds-bind 0)) + (t (case ue + (IHS (setf ihs-p ue)) + (IHS-ENV (setf ihs-p (or ihs-p ue))) + (BDS-BIND (incf bds-bind)) + (RETURN + (unless (eq *exit* 'RETURN) (baboon)) + ;; *destination* must be either RETURN or TRASH. + (cond ((eq loc 'VALUES) + ;; from multiple-value-prog1 or values + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return cl_env_copy->values[0];")) + ((eq loc 'RETURN) + ;; from multiple-value-prog1 or values + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return value0;")) + (t + (let* ((*destination* 'RETURN)) + (set-loc loc)) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return value0;"))) + (return)) + ((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT + RETURN-SINGLE-FLOAT RETURN-OBJECT) + (when (eq *exit* ue) + ;; *destination* must be RETURN-FIXNUM + (setq loc (list 'COERCE-LOC + (getf '(RETURN-FIXNUM :fixnum + RETURN-CHARACTER :char + RETURN-SINGLE-FLOAT :float + RETURN-DOUBLE-FLOAT :double + RETURN-OBJECT :object) + ue) + loc)) + (if (or bds-lcl (plusp bds-bind)) + (let ((lcl (make-lcl-var :type (second loc)))) + (wt-nl "{cl_fixnum " lcl "= " loc ";") + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (wt-nl "return(" lcl ");}")) + (progn + (wt-nl "return(" loc ");"))) + (return))) + (FRAME + (let ((*destination* (tmp-destination *destination*))) + (set-loc loc) + (setq loc *destination*)) + (wt-nl "ecl_frs_pop(cl_env_copy);")) + (TAIL-RECURSION-MARK) + (JUMP (setq jump-p t)) + (t (baboon)))))) + ;;; Never reached + ) + +(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) + (declare (fixnum bds-bind)) + (dolist (ue *unwind-exit* (baboon)) + (cond + ((consp ue) + (cond ((eq ue exit) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (return)) + ((eq (first ue) 'STACK) + (setf stack-frame (second ue))))) + ((numberp ue) (setq bds-lcl ue bds-bind 0)) + ((eq ue 'BDS-BIND) (incf bds-bind)) + ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER + RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT)) + (if (eq exit ue) + (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (return)) + (baboon)) + ;;; Never reached + ) + ((eq ue 'FRAME) (wt-nl "ecl_frs_pop(cl_env_copy);")) + ((eq ue 'TAIL-RECURSION-MARK) + (if (eq exit 'TAIL-RECURSION-MARK) + (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) + (return)) + (baboon)) + ;;; Never reached + ) + ((eq ue 'JUMP)) + ((eq ue 'IHS-ENV) + (setf ihs-p ue)) + (t (baboon)) + )) + ;;; Never reached + ) + +;;; Tail-recursion optimization for a function F is possible only if +;;; 1. F receives only required parameters, and +;;; 2. no required parameter of F is enclosed in a closure. +;;; +;;; A recursive call (F e1 ... en) may be replaced by a loop only if +;;; 1. F is not declared as NOTINLINE, +;;; 2. n is equal to the number of required parameters of F, +;;; 3. the form is a normal function call (i.e. args are not ARGS-PUSHED), +;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic +;;; binding (such as LET, LET*, PROGV), +;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame +;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are +;;; enclosed in a closure, and CATCH), + +(defun tail-recursion-possible () + (dolist (ue *unwind-exit* (baboon)) + (cond ((eq ue 'TAIL-RECURSION-MARK) (return t)) + ((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME)) + (return nil)) + ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV))) + (t (baboon))))) diff --git a/src/new-cmp/cmpffi.lsp b/src/new-cmp/cmpffi.lsp new file mode 100644 index 000000000..f0fb2c95c --- /dev/null +++ b/src/new-cmp/cmpffi.lsp @@ -0,0 +1,451 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPFFI -- Foreign functions interface. + +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;; ---------------------------------------------------------------------- +;; REPRESENTATION TYPES +;; + +(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. + :byte ((signed-byte 8) "int8_t") + :unsigned-byte ((unsigned-byte 8) "uint8_t") + :fixnum (fixnum "cl_fixnum") + :int ((integer #.si:c-int-min #.si:c-int-max) "int") + :unsigned-int ((integer 0 #.si:c-uint-max) "unsigned int") + :long ((integer #.si:c-long-min #.si:c-long-max) "long") + :unsigned-long ((integer 0 #.si:c-ulong-max) "unsigned long") + :cl-index ((integer 0 #.most-positive-fixnum) "cl_index") + :float (single-float "float") + :double (double-float "double") + #+:long-float :long-double #+:long-float (long-float "long double") + :unsigned-char (base-char "char") + :char (base-char "char") + :wchar (character "ecl_character") + :object (t "cl_object") + :bool (t "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*") + :cstring (string "char*") + :char* (string "char*") + :short ((integer #.si:c-short-min #.si:c-short-max) "short") + :unsigned-short ((integer 0 #.si:c-ushort-max) "unsigned short") + )) + + +(defun rep-type->lisp-type (rep-type) + (let ((output (getf +representation-types+ rep-type))) + (cond (output + (if (eq rep-type :void) nil + (or (first output) + (cmperr "Representation type ~S cannot be coerced to lisp" + rep-type)))) + ((lisp-type-p rep-type) rep-type) + (t (cmperr "Unknown representation type ~S" rep-type))))) + +(defun lisp-type->rep-type (type) + (cond + ;; We expect type = NIL when we have no information. Should be fixed. FIXME! + ((null type) + :object) + ((getf +representation-types+ type) + type) + (t + (do ((l +representation-types+ (cddr l))) + ((endp l) :object) + (when (subtypep type (first (second l))) + (return-from lisp-type->rep-type (first l))))))) + +(defun rep-type-name (type) + (or (second (getf +representation-types+ type)) + (cmperr "Not a valid type name ~S" type))) + +(defun lisp-type-p (type) + (subtypep type 'T)) + + +;; ---------------------------------------------------------------------- +;; LOCATIONS and representation types +;; +;; Locations are lisp expressions which represent actual C data. To each +;; location we can associate a representation type, which is the type of +;; the C data. The following routines help in determining these types, +;; and also in moving data from one location to another. + +(defun loc-movable-p (loc) + (if (atom loc) + t + (case (first loc) + ((CALL CALL-LOCAL) NIL) + ((C-INLINE) (not (fifth loc))) ; side effects? + (otherwise t)))) + +(defun loc-type (loc) + (cond ((eq loc NIL) 'NULL) + ((var-p loc) (var-type loc)) + ((si::fixnump loc) 'fixnum) + ((atom loc) 'T) + (t + (case (first loc) + (FIXNUM-VALUE 'FIXNUM) + (CHARACTER-VALUE (type-of (code-char (second loc)))) + (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) + (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) + (LONG-FLOAT-VALUE 'LONG-FLOAT) + (C-INLINE (let ((type (first (second loc)))) + (cond ((and (consp type) (eq (first type) 'VALUES)) T) + ((lisp-type-p type) type) + (t (rep-type->lisp-type type))))) + (BIND (var-type (second loc))) + (LCL (or (third loc) T)) + (MAKE-CCLOSURE 'FUNCTION) + ((VV VV-TEMP) + (if (cddr loc) + (object-type (third loc)) + T)) + (otherwise T))))) + +(defun loc-representation-type (loc) + (cond ((member loc '(NIL T)) :object) + ((var-p loc) (var-rep-type loc)) + ((si::fixnump loc) :fixnum) + ((eq loc 'TRASH) :void) + ((atom loc) :object) + (t + (case (first loc) + (FIXNUM-VALUE :fixnum) + (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) + (DOUBLE-FLOAT-VALUE :double) + (SINGLE-FLOAT-VALUE :float) + (LONG-FLOAT-VALUE :long-double) + (C-INLINE (let ((type (first (second loc)))) + (cond ((and (consp type) (eq (first type) 'VALUES)) :object) + ((lisp-type-p type) (lisp-type->rep-type type)) + (t type)))) + (BIND (var-rep-type (second loc))) + (LCL (lisp-type->rep-type (or (third loc) T))) + (otherwise :object))))) + +(defun wt-coerce-loc (dest-rep-type loc) + (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) + ;(print dest-rep-type) + ;(print loc) + (let* ((dest-type (rep-type->lisp-type dest-rep-type)) + (loc-type (loc-type loc)) + (loc-rep-type (loc-representation-type loc))) + (labels ((coercion-error () + (cmperr "Unable to coerce lisp object from type (~S,~S)~%~ + to C/C++ type (~S,~S)" + loc-type loc-rep-type dest-type dest-rep-type)) + (ensure-valid-object-type (a-lisp-type) + (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) + (coercion-error)))) + (when (eq dest-rep-type loc-rep-type) + (wt loc) + (return-from wt-coerce-loc)) + (case dest-rep-type + ((:byte :unsigned-byte :short :unsigned-short :int :unsigned-int + :long :unsigned-long :fixnum :cl-index) + (case loc-rep-type + (#1=(:byte :unsigned-byte :short :unsigned-short :int :unsigned-int + :long :unsigned-long :fixnum :cl-index + :float :double :long-double) ; number types + (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) + ((:object) + (ensure-valid-object-type dest-type) + (wt (cond ((or (subtypep (loc-type loc) 'fixnum) + (not (policy-check-all-arguments-p))) + "fix(") + ((member dest-rep-type '(:unsigned-short :unsigned-long :cl-index)) + "ecl_to_unsigned_integer(") + (t + "ecl_to_fixnum(")) + loc ")")) + (otherwise + (coercion-error)))) + ((:char :unsigned-char :wchar) + (case loc-rep-type + ((:char :unsigned-char :wchar) + (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) + ((:object) + (ensure-valid-object-type dest-type) + (wt "ecl_char_code(" loc ")")) + (otherwise + (coercion-error)))) + ((:float :double :long-double) + (case loc-rep-type + (#1# ; number type + (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) + ((:object) + ;; We relax the check a bit, because it is valid in C to coerce + ;; between floats of different types. + (ensure-valid-object-type 'FLOAT) + (wt (ecase dest-rep-type + (:float "ecl_to_float(") + (:double "ecl_to_double(") + (:long-double "ecl_to_long_double(")) + loc ")")) + (otherwise + (coercion-error)))) + ((:bool) + (case loc-rep-type + (#1# ; number type + (wt "1")) + ((:object) + (wt "(" loc ")!=Cnil")) + (otherwise + (coercion-error)))) + ((:object) + (case loc-rep-type + ((:short :int :long) + (wt "ecl_make_integer(" loc ")")) + ((:unsigned-short :unsigned-int :unsigned-long) + (wt "ecl_make_unsigned_integer(" loc ")")) + ((:byte :unsigned-byte :fixnum) + (wt "MAKE_FIXNUM(" loc ")")) + ((:float) + (if (and (consp loc) (eq (first loc) 'SINGLE-FLOAT-VALUE)) + (wt (third loc)) ;; VV index + (wt "ecl_make_singlefloat(" loc ")"))) + ((:double) + (if (and (consp loc) (eq (first loc) 'DOUBLE-FLOAT-VALUE)) + (wt (third loc)) ;; VV index + (wt "ecl_make_doublefloat(" loc ")"))) + ((:long-double) + (if (and (consp loc) (eq (first loc) 'LONG-FLOAT-VALUE)) + (wt (third loc)) ;; VV index + (wt "ecl_make_longfloat(" loc ")"))) + ((:bool) + (wt "((" loc ")?Ct:Cnil)")) + ((:char :unsigned-char :wchar) + (wt "CODE_CHAR(" loc ")")) + ((:cstring) + (wt "ecl_cstring_to_base_string_or_nil(" loc ")")) + ((:pointer-void) + (wt "ecl_make_foreign_data(Cnil, 0, " loc ")")) + (otherwise + (coercion-error)))) + ((:pointer-void) + (case loc-rep-type + ((:object) + ;; Only foreign data types can be coerced to a pointer + (wt "ecl_foreign_data_pointer_safe(" loc ")")) + ((:cstring) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:cstring) + (coercion-error)) + ((:char*) + (case loc-rep-type + ((:object) + (wt "ecl_base_string_pointer_safe(" loc ")")) + ((:pointer-void) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:void) + (wt loc)) + (t + (coercion-error)))))) + +;; ---------------------------------------------------------------------- +;; C/C++ DECLARATIONS AND HEADERS +;; + +(defun c1clines (destination args) + (unless (every #'stringp args) + (cmperr "The argument to CLINES, ~s, is not a list of strings." args)) + (setf *clines-string-list* (nconc *clines-string-list* (copy-list args))) + (c1translate destination '(progn))) + +;; ---------------------------------------------------------------------- +;; C/C++ INLINE CODE +;; + +(defun c1c-inline (destination args) + ;; We are on the safe side by assuming that the form has side effects + (destructuring-bind (arguments arg-types output-type c-expression + &rest rest + &key (side-effects t) one-liner + &aux output-rep-type) + args + (unless (= (length arguments) (length arg-types)) + (cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S" + `(C-INLINE ,@args))) + ;; We cannot handle :cstrings as input arguments. :cstrings are + ;; null-terminated strings, but not all of our lisp strings will + ;; be null terminated. In particular, those with a fill pointer + ;; will not. + (let ((ndx (position :cstring arg-types))) + (when ndx + (let* ((var (gensym)) + (value (elt arguments ndx))) + (setf (elt arguments ndx) var + (elt arg-types ndx) :char*) + (return-from c1c-inline + (c1translate destination + `(ffi::with-cstring (,var ,value) + (c-inline ,arguments ,arg-types ,output-type ,c-expression + ,@rest))))))) + ;; Find out the output types of the inline form. The syntax is rather relaxed + ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) + (flet ((produce-type-pair (type) + (if (lisp-type-p type) + (cons type (lisp-type->rep-type type)) + (cons (rep-type->lisp-type type) type)))) + (cond ((eq output-type ':void) + (setf output-rep-type '() + output-type 'NIL)) + ((equal output-type '(VALUES &REST t)) + (setf output-rep-type '((VALUES &REST t)))) + ((and (consp output-type) (eql (first output-type) 'VALUES)) + (setf output-rep-type (mapcar #'cdr (mapcar #'produce-type-pair (rest output-type))) + output-type 'T)) + (t + (let ((x (produce-type-pair output-type))) + (setf output-type (car x) + output-rep-type (list (cdr x))))))) + (let* ((processed-arguments '())) + (unless (and (listp arguments) + (listp arg-types) + (stringp c-expression)) + (cmperr "C-INLINE: wrong type of arguments ~S" + arguments arg-types c-expression)) + (unless (= (length arguments) + (length arg-types)) + (cmperr "C-INLINE: mismatch between sizes of argument list and argument types.")) + (c1with-saved-values (prefix postfix temps arguments) + (nconc prefix + (make-c1form* 'C-INLINE :type output-type + :args + destination + temps + arg-types + output-rep-type + c-expression + side-effects + one-liner) + postfix))))) + +(defun produce-inline-loc (argument-locs arg-types output-rep-type + c-expression side-effects one-liner) + (let* (args-to-be-saved + coerced-arguments) + ;; If the expression begins with @[0-9a-z]*, this means we are + ;; saving some variables. + (when (and (> (length c-expression) 1) + (eq (char c-expression 0) #\@)) + (do ((ndx 1 (1+ ndx))) + ((>= ndx (length c-expression))) + (let ((c (char c-expression ndx))) + (when (eq c #\;) + (setf c-expression (subseq c-expression (1+ ndx))) + (return)) + (unless (alphanumericp c) + (setf args-to-be-saved nil) + (return)) + (push (- (char-code c) (char-code #\0)) + args-to-be-saved)))) + + (setf coerced-arguments (coerce-locations argument-locs arg-types args-to-be-saved)) + ;;(setf output-rep-type (lisp-type->rep-type output-rep-type)) + + ;; If the form does not output any data, and there are no side + ;; effects, try to omit it. + (when (null output-rep-type) + (if side-effects + (progn + (wt-nl) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) + (when one-liner (wt ";"))) + (cmpwarn "Ignoring form ~S" c-expression)) + (return-from produce-inline-loc NIL)) + + ;; If the form is a one-liner, we can simply propagate this expression until the + ;; place where the value is used. + (when one-liner + (return-from produce-inline-loc + `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects + ,(if (equalp output-rep-type '((VALUES &REST T))) + 'VALUES NIL)))) + + ;; If the output is a in the VALUES vector, just write down the form and output + ;; the location of the data. + (when (equalp output-rep-type '((VALUES &REST T))) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects + 'VALUES) + (return-from produce-inline-loc 'VALUES)) + + ;; Otherwise we have to set up variables for holding the output. + (flet ((make-output-var (type) + (let ((var (make-lcl-var :rep-type type))) + (wt-nl (rep-type-name type) " " var ";") + var))) + (wt-nl "{") + (let ((output-vars (mapcar #'make-output-var output-rep-type))) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments + side-effects output-vars) + (cond ((= (length output-vars) 1) + (first output-vars)) + (t + (loop for v in output-vars + for i from 0 + do (set-loc v `(VALUE ,i))) + (wt "cl_env_copy->nvalues=" (length output-vars) ";") + 'VALUES))) + (wt-nl "}")))) + +(defun c2c-inline (destination arguments &rest rest) + (set-loc (apply #'produce-inline-loc arguments rest) + destination)) + +(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars) + (with-input-from-string (s c-expression) + (when (and output-vars (not (eq output-vars 'VALUES))) + (wt-nl)) + (do ((c (read-char s nil nil) + (read-char s nil nil))) + ((null c)) + (case c + (#\@ + (let ((object (read s))) + (cond ((and (consp object) (equal (first object) 'RETURN)) + (if (eq output-vars 'VALUES) + (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) + (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" + ndx l))))) + (t + (when (and (consp object) (eq (first object) 'QUOTE)) + (setq object (second object))) + (wt (add-object object :permanent t)))))) + (#\# + (let* ((k (read-char s)) + (next-char (peek-char nil s nil nil)) + (index (digit-char-p k 36))) + (cond ((or (null index) (and next-char (alphanumericp next-char))) + (wt #\# k)) + ((< index (length coerced-arguments)) + (wt (nth index coerced-arguments))) + (t + (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) + (otherwise + (write-char c *compiler-output1*)))))) diff --git a/src/new-cmp/cmpflet.lsp b/src/new-cmp/cmpflet.lsp new file mode 100644 index 000000000..13b7f61ed --- /dev/null +++ b/src/new-cmp/cmpflet.lsp @@ -0,0 +1,244 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPFLET Flet, Labels, and Macrolet. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defun c1labels (destination args) + (labels/flet-transform destination 'LABELS args)) + +(defun c1flet (destination args) + (labels/flet-transform destination 'FLET args)) + +(defun labels/flet-transform (destination origin args) + (check-args-number origin args 1) + (let ((definitions (pop args)) + (fun-names '()) + (fun-bodies '()) + (local-funs '()) + (vars '()) + (setf-statements '()) + (output)) + ;; If there are no definitions, do as an ordinary body with + ;; declarations. + (unless definitions + (return-from labels/flet-transform + (c1translate destination `(LOCALLY ,@args)))) + + ;; On a first round, we extract the definitions of the functions, + ;; and build empty function objects that record the references to + ;; this functions in the processed body. + (dolist (def definitions) + (cmpck (or (endp def) + (not (si::valid-function-name-p (car def))) + (endp (cdr def))) + "The local function definition ~s is illegal." def) + (let ((name (pop def))) + (cmpck (member name fun-names :test #'same-fname-p) + "The function ~s was already defined." name) + (push name fun-names) + (let* ((var (gensym "CLOSURE-VAR")) + (fun (make-fun :name name :var var))) + (push fun local-funs) + (push def fun-bodies) + (push var vars) + (push `(MAKE-FLET/LABELS-CLOSURE ,var ,fun) setf-statements)))) + + ;; Compile an extended form in which we include the possible closure + ;; variables associated to the functions. + (setf local-funs (nreverse local-funs) + fun-bodies (nreverse fun-bodies) + output (c1translate destination + `(LET ,vars + (DO-FLET/LABELS ,origin ,local-funs ,fun-bodies) + ,@setf-statements + ,@args))) + + ;; Once we have everything compiled, we can inspect the nature of + ;; the functions: whether they are closures or not, etc. We keep + ;; on inspecting the functions until the closure type does not + ;; change. + (loop while + (let ((x nil)) + (loop for f in local-funs + when (compute-fun-closure-type f) + do (setf x t)) + x)) + + output)) + +(defun c1do-flet/labels (destination args) + (unless (eq destination 'TRASH) + (error "Internal error in C1DO-FLET/LABELS: output value should not be used")) + (let* ((origin (pop args)) + (local-funs (pop args)) + (definitions (first args)) + (new-env (cmp-env-copy *cmp-env*))) + (loop for f in local-funs + for v = (fun-var f) + ;; We enlarge the environment + do (cmp-env-register-function f new-env) + ;; and assign to the function its variable. Previously + ;; we only stored the names. + do (setf (fun-var f) (cmp-env-search-var v *cmp-env*))) + + ;; We compile the functions, either in an empty environment in + ;; which there are no new functions + (let ((*cmp-env* (if (eq origin 'FLET) *cmp-env* new-env))) + (loop for fun in local-funs + for body in definitions + ;; The closure type will be fixed later on by COMPUTE-... + do (c1compile-function body :fun fun :CB/LB 'LB))) + + ;; When we are in a LABELs form, we have to propagate the external + ;; variables from one function to the other functions that use it. + (dolist (f1 local-funs) + (let ((vars (fun-referred-vars f1))) + (dolist (f2 local-funs) + (when (and (not (eq f1 f2)) + (member f1 (fun-referred-funs f2))) + (add-referred-variables-to-function f2 vars))))) + + (setf *cmp-env* new-env) + + (c1do-flet/labels-op local-funs))) + +(defun c1make-flet/labels-closure (destination args) + (let* ((var (pop args)) + (funob (pop args))) + (nconc (c1set-loc (c1vref var) (list 'MAKE-CCLOSURE funob)) + (c1set-loc destination nil)))) + +(defun fun-referred-local-vars (fun) + (remove-if #'(lambda (v) (member (var-kind v) '(SPECIAL GLOBAL REPLACED DISCARDED))) + (fun-referred-vars fun))) + +(defun compute-fun-closure-type (fun) + (labels + ((closure-type (fun &aux (lambda-form (fun-lambda fun))) + (let ((vars (fun-referred-local-vars fun)) + (funs (remove fun (fun-referred-funs fun) :test #'child-p)) + (closure nil)) + ;; it will have a full closure if it refers external non-global variables + (dolist (var vars) + ;; ...across CB + (if (ref-ref-ccb var) + (setf closure 'CLOSURE) + (unless closure (setf closure 'LEXICAL)))) + ;; ...or if it directly calls a function + (dolist (f funs) + ;; .. which has a full closure + (case (fun-closure f) + (CLOSURE (setf closure 'CLOSURE)) + (LEXICAL (unless closure (setf closure 'LEXICAL))))) + ;; ...or the function itself is referred across CB, either + ;; directly or through a second indirection to the function + ;; variable. + (when closure + (when (or (fun-ref-ccb fun) + (and (fun-var fun) + (not (unused-variable-p (fun-var fun))))) + (setf closure 'CLOSURE))) + closure)) + (child-p (presumed-parent fun) + (let ((real-parent (fun-parent fun))) + (when real-parent + (or (eq real-parent presumed-parent) + (child-p real-parent presumed-parent)))))) + ;; This recursive algorithm is guaranteed to stop when functions + ;; do not change. + (let ((new-type (closure-type fun)) + (old-type (fun-closure fun))) +;; (format t "~%CLOSURE-TYPE: ~A ~A -> ~A, ~A" (fun-name fun) +;; old-type new-type (fun-parent fun)) +;; (print (fun-referred-vars fun)) + ;; Same type + (when (eq new-type old-type) + (return-from compute-fun-closure-type nil)) + ;; {lexical,closure} -> no closure! + ;; closure -> {lexical, no closure} + (when (or (and (not new-type) old-type) + (eq old-type 'CLOSURE)) + (baboon)) + (setf (fun-closure fun) new-type) + ;; All external, non-global variables become of type closure + (when (eq new-type 'CLOSURE) + (when (fun-global fun) + (cmperr "Function ~A is global but is closed over some variables.~%~{~A ~}" + (fun-name fun) (mapcar #'var-name (fun-referred-vars fun)))) + (dolist (var (fun-referred-local-vars fun)) + (setf (var-ref-clb var) nil + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT)) + (dolist (f (fun-referred-funs fun)) + (setf (fun-ref-ccb f) t))) + ;; If the status of some of the children changes, we have + ;; to recompute the closure type. + (do ((finish nil t) + (recompute nil)) + (finish + (when recompute (compute-fun-closure-type fun))) + (dolist (f (fun-child-funs fun)) + (when (compute-fun-closure-type f) + (setf recompute t finish nil)))) + t))) + +(defun c1locally (destination args) + (multiple-value-bind (body ss ts is other-decl) + (c1body args t) + (let ((*cmp-env* (cmp-env-copy))) + (c1declare-specials ss) + (check-vdecl nil ts is) + (c1decl-body destination other-decl body)))) + +(defun c1macrolet (destination args) + (check-args-number 'MACROLET args 1) + (let ((*cmp-env* (cmp-env-copy))) + (cmp-env-register-macrolet (first args) *cmp-env*) + (c1locally destination (cdr args)))) + +(defun c1symbol-macrolet (destination args) + (check-args-number 'SYMBOL-MACROLET args 1) + (let ((*cmp-env* (cmp-env-copy))) + (dolist (def (car args)) + (let ((name (first def))) + (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) + "The symbol-macro definition ~s is illegal." def) + (cmp-env-register-symbol-macro name (second def)))) + (c1locally destination (cdr args)))) + +(defun local-function-ref (fname &optional build-object) + (multiple-value-bind (fun ccb clb unw) + (cmp-env-search-function fname) + (when fun + (when (functionp fun) + (when build-object + ;; Macro definition appears in #'.... This should not happen. + (cmperr "The name of a macro ~A was found in special form FUNCTION." name)) + (return-from local-function-ref nil)) + (incf (fun-ref fun)) + (cond (build-object + (setf (fun-ref-ccb fun) t)) + (*current-function* + (push fun (fun-referred-funs *current-function*)))) + ;; we introduce a variable to hold the funob + (let ((var (fun-var fun))) + (cond (ccb (when build-object + (setf (var-ref-ccb var) t + (var-kind var) 'CLOSURE)) + (setf (fun-ref-ccb fun) t)) + (clb (when build-object + (setf (var-ref-clb var) t + (var-kind var) 'LEXICAL)))))) + fun)) diff --git a/src/new-cmp/cmpfun.lsp b/src/new-cmp/cmpfun.lsp new file mode 100644 index 000000000..ba03dc48e --- /dev/null +++ b/src/new-cmp/cmpfun.lsp @@ -0,0 +1,164 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPFUN Library functions. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi and William F. Schelter. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + + +(in-package "COMPILER") + +(defvar *princ-string-limit* 80) + +(defun c1apply (destination args) + (check-args-number 'APPLY args 2) + (let* ((fun (first args)) + (arguments (rest args))) + (cond ((and (consp fun) + (eq (first fun) 'LAMBDA)) + (c1translate destination + (optimize-funcall/apply-lambda (cdr fun) arguments t))) + ((and (consp fun) + (eq (first fun) 'EXT::LAMBDA-BLOCK)) + (setf fun (macroexpand-1 fun)) + (c1translate destination + (optimize-funcall/apply-lambda (cdr fun) arguments t))) + ((and (consp fun) + (eq (first fun) 'FUNCTION) + (consp (second fun)) + (member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK))) + (c1apply destination (list* (second fun) arguments))) + (t + (c1funcall destination (list* '#'APPLY args)))))) + +(defun expand-rplaca/d (car-p cons value env) + (flet ((main-form (car-p cons value) + `(ffi:c-inline (,cons ,value) (:object :object) + :object + ,(if car-p "ECL_CONS_CAR(#0)=#1" "ECL_CONS_CDR(#0)=#1") + :one-liner t))) + (if (policy-assume-right-type env) + (let ((aux (gensym))) + `(let ((,aux ,cons)) + (declare (:read-only ,aux)) + (when (atom ,aux) + (error-not-a-cons ,aux)) + (locally (declare (optimize (safety 0))) + ,(main-form car-p aux value)))) + (main-form car-p cons value)))) + +(defmacro error-not-a-cons (object) + `(c-inline (,object) (:object) :void "FEtype_error_cons(#0);" :one-liner nil)) + +(define-compiler-macro rplaca (&whole form cons value &environment env) + (if (policy-open-code-accessors env) + (expand-rplaca/d (eq (first form) 'rplaca) cons value env) + form)) + +(defconstant +member-expansions+ + '(('EQ . #1="si_memq(#0,#1)") + (#'EQ . #1#) + ('#'EQ . #1#) + ('EQL . #2="ecl_memql(#0,#1)") + (#'EQL . #2#) + ('#'EQL . #2#) + ('EQUAL . #3="ecl_member(#0,#1)") + (#'EQUAL . #3#) + ('#'EQUAL . #3#))) + +(define-compiler-macro member (&whole form value list &rest extra &environment env) + (unless extra + (setf extra '(:test 'EQL))) + (when (and (= (length extra) 2) + (eq (first extra) :test)) + (let ((test (assoc (second extra) + +member-expansions+ :test #'equal))) + (when test + (setf form `(C-INLINE (,value ,list) (:object :object) :object + ,(cdr test) :one-liner t :side-effects nil))))) + form) + +(defconstant +assoc-expansions+ + '(('EQ . #1="ecl_assq(#0,#1)") + (#'EQ . #1#) + ('#'EQ . #1#) + ('EQL . #2="ecl_assql(#0,#1)") + (#'EQL . #2#) + ('#'EQL . #2#) + ('EQUAL . #3="ecl_assoc(#0,#1)") + (#'EQUAL . #3#) + ('#'EQUAL . #3#) + ('EQUALP . #4="ecl_assql(#0,#1)") + (#'EQUALP . #4#) + ('#'EQUALP . #4#))) + +(define-compiler-macro assoc (&whole form value list &rest extra &environment env) + (unless extra + (setf extra '(:test 'EQL))) + (when (and (= (length extra) 2) + (eq (first extra) :test)) + (let ((test (assoc (second extra) + +assoc-expansions+ :test #'equal))) + (when test + (setf form `(C-INLINE (,value ,list) (:object :object) :object + ,(cdr test) :one-liner t :side-effects nil))))) + form) + +(define-compiler-macro nth (&whole form which cons &environment env) + (if (and (policy-open-code-accessors env) (numberp which) (<= 0 which 7)) + (case which + (0 (list 'CAR cons)) + (1 (list 'CADR cons)) + (2 (list 'CADDR cons)) + (3 (list 'CADDDR cons)) + (4 (list 'CAR (list 'CDDDDR cons))) + (5 (list 'CADR (list 'CDDDDR cons))) + (6 (list 'CADDR (list 'CDDDDR cons))) + (7 (list 'CADDDR (list 'CDDDDR cons)))) + form)) + +(define-compiler-macro nthcdr (&whole form which cons &environment env) + (if (and (policy-open-code-accessors env) (numberp which) (<= 0 which 7)) + (case which + (0 cons) + (1 (list 'CDR cons)) + (2 (list 'CDDR cons)) + (3 (list 'CDDDR cons)) + (4 (list 'CDDDDR cons)) + (5 (list 'CDR (list 'CDDDDR cons))) + (6 (list 'CDDR (list 'CDDDDR cons))) + (7 (list 'CDDDR (list 'CDDDDR cons)))) + form)) + +;;---------------------------------------------------------------------- +;; We transform BOOLE into the individual operations, which have +;; inliners +;; + +(define-compiler-macro boole (&whole form op-code op1 op2) + (or (and (constantp op-code) + (case (eval op-code) + (#. boole-clr `(progn ,op1 ,op2 0)) + (#. boole-set `(progn ,op1 ,op2 -1)) + (#. boole-1 `(prog1 ,op1 ,op2)) + (#. boole-2 `(progn ,op1 ,op2)) + (#. boole-c1 `(prog1 (lognot ,op1) ,op2)) + (#. boole-c2 `(progn ,op1 (lognot ,op2))) + (#. boole-and `(logand ,op1 ,op2)) + (#. boole-ior `(logior ,op1 ,op2)) + (#. boole-xor `(logxor ,op1 ,op2)) + (#. boole-eqv `(logeqv ,op1 ,op2)) + (#. boole-nand `(lognand ,op1 ,op2)) + (#. boole-nor `(lognor ,op1 ,op2)) + (#. boole-andc1 `(logandc1 ,op1 ,op2)) + (#. boole-andc2 `(logandc2 ,op1 ,op2)) + (#. boole-orc1 `(logorc1 ,op1 ,op2)) + (#. boole-orc2 `(logorc2 ,op1 ,op2)))) + form)) diff --git a/src/new-cmp/cmpif.lsp b/src/new-cmp/cmpif.lsp new file mode 100644 index 000000000..10aa66e6f --- /dev/null +++ b/src/new-cmp/cmpif.lsp @@ -0,0 +1,118 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPIF Conditionals. + +(in-package "COMPILER") + +(defun c1alternatives (form true-branch false-branch) + (c1with-saved-value (prefix postfix temp form) + (nconc prefix + (if true-branch + (nconc (c1jmp-true true-branch temp) + (if false-branch (c1jmp false-branch))) + (c1jmp-false false-branch temp)) + postfix))) + +(defun c1if-and (forms true-branch false-branch) + (cond ((null forms) + t) + ((null (rest forms)) + (c1condition (first forms) true-branch false-branch)) + ((null false-branch) + (setf false-branch (make-tag :name (gensym "AND-FALSE") :label (next-label))) + (let ((f (c1if-and forms true-branch false-branch))) + (if (atom f) + f + (nconc f (list false-branch))))) + (t + (loop with output = '() + for f on forms + for form = (first f) + do (let ((x (c1condition form + (if (rest f) nil true-branch) + false-branch))) + (cond ((null x) + (return (nreconc output (c1jmp false-branch)))) + ((atom x) + ;; True branch, we do nothing + ) + (t + (setf output (nreconc x output))))) + finally (return (nreverse output)))))) + +(defun c1if-or (forms true-branch false-branch) + (cond ((null forms) + nil) + ((null (rest forms)) + (c1condition (first forms) true-branch false-branch)) + ((null true-branch) + (setf true-branch (make-tag :name (gensym "OR-TRUE") :label (next-label))) + (let ((f (c1if-or forms true-branch false-branch))) + (if (atom f) + f + (nconc f (list true-branch))))) + (t + (loop with output = '() + for f on forms + for form = (first f) + do (let ((x (c1condition form + true-branch + (if (rest f) nil false-branch)))) + (if (listp x) + (setf output (nreconc x output)) + (return (nreconc output (c1jmp true-branch))))) + finally (return (nreverse output)))))) + +(defun c1condition (form true-branch false-branch) + (cond ((constantp form) + (let ((value (cmp-eval form))) + (and value t))) + ((atom form) + (c1alternatives form true-branch false-branch)) + (t + (case (first form) + (AND (c1if-and (rest form) true-branch false-branch)) + (OR (c1if-or (rest form) true-branch false-branch)) + (NOT (check-args-number 'NOT (rest form) 1 1) + (c1condition (second form) false-branch true-branch)) + (otherwise (c1alternatives form true-branch false-branch)))))) + +(defun c1if (destination args) + (check-args-number 'IF args 2 3) + (if (and (eq destination 'TRASH) (= (length args) 2)) + (let* ((tag-false (make-tag :name (gensym "WHEN-EXIT") :label (next-label))) + (true-branch (second args)) + (condition (first args)) + (f (c1condition condition nil tag-false))) + (case f + ((T) (c1translate destination true-branch)) + ((NIL) (c1translate destination nil)) + (otherwise + (nconc f + (c1translate destination true-branch) + (list tag-false))))) + (let* ((tag-true (make-tag :name (gensym "IF-TRUE") :label (next-label))) + (tag-exit (make-tag :name (gensym "IF-EXIT") :label (next-label))) + (false-branch (third args)) + (true-branch (second args)) + (condition (first args)) + (f (c1condition condition tag-true nil))) + (case f + ((NIL) (c1translate destination false-branch)) + ((T) (c1translate destination true-branch)) + (t (nconc f + (c1translate destination false-branch) + (c1jmp tag-exit) + (list tag-true) + (c1translate destination true-branch) + (list tag-exit))))))) diff --git a/src/new-cmp/cmpinit.lsp b/src/new-cmp/cmpinit.lsp new file mode 100644 index 000000000..dd75acaeb --- /dev/null +++ b/src/new-cmp/cmpinit.lsp @@ -0,0 +1,25 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; + +(in-package 'compiler) + +;;; The production version: +(proclaim '(optimize (safety 0) (space 3) (speed 3))) + +(when (member :clos *features*) + (push :ansi *features*)) + +;#-CLOS +(defmacro setf-namep (setf-list) + `(let (setf-symbol) + (and (consp ,setf-list) + (= 2 (length ,setf-list)) + (eq (car ,setf-list) 'setf) + (setq setf-symbol (get (second ,setf-list) 'sys::setf-symbol)) + (symbolp setf-symbol) + setf-symbol))) + +;;; Disable PDE facilities within LISP kernel: +(setq *features* (delete ':pde *features*)) +;;; Disable record-source-pathname within LISP kernel: +(defmacro record-source-pathname (x y)) diff --git a/src/new-cmp/cmpinline.lsp b/src/new-cmp/cmpinline.lsp new file mode 100644 index 000000000..e7a459451 --- /dev/null +++ b/src/new-cmp/cmpinline.lsp @@ -0,0 +1,185 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPINLINE Open coding optimizer. + +(in-package "COMPILER") + +;;; +;;; inline-function: +;;; locs are typed locs as produced by inline-args +;;; returns NIL if inline expansion of the function is not possible +;;; +(defun inline-function (destination fname arg-types return-type + &optional (return-rep-type 'any)) + ;; Those functions that use INLINE-FUNCTION must rebind + ;; the variable *INLINE-BLOCKS*. + (and (inline-possible fname) + (not (get-sysprop fname 'C2)) + (let* ((dest-rep-type (loc-representation-type destination)) + (dest-type (rep-type->lisp-type dest-rep-type)) + (ii (get-inline-info fname arg-types return-type return-rep-type))) + ii))) + +(defun apply-inline-info (ii inlined-locs) + (let* ((arg-types (inline-info-arg-types ii)) + (out-rep-type (inline-info-return-rep-type ii)) + (out-type (inline-info-return-type ii)) + (side-effects-p (function-may-have-side-effects (inline-info-name ii))) + (fun (inline-info-expansion ii)) + (one-liner (inline-info-one-liner ii))) + (produce-inline-loc inlined-locs arg-types (list out-rep-type) + fun side-effects-p one-liner))) + +(defun choose-inline-info (ia ib return-type return-rep-type) + (cond + ;; Only accept inliners that have the right rep type + ((not (or (eq return-rep-type 'any) + (eq return-rep-type :void) + (let ((info-type (inline-info-return-rep-type ib))) + (or (eq return-rep-type info-type) + ;; :bool can be coerced to any other location type + (eq info-type :bool))))) + ia) + ((null ia) + ib) + ;; Keep the first one, which is typically the least safe but fastest. + ((equal (inline-info-arg-types ia) (inline-info-arg-types ib)) + ia) + ;; More specific? + ((every #'type>= (inline-info-arg-types ia) (inline-info-arg-types ib)) + ib) + ;; Keep the first one, which is typically the least safe but fastest. + (t + ia))) + +(defun get-inline-info (fname types return-type return-rep-type) + (declare (si::c-local)) + (let ((output nil)) + (dolist (x *inline-functions*) + (when (eq (car x) fname) + (let ((other (inline-type-matches (cdr x) types return-type))) + (setf output (choose-inline-info output other return-type return-rep-type))))) + (unless (safe-compile) + (dolist (x (get-sysprop fname ':INLINE-UNSAFE)) + (let ((other (inline-type-matches x types return-type))) + (when other + (setf output (choose-inline-info output other return-type return-rep-type)))))) + (dolist (x (get-sysprop fname ':INLINE-SAFE)) + (let ((other (inline-type-matches x types return-type))) + (when other + (setf output (choose-inline-info output other return-type return-rep-type))))) + (dolist (x (get-sysprop fname ':INLINE-ALWAYS)) + (let ((other (inline-type-matches x types return-type))) + (when other + (setf output (choose-inline-info output other return-type return-rep-type))))) + output)) + +(defun to-fixnum-float-type (type) + (dolist (i '(FIXNUM DOUBLE-FLOAT SINGLE-FLOAT + #+short-float SHORT-FLOAT #+long-float LONG-FLOAT) + nil) + (when (type>= i type) + (return i)))) + +(defun maximum-float-type (t1 t2) + (cond ((null t1) + t2) + #+long-float + ((or (eq t1 'LONG-FLOAT) (eq t2 'LONG-FLOAT)) + 'LONG-FLOAT) + ((or (eq t1 'DOUBLE-FLOAT) (eq t2 'DOUBLE-FLOAT)) + 'DOUBLE-FLOAT) + ((or (eq t1 'SINGLE-FLOAT) (eq t2 'SINGLE-FLOAT)) + 'SINGLE-FLOAT) + #+short-float + ((or (eq t1 'SHORT-FLOAT) (eq t2 'SHORT-FLOAT)) + 'SHORT-FLOAT) + (T + 'FIXNUM))) + +(defun inline-type-matches (inline-info arg-types return-type) + (let* ((rts nil) + (number-max nil)) + ;; + ;; Check that the argument types match those of the inline expression + ;; + (do* ((arg-types arg-types (cdr arg-types)) + (types (inline-info-arg-types inline-info) (cdr types))) + ((or (endp arg-types) (endp types)) + (when (or arg-types types) + (return-from inline-type-matches nil))) + (let* ((arg-type (first arg-types)) + (type (first types))) + (cond ((eq type 'FIXNUM-FLOAT) + (let ((new-type (to-fixnum-float-type arg-type))) + (unless new-type + (return-from inline-type-matches nil)) + (push new-type rts) + (setq number-max (maximum-float-type number-max new-type)))) + ((type>= type arg-type) + (push type rts)) + (t (return-from inline-type-matches nil))))) + ;; + ;; Now there is an optional check of the return type. This check is + ;; only used when enforced by the inliner. + ;; + (when (or (eq (inline-info-return-rep-type inline-info) :bool) + (null (inline-info-exact-return-type inline-info)) + (let ((inline-return-type (inline-info-return-type inline-info))) + (if number-max + ;; for arithmetic operators we take the maximal + ;; type as possible result type. Note that FIXNUM + ;; is not an option, because the product, addition + ;; or difference of fixnums may be a larger + ;; integer. + (and (setf number-max (if (eq number-max 'fixnum) + 'integer + number-max)) + (type>= inline-return-type number-max) + (type>= number-max return-type)) + ;; no contravariance + (type>= inline-return-type return-type)))) + (let ((inline-info (copy-structure inline-info))) + (setf (inline-info-arg-types inline-info) + (nreverse rts)) + inline-info)))) + +(defun close-inline-blocks () + (dotimes (i *inline-blocks*) (declare (fixnum i)) (wt #\}))) + +(defun form-causes-side-effect (form) + (if (listp form) + (some #'form-causes-side-effect form) + (case (c1form-name form) + ((LOCATION VAR SYS:STRUCTURE-REF #+clos SYS:INSTANCE-REF) + nil) + (CALL-GLOBAL + (let ((fname (c1form-arg 0 form)) + (args (c1form-arg 1 form))) + (or (function-may-have-side-effects fname) + (args-cause-side-effect args)))) + (t t)))) + +(defun args-cause-side-effect (forms) + (some #'form-causes-side-effect forms)) + +(defun function-may-have-side-effects (fname) + (declare (si::c-local)) + (not (get-sysprop fname 'no-side-effects))) + +(defun function-may-change-sp (fname) + (not (or (get-sysprop fname 'no-side-effects) + (get-sysprop fname 'no-sp-change)))) + +(defun function-can-be-evaluated-at-compile-time (fname) + (get-sysprop fname 'pure)) diff --git a/src/new-cmp/cmplam.lsp b/src/new-cmp/cmplam.lsp new file mode 100644 index 000000000..719860eab --- /dev/null +++ b/src/new-cmp/cmplam.lsp @@ -0,0 +1,529 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPLAM Lambda expression. + +(in-package "COMPILER") + +;;; 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. + +(defun c1lambda-doc (form) + (second (c1form-args form))) + +(defun c1lambda-body (form) + (third (c1form-args form))) + +(defun c1lambda-list (form) + (first (c1form-args form))) + +(defun fun-narg-p (fun) + (not (fun-fixed-narg fun))) + +(defun fun-volatile-p (fun) + (loop for f in (fun-lambda fun) + thereis (and (not (tag-p f)) (eq (c1form-name f) 'frame-set)))) + +(defun fun-fixed-narg (fun) + "Returns true if the function has a fixed number of arguments and it is not a closure. +The function thus belongs to the type of functions that ecl_make_cfun accepts." + (let (narg) + (and (not (eq (fun-closure fun) 'CLOSURE)) + (= (fun-minarg fun) (setf narg (fun-maxarg fun))) + (<= narg si::c-arguments-limit) + narg))) + +(defun add-referred-variables-to-function (fun var-list) + (setf (fun-referred-vars fun) + (set-difference (union (fun-referred-vars fun) var-list) + (fun-local-vars fun))) + fun) + +(defun c1compile-function (lambda-list-and-body &key (fun (make-fun)) + (name (fun-name fun)) (CB/LB 'CB)) + (setf (fun-name fun) name + (fun-parent fun) *current-function*) + (when *current-function* + (push fun (fun-child-funs *current-function*))) + (let* ((*lcl* 0) + (*last-label* 0) + (*current-function* fun)) + (c1lambda-expr fun lambda-list-and-body CB/LB) + (c1set-function-closure-type fun) + (setf (fun-last-lcl fun) *lcl* + (fun-last-label fun) *last-label*)) + fun) + +(defun cmp-process-lambda-list (list) + (handler-case (si::process-lambda-list list 'function) + (error (c) (cmperr "Illegal lambda list ~S" list)))) + +(defun c1set-function-properties (fun minargs maxargs declarations env) + (let* ((name (fun-name fun)) + (global-p (and (assoc 'SI::C-GLOBAL declarations) t)) + (no-entry-p (and (or (assoc 'SI::C-LOCAL declarations) + #+ecl-min + (member name c::*in-all-symbols-functions*)) + t)) + (debug (cmp-env-optimization 'debug env)) + cfun + exported-p + no-entry-p) + (if global-p + (multiple-value-setq (cfun exported-p) (exported-fname name)) + (setf cfun (next-cfun "LC~D~A" name) exported-p nil)) + (when (and no-entry-p (>= debug 2)) + (setf no-entry-p nil) + (cmpnote "Ignoring SI::C-LOCAL declaration for ~A when DEBUG is ~D" + name debug)) + (setf (fun-name fun) name + (fun-debug fun) debug + (fun-minarg fun) minargs + (fun-maxarg fun) maxargs + (fun-global fun) global-p + (fun-cfun fun) cfun + (fun-exported fun) exported-p + (fun-no-entry fun) no-entry-p + (fun-closure fun) nil + (fun-description fun) name))) + +(defun c1set-function-closure-type (fun) + (let ((children (fun-child-funs fun))) + ;; + ;; Ensure all variables referenced by children functions + ;; are registered with this function... + ;; + (reduce #'add-referred-variables-to-function + (mapcar #'fun-referred-vars children) + :initial-value fun) + (reduce #'add-referred-variables-to-function + (mapcar #'fun-referred-vars (fun-referred-funs fun)) + :initial-value fun) + ;; + ;; ...and then compute closure type for function and children + ;; + (do ((finish nil)) + (finish) + (setf finish t) + (dolist (f children) + (when (compute-fun-closure-type f) + (setf finish nil)))) + (compute-fun-closure-type fun) + (when (fun-global fun) + (when (fun-closure fun) + (cmperr "Function ~A is global but is closed over some variables.~%~{~A ~}" + (fun-name fun) (mapcar #'var-name (fun-referred-vars fun)))) + (new-defun fun (fun-no-entry fun))))) + + +(defun c1lambda-expr (fun lambda-expr CB/LB + &aux doc body ss is ts + other-decls + nargs + varargs + minargs + maxargs + compiled-body + (name (fun-name fun)) + (block-name (si::function-block-name name)) + (old-env *cmp-env*) + (*cmp-env* (cmp-env-mark CB/LB)) + (*permanent-data* t)) + (declare (si::c-local)) + + (cmpck (endp lambda-expr) + "The lambda expression ~s is illegal." (cons 'LAMBDA lambda-expr)) + + (multiple-value-setq (body ss ts is other-decls doc all-declarations) + (c1body (cdr lambda-expr) t)) + + (when block-name (setq body (list (cons 'BLOCK (cons block-name body))))) + + (multiple-value-bind (requireds optionals rest key-flag keywords + allow-other-keys aux-vars) + (cmp-process-lambda-list (car lambda-expr)) + + ;; We need to add the declarations right here, because they should + ;; affect _all_ statement in the function, including those in &optional, + ;; &key arguments, etc. + (setf *cmp-env* (add-declarations other-decls *cmp-env*)) + + (setq minargs (pop requireds) + maxargs (if (or rest (cdr keywords) allow-other-keys) + call-arguments-limit + (+ minargs (first optionals))) + optionals (rest optionals)) + + ;; At this point we know a lot about the function and can complete its + ;; properties, including the C name, number of arguments, etc. + (c1set-function-properties fun minargs maxargs other-decls *cmp-env*) + + ;; + ;; Compile statements for processing required, optionals, rest and + ;; keyword arguments. + ;; + (setf compiled-body (c1requireds requireds ss is ts)) + (let* ((nkeys (pop keywords))) + (when (or optionals rest keywords) + (setf nargs (make-var :name +nargs-var+ :type 'FIXNUM + :loc '(VV "narg" 0) + :kind :fixnum) + varargs (if (and (not (or rest keywords allow-other-keys)) + (< maxargs 30)) + +simple-va-args+ + +cl-va-args+) + varargs (make-var :name varargs :type 'T + :loc `(VV ,varargs 0) + :kind :OBJECT) + rest (when rest + (let ((rest-var (c1make-var rest ss is ts))) + (cmp-env-register-var rest-var) + rest-var)) + compiled-body (nconc (c1varargs-bind-op nargs varargs + minargs maxargs nkeys + (policy-check-nargs)) + compiled-body + (c1optionals optionals nargs varargs ss is ts))) + (when (or rest keywords allow-other-keys) + (setf compiled-body (nconc compiled-body + (c1keywords rest keywords allow-other-keys + nargs varargs + ss is ts)))) + (setf compiled-body (nconc compiled-body + (c1varargs-unbind-op nargs varargs + minargs maxargs nkeys))))) + + ;; Optional type checks for function arguments whose types have been + ;; declared. This is not mandated by the standard but it is a common practice + ;; begun by CMUCL & SBCL. + (setf compiled-body (nconc compiled-body + (c1optional-type-checks requireds optionals keywords + ts other-decls))) + + + ;; After creating all variables and processing the initalization + ;; forms, we wil process the body. However, all free declarations, + ;; that is declarations which do not refer to the function + ;; arguments, have to be applied to the body. At the same time, we + ;; replace &aux variables with a LET* form that defines them. + (let* ((declarations other-decls) + (new-variables (cmp-env-new-variables *cmp-env* old-env)) + (new-variable-names (mapcar #'var-name new-variables))) + (when (setq ss (set-difference ss new-variable-names)) + (push `(special ,@ss) declarations)) + (when (setq is (set-difference is new-variable-names)) + (push `(ignorable ,@is) declarations)) + (loop for (var . type) in ts + unless (member var new-variable-names) + do (push `(type ,type ,var) declarations)) + + (let ((*cmp-env* (cmp-env-copy))) + (when (policy-debug-variable-bindings) + (cmp-env-register-cleanup (c1debug-env-pop-vars requireds) *cmp-env*)) + + (setq body (c1lambda-body new-variables aux-vars declarations body)) + + (when (policy-debug-ihs-frame) + (setf body (nconc (c1debug-env-open block-name) + body + (c1debug-env-close block-name)))) + + (let* ((bound-variables (set-difference new-variables requireds)) + (non-special-bound-variables (remove-if #'global bound-variables))) + (setq compiled-body (nconc (c1bind non-special-bound-variables) + compiled-body + body + (c1unbind bound-variables) + (c1set-loc 'ACTUAL-RETURN 'VALUES+VALUE0))))) + + (setf compiled-body (nconc (c1function-prologue fun) + compiled-body + (c1function-epilogue fun))) + + ;; Assign locations to each variable that is not closed over + (dolist (var new-variables) + (check-vref var)) + + (setf (fun-lambda fun) compiled-body + (fun-doc fun) doc + (fun-lambda-list fun) (list requireds optionals rest + key-flag keywords allow-other-keys))))) + +(defun c1lambda-body (new-variables aux-vars declarations body) + (cond ((and new-variables (policy-debug-variable-bindings)) + (let* ((cleanup (c1debug-env-pop-vars new-variables)) + (*cmp-env* (cmp-env-register-cleanup cleanup (cmp-env-copy)))) + (nconc (c1debug-env-push-vars new-variables) + (c1lambda-body nil aux-vars declarations body) + (c1debug-env-pop-vars new-variables t)))) + (aux-vars + (c1translate 'VALUES+VALUE0 + `(let* ,(loop for specs on aux-vars by #'cddr + for var = (first specs) + for init = (second specs) + collect (if init (list var init) var)) + (declare ,@declarations) + ,@body))) + (declarations + (c1translate 'VALUES+VALUE0 `(locally (declare ,@declarations) + ,@body))) + (t + (c1progn 'VALUES+VALUE0 body)))) + +(defconstant +simple-va-args+ (make-symbol "args")) +(defconstant +cl-va-args+ (make-symbol "cl_args")) +(defconstant +nargs-var+ (make-symbol "narg")) + +(defun simple-varargs-loc-p (var) + (string= (var-name var) +simple-va-args+)) + +(defun c1requireds (requireds ss is ts) + (loop for i from 1 + for spec on requireds + for name = (first spec) + for var = (c1make-var name ss is ts) + do (setf (first spec) var) + do (push var (fun-local-vars *current-function*)) + do (cmp-env-register-var var) + nconc (c1bind-required var (next-lcl)))) + +(defun c1keywords (rest-var keywords allow-other-keys nargs varargs ss is ts) + (loop with keywords-list = '() + with output = '() + with nkeys = (/ (length keywords) 4) + for spec on keywords by #'cddddr + for i from 0 + for key = (first spec) + for name = (second spec) + for var = (c1make-var name ss is ts) + for init = (third spec) + for flag = (fourth spec) + for flag-var = (and flag (c1make-var flag ss is ts)) + do (let* ((found-tag (make-tag :name (gensym "KEY-FOUND") :label (next-label))) + (next-tag (make-tag :name (gensym "KEY-NEXT") :label (next-label)))) + (push key keywords-list) + (setf output (nconc output + (c1jmp-true found-tag `(KEYVARS ,(+ nkeys i))) + (c1maybe-bind-special var init) + (and flag + (setf flag (c1make-var flag ss is ts)) + (c1maybe-bind-special-op flag t)) + (c1jmp next-tag) + (list found-tag) + (c1maybe-bind-special-op var `(KEYVARS ,i)) + (and flag + (c1maybe-bind-special-op flag t)) + (list next-tag))) + (setf (first spec) var) + (push var (fun-local-vars *current-function*)) + (cmp-env-register-var var) + (when flag + (setf (fourth spec) flag) + (push flag (fun-local-vars *current-function*)) + (cmp-env-register-var flag))) + finally (return (nconc (c1varargs-rest-op rest-var nargs varargs i + (and keywords-list + (add-keywords (nreverse keywords-list))) + allow-other-keys) + output)))) + +(defun c1optionals (optionals nargs varargs ss is ts) + (unless optionals + (return-from c1optionals nil)) + (loop with output = '() + for spec on optionals by #'cdddr + for name = (first spec) + for init = (second spec) + for var = (c1make-var name ss is ts) + for flag = (third spec) + do (let* ((found-tag (make-tag :name (gensym "KEY-FOUND") :label (next-label))) + (next-tag (make-tag :name (gensym "KEY-NEXT") :label (next-label)))) + (setf output (nconc output + (c1jmp-true found-tag nargs) + (c1maybe-bind-special var init) + (and flag + (setf flag (c1make-var flag ss is ts)) + (c1maybe-bind-special-op flag t)) + (c1jmp next-tag) + (list found-tag) + (c1varargs-pop-op var nargs varargs) + (and flag + (c1maybe-bind-special-op flag t)) + (list next-tag)) + (first spec) var) + (push var (fun-local-vars *current-function*)) + (cmp-env-register-var var) + (when flag + (setf (third spec) flag) + (push flag (fun-local-vars *current-function*)) + (cmp-env-register-var flag))) + finally (return output))) + +(defun c1optional-type-checks (requireds optionals keywords ts other-decls) + ;; We generate automatic type checks for function arguments that + ;; are declared These checks can be deactivated by appropriate + ;; safety settings which are checked by OPTIONAL-CHECK-TYPE. Note + ;; that not all type declarations can be checked (take for instance + ;; (type (function (t t) t) foo)) We let OPTIONAL-CHECK-TYPE do the + ;; job. + (when (policy-automatic-check-type-p) + (let* ((type-checks (append requireds + (loop for spec on optionals by #'cdddr + collect (first spec)) + (loop for spec on keywords by #'cddddr + collect (first spec)))) + (pairs (loop for var in type-checks + nconc (let* ((name (var-name var)) + (type (assoc name ts))) + (when type + (loop for decl in other-decls + unless (and (consp decl) + (eq (first decl) 'si::no-check-type) + (member name (rest decl))) + do (return (list (list name (cdr type)))))))))) + (when pairs + (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}." + (fun-name *current-function*) + (mapcar #'var-name type-checks)) + (c1translate 'trash + (loop for pair in (nreverse pairs) + collect `(optional-check-type ,@pair))))))) + +#| Steps: + 1. defun creates declarations for requireds + va_alist + 2. c2lambda-expr adds declarations for: + unboxed requireds + lexical optionals (+ supplied-p), rest, keywords (+ supplied-p) + Lexical optionals and keywords can be unboxed if: + a. there is more then one reference in the body + b. they are not referenced in closures + 3. binding is performed for: + special or unboxed requireds + optionals, rest, keywords +|# + +(defun optimize-funcall/apply-lambda (lambda-form arguments apply-p + &aux body apply-list apply-var + let-vars extra-stmts all-keys) + (multiple-value-bind (requireds optionals rest key-flag keywords + allow-other-keys aux-vars) + (cmp-process-lambda-list (car lambda-form)) + (when apply-p + (setf apply-list (first (last arguments)) + apply-var (gensym) + arguments (butlast arguments))) + (setf arguments (copy-list arguments)) + (do ((scan arguments (cdr scan))) + ((endp scan)) + (let ((form (first scan))) + (unless (constantp form) + (let ((aux-var (gensym))) + (push `(,aux-var ,form) let-vars) + (setf (car scan) aux-var))))) + (when apply-var + (push `(,apply-var ,apply-list) let-vars)) + (dolist (i (cdr requireds)) + (push (list i + (cond (arguments + (pop arguments)) + (apply-p + `(if ,apply-var + (pop ,apply-var) + (si::dm-too-few-arguments))) + (t + (cmperr "Too few arguments for lambda form ~S" + (cons 'LAMBDA lambda-form))))) + let-vars)) + (do ((scan (cdr optionals) (cdddr scan))) + ((endp scan)) + (let ((opt-var (first scan)) + (opt-flag (third scan)) + (opt-value (second scan))) + (cond (arguments + (setf let-vars + (list* `(,opt-var ,(pop arguments)) + `(,opt-flag t) + let-vars))) + (apply-p + (setf let-vars + (list* `(,opt-var (if ,apply-var + (pop ,apply-var) + ,opt-value)) + `(,opt-flag ,apply-var) + let-vars))) + (t + (setf let-vars + (list* `(,opt-var ,opt-value) + `(,opt-flag nil) + let-vars)))))) + (when (or key-flag allow-other-keys) + (unless rest + (setf rest (gensym)))) + (when rest + (push `(,rest ,(if arguments + (if apply-p + `(list* ,@arguments ,apply-var) + `(list ,@arguments)) + (if apply-p apply-var nil))) + let-vars)) + (do ((scan (cdr keywords) (cddddr scan))) + ((endp scan)) + (let ((keyword (first scan)) + (key-var (second scan)) + (key-value (third scan)) + (key-flag (or (fourth scan) (gensym)))) + (push keyword all-keys) + (setf let-vars + (list* + `(,key-var (if (eq ,key-flag 'si::failed) ,key-value ,key-flag)) + `(,key-flag (si::search-keyword ,rest ,keyword)) + let-vars)) + (when (fourth scan) + (push `(setf ,key-flag (not (eq ,key-flag 'si::failed))) + extra-stmts)))) + (when (and key-flag (not allow-other-keys)) + (push `(si::check-keyword ,rest ',all-keys) extra-stmts)) + `(let* ,(nreverse (delete-if-not #'first let-vars)) + ,@(multiple-value-bind (decl body) + (si::find-declarations (rest lambda-form)) + (append decl extra-stmts body))))) diff --git a/src/new-cmp/cmplet.lsp b/src/new-cmp/cmplet.lsp new file mode 100644 index 000000000..fbcac80fa --- /dev/null +++ b/src/new-cmp/cmplet.lsp @@ -0,0 +1,140 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPLET Let and Let*. +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; ECL is free software; you can redistribute it and/or modify it +;;;; under the terms of the GNU Library General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defun c1let (destination args) + (c1let/let* destination T args)) + +(defun c1let* (destination args) + (c1let/let* destination NIL args)) + +(defun c1let/let* (destination psetq-p args) + (check-args-number (if psetq-p 'LET 'LET*) args 1) + (multiple-value-bind (body ss ts is other-decls) + (c1body (rest args) nil) + (let* ((*cmp-env* (cmp-env-copy *cmp-env*)) + ;; If there is only one variable binding, we use LET* instead of LET + (let-bindings (first args)) + (psetq-p (and psetq-p (rest let-bindings))) + (var-form-pairs (parse-let let-bindings ss is ts other-decls)) + (body (create-temps-for-specials var-form-pairs body psetq-p)) + (compiled-pairs (compile-let-forms var-form-pairs psetq-p + ss is ts other-decls)) + (compiled-body (c1decl-body destination other-decls body)) + (filtered-pairs (delete-replaceable-vars compiled-pairs))) + (loop with locals = '() + with specials = '() + with forms = '() + with extras = '() + for (v . f) in filtered-pairs + do (if (member (var-kind v) '(SPECIAL GLOBAL)) + (push v specials) + (push v locals)) + do (setf extras (nconc extras f)) + finally (return (nconc (c1bind locals) + extras + compiled-body + (c1unbind (append locals specials))) + ))))) + +(defun parse-let (var-assignment-pairs ss is ts other-decls) + (flet ((in-read-only-decl-p (v other-decls) + (dolist (i other-decls nil) + (when (and (eq (car i) :READ-ONLY) + (member v (rest i))) + (return t))))) + (loop for x in var-assignment-pairs + collect (let (name form) + (cond ((symbolp x) + (setf name x + form nil + x nil)) + ((not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) + (cmperr "Syntax error in LET/LET* variable binding~&~8T~S" x)) + (t + (setf name (first x) + form (rest x)))) + (let ((v (c1make-var name ss is ts))) + (when (in-read-only-decl-p name other-decls) + (setf (var-read-only-p v) t)) + (cons v (if form (first form) (default-init v)))))))) + +(defun create-temps-for-specials (var-form-pairs body psetq-p) + ;; In a LET form, when special variables are bound they cause a side + ;; effect. In order to keep the assignments really parallel, we have + ;; to save the temporal values. + (when psetq-p + (loop with specials = '() + for pair in var-form-pairs + for var = (car pair) + for form = (cdr pair) + when (member (var-kind var) '(SPECIAL GLOBAL)) + collect (let ((aux (c1make-var (gensym) nil nil nil))) + (setf (car pair) aux) + (push (list (var-name var) (var-name aux)) specials)) + finally (when specials + (setf body `((let* ,specials + (declare (special ,@(mapcar #'car specials))) + ,@body)))))) + body) + +(defun compile-let-forms (var-form-pairs psetq-p ss is ts other-decls) + ;; Compile the assigned forms. If the variables are sequentially + ;; assigned, as in LET*, they are added one by one to the + ;; environment. Otherwise PSETQ-P = T and the forms are compiled in + ;; an environment without the variables. + ;; For read only variables, we can change their values here. + (loop with variable-names = nil + for pair in var-form-pairs + for v = (car pair) + for name = (var-name v) + for form = (cdr pair) + for binding-type = (if (global v) 'c1bind-special 'c1translate) + for compiled-form = (funcall binding-type v form) + do (setf (cdr pair) compiled-form + variable-names (cons name variable-names)) + do (unless psetq-p + (cmp-env-register-var v)) + finally + (progn + (when psetq-p + (loop for (v . form) in var-form-pairs + do (cmp-env-register-var v))) + (check-vdecl variable-names ts is) + (c1declare-specials ss))) + var-form-pairs) + +(defun delete-replaceable-vars (var-form-pairs) + ;; Delete pairs of variables that are never used or which can + ;; be replaced by their values. + (loop for pair in var-form-pairs + for v = (car pair) + for form = (cdr pair) + unless (check-unused-variable-definition v form) + ;;Force unboxing: + ;;do (when (member-type (var-type v) + ;; '(FIXNUM CHARACTER DOUBLE-FLOAT SINGLE-FLOAT)) + ;; (incf (var-ref v))) + collect (progn (check-vref v) pair))) + +(defun check-unused-variable-definition (var form) + ;; Check whether the variable is ever read and, if not, whether the + ;; initialization form can be completely deleted + (when (unused-variable-p var) + (setf (var-kind var) 'DISCARDED) + (unless (form-causes-side-effect form) + (cmpnote "Deleted unused variable ~A and its initialization form." (var-name var)) + t))) + diff --git a/src/new-cmp/cmploc.lsp b/src/new-cmp/cmploc.lsp new file mode 100644 index 000000000..73b8db47a --- /dev/null +++ b/src/new-cmp/cmploc.lsp @@ -0,0 +1,248 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPLOC Set-loc and Wt-loc. + +(in-package "COMPILER") + +;;; Valid locations are: +;;; NIL +;;; T +;;; fixnum +;;; VALUE0 +;;; VALUES +;;; var-object +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( VV-temp vv-index ) +;;; ( LCL lcl [representation-type]) local variable, type unboxed +;;; ( TEMP temp ) local variable, type object +;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments +;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed +;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function +;;; ( C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( CAR lcl ) +;;; ( CDR lcl ) +;;; ( CADR lcl ) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) +;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( KEYVARS n ) +;;; ( THE type loc ) +;;; VA-ARG +;;; CL-VA-ARG + +;;; Valid *DESTINATION* locations are: +;;; +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. +;;; var-object +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) + +(defun tmp-destination (loc) + (case loc + (VALUES 'VALUES) + (TRASH 'TRASH) + (T 'RETURN))) + +(defun loc-has-side-effects (loc) + (if (atom loc) + ;; Needed to produce calls to ecl_symbol_value() for global + ;; variables. These calls can detect whether a variable is + ;; boudp and since the error is a side effect, they can not + ;; be suppressed. + (and (var-p loc) (global loc) + (policy-global-var-checking)) + (case (first loc) + ((CALL CALL-NORMAL CALL-INDIRECT) T) + (FFI:C-INLINE (fifth loc)) + (ACTUAL-RETURN T) + (FDEFINITION (policy-global-function-checking)) + (otherwise nil)))) + +;;; ------------------------------------------------------------------ +;;; WRITING C/C++ REPRESENTATIONS LOCATIONS +;;; + +(defun wt-loc (loc &aux fd) + (cond ((consp loc) + (unless (setq fd (gethash (first loc) +c2-wt-loc-table+)) + (error "Unknown or invalid location ~A" loc)) + (apply fd (rest loc))) + ((var-p loc) + (wt-var loc)) + ((setq fd (gethash loc +c2-wt-loc-table+)) + (funcall fd)) + (t + (error "Unknown or invalid location ~A" loc)))) + +(defun wt-nil-loc () (wt "Cnil")) + +(defun wt-t-loc () (wt "Ct")) + +(defun wt-value0-loc () (wt "value0")) + +(defun wt-values-loc () (wt "cl_env_copy->values[0]")) + +(defun wt-va-arg-loc () (wt "(narg--,va_arg(args,cl_object))")) + +(defun wt-cl-va-arg-loc () (wt "(narg--,cl_va_arg(cl_args))")) + +(defun last-call-p () + (member *exit* + '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT + RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT))) + +(defun wt-car (loc) (wt "CAR(" loc ")")) + +(defun wt-cdr (loc) (wt "CDR(" loc ")")) + +(defun wt-cadr (loc) (wt "CADR(" loc ")")) + +(defun lcl-name (lcl) + (if (minusp lcl) + (format nil "X~D" lcl) + (format nil "V~D" lcl))) + +(defun wt-lcl (lcl) + (cond ((not (numberp lcl)) (baboon)) + ((minusp lcl) (wt "X" (- lcl))) + (t (wt "V" lcl)))) + +(defun wt-vv (vv &optional value) + (if (numberp vv) + (wt "VV[" vv "]") + (wt vv))) + +(defun wt-vv-temp (vv &optional value) + (if (numberp vv) + (wt "VVtemp[" vv "]") + (wt vv))) + +(defun wt-lcl-loc (lcl &optional type) + (wt-lcl lcl)) + +(defun wt-temp (temp) + (wt "T" temp)) + +(defun wt-number (value &optional vv) + (wt value)) + +(defun wt-character (value &optional vv) + (wt (format nil "'\\~O'" value))) + +(defun wt-value (i) (wt "cl_env_copy->values[" i "]")) + +(defun wt-keyvars (i) (wt "keyvars[" i "]")) + +(defun loc-refers-to-special (loc) + (cond ((var-p loc) + (member (var-kind loc) '(SPECIAL GLOBAL))) + ((atom loc) + nil) + ((eq (setf loc (first loc)) 'BIND) + t) + ((eq loc 'C-INLINE) + t) ; We do not know, so guess yes + (t nil))) + +(defun values-loc (n) + (list 'VALUE n)) + +(defun wt-the-loc (type loc) + (wt-loc loc)) + +;;; ------------------------------------------------------------------ +;;; ASSIGNING TO LOCATIONS +;;; + +(defun uses-values (loc) + (and (consp loc) + (or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq) + (and (eq (car loc) 'C-INLINE) + (eq (sixth loc) 'VALUES))))) + +(defun set-loc (loc destination) + (unless (eql destination loc) + (cond ((var-p destination) + (set-var loc destination)) + ((atom destination) + (let ((fd (gethash destination +c2-set-loc-table+))) + (cond (fd + (funcall fd loc)) + ((setq fd (gethash destination +c2-wt-loc-table+)) + (wt-nl) (funcall fd) (wt "= ") + (wt-coerce-loc (loc-representation-type destination) loc) + (wt ";")) + (t + (error "No known way to assign to location ~A" + destination))))) + (t + (let* ((name (first destination)) + (fd (gethash name +c2-set-loc-table+))) + (cond (fd + (apply fd loc (rest destination))) + ((setq fd (gethash name +c2-wt-loc-table+)) + (wt-nl) (apply fd (rest destination)) (wt "= ") + (wt-coerce-loc (loc-representation-type destination) loc) + (wt ";")) + (t + (error "No known way to assign to location ~A" + destination)))))))) + +(defun set-values-loc (loc) + (cond ((eq loc 'VALUES)) + ((uses-values loc) + (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) (wt ";")) + (t + (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) + (wt ";") + (wt-nl "cl_env_copy->nvalues=1;")))) + +(defun set-values+value0-loc (loc) + (cond ((eq loc 'VALUES) + (wt-nl "value0=cl_env_copy->values[0];")) + ((uses-values loc) + (wt-nl "value0=")(wt-coerce-loc :object loc) (wt ";")) + (t + (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";") + (wt-nl "cl_env_copy->nvalues=1;")))) + +(defun set-value0-loc (loc) + (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) + +(defun set-return-loc (loc) + (set-values+value0-loc loc)) + +(defun set-actual-return-loc (loc) + (set-loc loc 'VALUES+VALUE0) + (wt-nl "return value0;")) + +(defun set-trash-loc (loc) + (when (loc-has-side-effects loc) + (wt-nl "(void)(" loc ");"))) + +(defun set-the-loc (value type loc) + (set-loc value loc)) diff --git a/src/new-cmp/cmpmac.lsp b/src/new-cmp/cmpmac.lsp new file mode 100644 index 000000000..e470b9e02 --- /dev/null +++ b/src/new-cmp/cmpmac.lsp @@ -0,0 +1,211 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;; ---------------------------------------------------------------------- +;;; Macros only used in the code of the compiler itself: + +(in-package "COMPILER") +(import 'sys::arglist "COMPILER") + +;; ---------------------------------------------------------------------- +;; CACHED FUNCTIONS +;; +(defmacro defun-cached (name lambda-list test &body body) + (let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*") + (symbol-package name))) + (reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE") + (symbol-package name))) + (hash-function (case test + (EQ 'SI::HASH-EQ) + (EQL 'SI::HASH-EQL) + (EQUAL 'SI::HASH-EQUAL) + (t (setf test 'EQUALP) 'SI::HASH-EQUALP))) + (hash (gensym "HASH"))) + `(progn + (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil)) + (defun ,reset-name () + (make-array 1024 :element-type t :adjustable nil)) + (defun ,name ,lambda-list + (flet ((,name ,lambda-list ,@body)) + (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) + (elt (aref ,cache-name hash))) + (declare (type (integer 0 1023) hash) + (type (array t (*)) ,cache-name)) + (if (and elt ,@(loop for arg in lambda-list + collect `(,test (pop (the cons elt)) ,arg))) + (first (the cons elt)) + (let ((output (,name ,@lambda-list))) + (setf (aref ,cache-name hash) (list ,@lambda-list output)) + output)))))))) + +(defmacro defun-equal-cached (name lambda-list &body body) + `(defun-cached ,name ,lambda-list equal ,@body)) + +;;; ---------------------------------------------------------------------- +;;; CONVENIENCE FUNCTIONS / MACROS +;;; + +(defun-cached env-var-name (n) eql + (format nil "env~D" n)) + +(defun-cached lex-env-var-name (n) eql + (format nil "lex~D" n)) + +(defun same-fname-p (name1 name2) (equal name1 name2)) + +(defun next-label () (incf *last-label*)) + +(defmacro wt-go (label) + `(wt "goto L" ,label ";")) + +;;; from cmplam.lsp +(defmacro ck-spec (condition) + `(unless ,condition + (cmperr "The parameter specification ~s is illegal." spec))) + +(defmacro ck-vl (condition) + `(unless ,condition + (cmperr "The lambda list ~s is illegal." vl))) + +;;; fromcmputil.sp +(defmacro cmpck (condition string &rest args) + `(if ,condition (cmperr ,string ,@args))) + +(defmacro cmpassert (condition string &rest args) + `(unless ,condition (cmperr ,string ,@args))) + +;;; from cmpwt.lsp +(defmacro wt (&rest forms &aux (fl nil)) + (dolist (form forms `(progn ,@(nreverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output1*) fl) + (push `(wt1 ,form) fl)))) + +(defmacro wt-h (&rest forms &aux (fl nil)) + (dolist (form forms `(progn ,@(nreverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output2*) fl) + (push `(wt-h1 ,form) fl)))) + +(defmacro wt-nl-h (&rest forms) + `(progn (terpri *compiler-output2*) (wt-h ,@forms))) + +(defmacro princ-h (form) `(princ ,form *compiler-output2*)) + +(defmacro wt-nl (&rest forms) + `(wt #\Newline #\Tab ,@forms)) + +(defmacro wt-nl1 (&rest forms) + `(wt #\Newline ,@forms)) + +(defmacro safe-compile () + `(>= (cmp-env-optimization 'safety) 2)) + +(defmacro compiler-check-args () + `(>= (cmp-env-optimization 'safety) 1)) + +(defmacro compiler-push-events () + `(>= (cmp-env-optimization 'safety) 3)) + +;; ---------------------------------------------------------------------- +;; C1-FORMS +;; + +(defstruct (c1form (:include info) + (:print-object print-c1form) + (:constructor do-make-c1form)) + (name nil) + (parent nil) + (args '()) + (env (cmp-env-copy)) + (form nil) + (toplevel-form) + (file nil) + (file-position 0)) + +(defun print-c1form (form stream) + (format stream "#
" (c1form-name form) (ext::pointer form))) + +(defmacro make-c1form* (&rest args) + `(list (make-c1form-alone ,@args))) + +(defmacro make-c1form-alone (name &rest args) + (let ((info-args '()) + (form-args '())) + (do ((l args (cdr l))) + ((endp l)) + (let ((key (first l))) + (cond ((not (keywordp key)) + (baboon)) + ((eq key ':args) + (setf form-args (rest l)) + (return)) + (t + (setf info-args (list* key (second l) info-args) + l (cdr l)))))) + `(do-make-c1form :name ,name :args (list ,@form-args) + :form *current-form* + :file *compile-file-truename* + :file-position *compile-file-position* + ,@info-args))) + +(defun make-c1form-alone (name &rest args) + (let ((info-args '()) + (form-args '())) + (do ((l args (cdr l))) + ((endp l)) + (let ((key (first l))) + (cond ((not (keywordp key)) + (baboon)) + ((eq key ':args) + (setf form-args (rest l)) + (return)) + (t + (setf info-args (list* key (second l) info-args) + l (cdr l)))))) + (apply #'do-make-c1form :name name :args form-args + :form *current-form* + :file *compile-file-truename* + :file-position *compile-file-position* + info-args))) + +(defun copy-c1form (form) + (copy-structure form)) + +(defmacro c1form-arg (nth form) + (case nth + (0 `(first (c1form-args ,form))) + (1 `(second (c1form-args ,form))) + (otherwise `(nth ,nth (c1form-args ,form))))) + +(defun c1form-volatile* (form) + (if (c1form-volatile form) "volatile " "")) + +(defun get-output-c1form (form) + (cond ((null form) + (error "Empty form list")) + ((listp form) + (first (last form))) + (t + form))) + +(defun c1form-values-type (form) + (c1form-type (get-output-c1form form))) + +(defun (setf c1form-values-type) (type form) + (setf (c1form-type (get-output-c1form form)) type)) + +(defun c1form-primary-type (form) + (values-type-primary-type (c1form-values-type form))) + +(defun find-node-in-list (home-node list) + (flet ((parent-node-p (node presumed-child) + (loop + (cond ((null presumed-child) (return nil)) + ((eq node presumed-child) (return t)) + (t (setf presumed-child (c1form-parent presumed-child))))))) + (member home-node list :test #'parent-node-p))) + +(defun c1form-set-volatile (flag forms) + (loop for i in forms + do (setf (c1form-volatile i) flag)) + forms) diff --git a/src/new-cmp/cmpmain.lsp b/src/new-cmp/cmpmain.lsp new file mode 100644 index 000000000..e74e9b3d2 --- /dev/null +++ b/src/new-cmp/cmpmain.lsp @@ -0,0 +1,878 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPMAIN Compiler main program. + +(in-package "COMPILER") + +#-threads +(defmacro with-lock ((lock) &body body) + `(progn ,@body)) + +(defun safe-system (string) + (cmpnote "Invoking external command:~% ~A" string) + (let ((result (si:system string))) + (unless (zerop result) + (cerror "Continues anyway." + "(SYSTEM ~S) returned non-zero value ~D" + string result)) + result)) + +(defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p) + verbose print c-file h-file data-file shared-data-file + system-p load) + (let* ((format '()) + (extension '())) + (unless type-supplied-p + (setf type (if system-p :object :fasl))) + (case type + ((:shared-library :dll) (setf format +shared-library-format+)) + ((:static-library :library :lib) (setf format +static-library-format+)) + (:data (setf extension "data")) + (:sdata (setf extension "sdat")) + (:c (setf extension "c")) + (:h (setf extension "h")) + (:object (setf extension +object-file-extension+)) + (:program (setf format +executable-file-format+)) + #+msvc + (:import-library (setf extension "implib")) + ((:fasl :fas) (setf extension "fas"))) + (cond ((not (member output-file '(T NIL))) + output-file) + (format + (merge-pathnames (format nil format (pathname-name name)) name)) + (t + (make-pathname :type extension :defaults name))))) + +#+msvc +(defun delete-msvc-generated-files (output-pathname) + (loop for i in '("lib" "exp" "ilk" "pdb") + do (let ((the-pathname (merge-pathnames (make-pathname :type i) output-pathname))) + (when (probe-file the-pathname) + (cmp-delete-file the-pathname))))) + +(defun cmp-delete-file (file) + (cond ((null *delete-files*)) + (*debug-compiler* + (cmpprogress "~%Postponing deletion of ~A" file) + (push file *files-to-be-deleted*)) + (t + (and (probe-file file) + (delete-file file))))) + +(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*)) + si::*exit-hooks*) + +#-mingw32 +(defmacro fix-for-mingw (directory-namestring) + directory-namestring) + +#+mingw32 +(defun fix-for-mingw (directory-namestring) + (let ((x (string-right-trim '(#\\ #\/) directory-namestring))) + (if (zerop (length x)) "/" x))) + +(defun linker-cc (o-pathname &rest options) + (safe-system + (format nil + *ld-format* + *ld* + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-flags*))) + +#+dlopen +(defun shared-cc (o-pathname &rest options) + #-(or mingw32) + (safe-system + (format nil + *ld-format* + *ld* + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-shared-flags*)) + #+(or mingw32) + (let ((lib-file (compile-file-pathname o-pathname :type :lib))) + (safe-system + (format nil + "gcc -shared -o ~S -L~S ~{~S ~} ~@?" + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-shared-flags*)))) + +#+dlopen +(defun bundle-cc (o-pathname init-name &rest options) + #-(or mingw32) + (safe-system + (format nil + *ld-format* + *ld* + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + #-msvc *ld-bundle-flags* + #+msvc (concatenate 'string *ld-bundle-flags* + " /EXPORT:" init-name + " /LIBPATH:" (ecl-library-directory) + " /IMPLIB:" + (si::coerce-to-filename + (compile-file-pathname + o-pathname :type :import-library))))) + #+(or mingw32) + (safe-system + (format nil + "gcc -shared -o ~A -Wl,--export-all-symbols -L~S ~{~S ~} ~@?" + (si::coerce-to-filename o-pathname) + (fix-for-mingw (ecl-library-directory)) + options + *ld-bundle-flags*))) + +(defconstant +lisp-program-header+ " +#include + +#ifdef __cplusplus +#define ECL_CPP_TAG \"C\" +#else +#define ECL_CPP_TAG +#endif + +~{ extern ECL_CPP_TAG void ~A(cl_object);~%~} + +") + +;; +;; This format string contains the structure of the code that initializes +;; a program, a library, a module, etc. Basically, it processes a codeblock +;; just like in a normal compiled file, but then adds all the codeblocks of +;; its corresponding modules. +;; +;; IMPORTANT: Notice how the modules are linked to the parent forming a +;; circular chain. This disables the garbage collection of the library until +;; _ALL_ functions in all modules are unlinked. +;; +(defconstant +lisp-program-init+ " +#ifdef __cplusplus +extern \"C\" +#endif +void ~A(cl_object cblock) +{ + static cl_object Cblock; + if (!FIXNUMP(cblock)) { + Cblock = cblock; + cblock->cblock.data_text = compiler_data_text; + cblock->cblock.data_text_size = compiler_data_text_size; +#ifndef ECL_DYNAMIC_VV + cblock->cblock.data = VV; +#endif + cblock->cblock.data_size = VM; + return; + } +#if defined(ECL_DYNAMIC_VV) && defined(ECL_SHARED_DATA) + VV = Cblock->cblock.data; +#endif + ~A +{ + cl_object current, next = Cblock; +~:[~{ current = read_VV(OBJNULL, ~A); current->cblock.next = next; next = current; ~%~} + Cblock->cblock.next = current; +~;~{ ~A(Cblock);~%~}~] +} + ~A +}") + +(defconstant +lisp-program-main+ " +int +main(int argc, char **argv) +{ + ~A + cl_boot(argc, argv); + read_VV(OBJNULL, ~A); + ~A +}") + +#+:win32 +(defconstant +lisp-program-winmain+ " +#include +int +WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow) +{ + char **argv; + int argc; + ~A + ecl_get_commandline_args(&argc, &argv); + cl_boot(argc, argv); + read_VV(OBJNULL, ~A); + ~A +}") + +(defun init-function-name (s &key (kind :object)) + (flet ((translate-char (c) + (cond ((and (char>= c #\a) (char<= c #\z)) + (char-upcase c)) + ((and (char>= c #\A) (char<= c #\Z)) + c) + ((or (eq c #\-) (eq c #\_)) + #\_) + ((eq c #\*) + #\x) + ((eq c #\?) + #\a) + ((digit-char-p c) + c) + (t + #\p))) + (disambiguation (c) + (case kind + (:object "") + (:program "exe_") + ((:fasl :fas) "fas_") + ((:library :shared-library :dll :static-library :lib) "lib_") + (otherwise (error "Not a valid argument to INIT-FUNCTION-NAME: kind = ~S" + kind))))) + (setq s (map 'string #'translate-char (string s))) + (concatenate 'string + "init_" + (disambiguation kind) + (map 'string #'translate-char (string s))))) + +(defun guess-kind (pathname) + "Given a file name, guess whether it is an object file, a library, a program +or a loadable module." + (let ((record (assoc (pathname-type pathname) + '(("o" :object) ("obj" :object) ("c" :c) + ("lib" :static-library) + ("a" :static-library) + ("dll" :shared-library) + ("so" :shared-library) + ("fas" :fasl)) + :test #'string-equal))) + (if record + (second record) + (progn + (warn "File ~s is of no known file type. Assuming it is an object file." + pathname) + :object)))) + +(defun guess-ld-flags (pathname &key (kind (guess-kind pathname))) + "Given a file name, return the compiler command line argument to link this file in." + (case kind + ((:object :c) + (si::coerce-to-filename pathname)) + ((:fasl :fas) + nil) + ((:static-library :lib) + (si::coerce-to-filename pathname)) + ((:shared-library :dll) + (si::coerce-to-filename pathname)) + ((:program) + nil) + (otherwise + (error "C::BUILDER cannot accept files of kind ~s" kind)))) + +(defun system-ld-flag (library) + "Given a symbol, try to find a library that matches it, either by looking in the +filesystem or in the database of ASDF modules." + (let ((asdf (find-package "ASDF")) + system) + (labels ((asdfsym (x) (find-symbol (string x) asdf)) + (asdfcall (fun &rest rest) (apply (asdfsym fun) rest)) + (system-output (system type) + (let ((build (make-instance (asdfsym :build-op) :type type))) + (first (asdfcall :output-files build system)))) + (existing-system-output (system type) + (let ((o (system-output system type))) + (and o (setf o (probe-file o)) (namestring o)))) + (find-archive (system) + (or (existing-system-output system :library) + (existing-system-output system :shared-library))) + (fallback () (format nil #-msvc "-l~A" #+msvc "~A.lib" (string-downcase library)))) + (or (and asdf + (setf system (asdfcall :find-system library nil)) + (find-archive system)) + (fallback))))) + +(defun builder (target output-name &key lisp-files ld-flags shared-data-file + (init-name nil) + (prologue-code "") + (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL))) + #+:win32 (system :console) + &aux + (*suppress-compiler-messages* (or *suppress-compiler-messages* + (not *compile-verbose*)))) + ;; Deprecated, to be removed in next release + (when *suppress-compiler-notes* + (setf *suppress-compiler-messages* + `(or ,*suppress-compiler-messages* compiler-note))) + (when *suppress-compiler-warnings* + (setf *suppress-compiler-messages* + `(or ,*suppress-compiler-messages* compiler-warning))) + + ;; + ;; The epilogue-code can be either a string made of C code, or a + ;; lisp form. In the latter case we add some additional C code to + ;; clean up, and the lisp form is stored in a text representation, + ;; to avoid using the compiler. + ;; + (cond ((null epilogue-code) + (setf epilogue-code "")) + ((stringp epilogue-code) + ) + (t + (with-standard-io-syntax + (setq epilogue-code + (with-output-to-string (stream) + (princ "{ const char *lisp_code = " stream) + (wt-filtered-data (write-to-string epilogue-code) stream) + (princ "; +cl_object output; +si_select_package(make_simple_base_string(\"CL-USER\")); +output = cl_safe_eval(c_string_to_object(lisp_code), Cnil, OBJNULL); +" stream) + (when (eq target :program) + (princ "cl_shutdown(); return (output != OBJNULL);" stream)) + (princ #\} stream) + ))))) + ;; + ;; When a module is built out of several object files, we have to + ;; create an additional object file that initializes those ones. + ;; This routine is responsible for creating this file. + ;; + ;; To avoid name clashes, this object file will have a temporary + ;; file name (tmp-name). + ;; + (let* ((tmp-name (si::mkstemp #P"TMP:ECLINIT")) + (c-name (si::coerce-to-filename + (compile-file-pathname tmp-name :type :c))) + (o-name (si::coerce-to-filename + (compile-file-pathname tmp-name :type :object))) + submodules + c-file) + (dolist (item (reverse lisp-files)) + (etypecase item + (symbol + (push (system-ld-flag item) ld-flags) + (push (init-function-name item :kind :lib) submodules)) + ((or string pathname) + (let* ((pathname (parse-namestring item)) + (kind (guess-kind pathname))) + (unless (member kind '(:shared-library :dll :static-library :lib + :object :c)) + (error "C::BUILDER does not accept a file ~s of kind ~s" item kind)) + (let* ((path (parse-namestring item)) + (init-fn (guess-init-name path)) + (flags (guess-ld-flags path))) + ;; We should give a warning that we cannot link this module in + (when flags (push flags ld-flags)) + (push init-fn submodules)))))) + (setq c-file (open c-name :direction :output :external-format :default)) + (format c-file +lisp-program-header+ submodules) + (cond (shared-data-file + (data-init shared-data-file) + (format c-file " +#define VM ~A +#ifdef ECL_DYNAMIC_VV +static cl_object *VV; +#else +static cl_object VV[VM]; +#endif +#define ECL_SHARED_DATA_FILE 1 +" (data-permanent-storage-size)) + (data-dump c-file)) + (t + (format c-file " +#define compiler_data_text NULL +#define compiler_data_text_size 0 +#define VV NULL +#define VM 0" c-file))) + (when (or (symbolp output-name) (stringp output-name)) + (setf output-name (compile-file-pathname output-name :type target))) + (unless init-name + (setf init-name (compute-init-name output-name :kind target))) + (ecase target + (:program + (format c-file +lisp-program-init+ init-name "" shared-data-file + submodules "") + (format c-file #+:win32 (ecase system (:console +lisp-program-main+) + (:windows +lisp-program-winmain+)) + #-:win32 +lisp-program-main+ + prologue-code init-name epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (apply #'linker-cc output-name (namestring o-name) ld-flags)) + ((:library :static-library :lib) + (format c-file +lisp-program-init+ init-name prologue-code + shared-data-file submodules epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (when (probe-file output-name) (delete-file output-name)) + #-msvc + (progn + (safe-system (format nil "ar cr ~A ~A ~{~A ~}" + output-name o-name ld-flags)) + (safe-system (format nil "ranlib ~A" output-name))) + #+msvc + (unwind-protect + (progn + (with-open-file (f "static_lib.tmp" :direction :output :if-does-not-exist :create :if-exists :supersede) + (format f "/DEBUGTYPE:CV /OUT:~A ~A ~{~&\"~A\"~}" + output-name o-name ld-flags)) + (safe-system "link -lib @static_lib.tmp")) + (when (probe-file "static_lib.tmp") + (cmp-delete-file "static_lib.tmp"))) + ) + #+dlopen + ((:shared-library :dll) + (format c-file +lisp-program-init+ init-name prologue-code + shared-data-file submodules epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (apply #'shared-cc output-name o-name ld-flags)) + #+dlopen + (:fasl + (format c-file +lisp-program-init+ init-name prologue-code shared-data-file + submodules epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (apply #'bundle-cc output-name init-name o-name ld-flags))) + (cmp-delete-file tmp-name) + (cmp-delete-file c-name) + (cmp-delete-file o-name) + output-name)) + +(defun build-fasl (&rest args) + (apply #'builder :fasl args)) + +(defun build-program (&rest args) + (apply #'builder :program args)) + +(defun build-static-library (&rest args) + (apply #'builder :static-library args)) + +(defun build-shared-library (&rest args) + #-dlopen + (error "Dynamically loadable libraries not supported in this system.") + #+dlopen + (apply #'builder :shared-library args)) + +(defun compile-file (input-pathname &rest args + &key + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) + (c-file nil) + (h-file nil) + (data-file nil) + (shared-data-file nil) + (system-p nil) + (load nil) + output-file + &aux (*standard-output* *standard-output*) + (*error-output* *error-output*) + (*compiler-in-use* *compiler-in-use*) + (*package* *package*) + (*print-pretty* nil) + (*compile-file-pathname* nil) + (*compile-file-truename* nil) + (*suppress-compiler-messages* + (or *suppress-compiler-messages* (not *compile-verbose*))) + init-name) + (declare (notinline compiler-cc)) + "Compiles the file specified by INPUT-PATHNAME and generates a fasl file +specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, +then \".lsp\" is used as the default file type for the source file. LOAD +specifies whether to load the generated fasl file after compilation. The +:O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters allow you to +control the intermediate files generated by the ECL compiler.If the file was +compiled successfully, returns the pathname of the compiled file" + ;; Deprecated, to be removed in next release + (when *suppress-compiler-notes* + (setf *suppress-compiler-messages* + `(or ,*suppress-compiler-messages* compiler-note))) + (when *suppress-compiler-warnings* + (setf *suppress-compiler-messages* + `(or ,*suppress-compiler-messages* compiler-warning))) + + #-dlopen + (unless system-p + (format t "~%;;;~ +~%;;; This system does not support loading dynamically linked libraries.~ +~%;;; Therefore, COMPILE-FILE without :SYSTEM-P T is unsupported.~ +~%;;;")) + + (setq *compile-file-pathname* (pathname (merge-pathnames input-pathname))) + (unless (probe-file *compile-file-pathname*) + (if (pathname-type input-pathname) + (error 'file-error :pathname input-pathname) + (dolist (ext '("lsp" "LSP" "lisp" "LISP") + (error 'file-error :pathname input-pathname)) + (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname)) + (when (probe-file *compile-file-pathname*) + (return))))) + (setq input-file (truename *compile-file-pathname*) + *compile-file-truename* input-file) + + (when (and system-p load) + (error "Cannot load system files.")) + + (cmpprogress "~&;;; Compiling ~a." (namestring input-pathname)) + + (let* ((eof '(NIL)) + (*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 + (c-pathname (apply #'compile-file-pathname output-file :output-file c-file + :type :c args)) + (h-pathname (apply #'compile-file-pathname output-file :output-file h-file + :type :h args)) + (data-pathname (apply #'compile-file-pathname output-file + :output-file data-file :type :data args)) + (shared-data-pathname (apply #'compile-file-pathname output-file + :output-file shared-data-file :type :sdata args)) + (compiler-conditions nil) + (to-delete (nconc (unless c-file (list c-pathname)) + (unless h-file (list h-pathname)) + (unless (or data-file shared-data-file) + (list data-pathname))))) + + (with-compiler-env (compiler-conditions) + + (print-compiler-info) + + (when (probe-file "./cmpinit.lsp") + (load "./cmpinit.lsp" :verbose *compile-verbose*)) + + (if shared-data-file + (if system-p + (data-init shared-data-pathname) + (error "Shared data files are only allowed when compiling ~& + with the flag :SYSTEM-P set to T.")) + (data-init)) + + (setf init-name (compute-init-name output-file :kind + (if system-p :object :fasl))) + + (with-t1expr (init-name) + (with-open-file (*compiler-input* *compile-file-pathname*) + (do* ((ext:*source-location* (cons *compile-file-pathname* 0)) + (*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*) *compile-file-position*) + (t1expr form))))) + (cmpprogress "~&;;; End of Pass 1.") + + (compiler-pass2 c-pathname h-pathname data-pathname system-p + init-name + shared-data-file + :input-designator (namestring input-pathname)) + + (if shared-data-file + (data-dump shared-data-pathname t) + (data-dump data-pathname)) + + (let ((o-pathname (if system-p + output-file + (compile-file-pathname output-file :type :object)))) + (compiler-cc c-pathname o-pathname) + #+dlopen + (unless system-p + (push o-pathname to-delete) + (bundle-cc (si::coerce-to-filename output-file) + init-name + (si::coerce-to-filename o-pathname)))) + + (if (setf true-output-file (probe-file output-file)) + (cmpprogress "~&;;; Finished compiling ~a.~%" (namestring input-pathname)) + (cmperr "The C compiler failed to compile the intermediate file.")) + + (mapc #'cmp-delete-file to-delete) + + (when (and load true-output-file (not system-p)) + (load true-output-file :verbose *compile-verbose*)) + + ) ; with-compiler-env + + (compiler-output-values true-output-file compiler-conditions))) + +(defun compiler-output-values (main-value conditions) + (loop for i in conditions + with warning-p = nil + with failure-p = nil + do (cond ((typep i 'style-warning) + (setf warning-p t)) + ((typep i '(or compiler-error warning)) + (setf warning-p t failure-p t))) + finally (return (values (and (not failure-p) main-value) warning-p failure-p)))) + +#-dlopen +(defun compile (name &optional (def nil supplied-p)) + (format t "~%;;;~ +~%;;; This system does not support loading dynamically linked libraries.~ +~%;;; Therefore, COMPILE is unsupported.~ +~%;;;")) + +#+dlopen +(defvar *gazonk-counter* 0) + +#+dlopen +(defun compile (name &optional (def nil supplied-p) + &aux form data-pathname + (*suppress-compiler-messages* (or *suppress-compiler-messages* + (not *compile-verbose*))) + (*compiler-in-use* *compiler-in-use*) + (*standard-output* *standard-output*) + (*error-output* *error-output*) + (*package* *package*) + (*compile-print* nil) + (*print-pretty* nil) + (*compiler-constants* t)) + "Args: (name &optional definition) + +If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. +In this case, COMPILE compiles the function, installs the compiled function as +the global function definition of NAME, and returns NAME. If DEFINITION is +non-NIL, it must be a lambda expression and NAME must be a symbol. COMPILE +compiles the lambda expression, installs the compiled function as the function +definition of NAME, and returns NAME. There is only one exception for this: +If NAME is NIL, then the compiled function is not installed but is simply +returned as the value of COMPILE. In any case, COMPILE creates temporary +files, whose filenames begin with \"gazonk\", which are automatically deleted +after compilation." + (unless (symbolp name) (error "~s is not a symbol." name)) + + ;; Deprecated, to be removed in next release + (when *suppress-compiler-notes* + (setf *suppress-compiler-messages* + `(or ,*suppress-compiler-messages* compiler-note))) + (when *suppress-compiler-warnings* + (setf *suppress-compiler-messages* + `(or ,*suppress-compiler-messages* compiler-warning))) + + (cond ((and supplied-p def) + (when (functionp def) + (unless (function-lambda-expression def) + (return-from compile def)) + (setf def (function-lambda-expression def))) + (setq form (if name + `(setf (symbol-function ',name) #',def) + `(set 'GAZONK #',def)))) + ((not (fboundp name)) + (error "Symbol ~s is unbound." name)) + ((typep (setf def (symbol-function name)) 'standard-generic-function) + (warn "COMPILE can not compile generic functions yet") + (return-from compile (values def t nil))) + ((null (setq form (function-lambda-expression def))) + (warn "We have lost the original function definition for ~s. Compilation to C failed") + (return-from compile (values def t nil))) + (t + (setq form `(setf (symbol-function ',name) #',form)))) + + (let ((template (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) + (unless (setq data-pathname (si::mkstemp template)) + (error "Unable to create temporay file~%~ + ~AXXXXXX +Make sure you have enough free space in disk, check permissions or set~%~ +the environment variable TMPDIR to a different value." template) + (return-from compile (values nil t t)))) + + (let*((*load-time-values* 'values) ;; Only the value is kept + (c-pathname (compile-file-pathname data-pathname :type :c)) + (h-pathname (compile-file-pathname data-pathname :type :h)) + (o-pathname (compile-file-pathname data-pathname :type :object)) + (so-pathname (compile-file-pathname data-pathname)) + (init-name (compute-init-name so-pathname :kind :fasl)) + (compiler-conditions nil)) + + (with-compiler-env (compiler-conditions) + (print-compiler-info) + (data-init) + (with-t1expr (init-name) + (t1expr form)) + (cmpprogress "~&;;; End of Pass 1.") + (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) + (compiler-pass2 c-pathname h-pathname data-pathname nil + init-name nil + :input-designator (format nil "~A" def))) + (setf *compiler-constants* (data-dump data-pathname)) + + (compiler-cc c-pathname o-pathname) + (bundle-cc (si::coerce-to-filename so-pathname) + init-name + (si::coerce-to-filename o-pathname)) + (cmp-delete-file c-pathname) + (cmp-delete-file h-pathname) + (cmp-delete-file o-pathname) + (cmp-delete-file data-pathname) + (cond ((probe-file so-pathname) + (load so-pathname :verbose nil) + #-(or mingw32 msvc cygwin) + (cmp-delete-file so-pathname) + #+msvc + (delete-msvc-generated-files so-pathname) + (setf name (or name (symbol-value 'GAZONK))) + ;; By unsetting GAZONK we avoid spurious references to the + ;; loaded code. + (set 'GAZONK nil) + (si::gc t) + (values name nil nil)) + (t + (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) + ) ; with-compiler-env + + (when (probe-file c-pathname) (cmp-delete-file c-pathname)) + (when (probe-file h-pathname) (cmp-delete-file h-pathname)) + (when (probe-file so-pathname) (cmp-delete-file so-pathname)) + (when (probe-file data-pathname) (cmp-delete-file data-pathname)) + #+msvc + (delete-msvc-generated-files so-pathname) + (compiler-output-values name compiler-conditions))) + +(defun disassemble (thing &key (h-file nil) (data-file nil) + &aux def disassembled-form + (*compiler-in-use* *compiler-in-use*) + (*print-pretty* nil)) +"Compiles the form specified by THING and prints the intermediate C language +code for that form. But does not install the result of compilation. If THING +is NIL, then the previously DISASSEMBLEd form is re-DISASSEMBLEd. If THING is +a symbol that names a function not yet compiled, the function definition is +disassembled. If THING is a lambda expression, it is disassembled as a +function definition. Otherwise, THING itself is disassembled as a top-level +form. H-FILE and DATA-FILE specify intermediate files to build a fasl file +from the C language code. NIL means \"do not create the file\"." + (when (si::valid-function-name-p thing) + (setq thing (fdefinition thing))) + (cond ((null thing)) + ((functionp thing) + (unless (si::bc-disassemble thing) + (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) + (return-from disassemble nil))) + ((atom thing) + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A" + :format-arguments (list thing))) + ((eq (car thing) 'LAMBDA) + (setq disassembled-form `(defun gazonk ,@(cdr thing)))) + ((eq (car thing) 'EXT:LAMBDA-BLOCK) + (setq disassembled-form `(defun ,@(rest thing)))) + (t + (error 'simple-type-error + :datum thing + :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) + :format-control "DISASSEMBLE cannot accept ~A" + :format-arguments (list thing)))) + + (let* ((null-stream (make-broadcast-stream)) + (*compiler-output1* null-stream) + (*compiler-output2* (if h-file + (open h-file :direction :output :external-format :default) + null-stream)) + (t3local-fun (symbol-function 'T3LOCAL-FUN)) + (compiler-conditions nil) + (init-name (compute-init-name "foo" :kind :fasl))) + (with-compiler-env (compiler-conditions) + (unwind-protect + (progn + (setf (symbol-function 'T3LOCAL-FUN) + #'(lambda (&rest args) + (let ((*compiler-output1* *standard-output*)) + (apply t3local-fun args)))) + (data-init) + (with-t1expr (init-name) + (t1expr disassembled-form)) + (ctop-write init-name + (if h-file h-file "") + (if data-file data-file "")) + (data-dump data-file)) + (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) + (when h-file (close *compiler-output2*))))) + nil) + +(defun compiler-pass2 (c-pathname h-pathname data-pathname system-p init-name + shared-data &key input-designator) + (with-open-file (*compiler-output1* c-pathname :direction :output) + (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) + #-ecl-min + (multiple-value-bind (second minute hour day month year) + (get-decoded-time) + (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) + (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) + (wt-nl1 "#include " *cmpinclude*) + (catch *cmperr-tag* (ctop-write init-name + h-pathname + data-pathname + :shared-data shared-data)) + (terpri *compiler-output1*) + (terpri *compiler-output2*)))) + +(defun ecl-include-directory () + "Finds the directory in which the header files were installed." + (cond ((and *ecl-include-directory* + (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) + *ecl-include-directory*) + ((probe-file "SYS:ecl;config.h") + (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find include directory")))) + +(defun ecl-library-directory () + "Finds the directory in which the ECL core library was installed." + (cond ((and *ecl-library-directory* + (probe-file (merge-pathnames (compile-file-pathname "ecl" :type + #+dlopen :shared-library + #-dlopen :static-library) + *ecl-library-directory*))) + *ecl-library-directory*) + ((probe-file "SYS:BUILD-STAMP") + (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find library directory")))) + +(defun compiler-cc (c-pathname o-pathname) + (safe-system + (format nil + *cc-format* + *cc* *cc-flags* (>= (cmp-env-optimization 'speed) 2) *cc-optimize* + (fix-for-mingw (ecl-include-directory)) + (si::coerce-to-filename c-pathname) + (si::coerce-to-filename o-pathname)) +; Since the SUN4 assembler loops with big files, you might want to use this: +; (format nil +; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" +; *cc* (>= *speed* 2) +; *include-directory* +; (namestring c-pathname) +; (namestring o-pathname) +; (namestring s-pathname)) + )) + +(defun print-compiler-info () + (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%" + *safety* *space* *speed* *debug*)) + +(defmacro with-compilation-unit (options &rest body) + `(progn ,@body)) + +(si::package-lock "CL" nil) + +#-ecl-min +(with-standard-io-syntax + (load "sys:sysfun")) + +(provide 'cmp) diff --git a/src/new-cmp/cmpmap.lsp b/src/new-cmp/cmpmap.lsp new file mode 100644 index 000000000..db8194cc9 --- /dev/null +++ b/src/new-cmp/cmpmap.lsp @@ -0,0 +1,74 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPMAP Map functions. + +(in-package "COMPILER") + +(defun expand-mapcar (whole) + (when (< (length whole) 3) + (si::signal-simple-error + #'program-error nil "Too few arguments to function ~A in form: ~A" + (firt whole) whole)) + (let ((which (first whole))) + (when (eq which 'FUNCALL) + (setf whole (rest whole) + which (first whole)) + (when (consp which) + (if (eq (first which) 'FUNCTION) + (setf which (second which)) + (return-from expand-mapcar whole)))) + (let* ((function (second whole)) + (args (cddr whole)) + iterators for-statements + (in-or-on :IN) + (do-or-collect :COLLECT) + (list-1-form nil) + (finally-form nil)) + (case which + (MAPCAR) + (MAPLIST (setf in-or-on :ON)) + (MAPC (setf do-or-collect :DO)) + (MAPL (setf in-or-on :ON do-or-collect :DO)) + (MAPCAN (setf do-or-collect 'NCONC)) + (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) + (when (eq do-or-collect :DO) + (let ((var (gensym))) + (setf list-1-form `(with ,var = ,(first args)) + args (list* var (rest args)) + finally-form `(finally (return ,var))))) + (loop for arg in (reverse args) + do (let ((var (gensym))) + (setf iterators (cons var iterators) + for-statements (list* :for var in-or-on arg for-statements)))) + `(loop ,@list-1-form + ,@for-statements + ,do-or-collect (funcall ,function ,@iterators) + ,@finally-form)))) + +(define-compiler-macro mapcar (&whole whole &rest r) + (expand-mapcar whole)) + +(define-compiler-macro mapc (&whole whole &rest r) + (expand-mapcar whole)) + +(define-compiler-macro mapcan (&whole whole &rest r) + (expand-mapcar whole)) + +(define-compiler-macro maplist (&whole whole &rest r) + (expand-mapcar whole)) + +(define-compiler-macro mapl (&whole whole &rest r) + (expand-mapcar whole)) + +(define-compiler-macro mapcon (&whole whole &rest r) + (expand-mapcar whole)) diff --git a/src/new-cmp/cmpmulti.lsp b/src/new-cmp/cmpmulti.lsp new file mode 100644 index 000000000..33b9155d9 --- /dev/null +++ b/src/new-cmp/cmpmulti.lsp @@ -0,0 +1,135 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPMULT Multiple-value-call and Multiple-value-prog1. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun c1multiple-value-call (destination args &aux forms) + (check-args-number 'MULTIPLE-VALUE-CALL args 1) + (cond + ;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION) + ((endp (rest args)) (c1funcall destination args)) + ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z) + ((and (= (length args) 2) + (consp (setq forms (second args))) + (eq 'VALUES (first forms))) + (c1funcall destination (list* (first args) (rest forms)))) + ;; More complicated case. + (t + (c1translate destination + (let ((function (gensym)) + (frame (gensym))) + `(with-stack ,frame + (let* ((,function ,(first args))) + ,@(loop for i in (rest args) + collect `(stack-push-values ,frame ,i)) + (si::apply-from-stack-frame ,frame ,function)))))))) + +(defun c1multiple-value-prog1 (destination args) + (check-args-number 'MULTIPLE-VALUE-PROG1 args 1) + (c1translate destination + (let ((frame (gensym))) + `(with-stack ,frame + (stack-push-values ,frame ,(first args)) + ,@(rest args) + (stack-pop ,frame))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Beppe: +;;; this is the WRONG way to handle 1 value problem. +;;; should be done in c2values, so that (values (truncate a b)) can +;;; be used to restrict to one value, so we would not have to warn +;;; if this occurred in a proclaimed fun. + +(defun c1values (destination forms) + (cond ((eq destination 'TRASH) + ;; When the values are not going to be used, then just + ;; process each form separately. + (loop for f in forms nconc (c1translate 'TRASH f))) + ;; For locations that involve multiple values, we must use + ;; the values operator + ((member destination '(RETURN VALUES VALUES+VALUE0)) + (c1with-saved-values (prefix postfix temps forms) + (nconc prefix + (c1values-op temps) + (c1set-loc destination 'VALUES) + postfix))) + ;; Otherwise we can just save the first value and trash the rest + (t + (unless forms (setf forms '(nil))) + (c1with-temps (prefix postfix temp) + (nconc prefix + (c1translate temp (pop forms)) + (loop for f in forms + nconc (c1translate 'TRASH f)) + (c1set-loc destination temp) + postfix))))) + +(defun c1multiple-value-setq (destination args &aux + (vars nil) (temp-vars nil) + (late-bindings nil)) + (check-args-number 'MULTIPLE-VALUE-SETQ args 2 2) + (dolist (var (reverse (first args))) + (cmpck (not (symbolp var)) "The variable ~s is not a symbol." var) + (setq var (chk-symbol-macrolet var)) + (cond ((symbolp var) + (cmpck (constantp var) + "The constant ~s is being assigned a value." var) + (push var vars)) + (t (let ((new-var (gensym))) + (push new-var vars) + (push new-var temp-vars) + (push `(setf ,var ,new-var) late-bindings))))) + (let ((value (second args))) + (cond (temp-vars + (c1translate destination + `(let* (,@temp-vars) + (multiple-value-setq ,vars ,value) + ,@late-bindings))) + ((endp vars) + (c1translate destination `(values ,value))) + ((= (length vars) 1) + (c1translate destination `(setq ,(first vars) ,value))) + (t + (setf vars (mapcar #'c1vref vars)) + (nconc (c1translate 'VALUES value) + (c1set-mv vars) + (c1var destination (var-name (first vars)))))))) + +#+(or) +(defun c1form-values-number (form) + (let ((type (c1form-values-type form))) + (cond ((or (eq type 'T) (eq type '*)) + (values 0 MULTIPLE-VALUES-LIMIT)) + ((or (atom type) (not (eq (first type) 'VALUES))) + (values 1 1)) + ((or (member '&rest type) (member 'optional type)) + (values 0 MULTIPLE-VALUES-LIMIT)) + (t + (let ((l (1- (length type)))) + (values l l)))))) + +(defun c1multiple-value-bind (destination args &aux + (vars nil) (vnames nil) init-form + ss is ts body other-decls + (*cmp-env* (cmp-env-copy))) + (check-args-number 'MULTIPLE-VALUE-BIND args 2) + (let* ((variables (pop args)) + (values (pop args))) + (c1translate destination + `(let ,variables + (multiple-value-setq ,variables ,values) + (locally ,@args))))) diff --git a/src/new-cmp/cmpname.lsp b/src/new-cmp/cmpname.lsp new file mode 100644 index 000000000..16701276c --- /dev/null +++ b/src/new-cmp/cmpname.lsp @@ -0,0 +1,125 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2007, Juan Jose Garcia Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPNAME Unambiguous init names for object files +;;;; +;;;; Every object file in a lisp library or combined FASL (such as the +;;;; compiler), needs a function that creates its data and installs the +;;;; functions. This initialization function has a C name which needs +;;;; to be unique. This file has functions to create such names. + +(in-package "COMPILER") + +(defvar *counter* 0) + +(defun encode-number-in-name (number) + ;; Encode a number in an alphanumeric identifier which is a valid C name. + (declare (si::c-local)) + (cond ((zerop number) "0") + ((minusp number) (encode-number-in-name (- number))) + (t + (do* ((code "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") + (base (length code)) + (output '()) + (digit 0)) + ((zerop number) (coerce (nreverse output) 'base-string)) + (multiple-value-setq (number digit) (floor number base)) + (push (char code digit) output))))) + +(defun unique-init-name (file) + "Create a unique name for this initialization function. The current algorithm +relies only on the name of the source file and the time at which it is built. This +should be enough to prevent name collisions for object files built in the same +machine." + (let* ((path (pathname file)) + (path-hash (logxor (ash (sxhash path) 8) + (ash (sxhash (cddr (pathname-directory path))) 16) + (sxhash (pathname-name path)))) + (seconds (get-universal-time)) + (ms (+ (* seconds 1000) + (mod (floor (* 1000 (get-internal-real-time)) + internal-time-units-per-second) + 1000))) + (tag (concatenate 'base-string + "_ecl" + (encode-number-in-name path-hash) + "_" + (encode-number-in-name ms)))) + (cmpnote "Creating tag: ~S for ~S" tag file) + tag)) + +(defun init-name-tag (init-name) + (concatenate 'base-string "@EcLtAg" ":" init-name "@")) + +(defun search-tag (stream tag) + (declare (si::c-local)) + (terpri) + (do* ((eof nil) + (key (concatenate 'list tag ":")) + (string key)) + (nil) + (let ((c (read-byte stream nil nil))) + (cond ((null c) (return nil)) + ((not (= c (char-code (pop string)))) + (setf string key)) + ((null string) + (return t)))))) + +(defun read-name (stream) + (declare (si::c-local)) + (concatenate 'string + (loop with c = t + until (or (null (setf c (read-byte stream nil nil))) + (= c #.(char-code #\@))) + collect (code-char c)))) + +(defun find-init-name (file &key (tag "@EcLtAg")) + "Search for the initialization function in an object file. Since the +initialization function in object files have more or less unpredictable +names, we store them in a string in the object file. This string is recognized +by the TAG it has at the beginning This function searches that tag and retrieves +the function name it precedes." + (with-open-file (stream file :direction :input :element-type '(unsigned-byte 8)) + (cmpnote "Scanning ~S" file) + (when (search-tag stream tag) + (let ((name (read-name stream))) + (cmpnote "Found tag: ~S for ~A" name file) + name)))) + +(defun remove-prefix (prefix name) + (if (equal 0 (search prefix name)) + (subseq name (length prefix) nil) + name)) + +(defun guess-init-name (pathname &key (kind (guess-kind pathname))) + (if (eq kind :object) + (or (and (probe-file pathname) + (find-init-name pathname)) + (error "Cannot find out entry point for binary file ~A" pathname)) + (compute-init-name pathname :kind kind))) + +(defun compute-init-name (pathname &key (kind (guess-kind pathname))) + (let ((filename (pathname-name pathname))) + (case kind + ((:object :c) + (unique-init-name pathname)) + ((:fasl :fas) + (init-function-name "CODE" :kind :fas)) + ((:static-library :lib) + (init-function-name (remove-prefix +static-library-prefix+ filename) + :kind :lib)) + ((:shared-library :dll) + (init-function-name (remove-prefix +shared-library-prefix+ filename) + :kind :dll)) + ((:program) + "init_ECL_PROGRAM") + (otherwise + (error "C::BUILDER cannot accept files of kind ~s" kind))))) diff --git a/src/new-cmp/cmpnum.lsp b/src/new-cmp/cmpnum.lsp new file mode 100644 index 000000000..66e5e44d6 --- /dev/null +++ b/src/new-cmp/cmpnum.lsp @@ -0,0 +1,190 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPNUM -- Optimizer for numerical expressions. + +;;;; Copyright (c) 2005, Juan Jose Garcia Ripoll +;;;; +;;;; ECoLisp is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defun simplify-arithmetic (operator args whole) + (if (every #'numberp args) + (apply operator args) + (let ((l (length args))) + (cond ((> l 2) + (simplify-arithmetic + operator + (list* (simplify-arithmetic operator + (list (first args) (second args)) + nil) + (cddr args)) + nil)) + ((= l 2) + (or whole (list* operator args))) + ((= l 1) + (if (or (eq operator '*) (eq operator '+)) + (first args) + (or whole (list* operator args)))) + ((eq operator '*) + 1) + ((eq operator '+) + 0) + (t + (error 'simple-program-error + :format-error "Wrong number of arguments for operator ~a in ~a" + :format-arguments (list operators (or whole + (list* operator args))))))))) + +(define-compiler-macro * (&whole all &rest args) + (simplify-arithmetic '* args all)) + +(define-compiler-macro + (&whole all &rest args) + (simplify-arithmetic '+ args all)) + +(define-compiler-macro / (&whole all &rest args) + (simplify-arithmetic '/ args all)) + +(define-compiler-macro - (&whole all &rest args) + (simplify-arithmetic '- args all)) + +;;; +;;; The following are type propagators for arithmetic operations. Note +;;; that some of they have become binary operators. +;;; + +(defun maximum-number-type (t1 t2 &optional only-real) + ;; Computes the output type of an operation between number types T1 + ;; and T2 using the rules of floating point contagion. It returns + ;; the type of the result, and the types of T1 and T2, if they + ;; represent known types, or NUMBER, in other cases. + (let ((t1-eq nil) + (t2-eq nil) + (output nil) + (default (if only-real 'REAL 'NUMBER)) + (types-list (if only-real + '(FIXNUM INTEGER RATIONAL + #+short-float SHORT-FLOAT SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL + NUMBER) + '(FIXNUM INTEGER RATIONAL + #+short-float SHORT-FLOAT SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL)))) + (dolist (i types-list + (values (if (and t1-eq t2-eq output) output default) + (if t1-eq t1 default) + (if t2-eq t2 default))) + (when (and (null t1-eq) (type>= i t1)) + (if (equalp t1 t2) + (setf t2-eq i)) + (setf t1-eq i output i)) + (when (and (null t2-eq) (type>= i t2)) + (setf t2-eq i output i))))) + +(defun ensure-number-type (general-type) + (maximum-number-type general-type general-type)) + +(defun ensure-nonrational-type (general-type) + (maximum-number-type general-type 'single-float)) + +(defun ensure-real-type (general-type) + (maximum-number-type general-type 'integer :only-real)) + +(defun arithmetic-propagator (op1-type others integer-result) + ;; Propagates types for an associative operator (we do not care which one). + ;; We collect either the types of the arguments or 'NUMBER, as a generic + ;; expected type. The output type is computed using the rules of floating + ;; point contagion, with the exception that an operation between two + ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else) + (multiple-value-bind (result-type op1-type) + (ensure-number-type op1-type) + (loop with arg-types = (list op1-type) + for x in others + for op2-type = x + do (progn + (multiple-value-setq (result-type op1-type op2-type) + (maximum-number-type result-type op2-type)) + (when (or (eq result-type 'FIXNUM) (eq result-type 'INTEGER)) + (setf result-type integer-result)) + (setf arg-types (cons op2-type arg-types))) + finally (return (values (nreverse arg-types) result-type))))) + +(def-type-propagator * (fname op1 &rest others) + (arithmetic-propagator op1 others 'integer)) + +(copy-type-propagator '* '(+ -)) + +(def-type-propagator / (fname op1 &rest others) + (arithmetic-propagator op1 others 'rational)) + +;;; +;;; SPECIAL FUNCTIONS +;;; + +(def-type-propagator cos (fname op1-type) + (multiple-value-bind (output-type op1-type) + (ensure-nonrational-type op1-type) + (values (list op1-type) output-type))) + +(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp)) + +(def-type-propagator acos (fname op1-type) + (multiple-value-bind (output-type op1-type) + (ensure-nonrational-type op1-type) + (values (list op1-type) 'NUMBER))) + +(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p)) + (multiple-value-bind (float-t1 t1) + (ensure-nonrational-type op1-type) + (if op2-p + (multiple-value-bind (result t1 t2) + (maximum-number-type t1 op2-type :only-real) + (values (list t1 t2) result)) + (values (list t1) t1)))) + +(def-type-propagator expt (fname base exponent) + ;; Rules: + ;; (expt number-type integer) -> number-type + ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) + ;; + (multiple-value-bind (simplified-exponent exponent) + (ensure-real-type exponent) + (unless (eql simplified-exponent 'integer) + (setf simplified-exponent (ensure-nonrational-type simplified-exponent))) + (multiple-value-bind (result-type base aux) + (maximum-number-type base simplified-exponent) + (values (list base exponent) result-type)))) + +(def-type-propagator abs (fname arg) + (multiple-value-bind (output arg) + (ensure-number-type arg) + (values (list arg) + (or (cdr (assoc output + '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM)) + (INTEGER . (INTEGER 0 *)) + (RATIONAL . (RATIONAL 0 *)) + (SHORT-FLOAT . (SHORT-FLOAT 0 *)) + (SINGLE-FLOAT . (SINGLE-FLOAT 0 *)) + (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *)) + (LONG-FLOAT . (LONG-FLOAT 0 *)) + (REAL . (REAL 0 *)) + (NUMBER . (REAL 0 *))))) + output)))) + +(def-type-propagator sqrt (fname arg) + (multiple-value-bind (output arg) + (ensure-nonrational-type arg) + (values (list arg) + (if (type>= '(REAL 0 *) arg) output 'NUMBER)))) + +(def-type-propagator isqrt (fname arg) + (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg) + (values '((integer 0 #.MOST-POSITIVE-FIXNUM)) + '(integer 0 #.MOST-POSITIVE-FIXNUM)) + (values '((integer 0 *)) '(integer 0 *)))) + diff --git a/src/new-cmp/cmpopt.lsp b/src/new-cmp/cmpopt.lsp new file mode 100644 index 000000000..3c619ad23 --- /dev/null +++ b/src/new-cmp/cmpopt.lsp @@ -0,0 +1,419 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPOPT. Optimization of library functions + +;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;; +;;; TYPEP +;;; +;;; Some of the type checks can be expanded inline if we know the name +;;; of the type and it corresponds to either a Common-Lisp base type +;;; or to some class. +;;; + +(defun expand-in-interval-p (var interval) + (declare (si::c-local)) + (let ((forms '())) + (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) + interval + (unless (eq lower-limit '*) + (push (if (consp lower-limit) + `(> ,var ,(first lower-limit)) + `(>= ,var ,lower-limit)) + forms)) + (unless (eq upper-limit '*) + (push (if (consp upper-limit) + `(< ,var ,(first upper-limit)) + `(<= ,var ,upper-limit)) + forms))) + forms)) + +(defun expand-typep (form object type env) + (declare (si::c-local)) + ;; This function is reponsible for expanding (TYPEP object type) + ;; forms into a reasonable set of system calls. When it fails to + ;; match the compiler constraints on speed and space, it simply + ;; returns the original form. Note that for successful recursion we + ;; have to output indeed the ORIGINAL FORM, not some intermediate + ;; step. Otherwise the compiler macro will enter an infinite loop. + (let* ((space (cmp-env-optimization 'space env)) + (speed (cmp-env-optimization 'speed env)) + (safety (cmp-env-optimization 'safety env)) + (orig-type type) + aux function + first rest) + (declare (si::fixnum space speed)) + (cond ((not (and (constantp type) (setf type (cmp-eval type)) t)) + form) + ;; Type is not known + ((not (known-type-p type)) + form) + ;; Simple ones + ((subtypep 'T type) T) + ((eq type 'NIL) NIL) + ((eq aux 'SATISFIES) + `(funcall #',function ,object)) + ;; + ;; Detect inconsistencies in the provided type. If we run at low + ;; safety, we will simply assume the user knows what she's doing. + ((subtypep type NIL) + (cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type) + (if (< safety 1) + NIL + form)) + ;; + ;; There exists a function which checks for this type? + ((setf function (get-sysprop type 'si::type-predicate)) + `(,function ,object)) + ;; + ;; Similar as before, but we assume the user did not give us + ;; the right name, or gave us an equivalent type. + ((loop for (a-type . function-name) in si::+known-typep-predicates+ + when (si::type= type a-type) + do (return `(,function-name ,object)))) + ;; + ;; The following are not real functions, but are expanded by the + ;; compiler into C forms. + ((setf function (assoc type '((SINGLE-FLOAT . SINGLE-FLOAT-P) + (SHORT-FLOAT . SHORT-FLOAT-P) + (DOUBLE-FLOAT . DOUBLE-FLOAT-P) + (LONG-FLOAT . LONG-FLOAT-P)))) + `(,(cdr function) ,object)) + ;; + ;; Complex types defined with DEFTYPE. + ((and (atom type) + (get-sysprop type 'SI::DEFTYPE-DEFINITION) + (setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION))) + (expand-typep form object `',(funcall function) env)) + ;; + ;; No optimizations that take up too much space unless requested. + ((and (>= space 2) (> space speed)) + form) + ;; + ;; CONS types. They must be checked _before_ sequence types. We + ;; do not produce optimized forms because they can be recursive. + ((and (consp type) (eq (first type) 'CONS)) + form) + ;; + ;; The type denotes a known class and we can check it + #+clos + ((setf aux (find-class type nil)) + `(si::of-class-p ,object ',type)) + ;; + ;; There are no other atomic types to optimize + ((atom type) + form) + ;; + ;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't)) + ((eq first 'NOT) + `(not (typep ,object ',(first rest)))) + ;; + ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...) + ;; (TYPEP o '(OR t1 t2 ...)) => (OR (TYPEP o 't1) (TYPEP o 't2) ...) + ((member first '(OR AND)) + (let ((var (gensym))) + `(let ((,var ,object)) + (declare (:read-only ,var)) + (,first ,@(loop for type in rest + collect `(typep ,var ',type)))))) + ;; + ;; (TYPEP o '(MEMBER a1 a2 ...)) => (MEMBER o '(a1 a2 ...)) + ((eq first 'MEMBER) + `(MEMBER ,object ',rest)) + ;; + ;; (INTEGER * *), etc + ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT + #+short-float SHORT-FLOAT)) + (let ((var (gensym))) + ;; Small optimization: it is easier to check for fixnum + ;; than for integer. Use it when possible. + (when (and (eq first 'integer) + (subtypep type 'fixnum)) + (setf first 'fixnum)) + `(LET ((,var ,object)) + (declare (:read-only ,var)) + (AND (TYPEP ,var ',first) + ,@(expand-in-interval-p `(the ,first ,var) rest))))) + ;; + ;; Complex types with arguments. + ((setf rest (rest type) + first (first type) + function (get-sysprop first 'SI::DEFTYPE-DEFINITION)) + (expand-typep form object `',(apply function rest) env)) + (t + form)))) + +(define-compiler-macro typep (&whole form object type &environment env) + (expand-typep form object type env)) + +;;; +;;; DOLIST +;;; +;;; We overwrite the original macros introducing type declarations and +;;; other possible type checks. +;;; + +(eval-when (:load-toplevel) +(defmacro dolist ((var expression &optional output-form) &body body &environment env) + (multiple-value-bind (declarations body) + (si:process-declarations body nil) + (let* ((list-var (gensym)) + (typed-var (if (policy-check-all-arguments-p env) + list-var + `(the cons ,list-var)))) + `(block nil + (let* ((,list-var ,expression) + ,var) + (declare ,@declarations) + (si::while ,list-var + (setq ,var (first ,typed-var)) + ,@body + (setq ,list-var (rest ,typed-var))) + ,(when output-form `(setq ,var nil)) + ,output-form))))) +) + +;;; +;;; COERCE +;;; +;;; Simple coercion rules are implemented using the following +;;; templates. X is replaced by the coerced value, which can be a +;;; lisp form. We use a LET form to avoid evaluating twice the same +;;; form. +;;; +(defparameter +coercion-table+ + '((integer . (let ((y x)) (check-type y integer) y)) + (float . (float x)) + (short-float . (float x 0.0s0)) + (single-float . (float x 0.0f0)) + (double-float . (float x 0.0d0)) + (long-float . (float x 0.0l0)) + (base-char . (character x)) + (character . (character x)) + (function . (si::coerce-to-function x)) + )) + +(defun expand-coerce (form value type env) + (declare (si::c-local)) + ;; This function is reponsible for expanding (TYPEP object type) + ;; forms into a reasonable set of system calls. When it fails to + ;; match the compiler constraints on speed and space, it simply + ;; returns the original form. Note that for successful recursion we + ;; have to output indeed the ORIGINAL FORM, not some intermediate + ;; step. Otherwise the compiler macro will enter an infinite loop. + (let* ((space (cmp-env-optimization 'space env)) + (speed (cmp-env-optimization 'speed env)) + (safety (cmp-env-optimization 'safety env)) + (orig-type type) + first rest) + (cond ((not (and (constantp type) (setf type (cmp-eval type)))) + form) + ;; + ;; Trivial case + ((subtypep 't type) + value) + ;; + ;; Detect inconsistencies in the type form. + ((subtypep type 'nil) + (cmperror "Cannot COERCE an expression to an empty type.")) + ;; + ;; No optimizations that take up too much space unless requested. + ((and (>= space 2) (> space speed)) + form) + ;; + ;; Search for a simple template above, replacing X by the value. + ((loop for (a-type . template) in +coercion-table+ + when (eq type a-type) + do (return (subst value 'x template)))) + ;; + ;; FIXME! COMPLEX cannot be in +coercion-table+ because + ;; (type= '(complex) '(complex double-float)) == T + ;; + ((eq type 'COMPLEX) + `(let ((y ,value)) + (declare (:read-only y)) + (complex (realpart y) (imagpart y)))) + ;; + ;; Complex types defined with DEFTYPE. + ((and (atom type) + (get-sysprop type 'SI::DEFTYPE-DEFINITION) + (setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION))) + (expand-coerce form value `',(funcall function) env)) + ;; + ;; CONS types are not coercible. + ((and (consp type) + (eq (first type) 'CONS)) + form) + ;; + ;; Search for a simple template above, but now assuming the user + ;; provided a more complex form of the same value. + ((loop for (a-type . template) in +coercion-table+ + when (si::type= type a-type) + do (return (subst value 'x template)))) + ;; + ;; SEQUENCE types + ((subtypep type 'sequence) + (multiple-value-bind (elt-type length) + (si::closest-sequence-type type) + (if (eq elt-type 'list) + `(si::coerce-to-list ,value) + `(si::coerce-to-vector ,value ',elt-type ',length)))) + ;; + ;; There are no other atomic types to optimize + ((atom type) + form) + ;; + ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...) + ((progn + (setf rest (rest type) first (first type)) + (eq first 'AND)) + `(let ((x ,value)) + ,@(loop for i in rest + collect `(setf x (coerce x ',i))) + x)) + ;; + ;; (COMPLEX whatever) types + ((and (eq first 'complex) + (= (length rest) 1)) + `(let ((y ,value)) + (declare (:read-only y)) + (complex (coerce (realpart y) ',(first rest)) + (coerce (imagpart y) ',(first rest))))) + ;; + ;; (INTEGER * *), etc We have to signal an error if the type + ;; does not match. However, if safety settings are low, we + ;; skip the interval test. + ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT + #+short-float SHORT-FLOAT)) + (let ((unchecked (expand-coerce form value `',first env))) + (if (< safety 1) + unchecked + `(let ((x ,unchecked)) + (declare (,first x)) + (unless (and ,@(expand-in-interval-p 'x (rest type))) + (si::do-check-type x ',type nil "coerced value")) + x)))) + ;; + ;; We did not find a suitable expansion. + (t + form) + ))) + +(define-compiler-macro coerce (&whole form value type &environment env) + (expand-coerce form value type env)) + +;;; +;;; AREF/ASET +;;; + +(define-compiler-macro aref (&whole form array &rest indices &environment env) + (if (policy-open-code-aref/aset-p env) + (let ((check (policy-array-bounds-check-p env))) + (cond ((null (rest indices)) + (if check + form + (list 'row-major-aref array (first indices)))) + ((and (null indices) (not check)) + (list 'row-major-aref array 0)) + (t + (expand-aref array indices check)))) + form)) + +(defun expand-aref (array indices check) + (let* ((a (gensym)) + (indices (expand-row-major-index a indices check))) + `(let ((,a ,array)) + (declare (:read-only ,a) + (optimize (safety 0))) + (row-major-aref ,a ,indices)))) + +(define-compiler-macro si::aset (&whole form value array &rest indices + &environment env) + (if (policy-open-code-aref/aset-p env) + (let ((check (policy-array-bounds-check-p env))) + (cond ((null (rest indices)) + (if check + form + (list 'si::row-major-aset array (first indices) value))) + ((and (null indices) (not check)) + (list 'si::row-major-aset array 0 value)) + (t + (expand-aset array indices value check)))) + form)) + +(defun expand-aset (array indices value check) + (let* ((a (gensym)) + (v (gensym)) + (indices (expand-row-major-index a indices check))) + `(let ((,v ,value) + (,a ,array)) + (declare (:read-only ,a ,v) + (optimize (safety 0))) + (si::row-major-aset ,a ,indices ,value)))) + +(defun expand-row-major-index (a indices check) + (let* ((output-var (gensym)) + (dim-var (gensym)) + (ndx-var (gensym)) + (expected-rank (length indices))) + `(let* ((,ndx-var ,(or (pop indices) 0)) + (,output-var ,ndx-var) + (,dim-var 0)) + (declare (type si::index ,ndx-var ,output-var ,dim-var)) + ,@(when check + `((declare (optimize (safety 0))) + (unless (arrayp ,a) + (error-not-an-array ,a)) + (unless (= (array-rank ,a) ,expected-rank) + (error-wrong-dimensions ,a ,expected-rank)) + (setf ,dim-var (array-dimension-fast ,a 0)) + (unless (< ,output-var ,dim-var) + (error-wrong-index ,a ,ndx-var ,dim-var)))) + ,@(loop for j from 1 + for index in indices + collect `(setf ,dim-var (array-dimension-fast ,a ,j) + ,ndx-var ,index) + collect (when check + `(unless (< ,ndx-var ,dim-var) + (error-wrong-index ,a ,ndx-var ,dim-var))) + collect `(setf ,output-var (the si::index + (+ (the si::index (* ,output-var ,dim-var)) + ,ndx-var)))) + ,output-var))) + +;(trace c::expand-row-major-index c::expand-aset c::expand-aref) + +(defmacro error-not-an-array (a) + `(c-inline (,a) (:object) :void "FEtype_error_array(#0);")) + +(defmacro error-wrong-dimensions (a rank) + `(c-inline (,a ,rank) (:object :cl-index) :void + "FEwrong_dimensions(#0,#1);")) + +(defmacro error-wrong-index (a ndx limit) + `(c-inline (,a ,ndx ,limit) (:object :cl-index :cl-index) :void + "FEwrong_index(#0,#1,#2);")) + +(defconstant +array-dimension-accessor+ + '#.(loop for i from 0 below array-rank-limit + collect (format nil "(#0)->array.dims[~D]" i))) + +(defmacro array-dimension-fast (array n) + (if (typep n '(integer 0 #.(1- array-rank-limit))) + `(c-inline (,array) (:object) :fixnum + ,(nth n +array-dimension-accessor+) + :one-liner t :side-effects nil) + (error "In macro ARRAY-DIMENSION-FAST, the index is not a constant integer: ~A" + n))) diff --git a/src/new-cmp/cmpprop.lsp b/src/new-cmp/cmpprop.lsp new file mode 100644 index 000000000..54ada0408 --- /dev/null +++ b/src/new-cmp/cmpprop.lsp @@ -0,0 +1,535 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPPROP Type propagation. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; TYPE PROPAGATION LOOP +;;; +;;; +;;; ALL C1FORMS: Intermediate language used by the compiler +;;; +;;; (LOCATION loc) +;;; (VAR var) +;;; (SETQ var value-c1form) +;;; (PSETQ var-list value-c1form-list) +;;; (BLOCK blk-var progn-c1form) +;;; (TAGBODY tag-var tag-body) +;;; (RETURN-FROM blk-var return-type value) +;;; (FUNCALL fun-value (arg-value*)) +;;; (CALL-LOCAL obj-fun (arg-value*)) +;;; (CALL-GLOBAL fun-name (arg-value*)) +;;; (CATCH catch-value body-c1form) +;;; (UNWIND-PROTECT protected-c1form body) +;;; (THROW catch-value output-value) +;;; (GO tag-var return-type) +;;; (C-INLINE (arg-c1form*) +;;; (arg-type-symbol*) +;;; output-rep-type +;;; c-expression-string +;;; side-effects-p +;;; one-liner-p) +;;; (DO-FLET/LABELS {FLET|LABELS} funob-list lambda-expr-list) +;;; (IF fmla-c1form true-c1form false-c1form) +;;; (FMLA-NOT fmla-c1form) +;;; (LAMBDA lambda-list doc body-c1form) +;;; (LET/LET* vars-list var-init-c1form-list progn-c1form) +;;; (VALUES values-c1form-list) +;;; (MULTIPLE-VALUE-SETQ vars-list values-c1form-list) +;;; (MULTIPLE-VALUE-BIND vars-list init-c1form body) +;;; (COMPILER-LET symbols values body) +;;; (FUNCTION {GLOBAL|CLOSURE} lambda-form fun-object) +;;; +;;; (SI:STRUCTURE-REF struct-c1form type-name slot-index {:UNSAFE|NIL}) +;;; (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form) +;;; +;;; (WITH-STACK body) +;;; (STACK-PUSH-VALUES value-c1form push-statement-c1form) +;;; +;;; (LOAD-TIME-VALUE dest-loc value-c1form) +;;; (FSET function-object vv-loc, macro-p pprint-p lambda-form) +;;; +;;; body = (c1form*) +;;; tag-body = ({c1form | tag}*) +;;; return-type = {CLB | CCB | UNWIND-PROTECT} +;;; *value = c1form +;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) +;;; +;;; + +(defvar *type-propagation-messages* t) + +;(setf *do-type-propagation* t) + +(eval-when (eval compile) + (defmacro prop-message (&rest args) + `(when *type-propagation-messages* + (format *standard-output* "~&;~2D " *prop-depth*) + (format *standard-output* ,@args)))) + +(defun propagate-function-types (fun) + (prop-message "~&;;; Propagating function ~A~&;;;" (fun-name fun)) + (let ((l (fun-lambda fun))) + (apply #'p1lambda l nil (c1form-args)))) + +(defvar *prop-depth* 0) + +(defun p1propagate (form assumptions) + (when (listp form) + (return-from p1propagate + (p1propagate-list form assumptions))) + (let* ((name (c1form-name form)) + (type (c1form-type form)) + (*cmp-env* (c1form-env form)) + (*prop-depth* (1+ *prop-depth*)) + propagator) + (cond ((eq name 'VAR) + (let* ((var (c1form-arg 0 form)) + (record (assoc var assumptions))) + (when record + (setf type (type-and (cdr record) type))) + (prop-message "Querying variable ~A gives ~A" (var-name var) type) + (values (setf (c1form-type form) type) assumptions))) + ((setf propagator (get-sysprop name 'p1propagate)) + (prop-message "Entering type propagation for ~A" name) + (multiple-value-bind (type assumptions) + (apply propagator form assumptions (c1form-args form)) + (prop-message "Propagating ~A gives type ~A" name type) + (values (setf (c1form-type form) type) assumptions))) + (t + (prop-message "Refusing to propagate ~A" name type) + (values (c1form-type form) assumptions))))) + +(defun p1propagate-list (list assumptions) + (loop with final-type = t + for f in list + do (multiple-value-setq (final-type assumptions) (p1propagate f assumptions)) + finally (return (values final-type assumptions)))) + +(defun print-assumptions (message assumptions &optional (always-p t)) + (when (and always-p (null assumptions)) + (prop-message "~A: NIL" message)) + (when assumptions + (prop-message "~A:" message)) + (dolist (record assumptions) + (prop-message "~A : ~A" (var-name (car record)) (cdr record)))) + +(defun p1merge-branches (root chains) + "ROOT is a list of assumptions, while CHAINS is list of extended versions of +ROOT. This function takes all those extensions and makes a final list in which +type assumptions have been merged, giving the variables the OR type of each +of the occurrences in those lists." + ;; First the simple case in which we only have one list. + (when (null (rest chains)) + (setf root (first chains)) + (print-assumptions "Only one branch" root) + (return-from p1merge-branches root)) + ;; When we have to merge more than one list, we use a hash table in which + ;; we push all possible assumptions, merging the types with TYPE-OR. + (let* ((all-new-variables (make-hash-table)) + (scanned (make-hash-table))) + (print-assumptions "Root branch" root t) + (dolist (l chains) + (print-assumptions "Extra branch" (ldiff l root))) + ;; The first pass is filling the hash with unequal assumptions + ;; mergin the types + (loop for c in chains + do (clrhash scanned) + do (loop for list on c + for record = (first list) + until (eq list root) + do (let* ((var (car record)) + (type (cdr record))) + (unless (gethash var scanned) + (setf (gethash var scanned) type) + (let ((other-type (gethash var all-new-variables :missing))) + (unless (eq other-type :missing) + (setf type (type-or type other-type))) + (setf (gethash var all-new-variables) type)))))) + ;; While the last pass is extending the list of assumptions with + ;; the merged ones. + (loop with new-root = root + for var being the hash-key in all-new-variables + using (hash-value type) + do (setf new-root (acons var type new-root)) + finally (progn + (print-assumptions "Output branch" new-root) + (return new-root))))) + +(defun revise-var-type (variable assumptions where-to-stop) + (unless (member (var-kind variable) + '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED DISCARDED) + :test #'eql) + (do* ((l assumptions (cdr l)) + (variable-type nil)) + ((or (null l) (eq l where-to-stop)) + (prop-message "Changing type of variable ~A to ~A" + (var-name variable) variable-type) + (unless variable-type + (error "Variable ~A not found" (var-name variable))) + (setf (var-type variable) variable-type + (var-kind variable) (lisp-type->rep-type variable-type))) + (let ((record (first l))) + (when (eql (car record) variable) + (let ((one-type (cdr record))) + (setf variable-type (if variable-type + (type-or variable-type one-type) + one-type)))))))) + +(defun p1expand-assumptions (var type assumptions) + (unless (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED)) + (prop-message "Adding variable ~A with type ~A" (var-name var) type) + (unless (or (var-set-nodes var) (var-functions-setting var)) + (prop-message "Changing type of read-only variable ~A" (var-name var)) + (setf (var-type var) type (var-kind var) (lisp-type->rep-type type))) + (setf assumptions (acons var type assumptions))) + assumptions) + +(defun p1expand-many (var type assumptions) + (loop for v in var + for v-t in type + do (setf assumptions (p1expand-assumptions v v-t assumptions))) + assumptions) + +#+nil +(trace c::p1propagate c::p1progate-list c::p1expand-assumptions + c::p1call-global) + +(defun p1block (c1form assumptions blk body) + (multiple-value-bind (normal-type assumptions) + (p1propagate body assumptions) + (values (type-or (blk-type blk) normal-type) + assumptions))) + +(defun p1enforce-type (c1form type assumptions) + (let* ((old-type (c1form-primary-type c1form)) + (and-type (type-and type old-type))) + (unless (equal and-type old-type) + (setf (c1form-type c1form) and-type) + (when (eq 'VAR (c1form-name c1form)) + (let ((var (c1form-arg 0 c1form))) + (setf assumptions (p1expand-assumptions var type assumptions))))) + assumptions)) + +(defun p1call-global (c1form assumptions fname args &optional (return-type t)) + (loop for v in args + with arg-type + do (multiple-value-setq (arg-type assumptions) (p1propagate v assumptions)) + finally (multiple-value-bind (arg-types type found) + (infer-arg-and-return-types fname args) + (prop-message "Computing output of function ~A with args~&;;;~ + ~{ ~A~}~&;;; gives ~A, while before ~A" + fname (mapcar #'c1form-primary-type args) + type (c1form-type c1form)) + ;; Back-propagate constraints. + (when found + (loop for type in arg-types + for form in args + do (setf assumptions (p1enforce-type form type assumptions)))) + (setf (c1form-args c1form) (list fname args return-type)) + (return (values type assumptions))))) + +(defun p1catch (c1form assumptions tag body) + (multiple-value-bind (tag-type assumptions) + (p1propagate tag assumptions) + (p1propagate body assumptions)) + (values t assumptions)) + +(defun p1if (c1form assumptions fmla true-branch false-branch) + (multiple-value-bind (fmla-type base-assumptions) + (p1propagate fmla assumptions) + (multiple-value-bind (t1 a1) + (p1propagate true-branch base-assumptions) + (multiple-value-bind (t2 a2) + (p1propagate false-branch base-assumptions) + (values (values-type-or t1 t2) + (p1merge-branches base-assumptions (list a1 a2))))))) + +(defun p1lambda (c1form assumptions lambda-list doc body block-name &rest not-used) + (prop-message "~&;;; Propagating lambda form ~A~&;;;" block-name) + (prop-message " REQUIREDS: ~{~A ~}" (mapcar #'var-name (first lambda-list))) + (let ((type (p1propagate body assumptions))) + (values type assumptions))) + +(defun p1let/let* (c1form base-assumptions vars forms body) + (let ((new-assumptions base-assumptions)) + (loop for v in vars + for f in forms + do (multiple-value-bind (type ass) + (p1propagate f base-assumptions) + (setf type (values-type-primary-type type) + new-assumptions (p1expand-assumptions v type new-assumptions)))) + (multiple-value-bind (type assumptions) + (p1propagate body new-assumptions) + (loop for v in vars + do (revise-var-type v assumptions base-assumptions)) + (values (setf (c1form-type c1form) type) + assumptions)))) + +(defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body) + (multiple-value-bind (init-form-type assumptions) + (p1propagate init-c1form assumptions) + (let ((new-types (values-type-to-n-types init-form-type (length vars-list)))) + (p1propagate body (p1expand-many vars-list new-types assumptions))))) + +(defun p1multiple-value-setq (c1form assumptions vars-list value-c1form) + (multiple-value-bind (init-form-type assumptions) + (p1propagate value-c1form assumptions) + (let ((new-types (values-type-to-n-types init-form-type (length vars-list)))) + (values init-form-type (p1expand-many vars-list new-types assumptions))))) + +(defun p1with-stack (c1form assumptions body-form) + (p1propagate body-form assumptions)) + +(defun p1setq (c1form assumptions var c1form) + (multiple-value-bind (value-type assumptions) + (p1propagate c1form assumptions) + (let ((type (type-and (var-type var) (values-type-primary-type value-type)))) + (values type (p1expand-assumptions var type assumptions))))) + +(defun p1psetq (c1form assumptions var-list form-list) + (values '(values) + (p1expand-many var-list + (loop for form in form-list + with value-type + collect (values-type-primary-type + (multiple-value-setq (value-type assumptions) + (p1propagate form assumptions)))) + assumptions))) + +(defun p1simple (c1form assumptions &rest args) + (declare (ignore args)) + (values (c1form-type c1form) assumptions)) + +(defun p1generic (c1form assumptions &rest args) + (loop for i in args + with value-type + when (typep i 'c1form) + do (multiple-value-setq (value-type assumptions) + (p1propagate i assumptions))) + (values (c1form-type c1form) assumptions)) + +(defun p1c-inline (c1form assumptions + args-list arg-type-list output-rep-type c-expression-string + side-effects-p one-liner-p) + (loop for form in args-list + with aux + do (multiple-value-setq (aux assumptions) (p1propagate form assumptions))) + (values (c1form-type c1form) assumptions)) + +(defvar *tagbody-depth* -1 + "If n > 0, limit the number of passes to converge tagbody forms. If +-1, let the compiler do as many passes as it wishes. Complexity grows +as 2^*tagbody-limit* in the worst cases.") + +(defun p1tagbody (c1form assumptions tag-loc body) + (let ((*tagbody-depth* *tagbody-depth*)) + (cond ((zerop *tagbody-depth*) + (p1tagbody-simple c1form assumptions tag-loc body)) + (t + (setf *tagbody-depth* (1- *tagbody-depth*)) + (p1tagbody-many-passes c1form assumptions tag-loc body))))) + +(defun filter-only-declarations (assumptions) + nil) + +(defun p1tagbody-one-pass (c1form assumptions tag-loc body) + (loop with local-ass = assumptions + with ass-list = '() + for f in body + do (if (tag-p f) + (let ((diff (ldiff local-ass assumptions))) + (when diff + (push diff ass-list)) + (prop-message "Label ~A found" (tag-name f)) + (setf local-ass assumptions)) + (multiple-value-setq (aux local-ass) (p1propagate f local-ass))) + finally (return + (let ((diff (ldiff local-ass assumptions))) + (if diff + (cons diff ass-list) + ass-list))))) + +(defun p1tagbody-simple (c1form orig-assumptions tag-loc body) + (prop-message "P1TAGBODY-SIMPLE pass") + (print-assumptions "Orig assumptions:" orig-assumptions) + (let* ((assumptions (filter-only-declarations orig-assumptions)) + (ass-list (p1tagbody-one-pass c1form assumptions tag-loc body))) + (values 'null (append (p1merge-branches nil ass-list) orig-assumptions)))) + +(defun p1tagbody-many-passes (c1form orig-assumptions tag-loc body) + (loop with orig-ass-list = '() + with assumptions = orig-assumptions + for i from 0 below 3 + for foo = (prop-message "P1TAGBODY-MANY-PASSES pass ~D" i) + for ass-list = (p1tagbody-one-pass c1form assumptions tag-loc body) + for faa = (progn + (print-assumptions "Old tagbody assumptions" assumptions) + (pprint ass-list)) + for new-assumptions = (nconc (p1merge-branches nil ass-list) orig-assumptions) + for fee = (print-assumptions "New tagbody assumptions" new-assumptions) + for end = (equalp assumptions (setf assumptions new-assumptions)) + until end + finally (cond (end + (prop-message "P1TAGBODY-MANY-PASSES exists at ~D" i) + (return (values 'null assumptions))) + (t + (prop-message "P1TAGBODY-MANY-PASSES refuses at ~D" i) + (p1tagbody-simple c1form orig-assumptions tag-loc body))))) + +(defun p1unwind-protect (c1form assumptions form body) + (multiple-value-bind (output-type assumptions) + (p1propagate form assumptions) + (p1propagate-list body assumptions) + (values output-type assumptions))) + +(defun p1values (c1form assumptions forms) + (values (list* 'values + (loop for form in forms + with value-type + collect (progn + (multiple-value-setq (value-type assumptions) + (p1propagate form assumptions)) + (values-type-primary-type value-type)))) + assumptions)) + +(defun p1compiler-let (c1form assumptions symbols values body) + (p1propagate-list body assumptions)) + +(defun p1location (c1form assumptions &rest args) + (prop-message "LOCATION contains ~{~A~}" args) + (values (c1form-type c1form) assumptions)) + +(put-sysprop 'location 'p1propagate 'p1location) +(put-sysprop 'setq 'p1propagate 'p1setq) +(put-sysprop 'psetq 'p1propagate 'p1psetq) +(put-sysprop 'block 'p1propagate 'p1block) +(put-sysprop 'tagbody 'p1propagate 'p1tagbody) +;(put-sysprop 'return-from 'p1propagate 'p1generic) +(put-sysprop 'funcall 'p1propagate 'p1generic) +(put-sysprop 'call-local 'p1propagate 'p1generic) +(put-sysprop 'call-global 'p1propagate 'p1call-global) +(put-sysprop 'catch 'p1propagate 'p1catch) +(put-sysprop 'unwind-protect 'p1propagate 'p1unwind-protect) +;(put-sysprop 'throw 'p1propagate 'p1generic) +(put-sysprop 'go 'p1propagate 'p1generic) +(put-sysprop 'ffi::c-inline 'p1propagate 'p1c-inline) +(put-sysprop 'do-flet/labels 'p1propagate 'p1simple) +(put-sysprop 'if 'p1propagate #'p1if) +(put-sysprop 'fmla-not 'p1propagate 'p1generic) +(put-sysprop 'lambda 'p1propagate 'p1lambda) +(put-sysprop 'let/let* 'p1propagate 'p1let/let*) +(put-sysprop 'values 'p1propagate 'p1values) +(put-sysprop 'multiple-value-setq 'p1propagate 'p1multiple-value-setq) +(put-sysprop 'multiple-value-bind 'p1propagate 'p1multiple-value-bind) +(put-sysprop 'compiler-let 'p1propagate 'compiler-let) + +(put-sysprop 'si:structure-ref 'p1propagate 'p1generic) +(put-sysprop 'si:structure-set 'p1propagate 'p1generic) + +(put-sysprop 'with-stack 'p1propagate 'p1with-stack) +(put-sysprop 'stack-push-values 'p1propagate 'p1generic) + +(put-sysprop 'fset 'p1propagate 'p1generic) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun type-from-array-elt (array) + "Input is a lisp type representing a valid subtype of ARRAY. Output is +either the array element type or NIL, denoting that we are not able to +compute it. This version only handles the simplest cases." + (values (cond ((eq array 'string) + 'character) + ((eq array 'base-string) + 'base-char) + ((member array '(array vector simple-vector simple-array)) + t) + ((atom array) + (setf array 'array) + t) + ((eq (first array) 'simple-vector) + t) + ((not (member (first array) + '(array vector simple-array))) + (setf array 'array) + t) + ((null (rest array)) + t) + (t + (second array))) + array)) + +(defun get-constant-value (form default) + (if (constantp form) + (cmp-eval form) + default)) + +(def-type-propagator si::aset (fname obj array-type &rest indices) + (multiple-value-bind (elt-type array-type) + (type-from-array-elt array-type) + (values (list* elt-type array-type + (make-list (length indices) :initial-element 'si::index)) + elt-type))) + +(def-type-propagator aref (fname array-type &rest indices) + (multiple-value-bind (elt-type array-type) + (type-from-array-elt array-type) + (values (list* array-type (make-list (length indices) + :initial-element 'si::index)) + elt-type))) + +(def-type-propagator si::row-major-aset (fname array-type index value) + (multiple-value-bind (elt-type array-type) + (type-from-array-elt array-type) + (values (list array-type 'si::index elt-type) elt-type))) + +(def-type-propagator row-major-aref (fname array-type index) + (multiple-value-bind (elt-type array-type) + (type-from-array-elt array-type) + (values (list array-type 'si::index) elt-type))) + +(define-compiler-macro make-array (&whole form dimensions + &key (element-type t) + (initial-element nil initial-element-supplied-p) + (initial-contents nil initial-contents-supplied-p) + adjustable fill-pointer + displaced-to (displaced-index-offset 0)) + (let* ((type (if (or (get-constant-value adjustable t) + (get-constant-value fill-pointer t) + (get-constant-value displaced-to t)) + 'array + 'simple-array)) + (upgraded-type (get-constant-value element-type '*)) + (guess-dims (get-constant-value dimensions '*)) + (form (list 'si::make-pure-array element-type dimensions adjustable + fill-pointer displaced-to displaced-index-offset))) + (unless (eq upgraded-type '*) + ;; Known type? + (if (nth-value 1 (subtypep t upgraded-type)) + (setf upgraded-type (upgraded-array-element-type upgraded-type)) + (cmpnote "Unknown element type ~A passed to MAKE-ARRAY" upgraded-type))) + (unless (eq guess-dims '*) + (if (listp guess-dims) + (setf guess-dims (make-list (length guess-dims) :initial-element '*)) + (setf guess-dims '(*)))) + (setf type (list type upgraded-type guess-dims)) + (cond (initial-element-supplied-p + (when initial-contents-supplied-p + (cmpwarn "In MAKE-ARRAY, both :INITIAL-ELEMENT and :INITIAL-CONTENTS were supplied.")) + (setf form `(si::fill-array-with-elt ,form ,initial-element 0 nil))) + (initial-contents-supplied-p + (setf form `(si::fill-array-with-seq ,form ,initial-contents)))) + `(the ,type ,form))) + diff --git a/src/new-cmp/cmpspecial.lsp b/src/new-cmp/cmpspecial.lsp new file mode 100644 index 000000000..b0b810f3a --- /dev/null +++ b/src/new-cmp/cmpspecial.lsp @@ -0,0 +1,119 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPSPECIAL Miscellaneous special forms. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + + +(in-package "COMPILER") + +(defun c1quote (destination args) + (check-args-number 'QUOTE args 1 1) + (c1constant-value destination (car args) :always t)) + +(defun c1declare (args) + (cmperr "The declaration ~s was found in a bad place." (cons 'DECLARE args))) + +(defun c1the (destination args) + (check-args-number 'THE args 2 2) + (let* ((type (pop args)) + (value (pop args))) + (c1translate `(THE ,type ,destination) value))) + +(defun c1compiler-let (destination args &aux (symbols nil) (values nil)) + (when (endp args) (too-few-args 'COMPILER-LET 1 0)) + (dolist (spec (car args)) + (cond ((consp spec) + (cmpck (not (and (symbolp (car spec)) + (or (endp (cdr spec)) + (endp (cddr spec))))) + "The variable binding ~s is illegal." spec) + (push (car spec) symbols) + (push (if (endp (cdr spec)) nil (eval (second spec))) values)) + ((symbolp spec) + (push spec symbols) + (push nil values)) + (t (cmperr "The variable binding ~s is illegal." spec)))) + (setq symbols (nreverse symbols)) + (setq values (nreverse values)) + (progv symbols values (c1progn destination (cdr args)))) + +(defun c1function (destination args &aux fd) + (check-args-number 'FUNCTION args 1 1) + (let ((fun (car args))) + (cond ((si::valid-function-name-p fun) + (let ((funob (local-function-ref fun t))) + (if funob + (c1set-loc destination (fun-var funob)) + (c1set-loc destination `(FDEFINITION ,fun))))) + ((and (consp fun) (member (car fun) '(LAMBDA EXT::LAMBDA-BLOCK))) + (cmpck (endp (cdr fun)) + "The lambda expression ~s is illegal." fun) + (let (name body) + (if (eq (first fun) 'EXT::LAMBDA) + (setf name (gensym) body (rest fun)) + (setf name (second fun) body (cddr fun))) + (let* ((funob (c1compile-function body :name name)) + (lambda-form (fun-lambda funob))) + (setf (fun-ref-ccb funob) t) + (compute-fun-closure-type funob) + (nconc (c1do-flet/labels-op (list funob)) + (c1set-loc destination `(MAKE-CCLOSURE ,funob)))))) + (t (cmperr "The function ~s is illegal." fun))))) + +;;; Mechanism for sharing code. +(defun new-local (fun) + ;; returns the previous function or NIL. + (declare (type fun fun)) + (case (fun-closure fun) + (CLOSURE + (setf (fun-level fun) 0 (fun-env fun) *env*)) + (LEXICAL + (let ((parent (fun-parent fun))) + ;; Only increase the lexical level if there have been some + ;; new variables created. This way, the same lexical environment + ;; can be propagated through nested FLET/LABELS. + (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*) + (fun-env fun) 0))) + (otherwise + (setf (fun-env fun) 0 (fun-level fun) 0))) + (push fun *local-funs*)) + +(defun wt-fdefinition (fun-name) + (let ((vv (add-object fun-name))) + (if (and (symbolp fun-name) + (or (not (safe-compile)) + (and (eql (symbol-package fun-name) (find-package "CL")) + (fboundp fun-name) (functionp (fdefinition fun-name))))) + (wt "(" vv "->symbol.gfdef)") + (wt "ecl_fdefinition(" vv ")")))) + +(defun environment-accessor (fun) + (let* ((env-var (env-var-name *env-lvl*)) + (expected-env-size (fun-env fun))) + (if (< expected-env-size *env*) + (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) + env-var))) + +(defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) + (declare (type fun fun)) + (let* ((closure (fun-closure fun)) + narg) + (cond ((eq closure 'CLOSURE) + (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," + (environment-accessor fun) + ",Cblock)")) + ((eq closure 'LEXICAL) + (baboon)) + ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args + (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",Cnil,Cblock," narg ")")) + (t ; empty environment variable number of args + (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",Cnil,Cblock)"))))) diff --git a/src/new-cmp/cmpstack.lsp b/src/new-cmp/cmpstack.lsp new file mode 100644 index 000000000..5a9e80239 --- /dev/null +++ b/src/new-cmp/cmpstack.lsp @@ -0,0 +1,63 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2006, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPSTACK Manipulation of the lisp stack from C code +;;;; +;;;; Following special forms are provided: +;;;; +;;;; (WITH-STACK {form}*) +;;;; Executes given forms, restoring the lisp stack on output. +;;;; (STACK-PUSH form) +;;;; (STACK-PUSH-VALUES form) +;;;; (STACK-POP nvalues) +;;;; + +(in-package "COMPILER") + +(defun c1with-stack (destination forms) + (let* ((var-name (pop forms)) + (var (make-var :name var-name :kind :object :type t)) + (cleanup (c1stack-frame-close var)) + (*cmp-env* (cmp-env-register-cleanup + cleanup + (cmp-env-register-var var (cmp-env-copy *cmp-env*))))) + (nconc (c1bind (list var)) + (c1stack-frame-open var) + (c1translate destination `(progn ,@forms)) + (c1stack-frame-close var) + (c1unbind (list var))))) + +(defun c1stack-push (destination args) + (let* ((var (c1vref (first args))) + (value (second args))) + (c1translate 'VALUE0 value) + (c1stack-frame-push var 'VALUE0))) + +(defun c1stack-push-values (destination args) + (unless (eq destination 'TRASH) + (error "In C1STACK-PUSH-VALUES, destination should be TRASH")) + (let* ((frame-var (pop args)) + (form (pop args))) + (c1translate 'VALUES form) + (c1stack-frame-push-values (c1vref frame-var)))) + +(defun c1stack-pop (destination args) + (let* ((frame-var-name (pop args)) + (frame-var (c1vref frame-var-name))) + (c1stack-frame-pop-values frame-var destination))) + +(defun c1apply-from-stack-frame (destination args) + (let* ((frame-var-name (first args)) + (function (second args)) + (frame-var (c1vref frame-var-name))) + (nconc (c1translate 'VALUE0 function) + (c1stack-frame-apply frame-var 'VALUE0) + (c1set-loc destination 'VALUES)))) diff --git a/src/new-cmp/cmpstructures.lsp b/src/new-cmp/cmpstructures.lsp new file mode 100644 index 000000000..1c12ac563 --- /dev/null +++ b/src/new-cmp/cmpstructures.lsp @@ -0,0 +1,141 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPSTRUCT. STRUCTURE related optimizations. + +;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;; +;;; GET-SLOT-TYPE +;;; +;;; Given a structure type and a slot index, infer the type of the output. +;;; +(defun get-slot-type (name index) + ;; default is t + (type-filter + (or (third (nth index (get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T))) + +;;; +;;; STRUCTURE SLOT READING +;;; +;;; By looking at the name of a function we may infer whether it is a +;;; reader for a structure slot. If this is the case and the policy +;;; allows us, we will inline the slot access and infer the type of +;;; the output. +;;; + +(defun maybe-optimize-structure-access (destination fname args) + (let* ((slot-description (get-sysprop fname 'SYS::STRUCTURE-ACCESS))) + (when (and slot-description + (inline-possible fname) + (policy-inline-slot-access-p)) + ;(format t "~%;;; Optimizing structure accessor ~A" fname) + (let (struture-type slot-index) + (unless (and (consp slot-description) + (setf structure-type (car slot-description) + slot-index (cdr slot-description)) + (typep slot-index 'fixnum)) + (cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A" + fname slot-index) + (return-from maybe-optimize-structure-access nil)) + (unless (= (length args) 1) + (cmpwarn "Too many arguments for structure slot accessor ~A" fname) + (return-from maybe-optimize-structure-access nil)) + (setf args (first args)) + (cond + ((eq structure-type 'list) + (c1expr destination `(elt ,args ,slot-index))) + ((eq structure-type 'vector) + (c1expr destination `(svref ,args ,slot-index))) + ((consp structure-type) + (c1expr destination `(aref (the ,structure-type ,args) ,slot-index))) + (t + (c1structure-ref destination `(,args ',structure-type ,slot-index)))))))) + +(defun c1structure-ref (destination args) + (check-args-number 'sys:structure-ref args 3) + ;(format t "~%;;; Optimizing structure-ref for ~A" args) + (let* ((form (first args)) + (c-form (c1expr 'SHOULD-BE-TEMP form)) + (name (second args)) + (index (third args))) + (if (and (constantp name) + (constantp index)) + (let* ((name (cmp-eval name)) + (index (cmp-eval index)) + (type (get-slot-type name index))) + (make-c1form* 'SYS:STRUCTURE-REF :type type + :args c-form (add-symbol name) index + (if (or (subtypep (c1form-primary-type c-form) structure-type) + (not (policy-check-all-arguments-p))) + :unsafe + nil))) + (c1call-global destination 'sys:structure-ref args)))) + +(defun c2structure-ref (form name-vv index unsafe) + (let* ((*inline-blocks* 0) + (*temp* *temp*) + (loc (first (coerce-locs (inline-args (list form)))))) + (unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index unsafe)) + (close-inline-blocks))) + +(defun wt-structure-ref (loc name-vv index unsafe) + (if unsafe + #+clos + (wt "(" loc ")->instance.slots[" `(COERCE-LOC :fixnum ,index) "]") + #-clos + (wt "(" loc ")->str.self[" `(COERCE-LOC :fixnum ,index) "]") + (wt "ecl_structure_ref(" loc "," name-vv "," `(COERCE-LOC :fixnum ,index) ")"))) + +(defun c1structure-set (destination args) + (if (and (not (safe-compile)) ; Beppe + (not (endp args)) + (not (endp (cdr args))) + (consp (second args)) + (eq (caadr args) 'QUOTE) + (not (endp (cdadr args))) + (symbolp (cadadr args)) + (endp (cddadr args)) + (not (endp (cddr args))) + (sys::fixnump (third args)) + (not (endp (cdddr args))) + (endp (cddddr args))) + (let ((x (c1expr 'SHOULD-BE-TEMP (car args))) + (y (c1expr 'SHOULD-BE-TEMP (fourth args))) + (name (cadadr args))) + (let* ((slot-type (get-slot-type name (third args)))) + (enforce-types 'SI:STRUCTURE-SET + (list slot-type) + (list y) + (list (fourth args)))) + (make-c1form* 'SYS:STRUCTURE-SET + :type (c1form-primary-type y) + :args x (add-symbol name) (third args) y)) + (c1call-global destination 'SYS:STRUCTURE-SET args))) + +(defun c2structure-set (x name-vv index y + &aux locs (*inline-blocks* 0)) + ;; the third argument here *c1t* is just a hack to ensure that + ;; a variable is introduced for y if it is an expression with side effects + (let* ((*inline-blocks* 0) + (*temp* *temp*) + (locs (inline-args (list x y *c1t*))) + (x (second (first locs))) + (y `(coerce-loc :object ,(second (second locs))))) + (if (safe-compile) + (wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");") + #+clos + (wt-nl "(" x ")->instance.slots[" index "]= " y ";") + #-clos + (wt-nl "(" x ")->str.self[" index "]= " y ";")) + (unwind-exit y) + (close-inline-blocks))) + diff --git a/src/new-cmp/cmptables.lsp b/src/new-cmp/cmptables.lsp new file mode 100644 index 000000000..2c7f8dab9 --- /dev/null +++ b/src/new-cmp/cmptables.lsp @@ -0,0 +1,257 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; DISPATCH TABLES FOR FRONT-ENDS AND BACK-ENDS +;;; + +;;; ---------------------------------------------------------------------- +;;; CONSTRUCTORS +;;; + +(defun make-dispatch-table (pairs) + (loop with output = (make-hash-table :size (* 2 (length pairs)) :test #'eq) + for (name . function) in pairs + do (setf (gethash name output) function) + finally (return output))) + +(defun extend-dispatch-table (pairs table) + (loop with output = (make-dispatch-table pairs) + for k being the hash-key in output using (hash-value v) + do (setf (gethash output k) v) + finally (return output))) + +;;; ------------------------------------------------------------------ +;;; COMMON LISP FORMS TRANSLATORS +;;; + +(defconstant +c1-dispatch-data+ + '( + ;; cmpblock.lsp + (block . c1block) + (return-from . c1return-from) + + ;; cmpcall.lsp + (funcall . c1funcall) + + ;; cmpcatch.lsp + (catch . c1catch) + (throw . c1throw) + (unwind-protect . c1unwind-protect) + + ;; cmpcbk.lsp + ;; (ffi:defcallback . c1-defcallback) + + ;; cmpeval + (progn . c1progn) + + ;; cmpffi.lsp + (ffi:clines . c1clines) + (ffi:c-inline . c1c-inline) + + ;; cmpflet + (flet . c1flet) + (labels . c1labels) + (do-flet/labels . c1do-flet/labels) + (make-flet/labels-closure . c1make-flet/labels-closure) + (locally . c1locally) + (macrolet . c1macrolet) + (symbol-macrolet . c1symbol-macrolet) + + ;; cmpfun.lsp + (apply . c1apply) + + ;; cmpif.lsp + (if . c1if) + + ;; cmplet.lsp + (let . c1let) + (let* . c1let*) + + ;; cmpmulti.lsp + (multiple-value-call . c1multiple-value-call) + (multiple-value-prog1 . c1multiple-value-prog1) + (values . c1values) + (multiple-value-setq . c1multiple-value-setq) + (multiple-value-bind . c1multiple-value-bind) + + ;; cmpspecial.lsp + (quote . c1quote) + (function . c1function) + (the . c1the) + (eval-when . c1eval-when) + (declare . c1declare) + (ext:compiler-let . c1compiler-let) + + ;; cmpstack.lsp + (with-stack . c1with-stack) + (stack-push . c1stack-push) + (stack-push-values . c1stack-push-values) + (stack-pop . c1stack-pop) + (si::apply-from-stack-frame . c1apply-from-stack-frame) + + ;; cmpstructures.lsp + ;; (sys::structure-ref . c1structure-ref) + ;; (sys::structure-set . c1structure-set) + + ;; cmptag.lsp + (tagbody . c1tagbody) + (go . c1go) + + ;; cmptop.lsp + (load-time-value . c1load-time-value) + (si:fset . c1fset) + + ;; cmptranslate.lsp + (values-ref . c1values-ref) + + ;; cmpvar.lsp + (setq . c1setq) + (psetq . c1psetq) + (progv . c1progv) + )) + +(defparameter +c1-dispatch-table+ (make-dispatch-table +c1-dispatch-data+)) + +;;; ------------------------------------------------------------------ +;;; C/C++ BACKEND +;;; + +(defparameter +c2-dispatch-table+ + (make-dispatch-table + '( + (set . c2set) + (set-mv . c2set-mv) + (values . c2values-op) + (bind . c2bind) + (bind-special . c2bind-special) + (progv . c2progv-op) + (unbind . c2unbind) + (progv-exit . c2progv-exit-op) + (frame-pop . c2frame-pop) + (frame-set . c2frame-set) + (frame-save-next . c2frame-save-next) + (frame-jmp-next . c2frame-jmp-next) + (frame-id . c2frame-id) + (jmp . c2jmp) + + (function-prologue . c2function-prologue) + (function-epilogue . c2function-epilogue) + + (bind-required . c2bind-required) + (varargs-bind . c2varargs-bind-op) + (varargs-pop . c2varargs-pop-op) + (varargs-rest . c2varargs-rest-op) + (varargs-unbind . c2varargs-unbind-op) + + (stack-frame-open . c2stack-frame-open) + (stack-frame-push . c2stack-frame-push) + (stack-frame-push-values . c2stack-frame-push-values) + (stack-frame-pop-values . c2stack-frame-pop-values) + (stack-frame-apply . c2stack-frame-apply) + (stack-frame-close . c2stack-frame-close) + + (throw . c2throw-op) + (return-from . c2return-from-op) + (go . c2go-op) + (funcall . c2funcall-op) + (call-local . c2call-local) + (call-global . c2call-global) + + (debug-env-open . c2debug-env-open) + (debug-env-close . c2debug-env-close) + (debug-env-push-vars . c2debug-env-push-vars) + (debug-env-pop-vars . c2debug-env-pop-vars) + + ;; cmpffi.lsp + (ffi:c-inline . c2c-inline) + + ;; cmpflet.lsp + (do-flet/labels . c2do-flet/labels) + + ;; cmpstructures.lsp + ;; (sys:structure-ref . c2structure-ref) + ;; (sys:structure-set . c2structure-set) + + ;; cmptop.lsp + (si:fset . c2fset) + ))) + +(defparameter +c2-wt-loc-table+ + (make-dispatch-table + '( + ;; cmploc.lsp + (temp . wt-temp) + (lcl . wt-lcl-loc) + (vv . wt-vv) + (vv-temp . wt-vv-temp) + (car . wt-car) + (cdr . wt-cdr) + (cadr . wt-cadr) + (fixnum-value . wt-number) + (character-value . wt-character) + (long-float-value . wt-number) + (double-float-value . wt-number) + (single-float-value . wt-number) + (value . wt-value) + (keyvars . wt-keyvars) + (the . wt-the-loc) + + (nil . wt-nil-loc) + (t . wt-t-loc) + (value0 . wt-value0-loc) + (return . wt-value0-loc) + (values+value0 . wt-value0-loc) + (values . wt-values-loc) + (va-arg . wt-va-arg-loc) + (cl-va-arg . wt-cl-va-arg-loc) + + ;; cmpbackend.lsp + (call . wt-call) + (call-normal . wt-call-normal) + (call-indirect . wt-call-indirect) + + ;; cmpffi.lsp + (ffi:c-inline . wt-c-inline-loc) + (coerce-loc . wt-coerce-loc) + + ;; cmpspecial.ls + (fdefinition . wt-fdefinition) + (make-cclosure . wt-make-closure) + + ;; cmpstructures.lsp + (sys:structure-ref . wt-structure-ref) + ))) + +(defparameter +c2-set-loc-table+ + (make-dispatch-table + '( + ;; cmpbind.lsp + (bind . bind) + + ;; cmploc.lsp + (values . set-values-loc) + (values+value0 . set-values+value0-loc) + (value0 . set-value0-loc) + (return . set-return-loc) + (actual-return . set-actual-return-loc) + (trash . set-trash-loc) + (the . set-the-loc) + + ;; cmpbackend.lsp + (jmp-true . set-loc-jmp-true) + (jmp-false . set-loc-jmp-false) + (jmp-zero . set-loc-jmp-false) + ))) + diff --git a/src/new-cmp/cmptag.lsp b/src/new-cmp/cmptag.lsp new file mode 100644 index 000000000..f137f9531 --- /dev/null +++ b/src/new-cmp/cmptag.lsp @@ -0,0 +1,184 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPTAG -- Tagbody and Go. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; ECoLisp is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + + +(in-package "COMPILER") + +;;; A dummy variable is created to hold the tag identifier and one tag +;;; structure (containing reference to such variable) is created for each +;;; label in the body. +;;; When a reference to a tag (go instruction) is found, the +;;; var-kind is stepped from NIL to OBJECT (if appearing inside an +;;; unwind-protect) to LEXICAL or CLOSURE (if appearing across a boundary). +;;; The tag-ref is also incremented. +;;; Therefore var-ref represents whether some tag is used at all and var-kind +;;; variable represents whether a tag identifier must be created and the +;;; kind of the dummy variable to store it. + + +(defvar *reg-amount* 60) +;;; amount to increase var-ref for each variable reference inside a loop + +(defun add-loop-registers (tagbody) + ;; Find a maximal iteration interval in TAGBODY from first to end + ;; then increment the var-ref slot. + (labels ((add-reg1 (form) + ;; increase the var-ref in FORM for all vars + (cond ((c1form-p form) + (dolist (v (c1form-args form)) + (add-reg1 v))) + ((consp form) + (dolist (v form) + (add-reg1 v))) + ((var-p form) + (incf (var-ref form) (the fixnum *reg-amount*))))) + (jumps-to-p (clause tag-name) + ;; Does CLAUSE have a go TAG-NAME in it? + (cond ((c1form-p clause) + (and (eq (c1form-name clause) 'GO) + (eq (tag-name (c1form-arg 0 clause)) tag-name))) + ((atom clause) nil) + (t (or (jumps-to-p (car clause) tag-name) + (jumps-to-p (cdr clause) tag-name)))))) + (do ((v tagbody (cdr v)) + (end nil) + (first nil)) + ((null v) + (do ((ww first (cdr ww))) + ((eq ww end) (add-reg1 (car ww))) + (add-reg1 (car ww)))) + (when (tag-p (car v)) + (unless first (setq first v)) + (do ((w (cdr v) (cdr w)) + (name (tag-name (car v)))) + ((null w)) + (when (jumps-to-p (car w) name) + (setq end w))))))) + +(defun make-tagbody-labels (body *cmp-env*) + "Produces two values. The first one is a list of forms where atoms have been +replaced with tags, collapsing pairs of consecutive atoms into the same tag. +The second value is an association list of atoms to the tags they represent." + (let ((tags '())) + (values (loop with tag-index = 0 + with last-tag = nil + with tag-env = *cmp-env* + for form in body + unless (when (and last-tag (atom form)) + (cmp-env-register-tag form last-tag) + (push last-tag tags) + t) + collect (if (atom form) + (let ((tag (make-tag :name form :index tag-index + :label (next-label) + :env *cmp-env*))) + (cmp-env-register-tag form tag) + (push tag tags) + (incf tag-index) + (setf last-tag tag)) + (progn + (setf last-tag nil) + form))) + tags + *cmp-env*))) + +(defun c1tagbody (destination orig-body &aux (*cmp-env* *cmp-env*) + (tag-var (make-var :name (gensym "TAGBODY-ID") :kind NIL)) + (tag-index 0) + (body nil) + (tags nil)) + ;; Register variable and frame for cleanup forms + (cmp-env-register-var tag-var *cmp-env*) + ;(cmp-env-register-frs tag-var *cmp-env*) + + ;; Establish tags. + (multiple-value-setq (body tags *cmp-env*) (make-tagbody-labels orig-body *cmp-env*)) + + ;; Ensure that the end is not just a tag, but at least a NIL body. + (when (every #'tag-p body) + (return-from c1tagbody (c1nil destination))) + + ;; Assign each tag the tagbody variable so that GO can find it. + (loop for tag in tags + do (setf (tag-var tag) tag-var)) + + ;; Split forms according to the tag they are preceded by and compile + ;; them grouped by PROGN. This help us use the optimizations in + ;; C1PROGN to recognize transfers of control. + (loop for form in body + with output = '() + with tag-body = nil + do (cond ((tag-p form) + (when tag-body + (setf output (cons (nreverse tag-body) output) + tag-body nil)) + (push form output)) + (t + (push form tag-body))) + finally (setf body (if tag-body + (cons (nreverse tag-body) output) + output))) + + ;; Compile the grouped forms, in order. All values are discarded + ;; and we add a final NIL form. + (setf body (loop for form in (nreverse body) + nconc (if (tag-p form) + (list form) + (c1progn 'TRASH form)))) + + ;; Delete unused tags. + (setf body (delete-if #'(lambda (x) (and (tag-p x) (zerop (tag-ref x)))) + body)) + + ;; When the variable of the tag forms is not referenced, we can just + ;; output the list of forms and tags. + (when (zerop (var-ref tag-var)) + (return-from c1tagbody (nconc body (c1nil destination)))) + + (add-loop-registers body) + (let ((normal-tag (make-tag :name "TAGBODY-NORMAL" :label (next-label)))) + (nconc (c1bind (list tag-var)) + (c1frame-id tag-var) + (c1frame-set tag-var normal-tag) + (loop for t in tags + when (or (tag-ref-ccb t) (tag-ref-clb t)) + collect (c1translate `(JMP-TRUE ,t) `(EQ (VALUES-REF 0) ,(tag-index t)))) + (c1translate 'TRASH '(error "Unknown GO tag")) + (list normal-tag) + body + (c1frame-pop tag-var) + (c1translate destination nil)))) + +(defun c1go (destination args) + (check-args-number 'GO args 1 1) + (let ((name (first args))) + (unless (or (symbolp name) (integerp name)) + (cmperr "The tag name ~s is not a symbol nor an integer." name)) + (multiple-value-bind (tag ccb clb unw) + (cmp-env-search-tag name) + (unless tag + (cmperr "Undefined tag ~A" name)) + (let ((var (tag-var tag))) + (cond (ccb (setf (tag-ref-ccb tag) t + (var-ref-ccb var) T + (var-kind var) 'CLOSURE)) + (clb (setf (tag-ref-clb tag) t + (var-ref-clb var) t)) + (unw (setf (tag-ref-clb tag) t) + (unless (var-kind var) + (setf (var-kind var) :OBJECT)))) + (incf (tag-ref tag)) + (if (or ccb clb unw) + (add-to-read-nodes var (c1go-op tag)) + (c1jmp tag)))))) diff --git a/src/new-cmp/cmptest.lsp b/src/new-cmp/cmptest.lsp new file mode 100644 index 000000000..308a27977 --- /dev/null +++ b/src/new-cmp/cmptest.lsp @@ -0,0 +1,253 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPTEST Functions for compiler test. + +(in-package "COMPILER") + +(defun self-compile () + (with-open-file (log "lsplog" :direction :output) + (let ((*standard-output* (make-broadcast-stream *standard-output* log))) + +; (self-compile2 "cmpbind") +; (self-compile2 "cmpblock") +; (self-compile2 "cmpcall") +; (self-compile2 "cmpcatch") + (self-compile2 "cmpenv") +; (self-compile2 "cmpeval") +; (self-compile2 "cmpflet") +; (self-compile2 "cmpfun") +; (self-compile2 "cmpif") +; (self-compile2 "cmpinline") + (self-compile2 "cmplabel") +; (self-compile2 "cmplam") +; (self-compile2 "cmplet") +; (self-compile2 "cmploc") +; (self-compile2 "cmpmap") +; (self-compile2 "cmpmulti") +; (self-compile2 "cmpspecial") +; (self-compile2 "cmptag") +; (self-compile2 "cmptop") +; (self-compile2 "cmptype") + (self-compile2 "cmputil") +; (self-compile2 "cmpvar") +; (self-compile2 "cmpvs") +; (self-compile2 "cmpwt") + + )) + t) + +(defun setup () + +; (allocate 'cons 800) +; (allocate 'string 256) +; (allocate 'structure 32) +; (allocate-relocatable-pages 128) + +; (load "cmpinline.lsp") + (load "cmputil.lsp") +; (load "cmptype.lsp") + +; (load "cmpbind.lsp") +; (load "cmpblock.lsp") + (load "cmpcall.lsp") +; (load "cmpcatch.lsp") +; (load "cmpenv.lsp") +; (load "cmpeval.lsp") + (load "cmpflet.lsp") +; (load "cmpfun.lsp") +; (load "cmpif.lsp") + (load "cmplabel.lsp") +; (load "cmplam.lsp") +; (load "cmplet.lsp") + (load "cmploc.lsp") +; (load "cmpmain.lsp") +; (load "cmpmap.lsp") +; (load "cmpmulti.lsp") +; (load "cmpspecial.lsp") +; (load "cmptag.lsp") + (load "cmptop.lsp") +; (load "cmpvar.lsp") +; (load "cmpvs.lsp") +; (load "cmpwt.lsp") + +; (load "lfun_list") +; (load "cmpopt.lsp") + + ) + +(defun cli () (process ":cli.pr")) + +(defun load-fasl () + + (load "cmpinline") + (load "cmputil") + (load "cmpbind") + (load "cmpblock") + (load "cmpcall") + (load "cmpcatch") + (load "cmpenv") + (load "cmpeval") + (load "cmpflet") + (load "cmpfun") + (load "cmpif") + (load "cmplabel") + (load "cmplam") + (load "cmplet") + (load "cmploc") + (load "cmpmap") + (load "cmpmulti") + (load "cmpspecial") + (load "cmptag") + (load "cmptop") + (load "cmptype") + (load "cmpvar") + (load "cmpvs") + (load "cmpwt") + + (load "cmpmain.lsp") + (load "lfun_list.lsp") + (load "cmpopt.lsp") + + ) + +(setq *macroexpand-hook* 'funcall) + +(defun self-compile1 (file) + (prin1 file) (terpri) + (compile-file1 file + :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)) + +(defun self-compile2 (file) + (prin1 file) (terpri) + (compile-file1 file + :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t) + (prin1 (load file)) (terpri)) + +(defvar *previous-form* nil) + +(defun cmp (form) + (setq *previous-form* form) + (again)) + +(defun again () + (init-env) + (print *previous-form*) + (terpri) + (setq *compiler-output1* *standard-output*) + (setq *compiler-output2* *standard-output*) + (t1expr *previous-form*) + (catch *cmperr-tag* (ctop-write "test")) + t) + +;(defun make-cmpmain-for-unix () +; (print "unixmain") +; (format t "~&The old value of *FEATURES* is ~s." *features*) +; (let ((*features* '(:unix :common :ecl))) +; (format t "~&The new value of *FEATURES* is ~s." *features*) +; (init-env) +; (compile-file1 "cmpmain.lsp" +; :output-file "unixmain" +; :c-file t +; :h-file t +; :data-file t +; :system-p t +; )) +; (format t "~&The resumed value of *FEATURES* is ~s." *features*) +; ) + +(defun compiler-make-ufun () + (make-ufun '( + "cmpbind.lsp" + "cmpblock.lsp" + "cmpcall.lsp" + "cmpcatch.lsp" + "cmpenv.lsp" + "cmpeval.lsp" + "cmpflet.lsp" + "cmpfun.lsp" + "cmpif.lsp" + "cmpinline.lsp" + "cmplabel.lsp" + "cmplam.lsp" + "cmplet.lsp" + "cmploc.lsp" + "cmpmain.lsp" + "cmpmap.lsp" + "cmpmulti.lsp" + "cmpspecial.lsp" + "cmptag.lsp" + "cmptop.lsp" + "cmptype.lsp" + "cmputil.lsp" + "cmpvar.lsp" + "cmpvs.lsp" + "cmpwt.lsp" + + )) + + t) + +(defun remrem () + (do-symbols (x (find-package 'lisp)) + (rem-sysprop x ':inline-always) + (rem-sysprop x ':inline-safe) + (rem-sysprop x ':inline-unsafe)) + (do-symbols (x (find-package 'system)) + (rem-sysprop x ':inline-always) + (rem-sysprop x ':inline-safe) + (rem-sysprop x ':inline-unsafe))) +(defun ckck () + (do-symbols (x (find-package 'lisp)) + (when (or (get-sysprop x ':inline-always) + (get-sysprop x ':inline-safe) + (get-sysprop x ':inline-unsafe)) + (print x))) + (do-symbols (x (find-package 'si)) + (when (or (get-sysprop x ':inline-always) + (get-sysprop x ':inline-safe) + (get-sysprop x ':inline-unsafe)) + (print x)))) + +(defun make-cmpopt (&aux (eof (cons nil nil))) + (with-open-file (in "cmpopt.db") + (with-open-file (out "cmpopt.lsp" :direction :output) + (print '(in-package "COMPILER") out) + (terpri out) (terpri out) + (do ((x (read in nil eof) (read in nil eof))) + ((eq x eof)) + (apply #'(lambda (property return-type side-effectp new-object-p + name arg-types body) + (when (stringp body) + (do ((i 0 (1+ i)) + (l nil) + (l1 nil)) + ((>= i (length body)) + (when l1 + (setq body + (concatenate 'string + "@" + (nreverse l1) + ";" + body)))) + (when (char= (aref body i) #\#) + (incf i) + (cond ((member (aref body i) l) + (pushnew (aref body i) l1)) + (t (push (aref body i) l)))))) + (print + `(push '(,arg-types ,return-type ,side-effectp + ,new-object-p ,body) + (get-sysprop ',name ',property)) + out)) + (cdr x))) + (terpri out)))) diff --git a/src/new-cmp/cmptop.lsp b/src/new-cmp/cmptop.lsp new file mode 100644 index 000000000..5c3de7b89 --- /dev/null +++ b/src/new-cmp/cmptop.lsp @@ -0,0 +1,426 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPTOP -- Compiler top-level. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defmacro with-t1expr ((init-name) &rest body) + `(t1loop #'(lambda () + (flet ((t1expr (form) + (let ((*current-toplevel-form* form) + (*compile-toplevel* t) + (*compile-time-too* nil)) + (setf *top-level-forms* (nreconc (t1expr* 'trash form) + *top-level-forms*))))) + ,@body)) + ,init-name)) + +(defparameter +init-function-name+ (gensym "ENTRY-POINT")) + +(defun t1loop (body init-name) + (let* ((only-argument (make-var :name (gensym "CBLOCK") + :type T + :kind :object + :loc `(LCL 1) + :ref 1)) + (fun (make-fun :name +init-function-name+ + :cfun init-name + :minarg 1 :maxarg 1 :closure nil + :global t :no-entry t :exported t)) + (*current-function* fun) + (*lcl* 1) + (*last-label* 0) + (*cmp-env* (cmp-env-register-var only-argument (cmp-env-new))) + (*permanent-data* nil)) + (setf *top-level-forms* nil) + (funcall body) + (setf (fun-lambda fun) (nconc (c1function-prologue fun) + (nreverse *top-level-forms*) + (c1function-epilogue fun)) + (fun-last-lcl fun) *lcl* + (fun-last-label fun) *last-label* + *top-level-forms* fun))) + +(defvar *toplevel-forms-to-print* + '(defun defmacro defvar defparameter defclass defmethod defgeneric)) + +(defun t1expr* (destination form) + ;(let ((*print-level* 3)) (print form)) + (catch *cmperr-tag* + (when (consp form) + (let ((fun (car form)) (args (cdr form)) fd) + (when (member fun *toplevel-forms-to-print*) + (print-current-form)) + (cond + ((consp fun) (t1ordinary destination form)) + ((not (symbolp fun)) + (cmperr "~s is illegal function." fun)) + ((eq fun 'QUOTE) + (t1ordinary destination 'NIL)) + ((setq fd (get-sysprop fun 'T1)) + (funcall fd destination args)) + ((or (get-sysprop fun 'C1) (get-sysprop fun 'C1SPECIAL)) + (t1ordinary destination form)) + ((and (setq fd (compiler-macro-function fun)) + (inline-possible fun) + (let ((success nil)) + (multiple-value-setq (fd success) + (cmp-expand-macro fd form)) + success)) + (t1expr* destination fd)) + ((setq fd (cmp-macro-function fun)) + (t1expr* destination (cmp-expand-macro fd form))) + (t (t1ordinary destination form)) + ))))) + +(defun t1/c1expr (destination form) + (cond ((not *compile-toplevel*) + (c1translate destination form)) + ((atom form) + (t1ordinary destination form)) + (t + (t1expr* destination form)))) + +(defun emit-local-funs (fun) + (loop with *compile-time-too* = nil + with *compile-toplevel* = nil + with emitted-local-funs = (make-hash-table :test #'eql) + with pending = (fun-child-funs fun) + for f = (first pending) + while f + do (progn + (when (gethash f emitted-local-funs) + (error "Doubly emitted function ~A" fun)) + (t3local-fun f) + (setf (gethash f emitted-local-funs) t + pending (nconc pending (copy-list (fun-child-funs f))))))) + +(defun ctop-write (name h-pathname data-pathname + &key shared-data + &aux def top-output-string + (*volatile* "volatile ")) + + ;(let ((*print-level* 3)) (pprint *top-level-forms*)) + (wt-nl1 "#include \"" (si::coerce-to-filename h-pathname) "\"") + ;; All lines from CLINES statements are grouped at the beginning of the header + ;; Notice that it does not make sense to guarantee that c-lines statements + ;; are produced in-between the function definitions, because two functions + ;; might be collapsed into one, or we might not produce that function at all + ;; and rather inline it. + (do () + ((null *clines-string-list*)) + (wt-nl-h (pop *clines-string-list*))) + (wt-nl-h "#ifdef __cplusplus") + (wt-nl-h "extern \"C\" {") + (wt-nl-h "#endif") + (when si::*compiler-constants* + (wt-nl-h "#include ")) + ;;; Initialization function. + (let* ((c-output-file *compiler-output1*) + (*compiler-output1* (make-string-output-stream)) + (*compiler-declared-globals* (make-hash-table))) + (unless shared-data + (wt-nl1 "#include \"" (si::coerce-to-filename data-pathname) "\"")) + + ;; Type propagation phase + (when *do-type-propagation* + (setq *compiler-phase* 'p1propagate) + (dolist (form *top-level-forms*) + (p1propagate form nil)) + (dolist (fun *local-funs*) + (propagate-function-types fun))) + + (setq *compiler-phase* 't2) + + ;; Emit entry function + (let ((*compile-to-linking-call* nil)) + (t3local-fun *top-level-forms*)) + + ;; Now emit the rest + (let ((*compiler-output1* c-output-file)) + (emit-local-funs *top-level-forms*)) + + (setq top-output-string (get-output-stream-string *compiler-output1*))) + + ;; Declarations in h-file. + (wt-nl-h "static cl_object Cblock;") + (let ((num-objects (data-size))) + (if (zerop num-objects) + (progn + (wt-nl-h "#undef ECL_DYNAMIC_VV") + (wt-nl-h "#define compiler_data_text \"\"") + (wt-nl-h "#define compiler_data_text_size 0") + (wt-nl-h "#define VM 0") + (wt-nl-h "#define VMtemp 0") + (wt-nl-h "#define VV NULL")) + (progn + (wt-nl-h "#define VM " (data-permanent-storage-size)) + (wt-nl-h "#define VMtemp " (data-temporary-storage-size)) + (wt-nl-h "#ifdef ECL_DYNAMIC_VV") + (wt-nl-h "static cl_object *VV;") + (wt-nl-h "#else") + (wt-nl-h "static cl_object VV[VM];") + (wt-nl-h "#endif")))) + + (dolist (l *linking-calls*) + (let* ((c-name (fourth l)) + (var-name (fifth l))) + (wt-nl-h "static cl_object " c-name "(cl_narg, ...);") + (wt-nl-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";"))) + + ;;; Initial functions for linking calls. + (dolist (l *linking-calls*) + (let* ((var-name (fifth l)) + (c-name (fourth l)) + (lisp-name (third l))) + (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)" + "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}"))) + + (wt-nl-h "#ifdef __cplusplus") + (wt-nl-h "}") + (wt-nl-h "#endif") + + (when (and (listp *static-constants*) + (setf *static-constants* (nreverse *static-constants*))) + (wt-nl-h "/*") + (wt-nl-h " * Statically defined constants") + (wt-nl-h " */") + (loop for (value name builder) in (reverse *static-constants*) + do (terpri *compiler-output2*) + do (funcall builder name value *compiler-output2*))) + + (output-cfuns *compiler-output2*) + + (setq *compiler-phase* 't3) + + ;;; Callbacks + (when *callbacks* + (wt-nl-h "#include ") + (dolist (x *callbacks*) + (apply #'t3-defcallback x))) + + (wt-nl top-output-string)) + +(defun c1eval-when (destination args) + (check-args-number 'EVAL-WHEN args 1) + (pprint `(EVAL-WHEN ,@args)) + (let ((load-flag nil) + (compile-flag nil) + (execute-flag nil)) + (dolist (situation (car args)) + (case situation + ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) + ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) + ((EVAL :EXECUTE) + (if *compile-toplevel* + (setq compile-flag (or *compile-time-too* compile-flag)) + (setq execute-flag t))) + (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." + situation)))) + (cond ((not *compile-toplevel*) + (c1progn destination (and execute-flag (rest args)))) + (load-flag + (let ((*compile-time-too* compile-flag)) + (c1progn destination (rest args)))) + (compile-flag + (cmp-eval (cons 'PROGN (rest args))) + (c1progn destination 'NIL)) + (t + (c1progn destination 'NIL))))) + +(defun exported-fname (name) + (let (cname) + (if (and (symbolp name) + (not (member name *notinline*)) + (setf cname (get-sysprop name 'Lfun))) + (values cname t) + (values (next-cfun "L~D~A" name) nil)))) + +(defun new-defun (new &optional no-entry) + (push new *global-funs*)) + +(defun print-function (x) + (format t "~%" + (fun-name x) (fun-closure x) (fun-level x) (fun-env x))) + +(defun rep-type (type) + (case type + (FIXNUM "cl_fixnum ") + (CHARACTER "unsigned char ") + (SINGLE-FLOAT "float ") + (DOUBLE-FLOAT "double ") + (otherwise "cl_object "))) + +(defun t1ordinary (destination form) + (when *compile-time-too* (cmp-eval form)) + (let* ((*compile-toplevel* nil) + (*compile-time-too* nil)) + (add-load-time-values (c1translate destination form)))) + +(defun add-load-time-values (form) + (let ((previous (nconc *load-time-values* *make-forms*))) + (setf *load-time-values* nil + *make-forms* nil) + (nconc previous form))) + +(defun c1load-time-value (destination args) + (check-args-number 'LOAD-TIME-VALUE args 1 2) + (let ((form (first args)) + loc) + (cond ((not (listp *load-time-values*)) + ;; When using COMPILE, we set *load-time-values* to 'VALUES and + ;; thus signal that we do not want to compile these forms, but + ;; just to retain their value. + (return-from c1load-time-value (c1constant-value destination + (cmp-eval form) :always t))) + ((typep form '(or list symbol)) + (setf loc (data-empty-loc)) + (setf *load-time-values* (nconc *load-time-values* + (c1translate loc form)))) + (t + (setf loc (add-object (cmp-eval form))))) + (c1set-loc destination loc))) + +(defun parse-cvspecs (x &aux (cvspecs nil)) + (dolist (cvs x (nreverse cvspecs)) + (cond ((symbolp cvs) + (push (list :OBJECT (string-downcase (symbol-name cvs))) cvspecs)) + ((stringp cvs) (push (list :OBJECT cvs) cvspecs)) + ((and (consp cvs) + (member (car cvs) '(OBJECT CHAR INT FLOAT DOUBLE))) + (dolist (name (cdr cvs)) + (push (list (car cvs) + (cond ((symbolp name) + (string-downcase (symbol-name name))) + ((stringp name) name) + (t (cmperr "The C variable name ~s is illegal." + name)))) + cvspecs))) + (t (cmperr "The C variable specification ~s is illegal." cvs))))) + +(defun locative-type-from-var-kind (kind) + (cdr (assoc kind + '((:object . "_ecl_object_loc") + (:fixnum . "_ecl_fixnum_loc") + (:char . "_ecl_base_char_loc") + (:float . "_ecl_float_loc") + (:double . "_ecl_double_loc") + ((special global closure replaced discarded lexical) . NIL))))) + +(defun t3local-fun (fun) + (print-emitting fun) + (let* ((*current-function* fun) + (*lcl* (fun-last-lcl fun)) + (*last-label* (fun-last-label fun)) + (*lex* 0) + (*max-lex* 0) + (*env* (fun-env fun)) ; continue growing env + (*max-env* *env*) + (*env-lvl* 0) + (*level* (if (eq (fun-closure fun) 'LEXICAL) + (fun-level fun) + 0)) + (*volatile* (if (fun-volatile-p fun) "volatile " "")) + (*permanent-data* t)) + (c2translate (fun-lambda fun)))) + +;;; ---------------------------------------------------------------------- +;;; Optimizer for FSET. Removes the need for a special handling of DEFUN as a +;;; toplevel form and also allows optimizing calls to DEFUN or DEFMACRO which +;;; are not toplevel, but which create no closures. +;;; +;;; The idea is as follows: when the function or macro to be defined is not a +;;; closure, we can use the auxiliary C functions c_def_c_*() instead of +;;; creating a closure and invoking si_fset(). However until the C2 phase of +;;; the compiler we do not know whether a function is a closure, hence the need +;;; for a c2fset. +;;; +(defun c1fset (destination args) + (destructuring-bind (fname def &optional (macro nil) (pprint nil)) + args + (let* ((unoptimized (c1call-global destination 'SI:FSET + (list fname def macro pprint))) + (fun-form (c1translate 'VALUE0 def))) + (if (and (eq destination 'TRASH) + (= (length fun-form) 1) + (setf fun-form (first fun-form)) + (eq (c1form-name fun-form) 'FUNCTION) + (not (eq (c1form-arg 0 fun-form) 'GLOBAL))) + (let ((fun-object (c1form-arg 2 fun-form))) + (cond ((fun-no-entry fun-object) + (when macro + (cmperr "Declaration C-LOCAL used in macro ~a" (fun-name fun))) + (make-c1form* 'SI:FSET :args fun-object nil nil nil nil)) + ((and (typep macro 'boolean) + (typep pprint '(or integer null)) + (consp fname) + (eq (first fname) 'quote)) + (make-c1form* 'SI:FSET + :args + fun-object ;; Function object + (add-object (second fname) :permanent t :duplicate t) + macro + pprint + unoptimized)))) + unoptimized)))) + +(defun c2fset (fun fname macro pprint c1forms) + (when (fun-no-entry fun) + (wt-nl "(void)0; /* No entry created for " + (format nil "~A" (fun-name fun)) + " */") + ;; FIXME! Look at c2function! + (new-local fun) + (return-from c2fset)) + (when (fun-closure fun) + (return-from c2fset (c2call-global destination 'SI:FSET c1forms))) + (let ((*inline-blocks* 0) + (loc (data-empty-loc))) + (push (list loc fname fun) *global-cfuns-array*) + ;; FIXME! Look at c2function! + (new-local fun) + (wt-nl (if macro "ecl_cmp_defmacro(" "ecl_cmp_defun(") + loc ");") + (close-inline-blocks))) + +(defun output-cfuns (stream) + (let ((n-cfuns (length *global-cfuns-array*))) + (wt-nl-h "/*") + (wt-nl-h " * Exported Lisp functions") + (wt-nl-h " */") + (wt-nl-h "#define compiler_cfuns_size " n-cfuns) + (if (zerop n-cfuns) + (wt-nl-h "#define compiler_cfuns NULL") + (progn + (format stream "~%static const struct ecl_cfun compiler_cfuns[] = {~ +~%~t/*t,m,narg,padding,name,block,entry*/"); + (loop for (loc fname-loc fun) in (nreverse *global-cfuns-array*) + do (let* ((cfun (fun-cfun fun)) + (minarg (fun-minarg fun)) + (maxarg (fun-maxarg fun)) + (narg (if (= minarg maxarg) maxarg nil))) + (format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),MAKE_FIXNUM(~D),(cl_objectfn)~A,Cnil,MAKE_FIXNUM(~D)}," + (or narg -1) (second loc) (second fname-loc) + cfun (fun-file-position fun)))) + (format stream "~%};"))))) + +;;; ---------------------------------------------------------------------- + +;;; Pass 1 top-levels. + +(put-sysprop 'COMPILER-LET 'T1 'c1compiler-let) +(put-sysprop 'EVAL-WHEN 'T1 'c1eval-when) +(put-sysprop 'PROGN 'T1 'c1progn) +(put-sysprop 'MACROLET 'T1 'c1macrolet) +(put-sysprop 'LOCALLY 'T1 'c1locally) +(put-sysprop 'SYMBOL-MACROLET 'T1 'c1symbol-macrolet) diff --git a/src/new-cmp/cmptranslate.lsp b/src/new-cmp/cmptranslate.lsp new file mode 100644 index 000000000..8784115ca --- /dev/null +++ b/src/new-cmp/cmptranslate.lsp @@ -0,0 +1,426 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; MAIN DRIVERS +;;; + +(defun c1translate (destination value) + (enforce-destination destination (c1expr destination value))) + +(defun c2translate (forms) + (c2expr forms)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; SPECIALIZED OPERATIONS +;;; + +;;; +;;; COMPUTING VALUE OF TRANSLATED FORMS +;;; +;;; This here should probably disappear, eventually, once the type +;;; passes are implemented. +;;; + +(defun translated-form-values-type (destination forms) + (loop with output-type = T + for f in forms + for name = (and (c1form-p f) (c1form-name f)) + do (case name + ((NIL)) + ((CALL-LOCAL CALL-GLOBAL FUNCALL + SET BIND-SPECIAL VARARGS-POP VARARGS-REST) + (when (eq destination (c1form-arg 0 f)) + (setf output-type (c1form-type f)))) + ((VALUES STACK-FRAME-POP-VALUES) + (when (eq destination 'VALUES) + (setf output-type (c1form-type f))))) + finally (return output-type))) + +(defun translated-form-primary-type (destination forms) + (values-type-primary-type + (translated-form-values-type destination forms))) + +;;; +;;; HANDLING OF TEMPORARIES +;;; + +(defvar *c1-temps* '()) + +(defun make-c1-temp () + (let ((v (make-var :kind :object :type t :ref 1 + :name (gensym "X") + :read-only-p t + :loc `(LCL ,(- (length *c1-temps*)))))) + (push v *c1-temps*) + v)) + +;;; +;;; HIGHER ORDER TRANSLATION CONSTRUCTS +;;; + +(defun enforce-destination (destination expr) + (loop with last-form = nil + for i in expr + when (c1form-p last-form) + do (setf last-form i) + finally (let ((actual-dest destination)) + (unless (or (eq actual-dest 'TRASH) + (eq actual-dest destination)) + (error "Wrong destination in forms list ~S" expr)))) + expr) + +(defun maybe-add-to-read-nodes (var-or-loc forms) + (when (var-p var-or-loc) + (add-to-read-nodes var-or-loc forms)) + forms) + +(defun maybe-add-to-set-nodes (var-or-loc forms) + (when (var-p var-or-loc) + (add-to-set-nodes var-or-loc forms)) + forms) + +(defun c1save-one-value (value) + (if (constantp value) + (values nil (build-constant-value-loc (cmp-eval value) :always t)) + (let ((v (make-c1-temp))) + (values (c1translate v value) v)))) + +(defmacro c1with-temps ((prefix postfix &rest temps) &rest body) + `(let* ((*c1-temps* *c1-temps*) + (*cmp-env* (cmp-env-copy)) + ,@(loop for t in temps + collect `(,t (make-c1-temp))) + (,prefix (c1bind (list ,@temps))) + (,postfix (c1unbind (list ,@temps)))) + ,@(loop for t in temps + collect `(cmp-env-register-var ,t *cmp-env*)) + ,@body)) + +(defmacro c1with-saved-one-value ((prefix postfix location expression) &rest body) + `(let* ((*c1-temps* *c1-temps*) + (,location (make-c1-temp)) + (,prefix (nconc + (c1bind (list ,location)) + (c1translate ,location ,expression))) + (,postfix (c1unbind (list ,location)))) + ,@body)) + +(defmacro c1with-saved-value ((prefix postfix temp value) &rest body) + (let ((forms (gensym)) + (vars (gensym))) + `(let* ((*c1-temps* *c1-temps*)) + (multiple-value-bind (,forms ,temp) + (c1save-one-value ,value) + (let* ((,vars (and ,forms (list ,temp))) + (,prefix (nconc (c1bind ,vars) ,forms)) + (,postfix (c1unbind ,vars))) + ,@body))))) + +(defmacro c1with-saved-values ((prefix postfix temps values) &rest body) + (let ((forms (gensym)) + (vars (gensym))) + `(let* ((*c1-temps* *c1-temps*) + (,temps '()) + (,vars '()) + (,prefix (loop for v in ,values + nconc (multiple-value-bind (forms temp) + (c1save-one-value v) + (when forms + (push temp ,vars)) + (push temp ,temps) + forms))) + (,postfix (c1unbind (setf ,vars (nreverse ,vars))))) + (setf prefix (nconc (c1bind ,vars) prefix) + ,temps (nreverse ,temps)) + ,@body))) + +(defun maybe-create-temp (destination) + (case destination + ((VALUES VALUE0 VALUES+VALUE0) destination) + (RETURN 'VALUES+VALUE0) + (ACTUAL-RETURN (baboon)) + (t (make-c1-temp)))) + +(defmacro c1with-saved-output ((prefix postfix new-destination old-destination) + &rest body) + `(let* ((*c1-temps* *c1-temps*) + (temp-var (maybe-create-temp ,old-destination)) + (,new-destination (or temp-var ,old-destination)) + (,prefix (and (var-p temp-var) (c1bind (list temp-var)))) + (,postfix (and (var-p temp-var) + (nconc (c1set-loc ,old-destination temp-var) + (c1unbind (list temp-var)))))) + ,@body)) + +;;; +;;; VARIABLE BINDINGS +;;; + +(defun c1bind (vars) + (and vars + (make-c1form* 'BIND :args vars))) + +(defun c1unbind (vars &optional (close-block t)) + (when vars + (make-c1form* 'UNBIND :args vars close-block))) + +(defun c1progv-op (ndx-loc vars-loc values-loc) + (make-c1form* 'PROGV :args ndx-loc vars-loc values-loc)) + +(defun c1progv-exit-op (ndx-loc) + (make-c1form* 'PROGV-EXIT :args ndx-loc)) + +;;; +;;; ASSIGNMENTS +;;; + +(defun update-destination-type (destination form type) + (cond ((not (var-p destination))) + ((eq type t)) + ((var-read-only-p destination) + (setf (var-type destination) type)) + (t + (let* ((type2 (var-type destination)) + (type1 (type-and type type2))) + ;; We only change the type if it is not NIL. Is this wise? + (unless type1 + (let* ((*print-length* 4) + (*print-level* 3)) + (cmpwarn "Variable ~A was declared to have type ~A~%and is assigned a value of type ~A" + (var-name destination) type2 type)))))) + (setf (c1form-values-type form) type)) + +(defun c1set-loc (dest value-loc) + (unless (eq dest value-loc) + (let* ((type (loc-type value-loc)) + (form (make-c1form* 'SET :type type :args dest value-loc))) + (update-destination-type dest form type) + (maybe-add-to-set-nodes dest form) + (maybe-add-to-read-nodes value-loc form)))) + +(defun c1bind-special-op (dest value-loc) + (let* ((type (loc-type value-loc)) + (form (make-c1form* 'BIND-SPECIAL :type type :args dest value-loc))) + (update-destination-type dest form type) + (maybe-add-to-set-nodes dest form) + (maybe-add-to-read-nodes value-loc form))) + +(defun c1maybe-bind-special (dest-var forms) + (if (global dest-var) + (c1bind-special dest-var forms) + (c1translate dest-var forms))) + +(defun c1maybe-bind-special-op (dest-var loc) + (if (global dest-var) + (c1bind-special-op dest-var loc) + (c1set-loc dest-var loc))) + +(defun c1bind-special (dest-var forms) + (c1with-saved-value (prefix postfix temp forms) + (nconc prefix + (c1bind-special-op dest-var temp) + postfix))) + +(defun c1set-from-values (new-destination) + (maybe-add-to-set-nodes new-destination + (c1set-loc new-destination 'VALUES))) + +(defun c1set-mv (locations &optional (min-args 0) (max-args multiple-values-limit)) + (loop with form = (make-c1form* 'SET-MV :args locations min-args max-args) + for v in locations + do (maybe-add-to-set-nodes v form) + finally (return form))) + +(defun c1values-op (locations) + (make-c1form* 'VALUES :type `(VALUES ,@(mapcar #'loc-type locations)) + :args locations)) + +;;; +;;; FUNCTION ARGUMENTS AND BLOCKS +;;; + +(defun c1function-prologue (fun) + (make-c1form* 'FUNCTION-PROLOGUE :args fun)) + +(defun c1function-epilogue (fun) + (make-c1form* 'FUNCTION-EPILOGUE :args fun)) + +(defun c1bind-required (var ndx) + (make-c1form* 'BIND-REQUIRED :args var ndx)) + +(defun c1varargs-bind-op (nargs-loc varargs-loc minargs maxargs nkeywords check) + (make-c1form* 'VARARGS-BIND + :args nargs-loc varargs-loc minargs maxargs nkeywords check)) + +(defun c1varargs-pop-op (dest nargs-loc varargs-loc) + (if (and (var-p dest) (global dest)) + (nconc (c1varargs-pop-op 'VALUE0 nargs-loc varargs-loc) + (c1bind-special-op dest 'VALUE0)) + (make-c1form* 'VARARGS-POP :args dest nargs-loc varargs-loc))) + +(defun c1varargs-rest-op (dest-loc nargs-loc varargs-loc nkeys + keywords-list allow-other-keys) + (make-c1form* 'VARARGS-REST :type 'LIST :args dest-loc nargs-loc varargs-loc + nkeys keywords-list allow-other-keys)) + +(defun c1varargs-unbind-op (nargs-loc varargs-loc minargs maxargs nkeywords) + (make-c1form* 'VARARGS-UNBIND + :args nargs-loc varargs-loc minargs maxargs nkeywords)) + +;;; +;;; LOCATIONS, VARIABLES, ASSIGNMENTS +;;; + +(defun c1values-ref (destination args) + (make-c1form* 'SET :args destination `(VALUE ,(first args)))) + +;;; +;;; JUMP FRAMES +;;; + +(defun c1frame-set (id-loc no-label) + (incf (tag-ref no-label)) + (maybe-add-to-set-nodes id-loc + (make-c1form* 'FRAME-SET :args id-loc no-label))) + +(defun c1frame-pop (&optional var) + (make-c1form* 'FRAME-POP :args var)) + +(defun c1frame-save-next (var) + (make-c1form* 'FRAME-SAVE-NEXT :args var)) + +(defun c1frame-jmp-next (var) + (make-c1form* 'FRAME-JMP-NEXT :args var)) + +(defun c1frame-id (var) + (make-c1form* 'FRAME-ID :args var)) + +;;; +;;; STACK FRAMES +;;; + +(defun c1stack-frame-open (var) + (make-c1form* 'STACK-FRAME-OPEN :args var)) + +(defun c1stack-frame-push (frame-var value-loc) + (maybe-add-to-read-nodes + frame-var + (make-c1form* 'STACK-FRAME-PUSH :args frame-var value-loc))) + +(defun c1stack-frame-push-values (frame-var) + (maybe-add-to-read-nodes + frame-var + (make-c1form* 'STACK-FRAME-PUSH-VALUES :args frame-var))) + +(defun c1stack-frame-pop-values (frame-var &optional (dest 'trash)) + (maybe-add-to-read-nodes + frame-var + (make-c1form* 'STACK-FRAME-POP-VALUES :args frame-var dest))) + +(defun c1stack-frame-apply (frame-var function-loc) + (maybe-add-to-read-nodes + frame-var + (make-c1form* 'STACK-FRAME-APPLY :args frame-var function-loc))) + +(defun c1stack-frame-close (frame-var) + (make-c1form* 'STACK-FRAME-CLOSE :args frame-var)) + +;;; +;;; LOCAL AND NONLOCAL CONTROL TRANSFER +;;; + +(defun add-jmp-cleanups (tag forms) + (let ((env (tag-env tag))) + (if env + (nconc (c1cleanup-forms env) forms) + forms))) + +(defun c1jmp (tag) + (incf (tag-ref tag)) ;; Only local jumps, so no -ccb or -clb + (add-jmp-cleanups tag (make-c1form* 'JMP :args tag))) + +(defun c1jmp-true (tag loc) + (incf (tag-ref tag)) + (add-jmp-cleanups tag (c1set-loc `(JMP-TRUE ,tag) loc))) + +(defun c1jmp-false (tag loc) + (incf (tag-ref tag)) + (add-jmp-cleanups tag (c1set-loc `(JMP-FALSE ,tag) loc))) + +(defun c1jmp-zero (tag loc) + (incf (tag-ref tag)) + (add-jmp-cleanups tag (c1set-loc `(JMP-ZERO ,tag) loc))) + +(defun c1return-from-op (var name) + (make-c1form* 'RETURN-FROM :args var name)) + +(defun c1throw-op (tag) + (make-c1form* 'THROW :args tag)) + +(defun c1go-op (tag) + (make-c1form* 'GO :args tag)) + +;;; +;;; FUNCTION CALLS, CLOSURES AND THE LIKE +;;; + +(defun c1do-flet/labels-op (function-list) + (make-c1form* 'DO-FLET/LABELS :args function-list)) + +(defun c1funcall-op (destination arguments) + (make-c1form* 'FUNCALL :args destination arguments)) + +(defun c1call-local-op (destination fun args-loc) + (let* ((return-type (or (get-local-return-type fun) 'T)) + (arg-types (get-local-arg-types fun)) + (form (make-c1form* 'CALL-LOCAL + :type return-type + :args destination fun args-loc))) + ;; Add type information to the arguments. + (loop for arg in args-loc + for type in arg-types + do (and-form-type (car arg-types) form (car args) + :safe "In a call to ~a" fname)) + (update-destination-type destination form return-type) + form)) + +(defun c1call-global-op (destination fname args) + (let* ((return-type (propagate-types fname args nil)) + (form (make-c1form* 'CALL-GLOBAL + :sp-change (function-may-change-sp fname) + :type return-type + :args destination fname args + (values-type-primary-type return-type)))) + (update-destination-type destination form return-type) + form)) + +;;; +;;; DEBUG INFORMATION +;;; + +(defun c1debug-env-open (fname) + (make-c1form* 'DEBUG-ENV-OPEN :args fname)) + +(defun c1debug-env-push-vars (variables) + (when variables + (make-c1form* 'DEBUG-ENV-PUSH-VARS :args variables))) + +(defun c1debug-env-pop-vars (variables &optional close-block) + (when variables + (make-c1form* 'DEBUG-ENV-POP-VARS :args variables close-block))) + +(defun c1debug-env-close (fname) + (make-c1form* 'DEBUG-ENV-CLOSE :args fname)) diff --git a/src/new-cmp/cmptype.lsp b/src/new-cmp/cmptype.lsp new file mode 100644 index 000000000..18c7809e8 --- /dev/null +++ b/src/new-cmp/cmptype.lsp @@ -0,0 +1,637 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPTYPE Type information. + +(in-package "COMPILER") + +;;; CL-TYPE is any valid type specification of Common Lisp. +;;; +;;; TYPE is a representation type used by ECL. TYPE is one of: +;;; +;;; T(BOOLEAN) +;;; +;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT +;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) +;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT) +;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT) +;;; (ARRAY FIXNUM) +;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) +;;; STANDARD-OBJECT STRUCTURE-OBJECT +;;; SYMBOL +;;; UNKNOWN +;;; +;;; NIL +;;; +;;; +;;; immediate-type: +;;; FIXNUM int +;;; CHARACTER char +;;; SINGLE-FLOAT float +;;; DOUBLE-FLOAT double + +(deftype any () 't) + +(defun member-type (type disjoint-supertypes) + (member type disjoint-supertypes :test #'subtypep)) + +(defun object-type (thing) + (type-of thing)) + +(defun type-filter (type &optional values-allowed) + (multiple-value-bind (type-name type-args) (sys::normalize-type type) + (case type-name + ((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name) + (SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT) + (LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT) + ((SIMPLE-STRING STRING) 'STRING) + ((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR) + ((NIL T) t) + ((SIMPLE-ARRAY ARRAY) + (cond ((endp type-args) '(ARRAY *)) ; Beppe + ((eq '* (car type-args)) t) + (t (let ((element-type (upgraded-array-element-type (car type-args))) + (dimensions (if (cdr type-args) (second type-args) '*))) + (if (and (not (eq dimensions '*)) + (or (numberp dimensions) + (= (length dimensions) 1))) + (case element-type + (BASE-CHAR 'STRING) + (BIT 'BIT-VECTOR) + (t (list 'VECTOR element-type))) + (list 'ARRAY element-type)))))) + (INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t)) + ((STREAM CONS) type-name) ; Juanjo + (FUNCTION type-name) + (t (cond ((eq type-name 'VALUES) + (unless values-allowed + (error "VALUES type found in a place where it is not allowed.")) + `(VALUES ,@(mapcar #'(lambda (x) + (if (or (eq x '&optional) + (eq x '&rest)) + x + (type-filter x))) + type-args))) + #+clos + ((subtypep type 'STANDARD-OBJECT) type) + #+clos + ((subtypep type 'STRUCTURE-OBJECT) type) + ((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT + #+short-float SHORT-FLOAT #+long-float LONG-FLOAT + (VECTOR T) STRING BIT-VECTOR + (VECTOR FIXNUM) (VECTOR SINGLE-FLOAT) + (VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR) + (ARRAY BIT) (ARRAY FIXNUM) + (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) + (ARRAY T))) ; Beppe + (when (subtypep type v) (return v)))) + ((and (eq type-name 'SATISFIES) ; Beppe + (symbolp (car type-args)) + (get-sysprop (car type-args) 'TYPE-FILTER))) + (t t)))))) + +(defun valid-type-specifier (type) + (handler-case + (if (subtypep type 'T) + (values t (type-filter type)) + (values nil nil)) + (error (c) (values nil nil)))) + +(defun known-type-p (type) + (subtypep type 'T)) + +(defun-equal-cached type-and (t1 t2) + ;; FIXME! Should we allow "*" as type name??? + (when (or (eq t1 t2) (eq t2 '*)) + (return-from type-and t1)) + (when (eq t1 '*) + (return-from type-and t2)) + (let* ((si::*highest-type-tag* si::*highest-type-tag*) + (si::*save-types-database* t) + (si::*member-types* si::*member-types*) + (si::*elementary-types* si::*elementary-types*) + (tag1 (si::safe-canonical-type t1)) + (tag2 (si::safe-canonical-type t2))) + (cond ((and (numberp tag1) (numberp tag2)) + (setf tag1 (si::safe-canonical-type t1) + tag2 (si::safe-canonical-type t2)) + (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL + NIL) + ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 + t1) + ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 + t2) + (t + `(AND ,t1 ,t2)))) + ((eq tag1 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) + t2) + ((eq tag2 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) + t1) + ((null tag1) + (setf c::*compiler-break-enable* t) + ;(error "foo") + (cmpwarn "Unknown type ~S. Assuming it is T." t1) + t2) + (t + (setf c::*compiler-break-enable* t) + ;(error "foo") + (cmpwarn "Unknown type ~S. Assuming it is T." t2) + t1)))) + +(defun-equal-cached values-type-primary-type (type) + (when (and (consp type) (eq (first type) 'VALUES)) + (let ((subtype (second type))) + (when (or (eq subtype '&optional) (eq subtype '&rest)) + (setf type (cddr type)) + (when (or (null type) + (eq (setf subtype (first type)) '&optional) + (eq subtype '&rest)) + (cmperr "Syntax error in type expression ~S" type)) + ;; An &optional or &rest output value might be missing + ;; If this is the case, the the value will be NIL. + (setf subtype (type-or 'null subtype))) + (setf type subtype))) + type) + +(defun-equal-cached values-type-to-n-types (type length) + (if (or (atom type) (not (eql (first type) 'values))) + (list* type (make-list (1- length) :initial-element 'NULL)) + (do* ((l (rest type)) + (output '()) + (n length (1- n))) + ((or (null l) (zerop n)) (nreverse output)) + (let ((type (pop l))) + (case type + (&optional + (when (null l) + (cmperr "Syntax error in type expression ~S" type)) + (setf type (pop l))) + (&rest + (when (null l) + (cmperr "Syntax error in type expression ~S" type)) + (return-from values-type-to-n-types + (nreconc output (make-list n :initial-element (first l)))))) + (push type output))))) + +(defun split-values-type (type) + (if (or (atom type) (not (eq (first type) 'VALUES))) + (values (list type) nil nil) + (let ((rest (member '&rest type)) + (opt (member '&optional type))) + (values (ldiff (rest type) (or rest opt)) + (ldiff (rest (member '&optional type)) rest) + (rest (member '&rest type)))))) + +(defun-equal-cached values-type-or (t1 t2) + (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) + (return-from values-type-or t2)) + (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) + (return-from values-type-or t1)) + (unless t1 + (return-from values-type-or t2)) + (unless t2 + (return-from values-type-or t1)) + (multiple-value-bind (req1 opt1 rest1) + (split-values-type t1) + (multiple-value-bind (req2 opt2 rest2) + (split-values-type t2) + (let ((req '()) + (opt '()) + (rest '())) + (loop for t1 in req1 + do (cond (req2 + (push (type-or t1 (pop req2)) req)) + (opt2 + (push (type-or t1 (pop opt2)) opt)) + (rest2 + (push (type-or t1 (first rest2)) opt)) + (t + (push t1 opt)))) + (loop for t1 in opt1 + do (cond (req2 + (push (type-or t1 (pop req2)) opt)) + (opt2 + (push (type-or t1 (pop opt2)) opt)) + (rest2 + (push (type-or t1 (first rest2)) opt)) + (t + (push t1 opt)))) + (let ((t1 (if rest1 (first rest1) t))) + (loop for t2 in req2 + do (push (type-or t1 t2) opt)) + (loop for t2 in opt2 + do (push (type-or t1 t2) opt)) + (if rest2 + (setf rest (list (type-or t1 (first rest2)))) + (setf rest rest1))) + `(VALUES ,@(nreverse req) + ,@(and opt (cons '&optional (nreverse opt))) + ,@(and rest (cons '&optional rest))))))) + +(defun-equal-cached values-type-and (t1 t2) + (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) + (return-from values-type-and t1)) + (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) + (return-from values-type-and t2)) + (when (or (null t1) (null t2)) + (return-from values-type-and nil)) + (multiple-value-bind (req1 opt1 rest1) + (split-values-type t1) + (multiple-value-bind (req2 opt2 rest2) + (split-values-type t2) + (let ((req '()) + (opt '()) + (rest '())) + (loop for t1 in req1 + do (cond (req2 (push (type-and t1 (pop req2)) req)) + (opt2 (push (type-and t1 (pop opt2)) req)) + (rest2 (push (type-and t1 (first rest2)) req)) + (t (setf opt1 nil rest1 nil) (return)))) + (loop for t1 in opt1 + do (cond (req2 (push (type-and t1 (pop req2)) req)) + (opt2 (push (type-and t1 (pop opt2)) opt)) + (rest2 (push (type-and t1 (first rest2)) opt)) + (t (setf opt1 nil rest1 nil) (return)))) + (when rest + (let ((t1 (first rest))) + (loop for t2 in req2 + do (push (type-and t1 t2) req)) + (loop for t2 in opt2 + do (push (type-and t1 t2) opt)) + (when rest2 + (setf rest (list (type-and t1 (first rest2))))))) + `(VALUES ,@(nreverse req) + ,@(and opt (cons '&optional (nreverse opt))) + ,@(and rest (cons '&optional rest))))))) + +(defun-equal-cached type-or (t1 t2) + ;; FIXME! Should we allow "*" as type name??? + (when (or (eq t1 t2) (eq t2 '*)) + (return-from type-or t1)) + (when (eq t1 '*) + (return-from type-or t2)) + (let* ((si::*highest-type-tag* si::*highest-type-tag*) + (si::*save-types-database* t) + (si::*member-types* si::*member-types*) + (si::*elementary-types* si::*elementary-types*) + (tag1 (si::safe-canonical-type t1)) + (tag2 (si::safe-canonical-type t2))) + (cond ((and (numberp tag1) (numberp tag2)) + (setf tag1 (si::safe-canonical-type t1) + tag2 (si::safe-canonical-type t2)) + (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 + t2) + ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 + t1) + (t + `(OR ,t1 ,t2)))) + ((eq tag1 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) + T) + ((eq tag2 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) + T) + ((null tag1) + (cmpwarn "Unknown type ~S" t1) + T) + (t + (cmpwarn "Unknown type ~S" t2) + T)))) + +(defun type>= (type1 type2) + (subtypep type2 type1)) + +;;; +;;; and-form-type +;;; returns a copy of form whose type is the type-and of type and the form's +;;; type +;;; +(defun and-form-type (type form original-form &optional (mode :safe) + (format-string "") &rest format-args) + (let* ((type2 (c1form-or-loc-primary-type form)) + (type1 (type-and type type2))) + ;; We only change the type if it is not NIL. Is this wise? + (if type1 + (setf (c1form-or-loc-values-type form) type1) + (funcall (if (eq mode :safe) #'cmperr #'cmpwarn) + "~?, the type of the form ~s is ~s, not ~s." format-string + format-args original-form type2 type)) + form)) + +(defun default-init (var) + (let ((new-value (cdr (assoc (var-type var) + '((fixnum . 0) (character . #\space) + #+long-float (long-float 0.0L1) + (double-float . 0.0D1) (single-float . 0.0F1)) + :test #'subtypep)))) + new-value)) + +(defun default-init-loc (var) + (c1form-arg 0 (c1expr (default-init var)))) + +;;---------------------------------------------------------------------- +;; (FUNCTION ...) types. This code is a continuation of predlib.lsp. +;; It implements function types and a SUBTYPEP relationship between them. +;; + +(in-package "SI") + +(defstruct function-type + required + optional + rest + key-p + keywords + keyword-types + allow-other-keys-p + output) + +(defun canonical-function-type (ftype) + (when (function-type-p ftype) + (return-from canonical-function-type ftype)) + (flet ((ftype-error () + (error "Syntax error in FUNCTION type definition ~S" ftype))) + (let (o k k-t values) + (unless (and (= (length ftype) 3) (eql (first ftype) 'FUNCTION)) + (ftype-error)) + (multiple-value-bind (requireds optionals rest key-flag keywords + allow-other-keys-p auxs) + (si::process-lambda-list (second ftype) 'FTYPE) + (dotimes (i (pop optionals)) + (let ((type (first optionals)) + (init (second optionals)) + (flag (third optionals))) + (setq optionals (cdddr optionals)) + (when (or init flag) (ftype-error)) + (push type o))) + (dotimes (i (pop keywords)) + (let ((keyword (first keywords)) + (var (second keywords)) + (type (third keywords)) + (flag (fourth keywords))) + (setq keywords (cddddr keywords)) + (when (or var flag) (ftype-error)) + (push keyword k) + (push type k-t))) + (setf values (third ftype)) + (cond ((atom values) (setf values (list 'VALUES values))) + ((and (listp values) (eql (first values) 'VALUES))) + (t (ftype-error))) + (when (and rest key-flag + (not (subtypep 'keyword rest))) + (ftype-error)) + (make-function-type :required (rest requireds) + :optional o + :rest rest + :key-p key-flag + :keywords k + :keyword-types k-t + :allow-other-keys-p allow-other-keys-p + :output (canonical-values-type values)))))) + +(defconstant +function-type-tag+ (cdr (assoc 'FUNCTION *elementary-types*))) + +(defun register-function-type (type) + (or (find-registered-tag type) + (find-registered-tag (setq ftype (canonical-function-type type))) + (let ((tag (register-type ftype #'function-type-p #'function-type-<=))) + (update-types +function-type-tag+ tag) + tag))) + +(defun function-type-<= (f1 f2) + (unless (and (every* #'subtypep + (function-type-required f2) + (function-type-required f1)) + (do* ((o1 (function-type-optional f1) (cdr o1)) + (o2 (function-type-optional f2) (cdr o2)) + (r1 (function-type-rest f1)) + (r2 (function-type-rest f2)) + t1 t2) + ((and (endp o1) (endp o2)) t) + (setf t1 (cond ((consp o1) (first o1)) + (r1 r1) + (t (return nil))) + t2 (cond ((consp o2) (first o2)) + (r2 r2) + (t (return nil)))) + (unless (subtypep t1 t2) + (return nil))) + (subtypep (function-type-output f1) + (function-type-output f2)) + (eql (function-type-key-p f1) (function-type-key-p f2)) + (or (function-type-allow-other-keys-p f2) + (not (function-type-allow-other-keys-p f1)))) + (return-from function-type-<= nil)) + (do* ((k2 (function-type-keywords f2)) + (k-t2 (function-type-keyword-types f2)) + (k1 (function-type-keywords f1) (cdr k1)) + (k-t1 (function-type-keyword-types f1) (cdr k1))) + ((endp k1) + t) + (unless + (let* ((n (position (first k1) k2))) + (when n + (let ((t2 (nth n k-t2))) + (subtypep (first k-t1) t2)))) + (return-from function-type-<= nil)))) + +;;---------------------------------------------------------------------- +;; (VALUES ...) type + +(defstruct values-type + min-values + max-values + required + optional + rest) + +(defun register-values-type (vtype) + (or (find-registered-tag vtype) + (find-registered-tag (setf vtype (canonical-values-type vtype))) + (register-type vtype #'values-type-p #'values-type-<=))) + +(defun canonical-values-type (vtype) + (when (values-type-p vtype) + (return-from canonical-values-type vtype)) + (flet ((vtype-error () + (error "Syntax error in VALUES type definition ~S" vtype))) + (unless (and (listp vtype) (eql (pop vtype) 'VALUES)) + (vtype-error)) + (let ((required '()) + (optional '()) + (rest nil)) + (do () + ((endp vtype) + (make-values-type :min-values (length required) + :max-values (if rest multiple-values-limit + (+ (length required) + (length optional))) + :required (nreverse required) + :optional (nreverse optional) + :rest rest)) + + (let ((type (pop vtype))) + (if (eql type '&optional) + (do () + ((endp vtype)) + (let ((type (pop vtype))) + (if (eql type '&rest) + (if (endp vtype) + (ftype-error) + (setf rest (first vtype))) + (push type optional)))) + (push type required))))))) + +(defun values-type-<= (v1 v2) + (and (= (values-type-min-values v1) (values-type-min-values v2)) + (= (values-type-max-values v1) (values-type-max-values v2)) + (every* #'subtypep (values-type-required v1) (values-type-required v2)) + (every* #'subtypep (values-type-optional v1) (values-type-optional v2)) + (subtypep (values-type-rest v1) (values-type-rest v2)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; TYPE PROPAGATORS +;;; + +(in-package "COMPILER") + +(defun c1form-or-loc-primary-type (x) + (cond ((c1form-p x) + (c1form-primary-type x)) + ((var-p x) + (var-type x)) + (t + (loc-type x)))) + +(defun c1form-or-loc-values-type (x) + (cond ((c1form-p x) + (c1form-values-type x)) + ((var-p x) + (var-type x)) + (t + (loc-type x)))) + +(defun (setf c1form-or-loc-values-type) (v x) + (cond ((c1form-p x) + (setf (c1form-values-type x) v)) + ((var-p x) + (setf (var-type x) v)) + (t + (error) + (cmpnote "Cannot change type of location ~A" x)))) + +(defun enforce-types (fname arg-types forms &optional lisp-forms) + (do* ((types arg-types (rest types)) + (fl forms (rest fl)) + (al lisp-forms (rest al)) + (i 1 (1+ i)) + (in-optionals nil)) + ((endp types) + (when types + (cmpwarn "Too many arguments passed to ~A" fname))) + (let ((expected-type (first types))) + (when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq) + (return)) + (when (eq expected-type '&optional) + (when (or in-optionals (null (rest types))) + (cmpwarn "Syntax error in type proclamation for function ~A.~&~A" + fname arg-types)) + (setf in-optionals t + types (rest types) + expected-type (first types))) + (when (endp fl) + (unless in-optionals + (cmpwarn "Too few arguments for proclaimed function ~A" fname)) + (return)) + (when lisp-forms + (let* ((form (first fl)) + (lisp-form (first al)) + (old-type (c1form-or-loc-values-type form))) + (and-form-type expected-type form lisp-form + :safe "In the argument ~d of a call to ~a" i fname) + ;; In safe mode, we cannot assume that the type of the + ;; argument is going to be the right one. + (unless (zerop (cmp-env-optimization 'safety)) + (setf (c1form-or-loc-values-type form) old-type))))))) + +(defun infer-arg-and-return-types (fname forms &optional (env *cmp-env*)) + (let ((found (get-sysprop fname 'C1TYPE-PROPAGATOR)) + arg-types + (return-type '(VALUES &REST T))) + (cond (found + (multiple-value-setq (arg-types return-type) + (apply found fname (mapcar #'c1form-or-loc-primary-type forms)))) + ((multiple-value-setq (arg-types found) + (get-arg-types fname env)) + (setf return-type (or (get-return-type fname) return-type)))) + (values arg-types return-type found))) + +(defun propagate-types (fname forms lisp-forms) + (multiple-value-bind (arg-types return-type found) + (infer-arg-and-return-types fname forms) + (when found + (enforce-types fname arg-types forms lisp-forms)) + return-type)) + +(defmacro def-type-propagator (fname lambda-list &body body) + (unless (member '&rest lambda-list) + (let ((var (gensym))) + (setf lambda-list (append lambda-list (list '&rest var)) + body (list* `(declare (ignorable ,var)) body))) + `(put-sysprop ',fname 'C1TYPE-PROPAGATOR + #'(ext:lambda-block ,fname ,lambda-list ,@body)))) + +(defun copy-type-propagator (orig dest-list) + (loop with function = (get-sysprop orig 'C1TYPE-PROPAGATOR) + for name in dest-list + do (put-sysprop name 'C1TYPE-PROPAGATOR function))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; TYPE CHECKING +;; + +(defun remove-function-types (type) + ;; We replace this type by an approximate one that contains no function + ;; types. This function may not produce the best approximation. Hence, + ;; it is only used for optional type checks where we do not want to pass + ;; TYPEP a complex type. + (flet ((simplify-type (type) + (cond ((subtypep type '(NOT FUNCTION)) + type) + ((subtypep type 'FUNCTION) + 'FUNCTION) + (t + T)))) + (if (atom type) + (simplify-type type) + (case (first type) + ((OR AND NOT) + (cons (first type) + (loop for i in (rest type) collect (remove-function-types i)))) + (FUNCTION 'FUNCTION) + (otherwise (simplify-type type)))))) + +(defmacro optional-check-type (&whole whole var-name type &environment env) + "Generates a type check that is only activated for the appropriate +safety settings and when the type is not trivial." + (unless (policy-automatic-check-type-p env) + (cmpnote "Unable to emit check for variable ~A" whole)) + (when (policy-automatic-check-type-p env) + (setf type (remove-function-types type)) + (multiple-value-bind (ok valid) + (subtypep 't type) + (unless (or ok (not valid)) + `(check-type ,var-name ,type))))) diff --git a/src/new-cmp/cmputil.lsp b/src/new-cmp/cmputil.lsp new file mode 100644 index 000000000..c96980483 --- /dev/null +++ b/src/new-cmp/cmputil.lsp @@ -0,0 +1,298 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPUTIL -- Miscellaneous Functions. + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; ECoLisp is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(define-condition compiler-message (simple-condition) + ((prefix :initform "Note" :accessor compiler-message-prefix) + (file :initarg :file :initform *compile-file-pathname* + :accessor compiler-message-file) + (position :initarg :file :initform *compile-file-position* + :accessor compiler-message-file-position) + (toplevel-form :initarg :form :initform *current-toplevel-form* + :accessor compiler-message-toplevel-form) + (form :initarg :form :initform *current-form* :accessor compiler-message-form)) + (:REPORT + (lambda (c stream) + (let ((position (compiler-message-file-position c))) + (if position + (let ((*print-length* 3) + (*print-level* 2)) + (format stream "~A: in file ~A, position ~D, and form ~% ~A~%" + (compiler-message-prefix c) + (compiler-message-file c) position + (compiler-message-toplevel-form c))) + (format stream "~A: " (compiler-message-prefix c))) + (format stream "~?" + (simple-condition-format-control c) + (simple-condition-format-arguments c)))))) + +(define-condition compiler-note (compiler-message) ()) + +(define-condition compiler-warning (compiler-message simple-condition style-warning) + ((prefix :initform "Warning"))) + +(define-condition compiler-error (compiler-message) + ((prefix :initform "Error"))) + +(define-condition compiler-fatal-error (compiler-message) ()) + +(define-condition compiler-internal-error (compiler-fatal-error) + ((prefix :initform "Internal error"))) + +(define-condition compiler-style-warning (compiler-message style-warning) + ((prefix :initform "Style warning"))) + +(define-condition compiler-undefined-variable (compiler-style-warning) + ((variable :initarg :name :initform nil)) + (:report + (lambda (condition stream) + (format stream "Variable ~A was undefined. Compiler assumes it is a global." + (slot-value condition 'variable))))) + +(defun print-compiler-message (c stream) + (unless (typep c *suppress-compiler-messages*) + (format stream "~&~@<;;; ~@;~A~:>" c))) + +;;; A few notes about the following handlers. We want the user to be +;;; able to capture, collect and perhaps abort on the different +;;; conditions signaled by the compiler. Since the compiler uses +;;; HANDLER-BIND, the only way to let this happen is either let the +;;; handler return or use SIGNAL at the beginning of the handler and +;;; let the outer handler intercept. +;;; +;;; In neither case do we want to enter the the debugger. That means +;;; we can not derive the compiler conditions from SERIOUS-CONDITION. +;;; +(defun handle-compiler-note (c) + nil) + +(defun handle-compiler-warning (c) + (push c *compiler-conditions*) + nil) + +(defun handle-compiler-error (c) + (signal c) + (push c *compiler-conditions*) + (print-compiler-message c t) + (abort)) + +(defun handle-compiler-internal-error (c) + (when *compiler-break-enable* + (si::default-debugger c)) + (setf c (make-condition 'compiler-internal-error + :format-control "~A" + :format-arguments (list c))) + (signal c) + (print-compiler-message c t) + (abort)) + +(defun do-compilation-unit (closure &key override) + (cond (override + (let* ((*active-protection* nil)) + (do-compilation-unit closure))) + ((null *active-protection*) + (let* ((*active-protection* t) + (*pending-actions* nil)) + (unwind-protect (do-compilation-unit closure) + (loop for action in *pending-actions* + do (funcall action))))) + (t + (funcall closure)))) + +(defmacro with-compilation-unit ((&rest options) &body body) + `(do-compilation-unit #'(lambda () ,@body) ,@options)) + +(defun compiler-debugger (condition old-hook) + (when *compiler-break-enable* + (si::default-debugger condition)) + (abort)) + +(defmacro with-compiler-env ((compiler-conditions) &body body) + `(let ((*compiler-conditions* nil)) + (declare (special *compiler-conditions*)) + (restart-case + (handler-bind ((compiler-note #'handle-compiler-note) + (warning #'handle-compiler-warning) + (compiler-error #'handle-compiler-error) + (compiler-internal-error #'handle-compiler-internal-error) + (serious-condition #'handle-compiler-internal-error)) + (with-lock (+load-compile-lock+) + (let ,+init-env-form+ + (with-compilation-unit () + ,@body)))) + (abort ())) + (setf ,compiler-conditions *compiler-conditions*))) + +(defvar *c1form-level* 0) +(defun print-c1forms (form) + (cond ((consp form) + (let ((*c1form-level* (1+ *c1form-level*))) + (mapc #'print-c1forms form))) + ((c1form-p form) + (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form)) + (print-c1forms (c1form-args form)) + form + ))) + +(defun print-ref (ref-object stream) + (let ((name (ref-name ref-object))) + (if name + (format stream "#" (type-of ref-object) name) + (format stream "#" (type-of ref-object))))) + +(defun print-var (var-object stream) + (format stream "#" (var-name var-object) (var-kind var-object))) + +(defun cmpprogress (&rest args) + (when *compile-verbose* + (apply #'format t args))) + +(defun cmperr (string &rest args) + (let ((c (make-condition 'compiler-error + :format-control string + :format-arguments args))) + (signal c) + (print-compiler-message c t) + (abort))) + +(defun check-args-number (operator args &optional (min 0) (max nil)) + (let ((l (length args))) + (when (< l min) + (too-few-args operator min l)) + (when (and max (> l max)) + (too-many-args operator max l)))) + +(defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) + (cmperr "~S requires at most ~R argument~:p, but ~R ~:*~[were~;was~:;were~] supplied.~%" + name + upper-bound + n)) + +(defun too-few-args (name lower-bound n) + (cmperr "~S requires at least ~R argument~:p, but only ~R ~:*~[were~;was~:;were~] supplied.~%" + name + lower-bound + n)) + +(defun do-cmpwarn (&rest args) + (declare (si::c-local)) + (let ((condition (apply #'make-condition args))) + (restart-case (signal condition) + (muffle-warning () + :REPORT "Skip warning" + (return-from do-cmpwarn nil))) + (print-compiler-message condition t))) + +(defun cmpwarn-style (string &rest args) + (do-cmpwarn 'compiler-style-warning :format-control string :format-arguments args)) + +(defun cmpwarn (string &rest args) + (do-cmpwarn 'compiler-warning :format-control string :format-arguments args)) + +(defun cmpnote (string &rest args) + (do-cmpwarn 'compiler-note :format-control string :format-arguments args)) + +(defun print-current-form () + (when *compile-print* + (let ((*print-length* 2) + (*print-level* 2)) + (format t "~&;;; Compiling ~s.~%" *current-toplevel-form*))) + nil) + +(defun print-emitting (f) + (when *compile-print* + (let* ((name (or (fun-name f) (fun-description f)))) + (when name + (format t "~&;;; Emitting code for ~s.~%" name))))) + +(defun undefined-variable (sym) + (do-cmpwarn 'compiler-undefined-variable :name sym)) + +(defun baboon (&aux (*print-case* :upcase)) + (signal 'compiler-internal-error + :format-control "A bug was found in the compiler." + :format-arguments nil)) + +(defmacro with-cmp-protection (main-form error-form) + `(let* ((si::*break-enable* *compiler-break-enable*) + (throw-flag t)) + (unwind-protect + (multiple-value-prog1 + (if *compiler-break-enable* + (handler-bind ((error #'invoke-debugger)) + ,main-form) + ,main-form) + (setf throw-flag nil)) + (when throw-flag ,error-form)))) + +(defun cmp-eval (form) + (pprint 'CMP-EVAL) + (pprint form) + (if (and (atom form) (not (symbolp form))) + form + (handler-case (eval form) + (serious-condition (c) + (when *compiler-break-enable* + (invoke-debugger c)) + (cmperr "The form ~s was not evaluated successfully.~%Error detected:~%~A" + form c) + nil)))) + +(defun cmp-macroexpand (form &optional (env *cmp-env*)) + (handler-case (macroexpand form env) + (serious-condition (c) + (when *compiler-break-enable* + (invoke-debugger c)) + (cmperr "The macro form ~s was not expanded successfully.~%Error detected:~%~A" + form c) + nil))) + +(defun cmp-expand-macro (fd form &optional (env *cmp-env*)) + (handler-case + (let ((new-form (funcall *macroexpand-hook* fd form env))) + (values new-form (not (eql new-form form)))) + (serious-condition (c) + (when *compiler-break-enable* + (invoke-debugger c)) + (cmperr "The macro form ~s was not expanded successfully.~%Error detected:~%~A" + form c) + (values nil nil)))) + +(defun si::compiler-clear-compiler-properties (symbol) + #-:CCL + ;(sys::unlink-symbol symbol) + (rem-sysprop symbol 't1) + (rem-sysprop symbol 't2) + (rem-sysprop symbol 't3) + (rem-sysprop symbol ':inline-always) + (rem-sysprop symbol ':inline-unsafe) + (rem-sysprop symbol ':inline-safe) + (rem-sysprop symbol 'lfun)) + +(defun lisp-to-c-name (obj) + "Translate Lisp object prin1 representation to valid C identifier name" + (and obj + (map 'string + #'(lambda (c) + (let ((cc (char-code c))) + (if (or (<= #.(char-code #\a) cc #.(char-code #\z)) + (<= #.(char-code #\0) cc #.(char-code #\9))) + c #\_))) + (string-downcase (prin1-to-string obj))))) + +(defun proper-list-p (x &optional test) + (and (listp x) + (handler-case (list-length x) (type-error (c) nil)) + (or (null test) (every test x)))) diff --git a/src/new-cmp/cmpvar.lsp b/src/new-cmp/cmpvar.lsp new file mode 100644 index 000000000..e127bfeb0 --- /dev/null +++ b/src/new-cmp/cmpvar.lsp @@ -0,0 +1,353 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPVAR Variables. + +(in-package "COMPILER") + +(defun make-var (&rest args) + (let ((var (apply #'%make-var args))) + (unless (member (var-kind var) '(SPECIAL GLOBAL)) + (when *current-function* + (push var (fun-local-vars *current-function*)))) + var)) + +;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too +;;; pessimistic. One should check whether the functions reading/setting the +;;; variable are actually called from the given node. The problem arises when +;;; we create a closure of a function, as in +;;; +;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) +;;; +;;; To know whether A is changed or read, we would have to track where B is +;;; actually used. + +(defun var-referenced-in-form (var form) + (declare (type var var)) + (cond ((consp form) + (loop for f in form thereis (var-referenced-in-form var f))) + ((eq (var-kind var) 'REPLACED) + (let ((loc (var-loc var))) + (when (var-p loc) + (var-referenced-in-forms loc form)))) + ((or (find-node-in-list form (var-read-nodes var)) + (var-functions-reading var))))) + +(defun var-changed-in-form (var form) + (declare (type var var)) + (if (listp form) + (loop for f in form + thereis (var-changed-in-form var f)) + (let ((kind (var-kind var))) + (if (eq kind 'REPLACED) + (let ((loc (var-loc var))) + (when (var-p loc) + (var-changed-in-form loc form))) + (or (find-node-in-list form (var-set-nodes var)) + (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) + (c1form-sp-change form) + (var-functions-setting var))))))) + +(defun add-to-read-nodes (var forms) + (dolist (form forms) + (incf (var-ref var)) + (push form (var-read-nodes var)) + (when *current-function* + (unless (eq *current-function* (var-function var)) + (pushnew *current-function* (var-functions-reading var)) + (pushnew var (fun-referred-vars *current-function*))))) + forms) + +(defun add-to-set-nodes (var forms) + (dolist (form forms) + (incf (var-ref var)) + (push form (var-set-nodes var)) + ;;(push form (var-read-nodes var)) + (when *current-function* + (unless (eq *current-function* (var-function var)) + (pushnew *current-function* (var-functions-setting var)) + (pushnew var (fun-referred-vars *current-function*))))) + forms) + +(defun add-to-set-nodes-of-var-list (var-list forms) + (dolist (v var-list) + (add-to-set-nodes v forms)) + forms) + +;;; A special binding creates a var object with the kind field SPECIAL, +;;; whereas a special declaration without binding creates a var object with +;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure +;;; that the variable has a value. + +;;; Bootstrap problem: proclaim needs this function: +(defun sch-global (name) + (dolist (var *undefined-vars* nil) + (declare (type var var)) + (when (eq (var-name var) name) + (return-from sch-global var)))) + +;;; +;;; Check if a variable has been declared as a special variable with a global +;;; value. + +(defun check-global (name) + (member name *global-vars* :test #'eq :key #'var-name)) + +;;; +;;; Check if the symbol has a symbol macro +;;; +(defun chk-symbol-macrolet (form) + (loop + (when (not (symbolp form)) + (return form)) + (let ((new-form (macroexpand-1 form *cmp-env*))) + (when (eq new-form form) + (return form)) + (setf form new-form)))) + +(defun c1make-var (name specials ignores types) + (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) + (cmpck (constantp name) "The constant ~s is being bound." name) + (let (type) + (if (setq type (assoc name types)) + (setq type (type-filter (cdr type))) + (setq type 'T)) + (cond ((or (member name specials) + (sys:specialp name) + (check-global name)) ;; added. Beppe 17 Aug 1987 + (unless type + (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) + (c1make-global-variable name :kind 'SPECIAL :type type)) + (t + (make-var :name name :type type :loc 'OBJECT + :kind 'LEXICAL ; we rely on check-vref to fix it + :ref (if (member name ignores) -1 0)))))) + +(defun check-vref (var) + (when (eq (var-kind var) 'LEXICAL) + (when (zerop (var-ref var)) ;;; This field may be -1 (IGNORE). Beppe + (cmpwarn-style "The variable ~s is not used." (var-name var))) + (when (not (var-ref-clb var)) + ;; if the variable can be stored locally, set it var-kind to its type + (setf (var-kind var) + (if (plusp (var-ref var)) + (lisp-type->rep-type (var-type var)) + :OBJECT))))) + +(defun c1var (destination name) + (let ((vref (c1vref name (eq destination 'TRASH)))) + (when vref + (c1set-loc destination vref)))) + +(defun make-lcl-var (&key rep-type (type 'T)) + (unless rep-type + (setq rep-type (if type (lisp-type->rep-type type) :object))) + (unless type + (setq type 'T)) + (make-var :kind rep-type :type type :loc (next-lcl))) + +(defun make-temp-var (&optional (type 'T)) + (make-var :kind :object :type type :loc `(TEMP ,(next-temp)))) + +(defun c1vref (name &optional maybe-drop-ref) + (multiple-value-bind (var ccb clb unw) + (cmp-env-search-var name) + (cond ((null var) + (unless (and maybe-drop-ref (not (policy-global-var-checking))) + (c1make-global-variable name :warn t + :type (or (get-sysprop name 'CMP-TYPE) t)))) + ((not (var-p var)) + ;; symbol-macrolet + (baboon)) + (t + (when (and maybe-drop-ref (or (local var) (not (policy-global-var-checking)))) + (return-from c1vref nil)) + (when (minusp (var-ref var)) ; IGNORE. + (cmpwarn-style "The ignored variable ~s is used." name) + (setf (var-ref var) 0)) + (when (eq (var-kind var) 'LEXICAL) + (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT)) + (clb (setf (var-ref-clb var) t + (var-loc var) 'OBJECT)))) + var)))) + +(defun unboxed (var) + (not (eq (var-rep-type var) :object))) + +(defun global (var) + (member (var-kind var) '(SPECIAL GLOBAL))) + +(defun local (var) + (let ((kind (var-kind var))) + (unless (member kind '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED DISCARDED)) + kind))) + +(defun wt-var (var &aux (var-loc (var-loc var))) ; ccb + (declare (type var var)) + (case (var-kind var) + (CLOSURE (wt-env var-loc)) + (LEXICAL (wt-lex var-loc)) + (REPLACED (wt var-loc)) + (DISCARDED (baboon)) + ((SPECIAL GLOBAL) + (if (policy-global-var-checking) + (wt "ecl_symbol_value(" var-loc ")") + (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) + (t (wt var-loc)) + )) + +(defun var-rep-type (var) + (case (var-kind var) + ((LEXICAL CLOSURE SPECIAL GLOBAL) :object) + (REPLACED (loc-representation-type (var-loc var))) + (DISCARDED :object) + (t (var-kind var)))) + +(defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb + (unless (var-p var) + (baboon)) + (when (unused-variable-p var) + (set-loc loc 'trash) + (return-from set-var)) + (case (var-kind var) + (DISCARDED + (set-loc loc 'TRASH)) + (CLOSURE + (wt-nl)(wt-env var-loc)(wt "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)) + (LEXICAL + (wt-nl)(wt-lex var-loc)(wt "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)) + ((SPECIAL GLOBAL) + (if (safe-compile) + (wt-nl "cl_set(" var-loc ",") + (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) + (wt-coerce-loc (var-rep-type var) loc) + (wt ");")) + (t + (wt-nl var-loc "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)))) + +(defun wt-lex (lex) + (if (consp lex) + (wt "lex" (car lex) "[" (cdr lex) "]") + (wt-lcl lex))) + +;;; reference to variable of inner closure. +(defun wt-env (clv) (wt "ECL_CONS_CAR(CLV" clv ")")) + +;;; ---------------------------------------------------------------------- + +(defun c1make-global-variable (name &key (type t) (kind 'GLOBAL) (warn nil)) + (let ((var (find name *global-var-objects* :key #'var-name))) + (unless var + (setf var (make-var :name name :kind kind :type type :loc (add-symbol name)))) + (push var *global-var-objects*) + (when warn + (unless (or (sys:specialp name) (constantp name) (check-global name)) + (undefined-variable name) + (push var *undefined-vars*))) + var)) + +(defun c1declare-specials (globals) + (mapc #'cmp-env-declare-special globals)) + +(defun si::register-global (name) + (unless (check-global name) + (push (c1make-global-variable name :kind 'GLOBAL + :type (or (get-sysprop name 'CMP-TYPE) 'T)) + *global-vars*)) + (values)) + +(defun c1setq (destination args) + (let ((l (length args))) + (declare (fixnum l)) + (cmpck (oddp l) "SETQ requires an even number of arguments.") + (cond ((zerop l) (c1nil destination)) + ((= l 2) (c1setq1 destination (first args) (second args))) + (t + (c1progn destination + (loop while args + collect `(SETQ ,(pop args) ,(pop args)))))))) + +(defun c1setq1 (destination name form) + (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) + (cmpck (constantp name) "The constant ~s is being assigned a value." name) + (setq name (chk-symbol-macrolet name)) + (unless (symbolp name) + (return-from c1setq1 (c1translate destination `(setf ,name ,form)))) + (c1with-saved-one-value (prefix postfix temp form) + (let* ((name1 (c1vref name))) + (nconc prefix + (c1set-loc name1 temp) + postfix + (unless (eq destination 'trash) (c1set-loc destination name1)))))) + +(defun unused-variable-p (var) + "Is the value of the variable ever read?" + (and (null (var-read-nodes var)) + (not (global var)))) + +(defun c1progv (destination args) + (check-args-number 'PROGV args 2) + (c1with-temps (ndx-prefix ndx-postfix bds-ndx) + (let* ((variables (pop args)) + (values (pop args))) + (c1with-saved-values (prefix postfix temps (list variables values)) + (let* ((cleanup (c1progv-exit-op bds-ndx)) + (*cmp-env* (cmp-env-register-cleanup cleanup + (cmp-env-copy *cmp-env*)))) + (nconc ndx-prefix + prefix + (c1progv-op bds-ndx (first temps) (second temps)) + (c1translate destination args) + postfix + ndx-postfix)))))) + +(defun c1psetq (destination args) + (let* ((variables '()) + (values '()) + (use-psetf nil)) + (do ((l args)) + ((endp l)) + (declare (object l)) + (let ((var (pop l))) + (cmpck (not (symbolp var)) + "The variable ~s is not a symbol." var) + (cmpck (endp l) + "No form was given for the value of ~s." var) + (let* ((value (pop l)) + (expanded-var (chk-symbol-macrolet var))) + (push value values) + (push expanded-var variables) + (if (symbolp expanded-var) + (cmpck (constantp expanded-var) + "The constant ~s is being assigned a value." + expanded-var) + (setq use-psetf t))))) + (when use-psetf + (setf args (mapcan #'list variables values)) + (return-from c1psetq (c1translate destination `(psetf ,@args)))) + (c1with-saved-values (prefix postfix temps values) + (nconc prefix + (loop for name in variables + for vref = (c1vref name) + for x in temps + nconc (c1set-loc vref x)) + postfix + (c1set-loc destination nil))))) diff --git a/src/new-cmp/cmpwt.lsp b/src/new-cmp/cmpwt.lsp new file mode 100644 index 000000000..35c62c157 --- /dev/null +++ b/src/new-cmp/cmpwt.lsp @@ -0,0 +1,298 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPWT Output routines. + +(in-package "COMPILER") + +(defvar *wt-string-size* 0) + +;;; Each lisp compiled file consists on code and a data section. Whenever an +;;; #'in-package toplevel form is found, a read-time evaluated expression is +;;; inserted in the data section which changes the current package for the +;;; rest of it. This way it is possible to save some space by writing the +;;; symbol's package only when it does not belong to the current package. + +(defun wt-label (label) + (wt-nl1 "L" label ":;")) + +(defun wt-filtered-comment (text stream single-line) + (declare (string text)) + (if single-line + (progn + (fresh-line stream) + (princ "/* " stream)) + (format stream "~50T/* ")) + (let* ((l (1- (length text)))) + (declare (fixnum l)) + (dotimes (n l) + (let ((c (schar text n))) + (princ c stream) + (when (and (char= c #\*) (char= (schar text (1+ n)) #\/)) + (princ #\\ stream)))) + (princ (schar text l) stream)) + (format stream "~70T*/") + ) + +(defun do-wt-comment (message-or-format args single-line-p) + (unless (and (symbolp message-or-format) (not (symbol-package message-or-format))) + (wt-filtered-comment (if (stringp message-or-format) + (if args + (apply #'format nil message-or-format args) + message-or-format) + (princ-to-string message-or-format)) + *compiler-output1* + single-line-p))) + +(defun wt-comment (message &rest extra) + (do-wt-comment message extra nil)) + +(defun wt-comment-nl (message &rest extra) + (do-wt-comment message extra t)) + +(defun wt1 (form) + (typecase form + ((or STRING INTEGER CHARACTER) + (princ form *compiler-output1*)) + ((or DOUBLE-FLOAT SINGLE-FLOAT) + (format *compiler-output1* "~10,,,,,,'eG" form)) + (LONG-FLOAT + (format *compiler-output1* "~,,,,,,'eEl" form)) + (VAR (wt-var form)) + (t (wt-loc form))) + nil) + +(defun wt-h1 (form) + (if (consp form) + (let ((fun (get-sysprop (car form) 'wt-loc))) + (if fun + (let ((*compiler-output1* *compiler-output2*)) + (apply fun (cdr form))) + (cmperr "The location ~s is undefined." form))) + (princ form *compiler-output2*)) + nil) + +;;; This routine converts lisp data into C-strings. We have to take +;;; care of escaping special characteres with backslashes. We also have +;;; to split long lines using the fact that multiple strings are joined +;;; together by the compiler. +;;; +(defun wt-filtered-data (string stream &optional one-liner) + (let ((N (length string)) + (wt-data-column 80)) + (incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space + (format stream (if one-liner "\"" "~%\"")) + (dotimes (i N) + (decf wt-data-column) + (when (< wt-data-column 0) + (format stream "\"~% \"") + (setq wt-data-column 79)) + (let ((x (aref string i))) + (cond + ((or (< (char-code x) 32) + (> (char-code x) 127)) + (case x + ; We avoid a trailing backslash+newline because some preprocessors + ; remove them. + (#\Newline (princ "\\n" stream)) + (#\Tab (princ "\\t" stream)) + (t (format stream "\\~3,'0o" (char-code x))))) + ((char= x #\\) + (princ "\\\\" stream)) + ((char= x #\") + (princ "\\\"" stream)) + (t (princ x stream))))) + (princ (if one-liner "\"" " \"") stream) + string)) + +;;; ====================================================================== +;;; +;;; DATA FILES +;;; + +(defun data-permanent-storage-size () + (length *permanent-objects*)) + +(defun data-temporary-storage-size () + (length *temporary-objects*)) + +(defun data-size () + (+ (data-permanent-storage-size) + (data-temporary-storage-size))) + +(defun data-init (&optional filename) + (if (and filename (probe-file filename)) + (with-open-file (s filename :direction :input) + (setf *permanent-objects* (read s) + *temporary-objects* (read s))) + (setf *permanent-objects* (make-array 128 :adjustable t :fill-pointer 0) + *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))) + +(defun data-get-all-objects () + ;; We collect all objects that are to be externalized, but filter out + ;; those which will be created by a lisp form. + (loop for i in (nconc (map 'list #'first *permanent-objects*) + (map 'list #'first *temporary-objects*)) + collect (if (gethash i *load-objects*) + 0 + i))) + +(defun data-dump (stream &key as-lisp-file init-name &aux must-close) + (etypecase stream + (null (return-from data-dump)) + ((or pathname string) + (setf stream (open stream :direction :output :if-does-not-exist :create + :if-exists :supersede :external-format :default) + must-close stream)) + (stream)) + (si::with-ecl-io-syntax + (let ((output nil)) + (cond (as-lisp-file + (print *permanent-objects* stream) + (print *temporary-objects* stream)) + (*compiler-constants* + (format stream "~%#define compiler_data_text NULL~%#define compiler_data_text_size 0~%") + (setf output (concatenate 'vector (data-get-all-objects)))) + ((plusp (data-size)) + (wt-data-begin stream) + (wt-filtered-data + (subseq (prin1-to-string (data-get-all-objects)) 1) + stream) + (wt-data-end stream))) + (when must-close + (close must-close)) + (data-init) + output))) + +(defun wt-data-begin (stream) + (setq *wt-string-size* 0) + (setq *wt-data-column* 80) + (princ "static const char compiler_data_text[] = " stream) + nil) + +(defun wt-data-end (stream) + (princ #\; stream) + (format stream "~%#define compiler_data_text_size ~D~%" *wt-string-size*) + (setf *wt-string-size* 0)) + +(defun data-empty-loc () + (add-object 0 :duplicate t :permanent t)) + +(defun add-load-form (object location) + (when (clos::need-to-make-load-form-p object) + (if (not (eq *compiler-phase* 't1)) + (cmperr "Unable to internalize complex object ~A in ~a phase" + object *compiler-phase*) + (multiple-value-bind (make-form init-form) (make-load-form object) + (setf (gethash object *load-objects*) location) + (setf *make-forms* + (nconc *make-forms* + (and make-form (c1translate location make-form)) + (and init-form (c1translate location init-form)))))))) + +(defun add-object (object &key (duplicate nil) + (permanent (or (symbolp object) *permanent-data*))) + ;; FIXME! Currently we have two data vectors and, when compiling + ;; files, it may happen that a constant is duplicated and stored + ;; both in VV and VVtemp. This would not be a problem if the + ;; constant were readable, but due to using MAKE-LOAD-FORM we may + ;; end up having two non-EQ objects created for the same value. + (let* ((test (if *compiler-constants* 'eq 'equal)) + (array (if permanent *permanent-objects* *temporary-objects*)) + (vv (if permanent 'VV 'VV-temp)) + (x (or (and (not permanent) + (find object *permanent-objects* :test test + :key #'first)) + (find object array :test test :key #'first))) + (next-ndx (length array)) + found) + (cond ((add-static-constant object)) + ((and x duplicate) + (setq x (list* vv next-ndx (if (eq 0 object) nil (list object)))) + (vector-push-extend (list object x next-ndx) array) + x) + (x + (second x)) + ((and (not duplicate) + (symbolp object) + (multiple-value-setq (found x) (si::mangle-name object))) + x) + (t + (setq x (list* vv next-ndx (if (eq 0 object) nil (list object)))) + (vector-push-extend (list object x next-ndx) array) + (unless *compiler-constants* + (add-load-form object x)) + x)))) + +(defun add-symbol (symbol) + (add-object symbol :duplicate nil :permanent t)) + +(defun add-keywords (keywords) + ;; We have to build, in the vector VV[], a sequence with all + ;; the keywords that this function uses. It does not matter + ;; whether each keyword has appeared separately before, because + ;; cl_parse_key() needs the whole list. However, we can reuse + ;; keywords lists from other functions when they coincide with ours. + ;; We search for keyword lists that are similar. However, the list + ;; *OBJECTS* contains elements in decreasing order!!! + (let ((x (search keywords *permanent-objects* + :test #'(lambda (k record) (eq k (first record)))))) + (if x + (progn + (cmpnote "~@" keywords) + (second (elt *permanent-objects* x))) + (prog1 + (add-object (pop keywords) :duplicate t :permanent t) + (dolist (k keywords) + (add-object k :duplicate t :permanent t)))))) + +;;; ====================================================================== +;;; +;;; STATIC CONSTANTS +;;; + +(defun static-base-string-builder (name value stream) + (format stream "ecl_def_ct_base_string(~A," name) + (wt-filtered-data value stream t) + (format stream ",~D,static,const);" (length value))) + +(defun static-single-float-builder (name value stream) + (let* ((*read-default-float-format* 'single-float) + (*print-readably* t)) + (format stream "ecl_def_ct_single_float(~A,~S,static,const);" name value stream))) + +(defun static-double-float-builder (name value stream) + (let* ((*read-default-float-format* 'double-float) + (*print-readably* t)) + (format stream "ecl_def_ct_single_float(~A,~S,static,const);" name value stream))) + +(defun static-constant-builder (format value) + (lambda (name stream) + (format stream format name value))) + +(defun static-constant-expression (object) + (typecase object + (base-string #'static-base-string-builder) + ;;(single-float #'static-single-float-builder) + ;;(double-float #'static-double-float-builder) + (t nil))) + +(defun add-static-constant (object) + (unless (or *compiler-constants* (not (listp *static-constants*))) + (let ((record (find object *static-constants* :key #'first :test #'equal))) + (if record + (second record) + (let ((builder (static-constant-expression object))) + (when builder + (let* ((c-name (format nil "_ecl_static_~D" (length *static-constants*)))) + (push (list object c-name builder) *static-constants*) + `(VV ,c-name ,object)))))))) diff --git a/src/new-cmp/defsys.lsp.in b/src/new-cmp/defsys.lsp.in new file mode 100644 index 000000000..1f95d30b9 --- /dev/null +++ b/src/new-cmp/defsys.lsp.in @@ -0,0 +1,46 @@ +;;; ---------------------------------------------------------------------- +;;; CLOS +;;; ---------------------------------------------------------------------- + +(defparameter + *cmp-modules* + ;; file load compile files which force + ;; environment environment recompilations of + ;; this file + '( + (cmpdefs () () ()) + (cmpmac () () ()) + (cmpinline () () ()) + (cmputil () () ()) + (cmptype () () ()) + (cmpbind () () ()) + (cmpblock () () ()) + (cmpcall () () ()) + (cmpcatch () () ()) + (cmpenv () () ()) + (cmpeval () () ()) + (cmpexit () () ()) + (cmpflet () () ()) + (cmpfun () () ()) + (cmpif () () ()) + (cmplam () () ()) + (cmplet () () ()) + (cmploc () () ()) + (cmpmap () () ()) + (cmpmulti () () ()) + (cmpspecial () () ()) + (cmptag () () ()) + (cmptop () () ()) + (cmpvar () () ()) + (cmpwt () () ()) + (cmpmain () () ()) + (cmpffi () () ()) + (cmpcfg () () ()))) + +(sbt:defsystem + cmp + :modules *cmp-modules* + :source-directory '("@abs_srcdir@/" "@abs_builddir@/") + :fasl-directory "@abs_builddir@/" + :library-directory "@abs_top_builddir@/") + diff --git a/src/new-cmp/load.lsp.in b/src/new-cmp/load.lsp.in new file mode 100644 index 000000000..bd8f43f0c --- /dev/null +++ b/src/new-cmp/load.lsp.in @@ -0,0 +1,48 @@ +;;; @configure_input@ + +(defconstant +cmp-module-files+ +'("build:new-cmp;cmpdefs.lsp" + "src:new-cmp;cmpmac.lsp" + "src:new-cmp;cmpinline.lsp" + "src:new-cmp;cmputil.lsp" + "src:new-cmp;cmptype.lsp" + "src:new-cmp;cmpbind.lsp" + "src:new-cmp;cmptables.lsp" + "src:new-cmp;cmptranslate.lsp" + "src:new-cmp;cmpbackend.lsp" + "src:new-cmp;cmpblock.lsp" + "src:new-cmp;cmpcall.lsp" + "src:new-cmp;cmpcatch.lsp" + "src:new-cmp;cmpenv.lsp" + "src:new-cmp;cmpeval.lsp" + "src:new-cmp;cmpexit.lsp" + "src:new-cmp;cmpflet.lsp" + "src:new-cmp;cmpfun.lsp" + "src:new-cmp;cmpif.lsp" + "src:new-cmp;cmplam.lsp" + "src:new-cmp;cmplet.lsp" + "src:new-cmp;cmploc.lsp" + "src:new-cmp;cmpmap.lsp" + "src:new-cmp;cmpstack.lsp" + "src:new-cmp;cmpmulti.lsp" + "src:new-cmp;cmpspecial.lsp" + "src:new-cmp;cmptag.lsp" + "src:new-cmp;cmptop.lsp" + "src:new-cmp;cmpvar.lsp" + "src:new-cmp;cmpwt.lsp" + "src:new-cmp;cmpffi.lsp" + "src:new-cmp;cmpcbk.lsp" + "src:new-cmp;cmpct.lsp" + "src:new-cmp;cmpnum.lsp" + "src:new-cmp;cmpname.lsp" + "src:new-cmp;cmpopt.lsp" + "src:new-cmp;cmpprop.lsp" + "src:new-cmp;cmpclos.lsp" + "src:new-cmp;cmpstructures.lsp" + "src:new-cmp;cmparray.lsp" + "src:new-cmp;cmpmain.lsp")) + +(let ((si::*keep-documentation* nil)) + (mapc #'(lambda (x) (load x :verbose nil)) +cmp-module-files+) + (load "src:new-cmp;sysfun" :verbose nil)) + diff --git a/src/new-cmp/sysfun.lsp b/src/new-cmp/sysfun.lsp new file mode 100644 index 000000000..82bb52643 --- /dev/null +++ b/src/new-cmp/sysfun.lsp @@ -0,0 +1,2197 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;; CMPSYSFUN Database for system functions. +;;; +;;; Copyright (c) 2003, Juan Jose Garcia Ripoll +;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved. +;;; Copying of this file is authorized to users who have executed the true +;;; and proper "License Agreement for ECoLisp". +;;; +;;; DATABASE OF FUNCTION PROCLAMATIONS AND INLINE EXPANSIONS +;;; +;;; What follows is the complete list of function type proclamations for the +;;; most important functions in the ECL core library, together with some useful +;;; inline expansions. +;;; +;;; The function proclamations are created with PROCLAIM-FUNCTION, as in +;;; +;;; (PROCLAIM-FUNCTION function-name ([arg-type]*) return-type +;;; &rest {:no-sp-change|:pure|:reader|:no-side-effects}) +;;; +;;; with the following interpretation: ARG-TYPE and RETURN-TYPE denote the most +;;; general types for the input and output values of this function. If the +;;; compiler detects that some of the values passed to this function does not +;;; match these types, it will generate an error. In addition to this, ECL +;;; contemplates different function properties: +;;; +;;; :NO-SP-CHANGE indicates that the function does not change the value of any +;;; special variable, and it is used to perform code transformations. +;;; +;;; :NO-SIDE-EFFECTS is slightly stronger, as it indicates that the function +;;; does not change variables or the content of objects in the +;;; thread environment. Note the following: +;;; +;;; - Allocating memory, creating objects, etc is not considered a side +;;; effect, as it does not affect the code flow. +;;; - Similarly, signalling errors is not considered a side effect. +;;; - The environment may be changed by other threads. This is taken +;;; into account (see below). +;;; +;;; :READER indicates that the function not only has no side effects, but its +;;; value depends only on its arguments. However, :READER specifies that +;;; the arguments are mutable. +;;; +;;; :PURE is the strictest class of functions. They have no side effects, the +;;; output only depends on the arguments, the arguments are inmutable +;;; objects and the function call can be optimized away when the +;;; arguments are constant. +;;; +;;; Inline expansions, on the other hand, have the following syntax +;;; +;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type +;;; expansion-string) +;;; +;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family, +;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the +;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the +;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE, +;;; depending on whether the inline expression should be applied always, in safe +;;; or in unsafe compilation mode, respectively. +;;; + +(in-package "COMPILER") + +(defmacro proclaim-function (&whole form name arg-types return-type &rest properties) + (when (get-sysprop name 'proclaimed-arg-types) + (warn "Duplicate proclamation for ~A" name)) + (unless (or (equal arg-types '(*))) + (put-sysprop name 'proclaimed-arg-types arg-types)) + (when (and return-type (not (eq 'T return-type))) + (put-sysprop name 'proclaimed-return-type return-type)) + (loop for p in properties + do (case p + (:no-sp-change + (put-sysprop name 'no-sp-change t)) + ((:predicate :pure) + (put-sysprop name 'pure t) + (put-sysprop name 'no-side-effects t)) + ((:no-side-effects :reader) + (put-sysprop name 'no-side-effects t)) + (otherwise + (error "Unknown property ~S in function proclamation ~S" p form)))) + (rem-sysprop name ':inline-always) + (rem-sysprop name ':inline-safe) + (rem-sysprop name ':inline-unsafe) + nil) + +(defmacro def-inline (name safety arg-types return-rep-type expansion + &key (one-liner t) (exact-return-type nil) + &aux arg-rep-types) + (setf safety + (case safety + (:unsafe :inline-unsafe) + (:safe :inline-safe) + (:always :inline-always) + (t (error "In DEF-INLINE, wrong value of SAFETY")))) + (setf arg-rep-types + (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x))) + arg-types)) + (when (eq return-rep-type t) + (setf return-rep-type :object)) + (let* ((return-type (if (and (consp return-rep-type) + (eq (first return-rep-type) 'values)) + t + (rep-type->lisp-type return-rep-type))) + (inline-info + (make-inline-info :name name + :arg-rep-types arg-rep-types + :return-rep-type return-rep-type + :return-type return-type + :arg-types arg-types + :exact-return-type exact-return-type + ;; :side-effects (not (get-sysprop name 'no-side-effects)) + :one-liner one-liner + :expansion expansion)) + (previous (get-sysprop name safety))) + #+(or) + (loop for i in previous + when (and (equalp (inline-info-arg-types i) arg-types) + (not (equalp return-type (inline-info-return-type i)))) + do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>" + name i inline-info)) + (put-sysprop name safety (cons inline-info previous))) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; AUXILIARY TYPES +;; + +(deftype string-designator () '(or string symbol character)) +(deftype natural () '(integer 0 *)) +(deftype function-name () '(or list symbol)) +(deftype function-designator () '(or symbol function)) +(deftype extended-function-designator () '(or function-name function)) +(deftype environment () 'list) +(deftype type-specifier () '(or symbol class list)) +(deftype gen-bool () "Generalized boolean type" 't) +(deftype format-control () "Format control for FORMAT" '(or string function)) +(deftype restart-designator () '(or (and symbol (not (member nil))) restart)) +(deftype package-designator () '(or string-designator package)) +(deftype byte-specifier () '(cons unsigned-byte unsigned-byte)) +(deftype character-designator () '(or string-designator character)) +(deftype radix () '(integer 2 36)) +(deftype digit-weight () '(integer 0 35)) +(deftype character-code () '(integer 0 #.(1- char-code-limit))) +(deftype tree () 't) +(deftype association-list () 'list) +(deftype bit-array () '(array bit)) +(deftype pathname-designator () '(or string pathname stream)) +(deftype pathname-host () '(or string list (member nil :unspecific))) +(deftype pathname-device () '(or string (member nil :unspecific))) +(deftype pathname-directory () '(or string list (member :wild :unspecific))) +(deftype pathname-name () '(or string (member nil :wild :unspecific))) +(deftype pathname-type () '(or string (member nil :wild :unspecific))) +(deftype pathname-version () '(or unsigned-byte (member nil :wild :newest :unspecific))) +(deftype universal-time () 'unsigned-byte) +(deftype time-zone () '(rational -24 24)) +(deftype stream-designator () '(or stream (member t nil))) +(deftype file-position-designator () '(or unsigned-byte (member :start :end))) +(deftype external-file-format () '(or symbol list)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ALL FUNCTION DECLARATIONS +;;; +;;; +;;; ANSI SECTIONS +;;; +;;; 3. EVALUATION AND COMPILATION +;;; + +(proclaim-function compile (function-name &optional (or list function)) + (values (or function-name function) gen-bool gen-bool)) +(proclaim-function compiler-macro-function (function-name &optional environment) + function) +(proclaim-function constantp (t &optional environment) gen-bool :no-side-effects) +(proclaim-function eval (t) (values &rest t)) +(proclaim-function macro-function (symbol &optional environment) function) +(proclaim-function macroexpand (t &optional environment) (values t gen-bool)) +(proclaim-function macroexpand-1 (t &optional environment) (values t gen-bool)) +(proclaim-function proclaim (list) (values &rest t)) +(proclaim-function special-operator-p (symbol) gen-bool :pure) + +;; ECL extensions: +(proclaim-function si:specialp (symbol) gen-bool :predicate) + + +;;; +;;; 4. TYPES AND CLASSES +;;; + +(proclaim-function coerce (t type-specifier) t) +(proclaim-function subtypep (type-specifier type-specifier &optional environment) + (values gen-bool gen-bool)) +(proclaim-function type-of (t) type-specifier) +(proclaim-function typep (t type-specifier &optional environment) gen-bool) + +; Slot accessors: +; (proclaim-function type-error-datum (condition) t) +; (proclaim-function type-error-expected-type (condition) t) + + +;;; +;;; 5. DATA AND CONTROL FLOW +;;; + +(proclaim-function apply (function-designator &rest t) (values &rest t)) +(proclaim-function funcall (function-designator &rest t) (values &rest t)) +(proclaim-function fdefinition (function-name) (or list function (member 'SPECIAL))) +(proclaim-function fboundp (function-name) gen-bool :no-side-effects) +(proclaim-function fmakunbound (function-name) function-name) +(proclaim-function function-lambda-expression (function) (values list gen-bool t)) +(proclaim-function functionp (t) gen-bool :pure) +(proclaim-function compiled-function-p (t) gen-bool :pure) +(proclaim-function not (t) boolean :pure) +(proclaim-function eq (t t) gen-bool :pure) +(proclaim-function eql (t t) gen-bool :pure) +(proclaim-function equal (t t) gen-bool :pure) +(proclaim-function equalp (t t) gen-bool :pure) +(proclaim-function identity (t) t :no-side-effects) +(proclaim-function complement (function) function) +(proclaim-function constantly (t) function) +(proclaim-function every (function sequence &rest sequence) gen-bool) +(proclaim-function some (function sequence &rest sequence) t) +(proclaim-function notevery (function sequence &rest sequence) gen-bool) +(proclaim-function notany (function sequence &rest sequence) gen-bool) +(proclaim-function values-list (list) (values &rest t)) +(proclaim-function get-setf-expansion (t &optional enviroment) + (values t t t t t)) + +;; ECL extensions + +(proclaim-function si:fset (function-name function &optional gen-bool t) function) +(proclaim-function si:clear-compiler-properties (function-name) t) +(proclaim-function si:compiled-function-name (function) function-name) +(proclaim-function si:compiled-function-block (function) si::codeblock) +(proclaim-function si:compiled-function-file (function) t) + +(proclaim-function si:ihs-top () si::index) +(proclaim-function si:ihs-fun (si::index) (or null function-designator)) +(proclaim-function si:ihs-env (si::index) t) +(proclaim-function si:frs-top () si::index) +(proclaim-function si:frs-bds (si::index) si::index) +(proclaim-function si:frs-tag (si::index) t) +(proclaim-function si:frs-ihs (si::index) si::index) +(proclaim-function si:bds-top () si::index) +(proclaim-function si:bds-var (si::index) symbol) +(proclaim-function si:bds-val (si::index) t) +(proclaim-function si:sch-frs-base (si::index si::index) (or null si::index)) + + +;;; +;;; 7. OBJECTS +;;; + +(proclaim-function ensure-generic-function (function-name &rest t) generic-function) +(proclaim-function slot-boundp (si::instance symbol) gen-bool) +(proclaim-function slot-exists-p (si::instance symbol) gen-bool) +(proclaim-function slot-makunbound (si::instance symbol) si::instance) +(proclaim-function slot-value (si::instance symbol) t) +(proclaim-function make-load-form-saving-slots (t &rest t) (values t t)) +(proclaim-function find-class (symbol &optional environment t) (or class null)) +(proclaim-function class-of (t) class :no-side-effects) + +;; Slot accessors: +; (proclaim-function unbound-slot-instance (condition) si::instance :predicate) + + +;;; +;;; 8. STRUCTURES +;;; + +(proclaim-function copy-structure (t) t) + +;; ECL extensions +(proclaim-function si:make-structure (t &rest t) structure-object) +(proclaim-function si:structure-name (structure-object) symbol :reader) +(proclaim-function si:structure-ref (structure-object t fixnum) t :reader) +(proclaim-function si:structure-set (structure-object t fixnum t) t) +(proclaim-function si:structurep (t) gen-bool :predicate) +(proclaim-function si:structure-subtype-p (t t) gen-bool :predicate) + + +;;; +;;; 9. CONDITIONS +;;; + +(proclaim-function error (t &rest t) (values)) +;; FIXME! It is not clear from the specification whether CERROR actually +;; returns values. However ECL is actually using the fact that it returns +;; the value from CONTINUE. +(proclaim-function cerror (format-control t &rest t) (values &rest t)) +(proclaim-function invalid-method-error (method format-control &rest t) (values)) +(proclaim-function method-combination-error (method format-control &rest t) (values)) +(proclaim-function signal (t &rest t) null) +(proclaim-function warn (t &rest t) null) +(proclaim-function invoke-debugger (condition) (values)) +(proclaim-function break (&optional format-control &rest t) null) +(proclaim-function make-condition (type-specifier &rest t) condition) +(proclaim-function compute-restarts (&optional condition) list) +(proclaim-function find-restart (restart-designator &optional condition) restart) +(proclaim-function invoke-restart (restart-designator &rest t) (values &rest t)) +(proclaim-function invoke-restart-interactively (restart-designator) (values &rest t)) +(proclaim-function abort (&optional condition) (values)) +(proclaim-function continue (&optional condition) null) +(proclaim-function muffle-warning (&optional condition) (values)) +(proclaim-function store-value (value &optional condition) null) +(proclaim-function use-value (value &optional condition) null) + +;; Slot accessors: +;; (proclaim-function cell-error-name (cell-error) t) +;; (proclaim-function simple-condition-format-control (simple-condition) t) +;; (proclaim-function simple-condition-format-arguments (simple-condition) t) +;; (proclaim-function restart-name (restart) t) + +;; ECL extensions +(proclaim-function ext:catch-signal (fixnum gen-bool) null) + + +;;; +;;; 10. SYMBOLS +;;; + +(proclaim-function symbolp (t) gen-bool :pure) +(proclaim-function keywordp (t) gen-bool :pure) +(proclaim-function make-symbol (string) symbol) +(proclaim-function copy-symbol (symbol &optional gen-bool) symbol) +(proclaim-function gensym (&optional (or string natural)) symbol) +(proclaim-function gentemp (&optional string package-designator) symbol) +(proclaim-function symbol-function (symbol) (or list (member 'special) function)) +(proclaim-function symbol-name (symbol) string :pure) +(proclaim-function symbol-package (symbol) (or package null) :reader) +(proclaim-function symbol-plist (symbol) list :reader) +(proclaim-function symbol-value (symbol) t :reader) +(proclaim-function get (symbol t &optional t) t :no-side-effects) +(proclaim-function remprop (symbol t) gen-bool) +(proclaim-function boundp (symbol) gen-bool :no-side-effects) +(proclaim-function makunbound (symbol) symbol) +(proclaim-function set (symbol t) symbol) + +;; ECL extensions: +(proclaim-function si:*make-special (symbol) symbol) +(proclaim-function si:*make-constant (symbol) symbol) +(proclaim-function si:put-f (list t t) list) +(proclaim-function si:rem-f (list t) boolean) +(proclaim-function si:set-symbol-plist (symbol t) t) +(proclaim-function si:putprop (symbol t t) t) +(proclaim-function si:put-sysprop (t t t) t) +(proclaim-function si:get-sysprop (t t t) t) +(proclaim-function si:rem-sysprop (t t) t) + + +;;; +;;; 11. PACKAGES +;;; + +(proclaim-function export (list &optional package) t) +(proclaim-function find-symbol (string &optional package-designator) + (values symbol symbol)) +(proclaim-function find-package (package-designator) (or package null)) +(proclaim-function find-all-symbols (string) list) +(proclaim-function import (list &optional package-designator) t) +(proclaim-function list-all-packages () list) +(proclaim-function rename-package (package-designator package-designator + &optional list) package) +(proclaim-function shadow (list &optional package-designator) t) +(proclaim-function shadowing-import (list &optional package-designator) t) +(proclaim-function delete-package (package-designator) gen-bool) +(proclaim-function make-package (string-designator &rest t) package) +(proclaim-function unexport (list &optional package-designator) t) +(proclaim-function unintern (symbol &optional package-designator) gen-bool) +(proclaim-function unuse-package (list &optional package-designator) t) +(proclaim-function use-package (list &optional package-designator) t) +(proclaim-function intern (string &optional package-designator) (values symbol symbol)) +(proclaim-function package-name (package-designator) (or string null) :reader) +(proclaim-function package-nicknames (package-designator) list :reader) +(proclaim-function package-shadowing-symbols (package-designator) list :reader) +(proclaim-function package-use-list (package-designator) list :reader) +(proclaim-function package-used-by-list (package-designator) list :reader) +(proclaim-function packagep (t) gen-bool :pure) + +;; Slot accessor: +;; (proclaim-function package-error-package (condition) package) + +;; ECL extensions +(proclaim-function si:select-package (package-designator) package) +(proclaim-function si:package-hash-tables (package-designator) + (values hash-table hash-table list) :reader) +(proclaim-function si:package-lock (package-designator gen-bool) package) + + +;;; +;;; 12. NUMBERS +;;; + +(proclaim-function = (number &rest number) gen-bool :pure) +(proclaim-function /= (number &rest number) gen-bool :pure) +(proclaim-function < (real &rest real) gen-bool :pure) +(proclaim-function > (real &rest real) gen-bool :pure) +(proclaim-function <= (real &rest real) gen-bool :pure) +(proclaim-function >= (real &rest real) gen-bool :pure) +(proclaim-function max (real &rest real) real :pure) +(proclaim-function min (real &rest real) real :pure) +(proclaim-function minusp (real) gen-bool :pure) +(proclaim-function plusp (real) gen-bool :pure) +(proclaim-function zerop (number) gen-bool :pure) +(proclaim-function floor (real &optional real) (values integer real) :pure) +(proclaim-function ceiling (real &optional real) (values integer real) :pure) +(proclaim-function truncate (real &optional real) (values integer real) :pure) +(proclaim-function round (real &optional real) (values integer real) :pure) +(proclaim-function ffloor (real &optional real) (values float real) :pure) +(proclaim-function fceiling (real &optional real) (values float real) :pure) +(proclaim-function ftruncate (real &optional real) (values float real) :pure) +(proclaim-function fround (real &optional real) (values float real) :pure) +(proclaim-function cos (number) number :pure) +(proclaim-function sin (number) number :pure) +(proclaim-function tan (number) number :pure) +(proclaim-function cosh (number) number :pure) +(proclaim-function sinh (number) number :pure) +(proclaim-function tanh (number) number :pure) +(proclaim-function acos (number) number :pure) +(proclaim-function asin (number) number :pure) +(proclaim-function atan (number &optional real) number :pure) +(proclaim-function acosh (number) number :pure) +(proclaim-function asinh (number) number :pure) +(proclaim-function atanh (number) number :pure) +(proclaim-function * (&rest number) number :pure) +(proclaim-function + (&rest number) number :pure) +(proclaim-function - (&rest number) number :pure) +(proclaim-function / (&rest number) number :pure) +(proclaim-function 1+ (number) number :pure) +(proclaim-function 1- (number) number :pure) +(proclaim-function abs (number) (real 0 *) :pure) +(proclaim-function evenp (integer) gen-bool :pure) +(proclaim-function oddp (integer) gen-bool :pure) +(proclaim-function exp (number) number :pure) +(proclaim-function expt (number number) number :pure) +(proclaim-function gcd (&rest integer) unsigned-byte :pure) +(proclaim-function lcm (&rest integer) unsigned-byte :pure) +(proclaim-function log (number &optional number) number :pure) +(proclaim-function mod (real real) real :pure) +(proclaim-function rem (real real) real :pure) +(proclaim-function signum (number) number :pure) +(proclaim-function sqrt (number) number :pure) +(proclaim-function isqrt (unsigned-byte) unsigned-byte :pure) +(proclaim-function make-random-state (&optional (or random-state (member nil t))) + random-state) +(proclaim-function random ((or (integer 0 *) (float 0 *)) + &optional random-state) + (or (integer 0 *) (float 0 *))) +(proclaim-function random-state-p (t) gen-bool :pure) +(proclaim-function numberp (t) gen-bool :pure) +(proclaim-function cis (real) complex :pure) +(proclaim-function complex (real &optional real) number :pure) +(proclaim-function complexp (t) gen-bool :pure) +(proclaim-function conjugate (number) number :pure) +(proclaim-function phase (number) number :pure) +(proclaim-function realpart (number) real :pure) +(proclaim-function imagpart (number) real :pure) +(proclaim-function upgraded-complex-part-type + (type-specifier &optional environment) + type-specifier) +(proclaim-function realp (t) gen-bool :pure) +(proclaim-function numerator (rational) integer :pure) +(proclaim-function denominator (rational) unsigned-byte :pure) +(proclaim-function rational (real) rational :pure) +(proclaim-function rationalize (real) rational :pure) +(proclaim-function rationalp (t) gen-bool :pure) +(proclaim-function ash (integer integer) integer :pure) +(proclaim-function integer-length (integer) unsigned-byte :pure) +(proclaim-function integerp (t) gen-bool :pure) +(proclaim-function parse-integer (string &rest t) (values integer si::index)) +(proclaim-function boole ((integer 0 15) integer integer) integer :pure) +(proclaim-function logand (&rest integer) integer :pure) +(proclaim-function logandc1 (integer integer) integer :pure) +(proclaim-function logandc2 (integer integer) integer :pure) +(proclaim-function logeqv (&rest integer) integer :pure) +(proclaim-function logior (&rest integer) integer :pure) +(proclaim-function lognand (integer integer) integer :pure) +(proclaim-function lognor (integer integer) integer :pure) +(proclaim-function lognot (integer) integer :pure) +(proclaim-function logorc1 (integer integer) integer :pure) +(proclaim-function logorc2 (integer integer) integer :pure) +(proclaim-function logxor (&rest integer) integer :pure) +(proclaim-function logbitp (unsigned-byte integer) gen-bool :pure) +(proclaim-function logcount (integer) unsigned-byte :pure) +(proclaim-function logtest (integer integer) gen-bool :pure) +(proclaim-function byte (unsigned-byte unsigned-byte) byte-specifier :pure) +(proclaim-function byte-size (byte-specifier) unsigned-byte :pure) +(proclaim-function byte-position (byte-specifier) unsigned-byte :pure) +(proclaim-function deposit-field (integer byte-specifier integer) integer :pure) +(proclaim-function dpb (integer byte-specifier integer) integer :pure) +(proclaim-function ldb (byte-specifier integer) unsigned-byte :pure) +(proclaim-function ldb-test (byte-specifier integer) gen-bool :pure) +(proclaim-function mask-field (byte-specifier integer) unsigned-byte :pure) +(proclaim-function decode-float (float) (values float integer float) :pure) +(proclaim-function scale-float (float integer) float :pure) +(proclaim-function float-radix (float) fixnum :pure) +(proclaim-function float-sign (float &optional float) float :pure) +(proclaim-function float-digits (float) fixnum :pure) +(proclaim-function float-precision (float) fixnum :pure) +(proclaim-function integer-decode-float (float) + (values float integer (member -1 1)) + :pure) +(proclaim-function float (number &optional float) float :pure) +(proclaim-function floatp (t) gen-bool :pure) + +;; Slot accessors: +;; (proclaim-function arithmetic-error-operands (condition) t) +;; (proclaim-function arithmetic-error-operation (condition) t) + +;; ECL extensions +(proclaim-function si:bit-array-op (t t t t) t) + + +;;; +;;; 13. CHARACTERS +;;; + +(proclaim-function char= (character &rest character) gen-bool :pure) +(proclaim-function char/= (character &rest character) gen-bool :pure) +(proclaim-function char< (character &rest character) gen-bool :pure) +(proclaim-function char> (character &rest character) gen-bool :pure) +(proclaim-function char<= (character &rest character) gen-bool :pure) +(proclaim-function char>= (character &rest character) gen-bool :pure) +(proclaim-function char-equal (character &rest character) gen-bool :pure) +(proclaim-function char-not-equal (character &rest character) gen-bool :pure) +(proclaim-function char-lessp (character &rest character) gen-bool :pure) +(proclaim-function char-greaterp (character &rest character) gen-bool :pure) +(proclaim-function char-not-greaterp (character &rest character) gen-bool :pure) +(proclaim-function char-not-lessp (character &rest character) gen-bool :pure) +(proclaim-function character (character-designator) character) +(proclaim-function characterp (t) gen-bool :pure) +(proclaim-function alpha-char-p (character) gen-bool :pure) +(proclaim-function alphanumericp (character) gen-bool :pure) +(proclaim-function digit-char (digit-weight &optional radix) character :pure) +(proclaim-function digit-char-p (character &optional radix) + (or digit-weight null) + :pure) +(proclaim-function graphic-char-p (character) gen-bool :pure) +(proclaim-function standard-char-p (character) gen-bool :pure) +(proclaim-function char-upcase (character) character :pure) +(proclaim-function char-downcase (character) character :pure) +(proclaim-function upper-case-p (character) gen-bool :pure) +(proclaim-function lower-case-p (character) gen-bool :pure) +(proclaim-function both-case-p (character) gen-bool :pure) +(proclaim-function char-code (character) character-code :pure) +(proclaim-function char-int (character) character-code :pure) +(proclaim-function code-char (character-code) (or character null) :pure) +(proclaim-function char-name (character) (or string null) :pure) +(proclaim-function name-char (string-designator) (or character null) :pure) + +;; ECL extensions +(proclaim-function si:base-char-p (t) gen-bool :predicate) + + +;;; +;;; 14. CONSES +;;; + +(proclaim-function cons (t t) cons :no-side-effects) +(proclaim-function consp (t) gen-bool :pure) +(proclaim-function atom (t) gen-bool :pure) +(proclaim-function rplaca (cons t) cons) +(proclaim-function rplacd (cons t) cons) +(proclaim-function car (list) t :reader) +(proclaim-function cdr (list) t :reader) +(proclaim-function caar (list) t :reader) +(proclaim-function cadr (list) t :reader) +(proclaim-function cdar (list) t :reader) +(proclaim-function cddr (list) t :reader) +(proclaim-function caaar (list) t :reader) +(proclaim-function caadr (list) t :reader) +(proclaim-function cadar (list) t :reader) +(proclaim-function caddr (list) t :reader) +(proclaim-function cdaar (list) t :reader) +(proclaim-function cdadr (list) t :reader) +(proclaim-function cddar (list) t :reader) +(proclaim-function cdddr (list) t :reader) +(proclaim-function caaaar (list) t :reader) +(proclaim-function caaadr (list) t :reader) +(proclaim-function caadar (list) t :reader) +(proclaim-function caaddr (list) t :reader) +(proclaim-function cadaar (list) t :reader) +(proclaim-function cadadr (list) t :reader) +(proclaim-function caddar (list) t :reader) +(proclaim-function cadddr (list) t :reader) +(proclaim-function cdaaar (list) t :reader) +(proclaim-function cdaadr (list) t :reader) +(proclaim-function cdadar (list) t :reader) +(proclaim-function cdaddr (list) t :reader) +(proclaim-function cddaar (list) t :reader) +(proclaim-function cddadr (list) t :reader) +(proclaim-function cdddar (list) t :reader) +(proclaim-function cddddr (list) t :reader) +(proclaim-function copy-tree (tree) tree :no-side-effects) +(proclaim-function sublis (association-list tree &key) tree :no-side-effects) +(proclaim-function nsublis (association-list tree &key) tree) +(proclaim-function subst (t t tree &key) tree :no-side-effects) +(proclaim-function subst-if (t function-designator tree &key) tree) +(proclaim-function subst-if-not (t function-designator tree &key) tree) +(proclaim-function nsubst (t t tree &key) tree) +(proclaim-function nsubst-if (t function-designator tree &key) tree) +(proclaim-function nsubst-if-not (t function-designator tree &key) tree) +(proclaim-function tree-equal (tree tree &key) gen-bool :predicate) +(proclaim-function copy-list (list) list :no-side-effects) +(proclaim-function list (&rest t) list :no-side-effects) +(proclaim-function list* (&rest t) t :no-side-effects) +(proclaim-function list-length (list) (or null si::index) :no-side-effects) +(proclaim-function listp (t) gen-bool :pure) +(proclaim-function make-list (si::index &key) list) +(proclaim-function first (list) t :reader) +(proclaim-function second (list) t :reader) +(proclaim-function third (list) t :reader) +(proclaim-function fourth (list) t :reader) +(proclaim-function fifth (list) t :reader) +(proclaim-function sixth (list) t :reader) +(proclaim-function seventh (list) t :reader) +(proclaim-function eighth (list) t :reader) +(proclaim-function ninth (list) t :reader) +(proclaim-function tenth (list) t :reader) +(proclaim-function nth (unsigned-byte list) t :reader) +(proclaim-function endp (list) gen-bool :predicate) +(proclaim-function null (t) gen-bool :predicate) +(proclaim-function nconc (*) t) +(proclaim-function append (*) t :no-side-effects) +(proclaim-function revappend (list t) t :no-side-effects) +(proclaim-function nreconc (list t) t) +(proclaim-function butlast (list &optional unsigned-byte) list :no-side-effects) +(proclaim-function nbutlast (list &optional unsigned-byte) list :no-side-effects) +(proclaim-function last (list &optional unsigned-byte) list :reader) +(proclaim-function ldiff (list t) list :no-side-effects) +(proclaim-function tailp (t list) gen-bool :reader) +(proclaim-function nthcdr (fixnum list) t :no-side-effects) +(proclaim-function rest (list) t :no-side-effects) +(proclaim-function member (t list &key) list :no-side-effects) +(proclaim-function member-if (function-designator list &key) list) +(proclaim-function member-if-not (function-designator list &key) list) +(proclaim-function mapc (function-designator list &rest list) list) +(proclaim-function mapcar (function-designator list &rest list) list) +(proclaim-function mapcan (function-designator list &rest list) list) +(proclaim-function mapl (function-designator list &rest list) list) +(proclaim-function maplist (function-designator list &rest list) list) +(proclaim-function mapcon (function-designator list &rest list) list) +(proclaim-function acons (t t association-list) association-list :no-side-effects) +(proclaim-function assoc (t association-list &key) t :no-side-effects) +(proclaim-function assoc-if (function-designator association-list &key) t) +(proclaim-function assoc-if-not (function-designator association-list &key) t) +(proclaim-function copy-alist (association-list) association-list :no-side-effects) +(proclaim-function pairlis (list list &optional association-list) + association-list :no-side-effects) +(proclaim-function rassoc (t association-list &key) t :no-side-effects) +(proclaim-function rassoc-if (function-designator association-list &key) t) +(proclaim-function rassoc-if-not (function-designator association-list &key) t) +(proclaim-function get-properties (list list) (values t t list) :no-side-effects) +(proclaim-function getf (list t &optional t) t :no-side-effects) +(proclaim-function intersection (list list &key) list :no-side-effects) +(proclaim-function nintersection (list list &key) list) +(proclaim-function adjoin (t list &key) list :no-side-effects) +(proclaim-function set-difference (list list &key) list :no-side-effects) +(proclaim-function nset-difference (list list &key) list) +(proclaim-function set-exclusive-or (list list &key) list :no-side-effects) +(proclaim-function nset-exclusive-or (list list &key) list) +(proclaim-function subsetp (list list &key) gen-bool :predicate) +(proclaim-function union (list list &key) list :no-side-effects) +(proclaim-function nunion (list list &key) list) + +;; ECL extensions +(proclaim-function member1 (t list t t t) t) +(proclaim-function si:memq (t list) t) + + +;;; +;;; 15. ARRAYS +;;; + +(proclaim-function make-array ((or si::index list) &key) array) +(proclaim-function adjust-array (array (or si::index list) &key) array) +(proclaim-function adjustable-array-p (array) gen-bool :pure) +(proclaim-function aref (array &rest si::index) t :reader) +(proclaim-function array-dimension (array (integer 0 #.(1- array-rank-limit))) + si::index :reader) +(proclaim-function array-dimensions (array) list :reader) +(proclaim-function array-element-type (array) type-specifier :pure) +(proclaim-function array-has-fill-pointer-p (array) gen-bool :pure) +(proclaim-function array-displacement (array) (values (or array null) si::index) + :reader) +(proclaim-function array-in-bounds-p (array &rest si::index) gen-bool + :no-side-effects) +(proclaim-function array-rank (array) (integer 0 #.(1- array-rank-limit)) + :reader) +(proclaim-function array-row-major-index (array &rest si::index) si::index + :no-side-effects) +(proclaim-function array-total-size (array) si::index :reader) +(proclaim-function arrayp (t) gen-bool :pure) +(proclaim-function fill-pointer (vector) si::index :reader) +(proclaim-function row-major-aref (array si::index) t :reader) +(proclaim-function upgraded-array-element-type + (type-specifier &optional environment) + type-specifier :no-side-effects) +(proclaim-function simple-vector-p (t) gen-bool :pure) +(proclaim-function svref (simple-vector si::index) t :reader) +(proclaim-function vector (&rest t) vector :no-side-effects) +(proclaim-function vector-pop (vector) t) +(proclaim-function vector-push (t vector) (or si::index null)) +(proclaim-function vector-push-extend (t vector &optional si::index) si::index) +(proclaim-function vectorp (t) gen-bool :pure) +(proclaim-function bit ((array bit) &rest si::index) bit :reader) +(proclaim-function sbit ((simple-array bit) &rest si::index) + bit :reader) +(proclaim-function bit-and (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-andc1 (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-andc2 (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-eqv (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-ior (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-nand (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-nor (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-orc1 (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-orc2 (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-xor (bit-array bit-array &optional + (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-not (bit-array &optional (or bit-array (member t nil))) + bit-array) +(proclaim-function bit-vector-p (t) gen-bool :pure) +(proclaim-function simple-bit-vector-p (t) t :pure) + +;; ECL extensions +(proclaim-function si:make-pure-array (*) array) +(proclaim-function si:make-vector (*) vector) +(proclaim-function si:aset (t array &rest si::index) t) +(proclaim-function si:row-major-aset (array si::index t) t) +(proclaim-function si:svset (simple-vector si::index t) t) +(proclaim-function si:fill-pointer-set (vector si::index) si::index) +(proclaim-function si:replace-array (array array) array) + + +;;; +;;; 16. STRINGS +;;; + +(proclaim-function simple-string-p (t) gen-bool :pure) +(proclaim-function char (string si::index) character :reader) +(proclaim-function schar (simple-string si::index) character :reader) +(proclaim-function string (string-designator) string :no-side-effects) +(proclaim-function string-upcase (string-designator &key) + string :no-side-effects) +(proclaim-function string-downcase (string-designator &key) + string :no-side-effects) +(proclaim-function string-capitalize (string-designator &key) + string :no-side-effects) +(proclaim-function nstring-upcase (string &key) string) +(proclaim-function nstring-downcase (string &key) string) +(proclaim-function nstring-capitalize (string &key) string) +(proclaim-function string-trim (sequence string-designator) + string :no-side-effects) +(proclaim-function string-left-trim (sequence string-designator) + string :no-side-effects) +(proclaim-function string-right-trim (sequence string-designator) + string :no-side-effects) +(proclaim-function string= (string-designator string-designator &key) + gen-bool :no-side-effects) +(proclaim-function string/= (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string< (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string> (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string<= (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string>= (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string-equal (string-designator string-designator &key) + gen-bool :no-side-effects) +(proclaim-function string-not-equal (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string-lessp (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string-greaterp (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string-not-lessp (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function string-not-greaterp (string-designator string-designator &key) + (or si::index null) :no-side-effects) +(proclaim-function stringp (t) gen-bool :predicate) +(proclaim-function make-string (si::index &key) string :no-side-effects) + +;; ECL extensions: +(proclaim-function si:base-string-p (t) gen-bool :predicate) +(proclaim-function si:char-set (string si::index character) character) +(proclaim-function si:schar-set (string si::index character) character) +(proclaim-function si:base-string-concatenate (base-string) base-string) + + +;;; +;;; 17. SEQUENCES +;;; + +(proclaim-function copy-seq (sequence) sequence :no-side-effects) +(proclaim-function elt (sequence si::index) t :no-side-effects) +(proclaim-function fill (sequence t &key) sequence) +(proclaim-function make-sequence (type-specifier si::index &key) sequence) +(proclaim-function subseq (sequence si::index &optional (or si::index null)) + sequence) +(proclaim-function map (type-specifier function-designator sequence &rest sequence) + sequence) +(proclaim-function map-into (sequence function-designator sequence &rest sequence) + sequence) +(proclaim-function reduce (function-designator sequence &key) t) +(proclaim-function count (t sequence &key) si::index :no-side-effects) +(proclaim-function count-if (function-designator sequence &key) si::index) +(proclaim-function count-if-not (function-designator sequence &key) si::index) +(proclaim-function length (sequence) si::index :no-side-effects) +(proclaim-function reverse (sequence) sequence :no-side-effects) +(proclaim-function nreverse (sequence) sequence) +(proclaim-function sort (sequence function-designator &key) sequence) +(proclaim-function stable-sort (sequence function-designator &key) sequence) +(proclaim-function find (t sequence &key) t :no-side-effects) +(proclaim-function find-if (function-designator sequence &key) t) +(proclaim-function find-if-not (function-designator sequence &key) t) +(proclaim-function position (t sequence &key) (or null si::index) :no-side-effects) +(proclaim-function position-if (function-designator sequence &key) + (or null si::index)) +(proclaim-function position-if-not (function-designator sequence &key) + (or null si::index)) +(proclaim-function search (sequence sequence &key) + (or null si::index) :no-side-effects) +(proclaim-function mismatch (sequence sequence &key) + (or null si::index) :no-side-effects) +(proclaim-function replace (sequence sequence &key) sequence) +(proclaim-function substitute (t t sequence &key) sequence :no-side-effects) +(proclaim-function substitute-if (t function-designator sequence &key) sequence) +(proclaim-function substitute-if-not (t function-designator sequence &key) sequence) +(proclaim-function nsubstitute (t t sequence &key) sequence) +(proclaim-function nsubstitute-if (t function-designator sequence &key) sequence) +(proclaim-function nsubstitute-if-not (t function-designator sequence &key) sequence) +(proclaim-function concatenate (type-specifier &rest sequence) sequence + :no-side-effects) +(proclaim-function merge (type-specifier sequence sequence function-designator &key) + sequence) +(proclaim-function remove (t sequence &key) sequence :no-side-effects) +(proclaim-function remove-if (function-designator sequence &key) sequence) +(proclaim-function remove-if-not (function-designator sequence &key) sequence) +(proclaim-function delete (t sequence &key) sequence) +(proclaim-function delete-if (function-designator sequence &key) sequence) +(proclaim-function delete-if-not (function-designator sequence &key) sequence) +(proclaim-function remove-duplicates (sequence &key) sequence :no-side-effects) +(proclaim-function delete-duplicates (sequence &key) sequence) + +;; ECL extensions: +(proclaim-function si:elt-set (sequence si::index t) t) +(proclaim-function si::make-seq-iterator (t *) t :no-side-effects) +(proclaim-function si::seq-iterator-ref (t t) t :reader) +(proclaim-function si::seq-iterator-set (t t t) t :no-sp-change) +(proclaim-function si::seq-iterator-next (t t) t :reader) + + +;;; +;;; 18. HASH TABLES +;;; + +(proclaim-function make-hash-table (&key) hash-table :no-side-effects) +(proclaim-function hash-table-p (t) gen-bool :pure) +(proclaim-function hash-table-count (hash-table) si::index :reader) +(proclaim-function hash-table-rehash-size (hash-table) + (or (integer 1 *) (float (1.0) *)) + :reader) +(proclaim-function hash-table-rehash-threshold (hash-table) + (float (1.0) *) + :reader) +(proclaim-function hash-table-size (hash-table) si::index :reader) +(proclaim-function hash-table-test (hash-table) function-designator :reader) +(proclaim-function gethash (t hash-table &key) (values t gen-bool) :reader) +(proclaim-function remhash (t hash-table) gen-bool) +(proclaim-function maphash (function-designator hash-table) null) +(proclaim-function clrhash (hash-table) hash-table) +(proclaim-function sxhash (t) (integer 0 #.most-positive-fixnum) :no-side-effects) + +;; ECL extensions +(proclaim-function si:hash-set (t hash-table t) t) + + +;;; +;;; 19. FILENAMES +;;; + +(proclaim-function pathname (pathname-designator) pathname) +(proclaim-function make-pathname (&key) pathname) +(proclaim-function pathnamep (t) gen-bool :pure) +(proclaim-function pathname-host (pathname) pathname-host :reader) +(proclaim-function pathname-device (pathname) pathname-device :reader) +(proclaim-function pathname-directory (pathname) pathname-directory :reader) +(proclaim-function pathname-name (pathname) pathname-name :reader) +(proclaim-function pathname-type (pathname) pathname-type :reader) +(proclaim-function pathname-version (pathname) pathname-version :reader) +(proclaim-function load-logical-pathname-translations (string) gen-bool) +(proclaim-function logical-pathname-translations (string) list) +(proclaim-function logical-pathname (pathname-designator) logical-pathname) +(proclaim-function namestring (pathname-designator) (or string null)) +(proclaim-function file-namestring (pathname-designator) (or string null)) +(proclaim-function directory-namestring (pathname-designator) (or string null)) +(proclaim-function host-namestring (pathname-designator) (or string null)) +(proclaim-function enough-namestring (pathname-designator + &optional pathname-designator) + (or string null)) +(proclaim-function parse-namestring (pathname-designator + &optional pathname-host + pathname-designator &key) + (values (or pathname null) (or si::index null))) +(proclaim-function wild-pathname-p (pathname-designator + &optional (member :host :device :directory :name + :type :version nil)) + gen-bool) +(proclaim-function pathname-match-p (pathname-designator pathname-designator) + gen-bool) +(proclaim-function translate-logical-pathname (pathname-designator &key) pathname) +(proclaim-function translate-pathname (pathname-designator pathname-designator + pathname-designator &key) + pathname) +(proclaim-function merge-pathnames (pathname-designator + &optional pathname-designator + pathname-version) + pathname) + +;;; +;;; 20. FILES +;;; + +(proclaim-function directory (pathname-designator &key) list) +(proclaim-function probe-file (pathname-designator) (or pathname null)) +(proclaim-function ensure-directories-exist (pathname &key) + (values pathname gen-bool)) +(proclaim-function truename (pathname-designator) pathname) +(proclaim-function file-author (pathname-designator) (or string null)) +(proclaim-function file-write-date (pathname-designator) (or unsigned-byte null)) +(proclaim-function rename-file (pathname-designator pathname-designator) + (values pathname pathname pathname)) +(proclaim-function delete-file (pathname-designator) t) + +;; Slot accessors: +;; (proclaim-function file-error-pathname (condition) pathname-designator) + +;; ECL extensions +(proclaim-function ext:file-kind (pathname-designator gen-bool) symbol) +(proclaim-function ext:chdir (pathname-designator &optional gen-bool) pathname) +(proclaim-function ext:getcwd (&optional gen-bool) pathname) +(proclaim-function ext:mkdir (pathname-designator fixnum) string) +(proclaim-function ext:mkstemp (pathname-designator) (or null pathname)) +(proclaim-function ext:rmdir (pathname-designator) null) +(proclaim-function ext:copy-file (pathname-designator pathname-designator) gen-bool) + + +;;; +;;; 21. STREAMS +;;; + +(proclaim-function input-stream-p (stream) gen-bool :reader) +(proclaim-function output-stream-p (stream) gen-bool :reader) +(proclaim-function interactive-stream-p (stream) gen-bool :reader) +(proclaim-function open-stream-p (stream) gen-bool :reader) +(proclaim-function stream-element-type (stream) type-specifier :reader) +(proclaim-function streamp (t) gen-bool :pure) +(proclaim-function read-byte (stream &optional gen-bool t) t) +(proclaim-function write-byte (integer stream) integer) +(proclaim-function peek-char (&optional (or character boolean) + stream-designator + gen-bool + t + gen-bool) + t) +(proclaim-function read-char (&optional stream-designator gen-bool t gen-bool) t) +(proclaim-function read-char-no-hang (&optional stream-designator gen-bool t gen-bool) t) +(proclaim-function terpri (&optional stream-designator) null) +(proclaim-function fresh-line (&optional stream-designator) gen-bool) +(proclaim-function unread-char (character &optional stream-designator) null) +(proclaim-function write-char (character &optional stream-designator) character) +(proclaim-function read-line (&optional stream-designator gen-bool t gen-bool) + (values t gen-bool)) +(proclaim-function write-string (string &optional stream-designator &key) string) +(proclaim-function write-line (string &optional stream-designator &key) string) +(proclaim-function read-sequence (sequence stream &key) si::index) +(proclaim-function write-sequence (sequence stream &key) sequence) +(proclaim-function file-length (stream) unsigned-byte) +(proclaim-function file-position (stream file-position-designator) gen-bool) +(proclaim-function file-string-length (stream (or string character)) + (or unsigned-byte null)) +(proclaim-function open (pathname-designator &key) (or stream null)) +(proclaim-function stream-external-format (stream) external-file-format :reader) +(proclaim-function close (stream &key) t) +(proclaim-function listen (&optional stream-designator) gen-bool) +(proclaim-function clear-input (&optional stream-designator) null) +(proclaim-function finish-output (&optional stream-designator) null) +(proclaim-function force-output (&optional stream-designator) null) +(proclaim-function clear-output (&optional stream-designator) null) +(proclaim-function y-or-n-p (&optional format-control &rest t) gen-bool) +(proclaim-function yes-or-no-p (&optional format-control &rest t) gen-bool) +(proclaim-function make-synonym-stream (symbol) synonym-stream) +(proclaim-function synonym-stream-symbol (synonym-stream) symbol :reader) +(proclaim-function broadcast-stream-streams (broadcast-stream) list :reader) +(proclaim-function make-broadcast-stream (&rest stream) broadcast-stream) +(proclaim-function make-two-way-stream (stream stream) two-way-stream) +(proclaim-function two-way-stream-input-stream (two-way-stream) + stream :reader) +(proclaim-function two-way-stream-output-stream (two-way-stream) + stream :reader) +(proclaim-function echo-stream-output-stream (echo-stream) stream :reader) +(proclaim-function echo-stream-input-stream (echo-stream) stream :reader) +(proclaim-function make-echo-stream (stream stream) echo-stream) +(proclaim-function concatenated-stream-streams (concatenated-stream) + list :reader) +(proclaim-function make-concatenated-stream (&rest stream) concatenated-stream) +(proclaim-function get-output-stream-string (string-stream) + string :reader) +(proclaim-function make-string-input-stream (string &optional + (or si::index null) + (or si::index null)) + string-stream) +(proclaim-function make-string-output-stream (&key) string-stream) + +;; Slot accessors: +;; (proclaim-function stream-error-stream (condition) stream) + +;; ECL extensions: +(proclaim-function si:make-string-output-stream-from-string (string) string-stream) +(proclaim-function si:open-client-stream (t unsigned-byte) stream) +(proclaim-function si:open-server-stream (unsigned-byte) stream) +(proclaim-function si:open-unix-socket-stream (base-string) stream) +(proclaim-function si:lookup-host-entry (t) (values (or null string) list list)) + + +;;; +;;; 22. PRINT +;;; + +(proclaim-function copy-pprint-dispatch (&optional (or si::pprint-dispatch-table null)) + si::pprint-dispatch-table) +(proclaim-function pprint-dispatch (t &optional (or si::pprint-dispatch-table null)) + (values function-designator gen-bool)) +(proclaim-function pprint-fill (stream-designator t &optional gen-bool gen-bool) + null) +(proclaim-function pprint-linear (stream-designator t &optional gen-bool gen-bool) + null) +(proclaim-function pprint-tabular (stream-designator t &optional gen-bool gen-bool + unsigned-byte) + null) +(proclaim-function pprint-indent ((member :block :current) real + &optional stream-designator) + null) +(proclaim-function pprint-newline ((member :linear :fill :miser :mandatory) + &optional stream-designator) + null) +(proclaim-function pprint-tab ((member :line :section :line-relative :section-relative) + unsigned-byte unsigned-byte &optional stream-designator) + null) +(proclaim-function set-pprint-dispatch (type-specifier function-designator + &optional real si::pprint-dispatch-table) + null) +(proclaim-function write (t &key) t) +(proclaim-function prin1 (t &optional stream-designator) t) +(proclaim-function princ (t &optional stream-designator) t) +(proclaim-function print (t &optional stream-designator) t) +(proclaim-function pprint (t &optional stream-designator) (values)) +(proclaim-function write-to-string (t &key) string) +(proclaim-function prin1-to-string (t) string) +(proclaim-function princ-to-string (t) string) +(proclaim-function format ((or stream-designator t) format-control &rest t) + (or null string)) + +;; Slot accessor: +;; (proclaim-function print-not-readable-object (condition) t) + + +;;; +;;; 23. READER +;;; + +(proclaim-function copy-readtable (&optional readtable-designator (or readtable null)) + readtable) +(proclaim-function make-dispatch-macro-character + (character &optional gen-bool readtable) + (member t)) +(proclaim-function read (&optional stream-designator gen-bool t gen-bool) t) +(proclaim-function read-preserving-whitespace + (&optional stream-designator gen-bool t gen-bool) t) +(proclaim-function read-delimited-list (character &optional stream-designator gen-bool) + list) +(proclaim-function read-from-string (string &optional gen-bool t &key) + (values t si::index)) +(proclaim-function readtable-case (readtable) + (member :upcase :downcase :preserve :invert) + :reader) +(proclaim-function readtablep (t) gen-bool :pure) +(proclaim-function get-dispatch-macro-character + (character character &optional readtable-designator) + (or function-designator null) + :reader) +(proclaim-function set-dispatch-macro-character + (character character function-designator + &optional readtable-designator) + (member t)) +(proclaim-function get-macro-character + (character &optional readtable-designator) + (values (or function-designator null) gen-bool) + :reader) +(proclaim-function set-macro-character + (character function-designator + &optional gen-bool readtable-designator) + (member t)) +(proclaim-function set-syntax-from-char + (character character &optional readtable readtable-designator) + (member t)) + +;; ECL extensions: +(proclaim-function si:string-to-object (string) t) +(proclaim-function si:standard-readtable (t) readtable) + + +;;; +;;; 24. SYSTEM CONSTRUCTION +;;; + +(proclaim-function compile-file (pathname-designator &key) + (values (or pathname null) gen-bool gen-bool)) +(proclaim-function compile-file-pathname (pathname-designator &key) + pathname) +(proclaim-function load ((or stream pathname-designator) &key) gen-bool) +(proclaim-function provide (string-designator) t) +(proclaim-function require (string-designatior &optional list) t) + + +;;; +;;; 25. ENVIRONMENT +;;; + +(proclaim-function decode-universal-time (universal-time &optional time-zone) + (values (integer 0 59) + (integer 0 59) + (integer 0 23) + (integer 1 31) + (integer 1 12) + unsigned-byte + (integer 0 6) + gen-bool + time-zone) + :pure) +(proclaim-function encode-universal-time ((integer 0 59) + (integer 0 59) + (integer 0 23) + (integer 1 31) + (integer 1 12) + unsigned-byte + &optional time-zone) + universal-time + :pure) +(proclaim-function get-universal-time () universal-time) +(proclaim-function get-decoded-time () + (values (integer 0 59) + (integer 0 59) + (integer 0 23) + (integer 1 31) + (integer 1 12) + unsigned-byte + (integer 0 6) + gen-bool + time-zone)) +(proclaim-function sleep ((real 0 *)) null) +(proclaim-function apropos (string-designator &optional (or null package-designator)) + (values)) +(proclaim-function apropos-list + (string-designator &optional (or null package-designator)) + list) +(proclaim-function describe (t &optional stream-designator) (values)) +(proclaim-function get-internal-real-time () unsigned-byte) +(proclaim-function get-internal-run-time () unsigned-byte) +(proclaim-function disassemble ((or function-designator list)) null) +(proclaim-function room (&optional (member t nil :default)) (values &rest t)) +(proclaim-function ed (&optional (or null pathname string function-name)) + (values &rest t)) +(proclaim-function inspect (t) (values &rest t)) +(proclaim-function dribble (&optional pathname-designator) (values &rest t)) +(proclaim-function lisp-implementation-type () (or string null)) +(proclaim-function lisp-implementation-version () (or string null)) +(proclaim-function short-site-name () (or string null)) +(proclaim-function long-site-name () (or string null)) +(proclaim-function machine-instance () (or string null)) +(proclaim-function machine-type () (or string null)) +(proclaim-function machine-version () (or string null)) +(proclaim-function software-type () (or string null)) +(proclaim-function software-version () (or string null)) +(proclaim-function user-homedir-pathname (&optional pathname-host) + (or pathname null)) + +;; ECL extensions + +(proclaim-function si::room-report () (values t t t t t t t t)) +(proclaim-function si::reset-gbc-count () t) +(proclaim-function ext:gc (&optional gen-bool) t) +(proclaim-function ext:quit (&optional fixnum) t) +(proclaim-function ext:argc () si::index) +(proclaim-function ext:argv () list) +(proclaim-function ext:getenv (string) (or null string)) +(proclaim-function ext:system (string) fixnum) +(proclaim-function ext:getpid () fixnum) +(proclaim-function ext:make-pipe () (or two-way-stream null)) +(proclaim-function ext:run-program (string list &key) + (values (or null two-way-stream) + (or null integer))) + +;;; +;;; A. FFI +;;; + +(proclaim-function si:pointer (t) unsigned-byte) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; INLINE EXPANSIONS +;;; + +(def-inline aref :unsafe (t t t) t + "@0;ecl_aref_unsafe(#0,fix(#1)*(#0)->array.dims[1]+fix(#2))") +(def-inline aref :unsafe ((array t) t t) t + "@0;(#0)->array.self.t[fix(#1)*(#0)->array.dims[1]+fix(#2)]") +(def-inline aref :unsafe ((array bit) t t) :fixnum + "@0;ecl_aref_bv(#0,fix(#1)*(#0)->array.dims[1]+fix(#2))") +(def-inline aref :unsafe ((array t) fixnum fixnum) t + "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]") +(def-inline aref :unsafe ((array bit) fixnum fixnum) :fixnum + "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)") +(def-inline aref :unsafe ((array base-char) fixnum fixnum) :char + "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]") +(def-inline aref :unsafe ((array double-float) fixnum fixnum) :double + "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]") +(def-inline aref :unsafe ((array single-float) fixnum fixnum) :float + "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]") +(def-inline aref :unsafe ((array fixnum) fixnum fixnum) :fixnum + "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]") + +(def-inline aref :always (t t) t "ecl_aref1(#0,fixint(#1))") +(def-inline aref :always (t fixnum) t "ecl_aref1(#0,#1)") +(def-inline aref :unsafe (t t) t "ecl_aref1(#0,fix(#1))") +(def-inline aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))") +(def-inline aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") +#+unicode +(def-inline aref :unsafe ((array character) fixnum) :wchar + "(#0)->string.self[#1]") +(def-inline aref :unsafe ((array base-char) fixnum) :char + "(#0)->base_string.self[#1]") +(def-inline aref :unsafe ((array double-float) fixnum) :double + "(#0)->array.self.df[#1]") +(def-inline aref :unsafe ((array single-float) fixnum) :float + "(#0)->array.self.sf[#1]") +(def-inline aref :unsafe ((array fixnum) fixnum) :fixnum + "(#0)->array.self.fix[#1]") + +(def-inline si:aset :unsafe (t t t t) t + "@0;ecl_aset_unsafe(#1,fix(#2)*(#1)->array.dims[1]+fix(#3),#0)") +(def-inline si:aset :unsafe (t t fixnum fixnum) t + "@0;ecl_aset_unsafe(#1,(#2)*(#1)->array.dims[1]+(#3),#0)") +(def-inline si:aset :unsafe (t (array t) fixnum fixnum) t + "@1;(#1)->array.self.t[#2*(#1)->array.dims[1]+#3]= #0") +(def-inline si:aset :unsafe (t (array bit) fixnum fixnum) :fixnum + "@0;ecl_aset_bv(#1,(#2)*(#1)->array.dims[1]+(#3),fix(#0))") +(def-inline si:aset :unsafe (base-char (array base-char) fixnum fixnum) :char + "@1;(#1)->base_string.self[#2*(#1)->array.dims[1]+#3]= #0") +#+unicode +(def-inline si:aset :unsafe (character (array character) fixnum fixnum) :wchar + "@1;(#1)->string.self[#2*(#1)->array.dims[1]+#3]= #0") +(def-inline si:aset :unsafe (double-float (array double-float) fixnum fixnum) + :double "@1;(#1)->array.self.df[#2*(#1)->array.dims[1]+#3]= #0") +(def-inline si:aset :unsafe (single-float (array single-float) fixnum fixnum) + :float "@1;(#1)->array.self.sf[#2*(#1)->array.dims[1]+#3]= #0") +(def-inline si:aset :unsafe (fixnum (array fixnum) fixnum fixnum) :fixnum + "@1;(#1)->array.self.fix[#2*(#1)->array.dims[1]+#3]= #0") +(def-inline si:aset :unsafe (fixnum (array bit) fixnum fixnum) :fixnum + "@0;ecl_aset_bv(#1,(#2)*(#1)->array.dims[1]+(#3),#0)") +(def-inline si:aset :always (t t t) t "ecl_aset1(#1,fixint(#2),#0)") +(def-inline si:aset :always (t t fixnum) t "ecl_aset1(#1,#2,#0)") +(def-inline si:aset :unsafe (t t t) t "ecl_aset1(#1,fix(#2),#0)") +(def-inline si:aset :unsafe (t (array t) fixnum) t + "(#1)->vector.self.t[#2]= #0") +(def-inline si:aset :unsafe (t (array bit) fixnum) :fixnum + "ecl_aset_bv(#1,#2,fix(#0))") +(def-inline si:aset :unsafe (base-char (array base-char) fixnum) :char + "(#1)->base_string.self[#2]= #0") +#+unicode +(def-inline si:aset :unsafe (character (array character) fixnum) :wchar + "(#1)->string.self[#2]= #0") +(def-inline si:aset :unsafe (double-float (array double-float) fixnum) :double + "(#1)->array.self.df[#2]= #0") +(def-inline si:aset :unsafe (single-float (array single-float) fixnum) :float + "(#1)->array.self.sf[#2]= #0") +(def-inline si:aset :unsafe (fixnum (array fixnum) fixnum) :fixnum + "(#1)->array.self.fix[#2]= #0") +(def-inline si:aset :unsafe (fixnum (array bit) fixnum) :fixnum + "ecl_aset_bv(#1,#2,#0)") + +(def-inline row-major-aref :always (t t) t "ecl_aref(#0,fixint(#1))") +(def-inline row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)") +(def-inline row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,fix(#1))") +(def-inline row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)") +(def-inline row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))") +(def-inline row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") +#+unicode +(def-inline row-major-aref :unsafe ((array character) fixnum) :wchar + "(#0)->string.self[#1]") +(def-inline row-major-aref :unsafe ((array base-char) fixnum) :char + "(#0)->base_string.self[#1]") +(def-inline row-major-aref :unsafe ((array double-float) fixnum) :double + "(#0)->array.self.df[#1]") +(def-inline row-major-aref :unsafe ((array single-float) fixnum) :float + "(#0)->array.self.sf[#1]") +(def-inline row-major-aref :unsafe ((array fixnum) fixnum) :fixnum + "(#0)->array.self.fix[#1]") + +(def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,fixint(#1),#2)") +(def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)") +(def-inline si:row-major-aset :unsafe (t t t) t "ecl_aset_unsafe(#0,fix(#1),#2)") +(def-inline si:row-major-aset :unsafe (t fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") +(def-inline si:row-major-aset :unsafe ((array t) fixnum t) t + "(#0)->vector.self.t[#1]= #2") +(def-inline si:row-major-aset :unsafe ((array bit) fixnum t) :fixnum + "ecl_aset_bv(#0,#1,fix(#2))") +(def-inline si:row-major-aset :unsafe ((array bit) fixnum fixnum) :fixnum + "ecl_aset_bv(#0,#1,#2)") +(def-inline si:row-major-aset :unsafe ((array base-char) fixnum base-char) :char + "(#0)->base_string.self[#1]= #2") +#+unicode +(def-inline si:row-major-aset :unsafe ((array character) fixnum character) :wchar + "(#0)->string.self[#1]= #2") +(def-inline si:row-major-aset :unsafe ((array double-float) fixnum double-float) :double + "(#0)->array.self.df[#1]= #2") +(def-inline si:row-major-aset :unsafe ((array single-float) fixnum single-float) :float + "(#0)->array.self.sf[#1]= #2") +(def-inline si:row-major-aset :unsafe ((array fixnum) fixnum fixnum) :fixnum + "(#0)->array.self.fix[#1]= #2") + +(def-inline array-rank :unsafe (array) :fixnum + "(#0)->array.rank") + +(def-inline array-dimension :always (t t) fixnum + "ecl_array_dimension(#0,fixint(#1))") +(def-inline array-dimension :always (t fixnum) fixnum + "ecl_array_dimension(#0,#1)") + +(def-inline array-total-size :unsafe (t) :fixnum "((#0)->array.dim)") + +(def-inline svref :always (t t) t "ecl_aref1(#0,fixint(#1))") +(def-inline svref :always (t fixnum) t "ecl_aref1(#0,#1)") +(def-inline svref :unsafe (t t) t "(#0)->vector.self.t[fix(#1)]") +(def-inline svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]") + +(def-inline si:svset :always (t t t) t "ecl_aset1(#0,fixint(#1),#2)") +(def-inline si:svset :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") +(def-inline si:svset :unsafe (t t t) t "((#0)->vector.self.t[fix(#1)]=(#2))") +(def-inline si:svset :unsafe (t fixnum t) t "(#0)->vector.self.t[#1]= #2") + +(def-inline fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)") + +(def-inline si:fill-pointer-set :unsafe (t fixnum) :fixnum + "((#0)->vector.fillp)=(#1)") + +;; file character.d + +(def-inline standard-char-p :always (character) :bool "ecl_standard_char_p(#0)") + +(def-inline graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)") + +(def-inline alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)") + +(def-inline upper-case-p :always (character) :bool "ecl_upper_case_p(#0)") + +(def-inline lower-case-p :always (character) :bool "ecl_lower_case_p(#0)") + +(def-inline both-case-p :always (character) :bool "ecl_both_case_p(#0)") + +(def-inline alphanumericp :always (character) :bool "ecl_alphanumericp(#0)") + +(def-inline char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)") +(def-inline char= :always (character character) :bool "(#0)==(#1)") + +(def-inline char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)") +(def-inline char/= :always (character character) :bool "(#0)!=(#1)") + +(def-inline char< :always (character character) :bool "(#0)<(#1)") + +(def-inline char> :always (character character) :bool "(#0)>(#1)") + +(def-inline char<= :always (character character) :bool "(#0)<=(#1)") + +(def-inline char>= :always (character character) :bool "(#0)>=(#1)") + +(def-inline char-code :always (character) :fixnum "#0") + +(def-inline code-char :always (fixnum) :char "#0") + +(def-inline char-upcase :always (base-char) :char "ecl_char_upcase(#0)") +(def-inline char-upcase :always (character) :wchar "ecl_char_upcase(#0)") + +(def-inline char-downcase :always (base-char) :char "ecl_char_downcase(#0)") +(def-inline char-downcase :always (character) :wchar "ecl_char_downcase(#0)") + +(def-inline char-int :always (character) :fixnum "#0") + +;; file file.d + +(def-inline input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)") + +(def-inline output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)") + +;; file list.d + +(def-inline car :always (cons) t "CAR(#0)") +(def-inline car :unsafe (t) t "CAR(#0)") + +(def-inline cdr :always (cons) t "CDR(#0)") +(def-inline cdr :unsafe (t) t "CDR(#0)") + +(def-inline caar :always (cons) t "CAAR(#0)") +(def-inline caar :unsafe (t) t "CAAR(#0)") + +(def-inline cadr :always (cons) t "CADR(#0)") +(def-inline cadr :unsafe (t) t "CADR(#0)") + +(def-inline cdar :always (cons) t "CDAR(#0)") +(def-inline cdar :unsafe (t) t "CDAR(#0)") + +(def-inline cddr :always (cons) t "CDDR(#0)") +(def-inline cddr :unsafe (t) t "CDDR(#0)") + +(def-inline caaar :always (cons) t "CAAAR(#0)") +(def-inline caaar :unsafe (t) t "CAAAR(#0)") + +(def-inline caadr :always (cons) t "CAADR(#0)") +(def-inline caadr :unsafe (t) t "CAADR(#0)") + +(def-inline cadar :always (cons) t "CADAR(#0)") +(def-inline cadar :unsafe (t) t "CADAR(#0)") + +(def-inline caddr :always (cons) t "CADDR(#0)") +(def-inline caddr :unsafe (t) t "CADDR(#0)") + +(def-inline cdaar :always (cons) t "CDAAR(#0)") +(def-inline cdaar :unsafe (t) t "CDAAR(#0)") + +(def-inline cdadr :always (cons) t "CDADR(#0)") +(def-inline cdadr :unsafe (t) t "CDADR(#0)") + +(def-inline cddar :always (cons) t "CDDAR(#0)") +(def-inline cddar :unsafe (t) t "CDDAR(#0)") + +(def-inline cdddr :always (cons) t "CDDDR(#0)") +(def-inline cdddr :unsafe (t) t "CDDDR(#0)") + +(def-inline caaaar :always (cons) t "CAAAAR(#0)") +(def-inline caaaar :unsafe (t) t "CAAAAR(#0)") + +(def-inline caaadr :always (cons) t "CAAADR(#0)") +(def-inline caaadr :unsafe (t) t "CAAADR(#0)") + +(def-inline caadar :always (cons) t "CAADAR(#0)") +(def-inline caadar :unsafe (t) t "CAADAR(#0)") + +(def-inline caaddr :always (cons) t "CAADDR(#0)") +(def-inline caaddr :unsafe (t) t "CAADDR(#0)") + +(def-inline cadaar :always (cons) t "CADAAR(#0)") +(def-inline cadaar :unsafe (t) t "CADAAR(#0)") + +(def-inline cadadr :always (cons) t "CADADR(#0)") +(def-inline cadadr :unsafe (t) t "CADADR(#0)") + +(def-inline caddar :always (cons) t "CADDAR(#0)") +(def-inline caddar :unsafe (t) t "CADDAR(#0)") + +(def-inline cadddr :always (cons) t "CADDDR(#0)") +(def-inline cadddr :unsafe (t) t "CADDDR(#0)") + +(def-inline cdaaar :always (cons) t "CDAAAR(#0)") +(def-inline cdaaar :unsafe (t) t "CDAAAR(#0)") + +(def-inline cdaadr :always (cons) t "CDAADR(#0)") +(def-inline cdaadr :unsafe (t) t "CDAADR(#0)") + +(def-inline cdadar :always (cons) t "CDADAR(#0)") +(def-inline cdadar :unsafe (t) t "CDADAR(#0)") + +(def-inline cdaddr :always (cons) t "CDADDR(#0)") +(def-inline cdaddr :unsafe (t) t "CDADDR(#0)") + +(def-inline cddaar :always (cons) t "CDDAAR(#0)") +(def-inline cddaar :unsafe (t) t "CDDAAR(#0)") + +(def-inline cddadr :always (cons) t "CDDADR(#0)") +(def-inline cddadr :unsafe (t) t "CDDADR(#0)") + +(def-inline cdddar :always (cons) t "CDDDAR(#0)") +(def-inline cdddar :unsafe (t) t "CDDDAR(#0)") + +(def-inline cddddr :always (cons) t "CDDDDR(#0)") +(def-inline cddddr :unsafe (t) t "CDDDDR(#0)") + +(def-inline cons :always (t t) t "CONS(#0,#1)") + +(def-inline endp :safe (t) :bool "ecl_endp(#0)") +(def-inline endp :unsafe (t) :bool "#0==Cnil") + +(def-inline nth :always (t t) t "ecl_nth(fixint(#0),#1)") +(def-inline nth :always (fixnum t) t "ecl_nth(#0,#1)") +(def-inline nth :unsafe (t t) t "ecl_nth(fix(#0),#1)") +(def-inline nth :unsafe (fixnum t) t "ecl_nth(#0,#1)") + +(def-inline first :always (cons) t "ECL_CONS_CAR(#0)") +(def-inline first :unsafe (t) t "CAR(#0)") + +(def-inline second :always (cons) t "CADR(#0)") +(def-inline second :unsafe (t) t "CADR(#0)") + +(def-inline third :always (cons) t "CADDR(#0)") +(def-inline third :unsafe (t) t "CADDR(#0)") + +(def-inline fourth :always (cons) t "CADDDR(#0)") +(def-inline fourth :unsafe (t) t "CADDDR(#0)") + +(def-inline rest :always (cons) t "ECL_CONS_CDR(#0)") +(def-inline rest :unsafe (t) t "CDR(#0)") + +(def-inline nthcdr :always (t t) t "ecl_nthcdr(fixint(#0),#1)") +(def-inline nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)") +(def-inline nthcdr :unsafe (t t) t "ecl_nthcdr(fix(#0),#1)") +(def-inline nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)") + +(def-inline last :always (t) t "ecl_last(#0,1)") +(def-inline list :always nil t "Cnil") +(def-inline list :always (t) t "ecl_list1(#0)") + +(def-inline list* :always (t) t "#0") +(def-inline list* :always (t t) t "CONS(#0,#1)") + +(def-inline append :always (t t) t "ecl_append(#0,#1)") + +(def-inline nconc :always (t t) t "ecl_nconc(#0,#1)") + +(def-inline butlast :always (t) t "ecl_butlast(#0,1)") + +(def-inline nbutlast :always (t) t "ecl_nbutlast(#0,1)") + +;; file num_arith.d + +(def-inline + :always (t t) t "ecl_plus(#0,#1)") +(def-inline + :always (fixnum-float fixnum-float) :double + "(double)(#0)+(double)(#1)" :exact-return-type t) +(def-inline + :always (fixnum-float fixnum-float) :float + "(float)(#0)+(float)(#1)" :exact-return-type t) +(def-inline + :always (fixnum fixnum) :fixnum "(#0)+(#1)" :exact-return-type t) + +(def-inline - :always (t) t "ecl_negate(#0)") +(def-inline - :always (t t) t "ecl_minus(#0,#1)") +(def-inline - :always (fixnum-float fixnum-float) :double + "(double)(#0)-(double)(#1)" :exact-return-type t) +(def-inline - :always (fixnum-float fixnum-float) :float + "(float)(#0)-(float)(#1)" :exact-return-type t) +(def-inline - :always (fixnum fixnum) :fixnum "(#0)-(#1)" :exact-return-type t) +(def-inline - :always (fixnum-float) :double "-(double)(#0)" :exact-return-type t) +(def-inline - :always (fixnum-float) :float "-(float)(#0)" :exact-return-type t) +(def-inline - :always (fixnum) :fixnum "-(#0)" :exact-return-type t) + +(def-inline * :always (t t) t "ecl_times(#0,#1)") +(def-inline * :always (fixnum-float fixnum-float) :double + "(double)(#0)*(double)(#1)" :exact-return-type t) +(def-inline * :always (fixnum-float fixnum-float) :float + "(float)(#0)*(float)(#1)" :exact-return-type t) +(def-inline * :always (fixnum fixnum) t "fixnum_times(#0,#1)" :exact-return-type t) +(def-inline * :always (fixnum fixnum) :fixnum "(#0)*(#1)" :exact-return-type t) + +(def-inline / :always (t t) t "ecl_divide(#0,#1)") +(def-inline / :always (fixnum-float fixnum-float) :double + "(double)(#0)/(double)(#1)" :exact-return-type t) +(def-inline / :always (fixnum-float fixnum-float) :float + "(float)(#0)/(float)(#1)" :exact-return-type t) +(def-inline / :always (fixnum fixnum) :fixnum "(#0)/(#1)" :exact-return-type t) + +(def-inline 1+ :always (t) t "ecl_one_plus(#0)") +(def-inline 1+ :always (double-loat) :double "(double)(#0)+1") +(def-inline 1+ :always (single-float) :float "(float)(#0)+1") +(def-inline 1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t) + +(def-inline 1- :always (t) t "ecl_one_minus(#0)") +(def-inline 1- :always (double-float) :double "(double)(#0)-1") +(def-inline 1- :always (single-float) :float "(float)(#0)-1") +(def-inline 1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t) + +;; file num_co.d + +(def-inline float :always (t single-float) :float "ecl_to_float(#0)") +(def-inline float :always (t double-float) :double "ecl_to_double(#0)") +(def-inline float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t) +(def-inline float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t) + +(def-inline numerator :unsafe (integer) integer "(#0)") +(def-inline numerator :unsafe (ratio) integer "(#0)->ratio.num") + +(def-inline denominator :unsafe (integer) integer "MAKE_FIXNUM(1)") +(def-inline denominator :unsafe (ratio) integer "(#0)->ratio.den") + +(def-inline floor :always (t) (values &rest t) "ecl_floor1(#0)") +(def-inline floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)") +(def-inline floor :always (fixnum fixnum) :fixnum + "@01;(#0>=0&>0?(#0)/(#1):ecl_ifloor(#0,#1))") + +(def-inline ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)") +(def-inline ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)") + +(def-inline truncate :always (t) (values &rest t) "ecl_truncate1(#0)") +(def-inline truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)") +(def-inline truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)") + +(def-inline round :always (t) (values &rest t) "ecl_round1(#0)") +(def-inline round :always (t t) (values &rest t) "ecl_round2(#0,#1)") + +(def-inline mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])") +(def-inline mod :always (fixnum fixnum) :fixnum + "@01;(#0>=0&>0?(#0)%(#1):ecl_imod(#0,#1))") + +(def-inline rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])") +(def-inline rem :always (fixnum fixnum) :fixnum "(#0)%(#1)") + +(def-inline = :always (t t) :bool "ecl_number_equalp(#0,#1)") +(def-inline = :always (fixnum-float fixnum-float) :bool "(#0)==(#1)") + +(def-inline /= :always (t t) :bool "!ecl_number_equalp(#0,#1)") +(def-inline /= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)") + +(def-inline < :always (t t) :bool "ecl_number_compare(#0,#1)<0") +(def-inline < :always (fixnum-float fixnum-float) :bool "(#0)<(#1)") +(def-inline < :always (fixnum-float fixnum-float fixnum-float) :bool + "@012;((#0)<(#1) && (#1)<(#2))") + +(def-inline > :always (t t) :bool "ecl_number_compare(#0,#1)>0") +(def-inline > :always (fixnum-float fixnum-float) :bool "(#0)>(#1)") +(def-inline > :always (fixnum-float fixnum-float fixnum-float) :bool + "@012;((#0)>(#1) && (#1)>(#2))") + +(def-inline <= :always (t t) :bool "ecl_number_compare(#0,#1)<=0") +(def-inline <= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)") +(def-inline <= :always (fixnum-float fixnum-float fixnum-float) :bool + "@012;((#0)<=(#1) && (#1)<=(#2))") + +(def-inline >= :always (t t) :bool "ecl_number_compare(#0,#1)>=0") +(def-inline >= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)") +(def-inline >= :always (fixnum-float fixnum-float fixnum-float) :bool + "@012;((#0)>=(#1) && (#1)>=(#2))") + +(def-inline max :always (t t) t "@01;(ecl_number_compare(#0,#1)>=0?#0:#1)") +(def-inline max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1") + +(def-inline min :always (t t) t "@01;(ecl_number_compare(#0,#1)<=0?#0:#1)") +(def-inline min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1") + +;; file num_log.d + +(def-inline logand :always nil t "MAKE_FIXNUM(-1)") +(def-inline logand :always nil :fixnum "-1") +(def-inline logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))") +(def-inline logand :always (fixnum fixnum) :fixnum "((#0) & (#1))") + +(def-inline logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))") +(def-inline logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))") + +(def-inline logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))") +(def-inline logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))") + +(def-inline logeqv :always nil t "MAKE_FIXNUM(-1)") +(def-inline logeqv :always nil :fixnum "-1") +(def-inline logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))") +(def-inline logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))") + +(def-inline logior :always nil t "MAKE_FIXNUM(0)") +(def-inline logior :always nil :fixnum "0") +(def-inline logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))") +(def-inline logior :always (fixnum fixnum) :fixnum "((#0) | (#1))") + +(def-inline lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))") +(def-inline lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))") + +(def-inline lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))") +(def-inline lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))") + +(def-inline lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),MAKE_FIXNUM(-1))") +(def-inline lognot :always (fixnum) :fixnum "(~(#0))") + +(def-inline logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))") +(def-inline logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))") + +(def-inline logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))") +(def-inline logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))") + +(def-inline logxor :always nil t "MAKE_FIXNUM(0)") +(def-inline logxor :always nil :fixnum "0") +(def-inline logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))") +(def-inline logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))") + +(def-inline boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))") + +(def-inline logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") + +(def-inline zerop :always (t) :bool "ecl_zerop(#0)") +(def-inline zerop :always (fixnum-float) :bool "(#0)==0") + +(def-inline plusp :always (t) :bool "ecl_plusp(#0)") +(def-inline plusp :always (fixnum-float) :bool "(#0)>0") + +(def-inline minusp :always (t) :bool "ecl_minusp(#0)") +(def-inline minusp :always (fixnum-float) :bool "(#0)<0") + +(def-inline oddp :always (t) :bool "ecl_oddp(#0)") +(def-inline oddp :always (fixnum fixnum) :bool "(#0) & 1") + +(def-inline evenp :always (t) :bool "ecl_evenp(#0)") +(def-inline evenp :always (fixnum fixnum) :bool "~(#0) & 1") + +(def-inline expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") +(def-inline expt :always ((integer 0 0) t) :fixnum "0") +(def-inline expt :always ((integer 1 1) t) :fixnum "1") + +(def-inline log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t) +(def-inline log :always (fixnum-float) :float "(float)log((double)(#0))" :exact-return-type t) + +(def-inline sqrt :always ((or (long-float 0.0 *) (double-float 0.0 *))) :double "sqrt((double)(#0))") +(def-inline sqrt :always ((or (single-float 0.0 *) (short-float 0.0 *))) :float "(float)sqrt((double)(#0))") + +(def-inline sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t) +(def-inline sin :always (fixnum-float) :float "(float)sin((double)(#0))" :exact-return-type t) + +(def-inline cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t) +(def-inline cos :always (fixnum-float) :float "(float)cos((double)(#0))" :exact-return-type t) + +(def-inline tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t) +(def-inline tan :always (fixnum-float) :float "(float)tan((double)(#0))" :exact-return-type t) + +(def-inline sin :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t) +(def-inline sin :always (fixnum-float) :float "(float)sinh((double)(#0))" :exact-return-type t) + +(def-inline cos :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t) +(def-inline cos :always (fixnum-float) :float "(float)cosh((double)(#0))" :exact-return-type t) + +(def-inline tan :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t) +(def-inline tan :always (fixnum-float) :float "(float)tanh((double)(#0))" :exact-return-type t) + +;; file pathname.d + +(def-inline null :always (t) :bool "#0==Cnil") + +(def-inline symbolp :always (t) :bool "SYMBOLP(#0)") + +(def-inline atom :always (t) :bool "ATOM(#0)") + +(def-inline consp :always (t) :bool "CONSP(#0)") + +(def-inline listp :always (t) :bool "@0;LISTP(#0)") + +(def-inline numberp :always (t) :bool "ecl_numberp(#0)") + +(def-inline integerp :always (t) :bool + "@0;type_of(#0)==t_fixnum||type_of(#0)==t_bignum") + +(def-inline floatp :always (t) :bool "floatp(#0)") + +(def-inline characterp :always (t) :bool "CHARACTERP(#0)") + +(def-inline base-char-p :always (character) :bool "BASE_CHAR_P(#0)") + +(def-inline stringp :always (t) :bool "ecl_stringp(#0)") + +(def-inline base-string-p :always (t) :bool "type_of(#0)==t_base_string") + +(def-inline bit-vector-p :always (t) :bool "(type_of(#0)==t_bitvector)") + +(def-inline vectorp :always (t) :bool "@0;ECL_VECTORP(#0)") + +(def-inline arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)") + +(def-inline eq :always (t t) :bool "(#0)==(#1)") +(def-inline eq :always (fixnum fixnum) :bool "(#0)==(#1)") + +(def-inline eql :always (t t) :bool "ecl_eql(#0,#1)") +(def-inline eql :always (character t) :bool "(CODE_CHAR(#0)==(#1))") +(def-inline eql :always (t character) :bool "((#0)==CODE_CHAR(#1))") +(def-inline eql :always (character character) :bool "(#0)==(#1)") +(def-inline eql :always ((not (or complex bignum ratio float)) t) :bool + "(#0)==(#1)") +(def-inline eql :always (t (not (or complex bignum ratio float))) :bool + "(#0)==(#1)") +(def-inline eql :always (fixnum fixnum) :bool "(#0)==(#1)") + +(def-inline equal :always (t t) :bool "ecl_equal(#0,#1)") +(def-inline equal :always (fixnum fixnum) :bool "(#0)==(#1)") + +(def-inline equalp :always (t t) :bool "ecl_equalp(#0,#1)") +(def-inline equalp :always (fixnum fixnum) :bool "(#0)==(#1)") + +(def-inline not :always (t) :bool "(#0)==Cnil") + +;; file print.d, read.d + +(def-inline clear-output :always (stream) NULL "(ecl_clear_output(#0),Cnil)") + +(def-inline finish-output :always (stream) NULL "(ecl_finish_output(#0),Cnil)") + +(def-inline finish-output :always (stream) NULL "(ecl_force_output(#0),Cnil)") + +(def-inline prin1 :always (t t) t "ecl_prin1(#0,#1)") +(def-inline prin1 :always (t) t "ecl_prin1(#0,Cnil)") + +(def-inline princ :always (t t) t "ecl_princ(#0,#1)") +(def-inline princ :always (t) t "ecl_princ(#0,Cnil)") + +(def-inline print :always (t t) t "ecl_print(#0,#1)") +(def-inline print :always (t) t "ecl_print(#0,Cnil)") + +(def-inline terpri :always (t) t "ecl_terpri(#0)") +(def-inline terpri :always nil t "ecl_terpri(Cnil)") + +(def-inline write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),Cnil),(#0))") + +(def-inline clear-input :always (stream) NULL "(ecl_clear_input(#0),Cnil)") + +(def-inline copy-readtable :always (null null) t "standard_readtable") + +(def-inline boundp :always (symbol) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL") + +;; file sequence.d + +(def-inline elt :always (t t) t "ecl_elt(#0,fix(#1))") +(def-inline elt :always (t fixnum) t "ecl_elt(#0,#1)") +(def-inline elt :always (vector t) t "ecl_aref1(#0,fix(#1))") +(def-inline elt :always (vector fixnum) t "ecl_aref1(#0,#1)") + +(def-inline elt :unsafe (t t) t "ecl_elt(#0,fix(#1))") +(def-inline elt :unsafe (t fixnum) t "ecl_elt(#0,#1)") +(def-inline elt :unsafe (vector t) t "ecl_aref_unsafe(#0,fix(#1))") +(def-inline elt :unsafe (vector fixnum) t "ecl_elt_unsafe(#0,#1)") +(def-inline aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))") +(def-inline aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") +#+unicode +(def-inline aref :unsafe ((array character) fixnum) :wchar + "(#0)->string.self[#1]") +(def-inline aref :unsafe ((array base-char) fixnum) :char + "(#0)->base_string.self[#1]") +(def-inline aref :unsafe ((array double-float) fixnum) :double + "(#0)->array.self.df[#1]") +(def-inline aref :unsafe ((array single-float) fixnum) :float + "(#0)->array.self.sf[#1]") +(def-inline aref :unsafe ((array fixnum) fixnum) :fixnum + "(#0)->array.self.fix[#1]") + +(def-inline si:elt-set :always (t t t) t "ecl_elt_set(#0,fixint(#1),#2)") +(def-inline si:elt-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") +(def-inline si:elt-set :always (vector t t) t "ecl_aset1(#0,fixint(#1),#2)") +(def-inline si:elt-set :always (vector fixnum t) t "ecl_aset1(#0,#1,#2)") + +(def-inline si:elt-set :unsafe (t t t) t "ecl_elt_set(#0,fix(#1),#2)") +(def-inline si:elt-set :unsafe (vector t t) t "ecl_aset1_unsafe(#0,fixint(#1),#2)") +(def-inline si:elt-set :unsafe (vector fixnum t) t "ecl_aset1_unsafe(#0,#1,#2)") + +(def-inline length :always (t) :fixnum "ecl_length(#0)") +(def-inline length :unsafe (array t) :fixnum "(#0)->vector.fillp") + +;; file character.d + +(def-inline char :always (t fixnum) t "ecl_aref1(#0,#1)") +(def-inline char :always (t fixnum) :wchar "ecl_char(#0,#1)") +#-unicode +(def-inline char :unsafe (t t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") +#-unicode +(def-inline char :unsafe (t fixnum) :char "(#0)->base_string.self[#1]") +(def-inline char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") +#+unicode +(def-inline char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") + +(def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)") +(def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") +(def-inline si:char-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") +#-unicode +(def-inline si:char-set :unsafe (t t t) t + "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") +#-unicode +(def-inline si:char-set :unsafe (t fixnum character) :char + "(#0)->base_string.self[#1]= #2") +(def-inline si:char-set :unsafe (base-string t t) t + "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") +(def-inline si:char-set :unsafe (base-string fixnum base-char) :char + "(#0)->base_string.self[#1]= #2") +(def-inline si:char-set :unsafe (ext:extended-string t t) t + "@2;((#0)->string.self[fix(#1)]=ecl_char_code(#2),(#2))") +(def-inline si:char-set :unsafe (ext:extended-string fixnum character) :char + "(#0)->string.self[#1]= #2") + +(def-inline schar :always (t t) t "ecl_elt(#0,fixint(#1))") +(def-inline schar :always (t fixnum) t "ecl_elt(#0,#1)") +(def-inline schar :always (t fixnum) :wchar "ecl_char(#0,#1)") +(def-inline schar :unsafe (base-string t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") +#-unicode +(def-inline schar :unsafe (t fixnum) :char "(#0)->base_string.self[#1]") +(def-inline schar :unsafe (base-string fixnum) :char "(#0)->base_string.self[#1]") +#+unicode +(def-inline schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") + +(def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,fixint(#1),#2)") +(def-inline si:schar-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") +(def-inline si:schar-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") +#-unicode +(def-inline si:schar-set :unsafe (t t t) t + "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") +#-unicode +(def-inline si:schar-set :unsafe (t fixnum base-char) :char + "(#0)->base_string.self[#1]= #2") +(def-inline si:schar-set :unsafe (base-string t t) t + "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") +(def-inline si:schar-set :unsafe (base-string fixnum base-char) :char + "(#0)->base_string.self[#1]= #2") +#+unicode +(def-inline si:schar-set :unsafe (ext:extended-string fixnum t) :wchar + "@2;((#0)->string.self[#1]= ecl_char_code(#2),(#2))") +#+unicode +(def-inline si:schar-set :unsafe (ext:extended-string fixnum character) :wchar + "(#0)->string.self[#1]= #2") + +(def-inline string= :always (string string) :bool "ecl_string_eq(#0,#1)") + +;; file structure.d + +(def-inline si:structure-name :always (structure) symbol "SNAME(#0)") + +(def-inline si:structure-ref :always (t t fixnum) t "ecl_structure_ref(#0,#1,#2)") + +(def-inline si:structure-set :always (t t fixnum t) t + "ecl_structure_set(#0,#1,#2,#3)") + +;; file symbol.d + +(def-inline get :always (t t t) t "ecl_get(#0,#1,#2)") +(def-inline get :always (t t) t "ecl_get(#0,#1,Cnil)") + +(def-inline symbol-name :always (t) string "ecl_symbol_name(#0)") + +;; AKCL addition + +(proclaim-function si:copy-stream (t t) t) + +;; Additions used by the compiler. +;; The following functions do not exist. They are always expanded into the +;; given C code. References to these functions are generated in the C1 phase. + +(proclaim-function shift>> (*) nil :no-side-effects) +(def-inline shift>> :always (fixnum fixnum) :fixnum "((#0) >> (- (#1)))") + +(proclaim-function shift<< (*) nil :no-side-effects) +(def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))") + +(proclaim-function short-float-p (t) gen-bool :predicate) +#-short-float +(def-inline short-float-p :always (t) :bool "type_of(#0)==t_singlefloat") +#+short-float +(def-inline short-float-p :always (t) :bool "type_of(#0)==t_shortfloat") + +(proclaim-function single-float-p (t) gen-bool :predicate) +(def-inline single-float-p :always (t) :bool "type_of(#0)==t_singlefloat") + +(proclaim-function double-float-p (t) gen-bool :predicate) +(def-inline double-float-p :always (t) :bool "type_of(#0)==t_doublefloat") + +(proclaim-function long-float-p (t) gen-bool :predicate) +#-long-float +(def-inline long-float-p :always (t) :bool "type_of(#0)==t_doublefloat") +#+long-float +(def-inline long-float-p :always (t) :bool "type_of(#0)==t_longfloat") + +(proclaim-function si:fixnump (t) gen-bool :predicate) +(def-inline si:fixnump :always (t) :bool "FIXNUMP(#0)") +(def-inline si:fixnump :always (fixnum) :bool "1") + +(proclaim-function si:put-properties (*) nil :no-sp-change) + +(proclaim-function c::ldb1 (fixnum fixnum fixnum) fixnum :no-side-effects) +(def-inline c::ldb1 :always (fixnum fixnum fixnum) :fixnum + "((((~((cl_fixnum)-1 << (#0))) << (#1)) & (cl_fixnum)(#2)) >> (#1))") +(def-inline c::ldb1 :always (fixnum fixnum fixnum) t + "MAKE_FIXNUM((((~((cl_fixnum)-1 << (#0))) << (#1)) & (cl_fixnum)(#2)) >> (#1))") + +;; Functions only available with CLOS + +#+clos(progn +(proclaim-function si:allocate-raw-instance (t t fixnum) t) +(proclaim-function si:instance-ref-safe (t fixnum) t) +(proclaim-function si:instance-ref (t fixnum) t :no-side-effects) +(def-inline si:instance-ref :always (t fixnum) t "ecl_instance_ref((#0),(#1))") +(def-inline si:instance-ref :unsafe (standard-object fixnum) t + "(#0)->instance.slots[#1]") + +(proclaim-function si:instance-set (t fixnum t) t) +(def-inline si:instance-set :unsafe (t fixnum t) t + "ecl_instance_set((#0),(#1),(#2))") +(def-inline si:instance-set :unsafe (standard-object fixnum t) t + "(#0)->instance.slots[#1]=(#2)") + +(proclaim-function si:instance-class (t) t :no-side-effects) +(def-inline si:instance-class :always (standard-object) t "CLASS_OF(#0)") +(proclaim-function si:instance-class-set (t t) t) +(proclaim-function si:instancep (t) t :predicate) +(def-inline si::instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)") +(proclaim-function si:unbound (*) t :predicate) +(def-inline si:unbound :always nil t "ECL_UNBOUND") + +(proclaim-function si:sl-boundp (t) t :predicate) +(def-inline si:sl-boundp :always (t) :bool "(#0)!=ECL_UNBOUND") + +(proclaim-function si:sl-makunbound (t fixnum) t :predicate) + +(proclaim-function standard-instance-access (standard-object fixnum) t :no-side-effects) +(def-inline standard-instance-access :always (standard-object fixnum) t "ecl_instance_ref((#0),(#1))") +(def-inline standard-instance-access :unsafe (standard-object fixnum) t + "(#0)->instance.slots[#1]") + +(proclaim-function funcallable-standard-instance-access (funcallable-standard-object fixnum) t :no-side-effects) +(def-inline funcallable-standard-instance-access :always (funcallable-standard-object fixnum) t "ecl_instance_ref((#0),(#1))") +(def-inline funcallable-standard-instance-access :unsafe (funcallable-standard-object fixnum) t + "(#0)->instance.slots[#1]") + +(proclaim-function associate-methods-to-gfun (generic-function *) generic-function) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; FUNCTIONS WHICH CAN BE CALLED FROM C +;;; +;;; The following two lists contain all functions in the core library which do +;;; not belong to the C part of the library, but which should have an exported C +;;; name that users (and compiled code) can refer to. This means, for instance, that +;;; MAKE-ARRAY will be compiled to a function called cl_make_array, etc. +;;; + +(in-package "SI") + +(defvar c::*in-all-symbols-functions* + '(;; arraylib.lsp + make-array vector array-dimensions array-in-bounds-p array-row-major-index + bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 + bit-andc2 bit-orc1 bit-orc2 bit-not + vector-push vector-push-extend vector-pop adjust-array + ;; conditions.lsp + si::safe-eval + signal warn break make-condition compute-restarts find-restart + invoke-restart invoke-restart-interactively + abort continue muffle-warning store-value use-value + ;; config.lsp + short-site-name long-site-name machine-instance machine-type machine-version + software-type software-version lisp-implementation-type lisp-implementation-version + ;; describe.lsp + describe inspect + ;; iolib.lsp + read-from-string write-to-string prin1-to-string princ-to-string + y-or-n-p yes-or-no-p dribble + ;; listlib.lsp + union nunion intersection nintersection set-difference nset-difference + set-exclusive-or nset-exclusive-or subsetp rassoc-if rassoc-if-not + assoc-if assoc-if-not member-if member-if-not subst-if subst-if-not + nsubst-if nsubst-if-not + ;; mislib.lsp + logical-pathname-translations load-logical-pathname-translations decode-universal-time + encode-universal-time get-decoded-time + ensure-directories-exist si::simple-program-error si::signal-simple-error + ;; module.lsp + provide require + ;; numlib.lsp + isqrt phase signum cis + asin acos asinh acosh atanh ffloor fceiling ftruncate fround + logtest byte byte-size byte-position ldb ldb-test mask-field dpb + deposit-field + ;; packlib.lsp + find-all-symbols apropos apropos-list + find-relative-package package-parent package-children + ;; predlib.lsp + upgraded-array-element-type upgraded-complex-part-type typep subtypep coerce + do-deftype + ;; seq.lsp + make-sequence concatenate map some every notany notevery map-into + ;; seqlib.lsp + reduce fill replace + remove remove-if remove-if-not delete delete-if delete-if-not + count count-if count-if-not substitute substitute-if substitute-if-not + nsubstitute nsubstitute-if nsubstitute-if-not find find-if find-if-not + position position-if position-if-not remove-duplicates + delete-duplicates mismatch search sort stable-sort merge + complement constantly + ;; top.lsp + invoke-debugger + ;; pprint.lsp + pprint-fill copy-pprint-dispatch pprint-dispatch + pprint-linear pprint-newline pprint-tab pprint-tabular + set-pprint-dispatch pprint-indent . + #-clos + nil + #+clos + (;; combin.lsp + method-combination-error + invalid-method-error + #-(or) standard-instance-access ; this function is a synonym for si:instance-ref + #-(or) funcallable-standard-instance-access ; same for this one + subclassp of-class-p + ;; boot.lsp + slot-boundp + slot-makunbound + slot-value + slot-exists-p + ;; generic.lsp + ;; ensure-generic-function cannot be here because it is redefined at run time. + ;; print.lsp + make-load-form-saving-slots + ) +)) + +(proclaim + `(si::c-export-fname #+ecl-min ,@c::*in-all-symbols-functions* + si::ecase-error si::etypecase-error si::do-check-type + ccase-error typecase-error-string find-documentation find-declarations + si::search-keyword si::check-keyword si::check-arg-length + si::dm-too-few-arguments si::dm-bad-key + remove-documentation si::get-documentation + si::set-documentation si::expand-set-documentation + si::packages-iterator + si::pprint-logical-block-helper si::pprint-pop-helper + si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next + si::structure-type-error si::define-structure + si::coerce-to-list si::coerce-to-vector + si::fill-array-with-seq + #+formatter + ,@'( + format-princ format-prin1 format-print-named-character + format-print-integer + format-print-cardinal format-print-ordinal format-print-old-roman + format-print-roman format-fixed format-exponential + format-general format-dollars + format-relative-tab format-absolute-tab + format-justification + ) + #+clos + ,@'(;; defclass.lsp + clos::ensure-class + ;; combin.lsp + clos::simple-code-walker + ;; standard.lsp + clos::safe-instance-ref + clos::standard-instance-set + ;; kernel.lsp + clos::install-method + clos::class-id + clos::class-direct-superclasses + clos::class-direct-subclasses + clos::class-slots + clos::class-precedence-list + clos::class-direct-slots + clos::default-initargs-of + clos::generic-function-lambda-list + clos::generic-function-argument-precedence-order + clos::generic-function-method-combination + clos::generic-function-method-class + clos::generic-function-methods + clos::method-generic-function + clos::method-lambda-list + clos::method-specializers + clos::method-qualifiers + clos::method-function + clos::method-plist + clos::associate-methods-to-gfun + ;; method.lsp + clos::pop-next-method + ))) +