Commit 7b762a99 authored by jjgarcia's avatar jjgarcia
Browse files

New functions for performing type inference.

Arithmetic operators *,+,/,- now have simple optimizers.
Fixed several "bugs" in the C code to let ECL compile with GCC 4.0
parent 0f08472b
......@@ -116,6 +116,8 @@ ECL 0.9g
in which the DEFMETHOD is enclosed. This makes it now possible to write
(defmethod foo (x) (defmethod bar ((f (eql x)))))
- Fixes in the C code to comply with gcc 4.0.
* ANSI compatibility:
- Several functions that signaled type-errors did not set the right values
......@@ -381,6 +381,7 @@ ONCE_MORE:
obj->cblock.data_text = NULL;
obj->cblock.data_text_size = 0;
obj->cblock.links = Cnil;
obj-> = Cnil;
case t_foreign:
obj->foreign.tag = Cnil;
......@@ -115,8 +115,10 @@ cl_alloc_object(cl_type t)
obj->cblock.links = Cnil;
obj-> = Cnil;
obj-> = Cnil;
obj->cblock.data_text = obj-> = NULL;
obj->cblock.data_text_size = obj->cblock.data_size = 0;
obj->cblock.data_text = NULL;
obj-> = NULL;
obj->cblock.data_text_size = NULL;
obj->cblock.data_size = 0;
obj->cblock.handle = NULL;
......@@ -2492,7 +2492,7 @@ si_make_lambda(cl_object name, cl_object rest)
@(defun si::eval-with-env (form &optional (env Cnil) (stepping Cnil))
volatile struct cl_compiler_env *old_c_env = ENV;
struct cl_compiler_env *old_c_env = ENV;
struct cl_compiler_env new_c_env;
volatile cl_index handle;
struct ihs_frame ihs;
......@@ -733,7 +733,7 @@ si_bc_split(cl_object b)
if (type_of(b) != t_bytecodes)
@(return Cnil Cnil)
vector = cl_alloc_simple_vector(b->bytecodes.code_size, aet_b8);
vector->vector.self.b8 = b->bytecodes.code;
vector->vector.self.b8 = (uint8_t*)b->bytecodes.code;
data = cl_alloc_simple_vector(b->bytecodes.data_size, aet_object);
data->vector.self.t = b->;
@(return b->bytecodes.lex vector data)
......@@ -67,6 +67,7 @@
#include <stdlib.h>
#include <stdio.h>
#include <ctype.h>
#include <string.h>
......@@ -12,6 +12,7 @@
See file '../Copyright' for full details.
#include <string.h>
#include "ecl.h"
......@@ -1519,7 +1519,7 @@ si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e)
stream = stream->stream.object1;
goto AGAIN;
} else {
unsigned char *p;
char *p;
for (p= seq->; start < end; start++) {
ecl_write_char(p[start], stream);
......@@ -1602,7 +1602,7 @@ si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e)
stream = stream->stream.object0;
goto AGAIN;
} else {
unsigned char *p;
char *p;
for (p = seq->; start < end; start++) {
int c = ecl_read_char(stream);
if (c == EOF)
......@@ -860,7 +860,8 @@ interpret(cl_object bytecodes, void *pc) {
case OP_PFCALL: {
cl_fixnum n = GET_OPARG(vector);
cl_object fun = cl_env.stack_top[-n-1];
cl_env.stack_top[-1] = interpret_funcall(n, fun);
cl_object reg0 = interpret_funcall(n, fun);
cl_env.stack_top[-1] = reg0;
......@@ -13,6 +13,7 @@
See file '../Copyright' for full details.
#include <string.h>
#include "ecl.h"
#include "ecl-inl.h"
#include "internal.h"
......@@ -934,7 +934,7 @@ cl_symbols[] = {
{"VECTOR-POP", CL_ORDINARY, ECL_NAME(cl_vector_pop), -1, OBJNULL},
{"VECTOR-PUSH", CL_ORDINARY, ECL_NAME(cl_vector_push), -1, OBJNULL},
{"VECTOR-PUSH-EXTEND", CL_ORDINARY, ECL_NAME(cl_vector_push_extend), -1, OBJNULL},
{"VECTORP", CL_ORDINARY, cl_vectorp, 1, OBJNULL},
......@@ -462,7 +462,7 @@
(error 'simple-program-error
"Syntax error in method specializer ~A" arg))
((constantp (setf arg (second arg)))
`(eql ,arg))
`(eql ,(eval arg)))
(list 'eql (list 'si::unquote arg))))
......@@ -120,25 +120,17 @@
(warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)))
(defun get-arg-types (fname &aux x)
(if (setq x (assoc fname *function-declarations*))
(second x)
(get-sysprop fname 'PROCLAIMED-ARG-TYPES)))
(defun get-arg-types (fname)
(let ((x (assoc fname *function-declarations*)))
(if x
(second x)
(get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
(defun get-return-type (fname)
(let* ((x (assoc fname *function-declarations*))
(type1 (if x (caddr x) (get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
(cond (type1
(let ((type (get-sysprop fname 'RETURN-TYPE)))
(cond (type
(cond ((setq type (type-and type type1)) type)
"The return type of ~s was badly declared."
(t type1))))
(t (get-sysprop fname 'RETURN-TYPE)))
(let ((x (assoc fname *function-declarations*)))
(if x
(second x)
(get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
(defun get-local-arg-types (fun &aux x)
(if (setq x (assoc fun *function-declarations*))
......@@ -155,7 +147,7 @@
(get-sysprop fun 'PROCLAIMED-ARG-TYPES)
(if found
(let ((minarg (length x)))
(if (eq (last x) '*)
(if (eq (first (last x)) '*)
(setf minarg (1- minarg)
maxarg call-arguments-limit)
(setf maxarg minarg))
......@@ -101,29 +101,7 @@
(defun c1call-global (fname args)
(let* ((forms (c1args* args))
(return-type (or (get-return-type fname) '(VALUES &REST T))))
(let ((arg-types (get-arg-types fname)))
;; Add type information to the arguments.
(when arg-types
(do ((fl forms (cdr fl))
(fl1 nil)
(al args (cdr al)))
((endp fl)
(setq forms (nreverse fl1)))
(cond ((endp arg-types) (push (car fl) fl1))
(t (push (and-form-type (car arg-types) (car fl) (car al)
:safe "In a call to ~a" fname)
(pop arg-types))))))
(let ((arg-types (get-sysprop fname 'ARG-TYPES)))
;; Check argument types.
(when arg-types
(do ((fl forms (cdr fl))
(al args (cdr al)))
((or (endp arg-types) (endp fl)))
(and-form-type (car arg-types) (car fl) (car al) :safe
"In a call to ~a" fname)
(pop arg-types))))
(return-type (propagate-types fname forms args)))
(make-c1form* 'CALL-GLOBAL
:sp-change (function-may-change-sp fname)
:type return-type
;;;; 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)
(let ((l (length args)))
(cond ((every #'numberp args)
(apply operator args))
((> l 2)
(list* (simplify-arithmetic operator (list (first args) (second args)) nil)
(cddr args))
((= l 2)
(or whole (list* operator args)))
((= l 1)
(if (or (eq operator '*) (eq operator '+))
(first args)
(or whole (list* operator args))))
((eq operator '*)
((eq operator '+)
(error 'simple-program-error :format-error "Wrong number of arguments for operator ~a in ~a"
:format-args (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))
......@@ -68,10 +68,11 @@
(cond ((endp type-args) '(ARRAY *)) ; Beppe
((eq '* (car type-args)) t)
(t (let ((element-type (upgraded-array-element-type (car type-args))))
(if (and (cdr type-args)
(not (eq (second type-args) '*))
(= (length (second type-args)) 1))
(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
......@@ -355,3 +356,41 @@
(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))))
(in-package "COMPILER")
(defun simple-type-propagator (fname &rest form-types)
(let ((arg-types (get-arg-types fname))
(return-type (or (get-return-type fname) '(VALUES &REST T))))
(values arg-types return-type)))
(defun propagate-types (fname forms lisp-forms)
(multiple-value-bind (arg-types return-type)
(apply (or (get-sysprop fname 'C1TYPE-PROPAGATOR)
(when arg-types
(do ((fl forms (rest fl))
(al lisp-forms (rest al))
(i 1 (1+ i)))
((endp fl))
(unless (endp arg-types)
;; Check the type of the arguments.
(let ((new (and-form-type (pop arg-types) (first fl) (first al)
:safe "In the argument ~d of a call to ~a" i fname)))
;; In unsafe mode, we assume that the type of the
;; argument is going to be the right one.
(when (zerop *safety*)
(setf (car fl) new))))))
(defmacro def-type-propagator (fname lambda-list &body body)
`(put-sysprop ',fname 'C1TYPE-PROPAGATOR
#'(ext:lambda-block ,fname ,lambda-list ,body)))
......@@ -28,6 +28,7 @@
......@@ -48,11 +48,11 @@
&key no-sp-change predicate no-side-effects)
(unless (or (null arg-types)
(equal arg-types '(*)))
(put-sysprop name 'arg-types
(put-sysprop name 'proclaimed-arg-types
(mapcar #'(lambda (x) (if (eql x '*) '* (type-filter x)))
(when (and return-type (not (eq 'T return-type)))
(put-sysprop name 'return-type
(put-sysprop name 'proclaimed-return-type
(if (eql return-type '*) '* (type-filter return-type t))))
(when no-sp-change
(put-sysprop name 'no-sp-change t))
......@@ -861,15 +861,15 @@
(def-inline log :always (fixnum-float) :double "log((double)(#0))")
(def-inline log :always (fixnum-float) :float "(float)log((double)(#0))")
(proclaim-function sqrt (t) t :no-side-effects t)
(proclaim-function sqrt (number) number :no-side-effects t)
(def-inline sqrt :always (fixnum-float) :double "sqrt((double)(#0))")
(def-inline sqrt :always (fixnum-float) :float "(float)sqrt((double)(#0))")
(proclaim-function sin (t) t :no-side-effects t)
(proclaim-function sin (number) number :no-side-effects t)
(def-inline sin :always (fixnum-float) :double "sin((double)(#0))")
(def-inline sin :always (fixnum-float) :float "(float)sin((double)(#0))")
(proclaim-function cos (t) t :no-side-effects t)
(proclaim-function cos (number) number :no-side-effects t)
(def-inline cos :always (fixnum-float) :double "cos((double)(#0))")
(def-inline cos :always (fixnum-float) :float "(float)cos((double)(#0))")
......@@ -967,7 +967,7 @@ type_of(#0)==t_string||
(proclaim-function vector-push (t vector) fixnum :no-sp-change t)
(proclaim-function vector-push-extend (t vector) fixnum :no-sp-change t)
(proclaim-function vector-push-extend (t vector *) fixnum :no-sp-change t)
(proclaim-function simple-string-p (t) t :predicate t)
(proclaim-function simple-bit-vector-p (t) t :predicate t)
(proclaim-function simple-vector-p (t) t :predicate t)
......@@ -3,8 +3,8 @@
<p>You should read the <a href="#configure">Autoconf based configuration</a>
if you use ECL on a unix-like platform, such as
<li>Linux, NetBSD, FreeBSD, Sola.
<li>OSX (See <a href="#osx">below</a>)
<li>Linux, NetBSD, FreeBSD, Solaris 9
<li>Mac OSX (See <a href="#osx">below</a>)
<li>Cygwin or Mingw32 on Windows.
......@@ -33,9 +33,9 @@ and finish the compilation.
The previous step creates a directory with the name <b>build</b>, and
stores a bunch of makefiles in it. <b>Note:</b> If you are building
under Solaris, you should rather use
under Solaris 9, you should rather use
./configure --enable-slow-config
./configure --enable-slow-config --with-system-gmp=no
because otherwise ECL will fail to detect the 64-bit capabilities of
the operating system.
......@@ -97,13 +97,13 @@ Toolkit 2003, you should follow these before building ECL:
<h3><a name="osx">Mac OSX</a></h3>
<p>ECL is known to build and work on all versions of OSX, including
Tiger. The steps for building ECL are the ones shown in the <a
href="configure">Autoconf</a> section.
<p>ECL now compiles with GCC 4.0. You need not specify any particular
options. But if you still experience some strange behaviour, try
compiling with a previous version of the compiler before reporting the
<p>There is a caveat, though, which is that ECL currently cannot be built
using GCC 4.0. Hence, if you have OSX Tiger (>= 10.4) and XCode (>= 2) you
should instruct <tt>configure</tt> to use a different compiler, as in
<p>For compiling with GCC 3.3 (shipped with XCode >= 2) you
must instruct <tt>configure</tt> to use a different compiler, as in
$ CC=gcc-3.3 ./configure --prefix=/opt/local
......@@ -445,7 +445,7 @@ extern void FEreader_error(const char *s, cl_object stream, int narg, ...) /*__a
extern void FEerror(const char *s, int narg, ...) /*__attribute__((noreturn))*/;
extern void FEcannot_open(cl_object fn) /*__attribute__((noreturn))*/;
extern void FEend_of_file(cl_object strm) /*__attribute__((noreturn))*/;
extern void FEclosed_stream(cl_object strm) __attribute__ ((noreturn));
extern void FEclosed_stream(cl_object strm) /*__attribute__ ((noreturn))*/;
extern void FEwrong_type_argument(cl_object type, cl_object value) /*__attribute__((noreturn))*/;
extern void FEwrong_num_arguments(cl_object fun) /*__attribute__((noreturn))*/;
extern void FEwrong_num_arguments_anonym(void) /*__attribute__((noreturn))*/;
......@@ -1482,7 +1482,7 @@ extern cl_object cl_bit_andc2 _ARGS((cl_narg narg, cl_object V1, cl_object V2, .
extern cl_object cl_bit_orc1 _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern cl_object cl_bit_orc2 _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern cl_object cl_bit_not _ARGS((cl_narg narg, cl_object V1, ...));
extern cl_object cl_vector_push _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern cl_object cl_vector_push _ARGS((cl_object V1, cl_object V2));
extern cl_object cl_vector_push_extend _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern cl_object cl_vector_pop _ARGS((cl_narg narg, cl_object V1, ...));
extern cl_object cl_adjust_array _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment