mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 05:43:19 -08:00
Code Issues Projects Releases Packages Wiki Activity

Full code reorganization, further splitting the backend.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-12-29 12:05:21 +01:00
parent b695d03693
commit 187144581f
19 changed files with 854 additions and 993 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/new-cmp/cmpblock.lsp
View file

@ -90,8 +90,8 @@
output (nconc prefix
val
cleanup
(c1jmp exit-tag)
postfix)))))
postfix
(c1jmp exit-tag))))))
(setf (blk-type blk) (values-type-or (blk-type blk) type)
(blk-ref blk) (1+ (blk-ref blk)))
output))))

154
src/new-cmp/cmpc-data.lsp Normal file
View file

@ -0,0 +1,154 @@
;;;; -*- 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.
;;;; CMPC-DATA -- Dump data used by code in a textual representation
(in-package "C-BACKEND")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DUMP TEXTUAL DATA
;;;
;;; Dumps data that has to be parsed by read_VV() when initializing
;;; this file.
(defun data-dump (stream &key 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
(extract-static-constants stream)
(adjust-data-indices *permanent-objects*)
(adjust-data-indices *temporary-objects*)
(let ((output nil))
(cond (*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 adjust-data-indices (array)
(loop for last-index from 0
for record across array
for location = (second record)
do (setf (second location) last-index
(third record) last-index)))
(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))
;;; 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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DUMP STATIC DATA
;;;
(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 static-data-dump (stream)
(loop for (object c-name) in *static-constants*
for function = (static-constant-expression object)
do (funcall function c-name object stream)))
(defun extract-static-constants (stream)
(unless (or *compiler-constants* (not *use-static-constants-p*))
(let ((static-constants 0))
(flet ((turned-static-p (record)
(destructuring-bind (object (&whole location vv-tag index object-copy))
(let ((builder (static-constant-expression object)))
(when builder
(let* ((next-index (incf static-constants))
(name (format nil "_ecl_static_~D" next-index)))
(setf (second location) name)
(funcall name object sream)
t))))))
(setf *permanent-objects*
(delete-if #'turned-static-p *permanent-objects*)
*temporary-objects*
(delete-if #'turned-static-p *temporary-objects*))))))

114
src/new-cmp/cmploc.lsp → src/new-cmp/cmpc-loc.lsp
View file

@ -2,6 +2,7 @@
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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
@ -10,9 +11,9 @@
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPLOC Set-loc and Wt-loc.
;;;; CMPC-LOC Write locations as C expressions
(in-package "COMPILER")
(in-package "C-BACKEND")
;;; Valid locations are:
;;; NIL
@ -60,12 +61,17 @@
;;; ( BIND var alternative ) Alternative is optional
;;; ( JUMP-TRUE label )
;;; ( JUMP-FALSE label )
;;; ( JUMP-ZERO label )
;;; ( JUMP-NONZERO label )
(defun tmp-destination (loc)
(case loc
(VALUES 'VALUES)
(TRASH 'TRASH)
(T 'RETURN)))
(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 loc-has-side-effects (loc)
(if (atom loc)
@ -82,7 +88,8 @@
(FDEFINITION (policy-global-function-checking))
(otherwise nil))))
;;; ------------------------------------------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; WRITING C/C++ REPRESENTATIONS LOCATIONS
;;;
@ -110,11 +117,6 @@
(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 ")"))
@ -157,92 +159,6 @@
(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 loc ";")))
(defun set-the-loc (value type loc)
(set-loc value loc))

25
src/new-cmp/cmpbackend.lsp → src/new-cmp/cmpc-ops.lsp
View file

@ -9,7 +9,7 @@
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
(in-package "C-BACKEND")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@ -800,3 +800,26 @@
(error "Wrong value of environment size ~A" *env*))
(close-all-c-blocks)))
;;;
;;; FSET FIXME! UNUSED!
;;;
(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)))

88
src/new-cmp/cmpc-set.lsp Normal file
View file

@ -0,0 +1,88 @@
;;;; -*- 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.
;;;; CMPC-SET Set locations
(in-package "C-BACKEND")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 loc ";")))
(defun set-the-loc (value type loc)
(set-loc value loc))

145
src/new-cmp/cmpc-tables.lsp Normal file
View file

@ -0,0 +1,145 @@
;;;; -*- 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.
;;;;
;;;; CMPC-TABLES -- Dispatch tables for the C/C++ backend
;;;;
(in-package "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-requireds . c2bind-requireds)
(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-zero)
(jmp-nonzero . set-loc-jmp-nonzero)
)))

168
src/new-cmp/cmpc-top.lsp Normal file
View file

@ -0,0 +1,168 @@
;;;; -*- 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.
;;;;
;;;; CMPC-TOP -- Dump all lisp forms and data
;;;;
(in-package "C-BACKEND")
(defparameter +init-function-name+ (gensym "ENTRY-POINT"))
(defun ctop-write (name h-pathname data-pathname
&key shared-data
&aux def top-output-string
(*volatile* "volatile "))
(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)
;; Optimization passes
(c-backend-passes)
;; 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")
(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 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 "~%};")))))
(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)
while pending
do (let ((f (pop pending)))
(when (gethash f emitted-local-funs)
(error "Doubly emitted function ~A" f))
(t3local-fun f)
(setf (gethash f emitted-local-funs) t
pending (append (fun-child-funs f) pending)))))
(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))))

76
src/new-cmp/cmpc-wt.lsp Normal file
View file

@ -0,0 +1,76 @@
;;;; -*- 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 -- Routines for writing code to C files.
(in-package "C-BACKEND")
(defvar *wt-string-size* 0)
(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)

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

@ -0,0 +1,123 @@
;;;; -*- 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.
;;;; CMPDATA Collect data used in lisp code
(in-package "COMPILER")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DATA DATABASE
;;;
;;; Each lisp compiled file consists on code and a data section. Among
;;; other optimizations 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 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-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 ((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))))))

6
src/new-cmp/cmpdefs.lsp
View file

@ -45,6 +45,10 @@
"*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET"
"COMPILER-LET"))
(defpackage "C-BACKEND"
(:use "FFI" "CL" #+threads "MP" "C")
(:export "DUMP-ALL"))
(in-package "COMPILER")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -505,8 +509,6 @@ lines are inserted, but the order is preserved")
(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

6
src/new-cmp/cmpeval.lsp
View file

@ -96,12 +96,6 @@
(c1call-global-op destination fname temps)
postfix))))))
(defun c1progn (destination forms)
(or (loop for fl on forms
append (t1/c1expr (if (rest fl) 'TRASH destination)
(first fl)))
(t1/c1expr destination 'NIL)))
;;; ----------------------------------------------------------------------
(defvar *compiler-temps*

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

@ -1,186 +0,0 @@
;;;; -*- 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)))))

24
src/new-cmp/cmpflet.lsp
View file

@ -194,30 +194,6 @@
(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)

11
src/new-cmp/cmplam.lsp
View file

@ -433,6 +433,17 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(loop for pair in (nreverse pairs)
collect `(optional-check-type ,@pair)))))))
(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*))
#| Steps:
1. defun creates declarations for requireds + va_alist
2. c2lambda-expr adds declarations for:

22
src/new-cmp/cmpmain.lsp
View file

@ -390,7 +390,7 @@ static cl_object VV[VM];
#endif
#define ECL_SHARED_DATA_FILE 1
" (data-permanent-storage-size))
(data-dump c-file))
(c-backend::data-dump c-file))
(t
(format c-file "
#define compiler_data_text NULL
@ -582,8 +582,8 @@ compiled successfully, returns the pathname of the compiled file"
:input-designator (namestring input-pathname))
(if shared-data-file
(data-dump shared-data-pathname t)
(data-dump data-pathname))
(c-backend::data-dump shared-data-pathname t)
(c-backend::data-dump data-pathname))
(let ((o-pathname (if system-p
output-file
@ -796,10 +796,10 @@ from the C language code. NIL means \"do not create the file\"."
(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))
(c-backend::ctop-write init-name
(if h-file h-file "")
(if data-file data-file ""))
(c-backend::data-dump data-file))
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
(when h-file (close *compiler-output2*)))))
nil)
@ -816,10 +816,10 @@ from the C language code. NIL means \"do not create the file\"."
(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))
(catch *cmperr-tag* (c-backend::ctop-write init-name
h-pathname
data-pathname
:shared-data shared-data))
(terpri *compiler-output1*)
(terpri *compiler-output2*))))

133
src/new-cmp/cmptables.lsp
View file

@ -136,136 +136,3 @@
))
(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-requireds . c2bind-requireds)
(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-zero)
(jmp-nonzero . set-loc-jmp-nonzero)
)))

256
src/new-cmp/cmptop.lsp
View file

@ -25,8 +25,6 @@
,@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
@ -91,131 +89,11 @@
(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)
while pending
do (let ((f (pop pending)))
(when (gethash f emitted-local-funs)
(error "Doubly emitted function ~A" f))
(t3local-fun f)
(setf (gethash f emitted-local-funs) t
pending (append (fun-child-funs f) pending)))))
(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)
;; Optimization passes
(execute-pass 'pass-consistency)
(execute-pass 'pass-delete-no-side-effects)
(execute-pass 'pass-delete-unused-bindings)
(execute-pass 'pass-decide-var-rep-types)
(execute-pass 'pass-assign-labels)
;; 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 c1progn (destination forms)
(or (loop for fl on forms
append (t1/c1expr (if (rest fl) 'TRASH destination)
(first fl)))
(t1/c1expr destination 'NIL)))
(defun c1eval-when (destination args)
(check-args-number 'EVAL-WHEN args 1)
@ -243,29 +121,6 @@
(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)
@ -296,48 +151,29 @@
(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 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 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 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 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))))
(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))))
;;; ----------------------------------------------------------------------
;;; Optimizer for FSET. Removes the need for a special handling of DEFUN as a
@ -381,46 +217,6 @@
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.

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

@ -1,298 +0,0 @@
;;;; -*- 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))))))))

8
src/new-cmp/load.lsp.in
View file

@ -40,7 +40,13 @@
"src:new-cmp;cmpstructures.lsp"
"src:new-cmp;cmparray.lsp"
"src:new-cmp;cmppass.lsp"
"src:new-cmp;cmpbackend.lsp"
"src:new-cmp;cmpc-data.lsp"
"src:new-cmp;cmpc-wt.lsp"
"src:new-cmp;cmpc-loc.lsp"
"src:new-cmp;cmpc-set.lsp"
"src:new-cmp;cmpc-ops.lsp"
"src:new-cmp;cmpc-tables.lsp"
"src:new-cmp;cmpc-top.lsp"
"src:new-cmp;cmpmain.lsp"))
(let ((si::*keep-documentation* nil))