mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 01:10:53 -07:00
Code Issues Projects Releases Packages Wiki Activity

Incorporate the new compiler into the source tree.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-12-20 16:04:59 +01:00
parent 09e7b83ad2
commit 4ab12a4077
51 changed files with 13657 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

9
src/Makefile.in
View file

@ -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 ./

2
src/bare.lsp.in
View file

@ -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")
;;;

3
src/compile.lsp.in
View file

@ -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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

23
src/configure vendored
View file

@ -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

17
src/configure.in
View file

@ -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

91
src/new-cmp/TODO Normal file
View file

@ -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.

84
src/new-cmp/cmparray.lsp Normal file
View file

@ -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))

689
src/new-cmp/cmpbackend.lsp Normal file
View file

@ -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))

76
src/new-cmp/cmpbind.lsp Normal file
View file

@ -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)))

105
src/new-cmp/cmpblock.lsp Normal file
View file

@ -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))))

83
src/new-cmp/cmpcall.lsp Normal file
View file

@ -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)))))

92
src/new-cmp/cmpcatch.lsp Normal file
View file

@ -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)))

120
src/new-cmp/cmpcbk.lsp Normal file
View file

@ -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 "}")))

118
src/new-cmp/cmpclos.lsp Normal file
View file

@ -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))))))))))

123
src/new-cmp/cmpct.lsp Normal file
View file

@ -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 <float.h>" *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")
)
)))

548
src/new-cmp/cmpdefs.lsp Normal file
View file

@ -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* "<ecl/ecl-cmp.h>")
(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)

726
src/new-cmp/cmpenv.lsp Normal file
View file

@ -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-<push-events)
;(>= *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))

153
src/new-cmp/cmpeval.lsp Normal file
View file

@ -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))))))

186
src/new-cmp/cmpexit.lsp Normal file
View file

@ -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)))))

451
src/new-cmp/cmpffi.lsp Normal file
View file

@ -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*))))))

244
src/new-cmp/cmpflet.lsp Normal file
View file

@ -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))

164
src/new-cmp/cmpfun.lsp Normal file
View file

@ -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))

118
src/new-cmp/cmpif.lsp Normal file
View file

@ -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)))))))

25
src/new-cmp/cmpinit.lsp Normal file
View file

@ -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))

185
src/new-cmp/cmpinline.lsp Normal file
View file

@ -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))

529
src/new-cmp/cmplam.lsp Normal file
View file

@ -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)))))

140
src/new-cmp/cmplet.lsp Normal file
View file

@ -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)))

248
src/new-cmp/cmploc.lsp Normal file
View file

@ -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))

211
src/new-cmp/cmpmac.lsp Normal file
View file

@ -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 "#<form ~A ~X>" (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)

878
src/new-cmp/cmpmain.lsp Normal file
View file

@ -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 <ecl/ecl.h>
#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 <windows.h>
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)

74
src/new-cmp/cmpmap.lsp Normal file
View file

@ -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))

135
src/new-cmp/cmpmulti.lsp Normal file
View file

@ -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)))))

125
src/new-cmp/cmpname.lsp Normal file
View file

@ -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)))))

190
src/new-cmp/cmpnum.lsp Normal file
View file

@ -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 *))))

419
src/new-cmp/cmpopt.lsp Normal file
View file

@ -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)))

535
src/new-cmp/cmpprop.lsp Normal file
View file

@ -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)))

119
src/new-cmp/cmpspecial.lsp Normal file
View file

@ -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)")))))

63
src/new-cmp/cmpstack.lsp Normal file
View file

@ -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))))

141
src/new-cmp/cmpstructures.lsp Normal file
View file

@ -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)))

257
src/new-cmp/cmptables.lsp Normal file
View file

@ -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)
)))

184
src/new-cmp/cmptag.lsp Normal file
View file

@ -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))))))

253
src/new-cmp/cmptest.lsp Normal file
View file

@ -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))))

426
src/new-cmp/cmptop.lsp Normal file
View file

@ -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 <string.h>"))
;;; 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 <ecl/internal.h>")
(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 "~%<a FUN: ~A, CLOSURE: ~A, LEVEL: ~A, ENV: ~A>"
(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)

426
src/new-cmp/cmptranslate.lsp Normal file
View file

@ -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))

637
src/new-cmp/cmptype.lsp Normal file
View file

@ -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)))))

298
src/new-cmp/cmputil.lsp Normal file
View file

@ -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 "#<a ~A: ~A>" (type-of ref-object) name)
(format stream "#<a ~A>" (type-of ref-object)))))
(defun print-var (var-object stream)
(format stream "#<a VAR: ~A KIND: ~A>" (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))))

353
src/new-cmp/cmpvar.lsp Normal file
View file

@ -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)))))

298
src/new-cmp/cmpwt.lsp Normal file
View file

@ -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 "~@<Reusing keywords lists for ~_~A~@:>" 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))))))))

46
src/new-cmp/defsys.lsp.in Normal file
View file

@ -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@/")

48
src/new-cmp/load.lsp.in Normal file
View file

@ -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))

2197
src/new-cmp/sysfun.lsp Normal file
View file

File diff suppressed because it is too large Load diff