Commit c8c59167 authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

cmp: major cleanup, separate passes

- separate passes

  The separation is not fine-grained but is a good starting point for further
  cleanup. This is a preliminary requirement for multiple backends.

- use uninternet symbol in the package definition

- remove "execute" permission from all files

- remove a few unused functions

- rearrange loaded files

- less verbose compiler

  Don't print "End of pass 1." message. This doesn't provide any valuable
  information to the programmer.
parent 0aa627e3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;;
;;;; 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 (typep var-loc 'fixnum)
;; first binding: assign location
(setq var-loc (next-env))
(setf (var-loc var) var-loc))
(when (zerop var-loc) (wt-nl "env" *env-lvl* " = ECL_NIL;"))
(wt-nl "CLV" var-loc " = env" *env-lvl* " = CONS(")
(wt-coerce-loc :object loc)
(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 :format-control "bind: unexpected var-kind (~s) and loc (~s)."
:format-arguments (list (var-kind var) loc)))))))
;;; Used by let*, defmacro and lambda's &aux, &optional, &rest, &keyword
(defun bind-init (form var)
(let ((kind (var-kind var)))
(if (member kind '(CLOSURE LEXICAL SPECIAL GLOBAL))
;; Binding these variables is complicated and involves lexical
;; environments, global environments, etc. If we use `(BIND var)
;; as destination, BIND might receive the wrong environment.
(let* ((*inline-blocks* 0)
(*temp* *temp*)
(locs (coerce-locs (inline-args (list form)))))
(bind (first locs) var)
(close-inline-blocks)
;; Notice that we do not need to update *UNWIND-EXIT*
;; because BIND does it for us.
)
;; The simple case of a variable which is local to a function.
(let ((*destination* `(BIND ,var)))
(c2expr* form)))))
(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 ");")))
(push 'BDS-BIND *unwind-exit*)
(wt-comment (var-name var)))
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;;
;;;; 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
;;; (`SI:FUNCTION-BOUNDARY' or `SI:UNWIND-PROTECT-BOUNDARY'), 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 (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 block-name :kind 'LEXICAL))
(blk (make-blk :var blk-var :name block-name))
(body (let ((*cmp-env* (cmp-env-copy)))
(cmp-env-register-block blk)
(c1progn (rest args)))))
(when (or (var-ref-ccb blk-var) (var-ref-clb blk-var))
(incf *setjmps*))
(if (plusp (blk-ref blk))
(make-c1form* 'BLOCK
:local-vars (list blk-var)
:type (values-type-or (blk-type blk) (c1form-type body))
:args blk body)
body))))
(defun c2block (c1form blk body)
(declare (ignore c1form))
(setf (blk-exit blk) *exit*
(blk-destination blk) *destination*)
(if (plusp (var-ref (blk-var blk)))
(let* ((blk-var (blk-var blk))
(*env-lvl* *env-lvl*))
(check-vref blk-var)
(wt-nl-open-brace)
(when (eq :object (var-kind blk-var))
(setf (var-loc blk-var) (next-lcl))
(wt-nl "cl_object " blk-var ";"))
(when (env-grows (var-ref-ccb blk-var))
;; var is referenced from a closure which may escape.
(let ((env-lvl *env-lvl*))
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
(wt-nl-open-brace)
(wt-nl "ecl_frs_push(cl_env_copy," blk-var ");")
(wt-nl "if (__ecl_frs_push_result!=0) {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
(unwind-exit 'VALUES)
(wt-nl "} else {")
(c2expr body)
(wt "}"))
(wt-nl-close-brace)
(when (var-ref-ccb blk-var) (decf *env*))
(wt-nl-close-brace))
(c2expr body)))
(defun c1return-from (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 cfb unw)
(cmp-env-search-block name)
(unless blk
(cmperr "The block ~s is undefined." name))
(let* ((val (c1expr (second args)))
(var (blk-var blk))
(type T))
(cond (cfb (setf type 'CLB
(var-ref-clb var) T))
(unw (setf type 'UNWIND-PROTECT)))
(incf (blk-ref blk))
(setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val)))
(let ((output (make-c1form* 'RETURN-FROM :type 'T :args blk type val)))
(when (or cfb unw)
(add-to-read-nodes var output))
output)))))
(defun c2return-from (c1form blk type val)
(declare (ignore c1form))
(case type
(CCB
(let ((*destination* 'VALUES)) (c2expr* val))
(wt-nl "cl_return_from(" (blk-var blk) "," (add-symbol (blk-name blk)) ");"))
((CLB UNWIND-PROTECT)
(let ((*destination* 'VALUES)) (c2expr* val))
(wt-nl "cl_return_from(" (blk-var blk) ",ECL_NIL);"))
(T (let ((*destination* (blk-destination blk))
(*exit* (blk-exit blk)))
(c2expr val)))))
......@@ -15,63 +15,6 @@
(in-package "COMPILER")
(defparameter +optimizable-constants+ '())
(defun c1constant-value (val &key always only-small-values)
(cond
((let ((x (assoc val *optimizable-constants*)))
(when x
(pushnew "#include <float.h>" *clines-string-list*)
(pushnew "#include <complex.h>" *clines-string-list*)
(setf x (cdr x))
(if (listp x)
(c1expr x)
x))))
((eq val nil) (c1nil))
((eq val t) (c1t))
((sys::fixnump val)
(make-c1form* 'LOCATION :type 'FIXNUM :args (list 'FIXNUM-VALUE val)))
((characterp val)
(make-c1form* 'LOCATION :type 'CHARACTER
:args (list 'CHARACTER-VALUE (char-code val))))
((typep val 'DOUBLE-FLOAT)
(when (and (ext:float-nan-p val) (not only-small-values))
(cmperr "Cannot externalize value ~A" val))
(make-c1form* 'LOCATION :type 'DOUBLE-FLOAT
:args (list 'DOUBLE-FLOAT-VALUE val (add-object val))))
((typep val 'SINGLE-FLOAT)
(when (and (ext:float-nan-p val) (not only-small-values))
(cmperr "Cannot externalize value ~A" val))
(make-c1form* 'LOCATION :type 'SINGLE-FLOAT
:args (list 'SINGLE-FLOAT-VALUE val (add-object val))))
((typep val 'LONG-FLOAT)
(when (and (ext:float-nan-p val) (not only-small-values))
(cmperr "Cannot externalize value ~A" val))
(make-c1form* 'LOCATION :type 'LONG-FLOAT
:args (list 'LONG-FLOAT-VALUE val (add-object val))))
#+sse2
((typep val 'EXT:SSE-PACK)
(c1constant-value/sse val))
(only-small-values nil)
(always
(make-c1form* 'LOCATION :type `(eql ,val)
:args (add-object val)))
(t nil)))
#+sse2
(defun c1constant-value/sse (value)
(let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8)))
(elt-type (ext:sse-pack-element-type value)))
(multiple-value-bind (wrapper rtype)
(case elt-type
(single-float (values "_mm_castsi128_ps" :float-sse-pack))
(double-float (values "_mm_castsi128_pd" :double-sse-pack))
(otherwise (values "" :int-sse-pack)))
`(c-inline () () ,rtype
,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))"
wrapper (coerce bytes 'list))
:one-liner t :side-effects nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; KNOWN OPTIMIZABLE CONSTANTS
......
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;;
;;;; 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 (args) (c1labels/flet 'LABELS args))
(defun c1flet (args) (c1labels/flet 'FLET args))
(defun c1labels/flet (origin args)
(check-args-number origin args 1)
(let ((new-env (cmp-env-copy))
(defs '())
(local-funs '())
(fnames '())
body-c1form)
;; 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. In the end
;; DEFS = ( { ( fun-object function-body ) }* ).
(dolist (def (car args))
(cmpck (or (endp def)
(not (si::valid-function-name-p (car def)))
(endp (cdr def)))
"The local function definition ~s is illegal." def)
(cmpck (member (car def) fnames)
"~s: The function ~s was already defined." origin (car def))
(push (car def) fnames)
(let* ((name (car def))
(var (make-var :name name :kind :object))
(fun (make-fun :name name :var var)))
(cmp-env-register-function fun new-env)
(push (cons fun (cdr def)) defs)))
;; Now we compile the functions, either in the current environment
;; or in an empty environment in which there are no new functions
(let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env))))
(dolist (def (nreverse defs))
(let ((fun (first def)))
;; The closure type will be fixed later on by COMPUTE-...
(push (c1compile-function (rest def) :fun fun)
local-funs))))
;; When we are in a LABELs form, we have to propagate the external
;; variables from one function to the other functions that use it.
(when (eq origin 'LABELS)
(loop for change = nil
do (loop for f1 in local-funs
for vars = (fun-referenced-vars f1)
for funs = (fun-referenced-funs f1)
do (loop for f2 in (fun-referencing-funs f1)
for c1 = (add-to-fun-referenced-vars f2 vars)
for c2 = (add-to-fun-referenced-funs f2 funs)
for c3 = (update-fun-closure-type f2)
when (or c1 c2 c3)
do (setf change t)))
do (unless change (return))))
;; Now we can compile the body itself.
(let ((*cmp-env* new-env))
(multiple-value-bind (body ss ts is other-decl)
(c1body (rest args) t)
(mapc #'cmp-env-declare-special ss)
(check-vdecl nil ts is)
(setq body-c1form (c1decl-body other-decl body))))
;; Keep only functions that have been referenced at least once.
;; It is not possible to look at FUN-REF before because functions
;; in a LABELS can reference each other.
(setf local-funs (remove-if-not #'plusp local-funs :key #'fun-ref))
;; Keep on inspecting the functions until the closure type does not
;; change.
(loop while
(let ((x nil))
(loop for f in local-funs
when (update-fun-closure-type f)
do (setf x t))
x))
(if local-funs
(make-c1form* 'LOCALS :type (c1form-type body-c1form)
:args local-funs body-c1form (eq origin 'LABELS))
body-c1form)))
(defun child-function-p (presumed-parent fun)
(declare (optimize speed))
(loop for real-parent = (fun-parent fun)
while real-parent
do (if (eq real-parent presumed-parent)
(return t)
(setf fun real-parent))))
(defun compute-closure-type (fun)
(declare (si::c-local))
(let ((lexical-closure-p nil))
;; it will have a full closure if it refers external non-global variables
(dolist (var (fun-referenced-vars fun))
(cond ((global-var-p var))
;; ...across CB
((ref-ref-ccb var)
(return-from compute-closure-type 'CLOSURE))
(t
(setf lexical-closure-p t))))
;; ...or if it directly calls a function
(dolist (f (fun-referenced-funs fun))
(unless (child-function-p fun f)
;; .. which has a full closure
(case (fun-closure f)
(CLOSURE (return-from compute-closure-type 'CLOSURE))
(LEXICAL (setf lexical-closure-p t)))))
;; ...or the function itself is referred across CB
(when lexical-closure-p
(if (or (fun-ref-ccb fun)
(and (fun-var fun)
(plusp (var-ref (fun-var fun)))))
'CLOSURE
'LEXICAL))))
(defun update-fun-closure-type-many (function-list)
(do ((finish nil t)
(recompute nil))
(finish
recompute)
(dolist (f function-list)
(when (update-fun-closure-type f)
(setf recompute t finish nil)))))
(defun prepend-new (l1 l2)
(loop for f in l1
do (pushnew f l2))
l2)
(defun update-fun-closure-type (fun)
(let ((old-type (fun-closure fun)))
(when (eq old-type 'closure)
(return-from update-fun-closure-type nil))
;; This recursive algorithm is guaranteed to stop when functions
;; do not change.
(let ((new-type (compute-closure-type fun))
to-be-updated)
;; Same type
(when (eq new-type old-type)
(return-from update-fun-closure-type nil))
(when (fun-global fun)
(cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}"
(fun-name fun) (mapcar #'var-name (fun-referenced-vars fun))))
(setf to-be-updated (append (fun-child-funs fun) (fun-referencing-funs fun)))
(setf (fun-closure fun) new-type)
;; All external, non-global variables become of type closure
(when (eq new-type 'CLOSURE)
(dolist (var (fun-referenced-vars fun))
(unless (or (global-var-p var)
(eq (var-kind var) new-type))
(setf (var-ref-clb var) nil
(var-ref-ccb var) t
(var-kind var) 'CLOSURE
(var-loc var) 'OBJECT
to-be-updated
(prepend-new (var-functions-reading var)
(prepend-new (var-functions-setting var)
to-be-updated)))))
(dolist (f (fun-referenced-funs fun))
(setf (fun-ref-ccb f) t)))
;; If the status of some of the children changes, we have
;; to recompute the closure type.
(when (update-fun-closure-type-many to-be-updated)
(update-fun-closure-type fun))
t)))
(defun c2locals (c1form funs body labels ;; labels is T when deriving from labels
&aux
(*env* *env*)
(*inline-blocks* 0)
(*env-lvl* *env-lvl*))
(declare (ignore c1form labels))
;; create location for each function which is returned,
;; either in lexical:
(loop with env-grows = nil
with closed-vars = '()
for fun in funs
for var = (fun-var fun)
when (plusp (var-ref var))
do (case (var-kind var)
((lexical closure)
(push var closed-vars)
(unless env-grows
(setq env-grows (var-ref-ccb var))))
(otherwise
(maybe-open-inline-block)
(bind (next-lcl) var)
(wt-nl "cl_object " *volatile* var ";")))
finally
;; if we have closed variables
(when (env-grows env-grows)
(maybe-open-inline-block)
(let ((env-lvl *env-lvl*))
(wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
;; bind closed locations because of possible circularities
(loop for var in closed-vars
do (bind nil var)))
;; create the functions:
(mapc #'new-local funs)
;; - then assign to it
(loop for fun in funs
for var = (fun-var fun)
when (plusp (var-ref var))
do (set-var (list 'MAKE-CCLOSURE fun) var))
(c2expr body)
(close-inline-blocks))
(defun c1decl-body (decls body)
(if (null decls)
(c1progn body)
(let* ((*cmp-env* (reduce #'add-one-declaration decls
:initial-value (cmp-env-copy *cmp-env*))))
(c1progn body))))
(defun c1locally (args)
(multiple-value-bind (body ss ts is other-decl)
(c1body args t)
(if (or ss ts is other-decl)
(let ((*cmp-env* (cmp-env-copy)))
(mapc #'cmp-env-declare-special ss)
(check-vdecl nil ts is)
(c1decl-body other-decl body))
(c1progn body))))
(defun c1macrolet (args)
(check-args-number 'MACROLET args 1)
(let ((*cmp-env* (si:cmp-env-register-macrolet (first args) (cmp-env-copy))))
(c1locally (cdr args))))
(defun c1symbol-macrolet (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 (cdr args))))
(defun local-function-ref (fname &optional build-object)
(multiple-value-bind (fun cfb unw)
(cmp-env-search-function fname)
(declare (ignore unw))
(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." fname))
(return-from local-function-ref nil))
(incf (fun-ref fun))
(if build-object
(setf (fun-ref-ccb fun) t)
(let ((caller *current-function*))
(when (and caller
(not (member fun (fun-referenced-funs caller) :test #'eq)))
(push fun (fun-referenced-funs caller))
(push caller (fun-referencing-funs fun)))))
;; we introduce a variable to hold the funob
(let ((var (fun-var fun)))
(when (and cfb build-object)
(setf (var-ref-clb var) t)
(when (not (eq (var-kind var) 'CLOSURE))
(setf (var-kind var) 'LEXICAL)))))
fun))
(defun c2call-local (c1form fun args)
(declare (type fun fun))
(unless (c2try-tail-recursive-call fun args)
(let ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit (call-loc (fun-name fun) fun (inline-args args)
(c1form-primary-type c1form)))
(close-inline-blocks))))
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;;
;;;; 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")
(defun c1apply (args)
(check-args-number 'APPLY args 2)
(flet ((default-apply (fun arguments)
(let ((form (c1funcall (list* '#'APPLY fun arguments))))
(when (and (consp fun) (eq (first fun) 'FUNCTION))
(let* ((fname (second fun))
(type (get-return-type fname)))
(when type
(setf (c1form-type form) type))))
form)))
(let* ((fun (first args))
(arguments (rest args)))
(cond ((eql (first (last arguments)) 'clos::.combined-method-args.)
;; Uses frames instead of lists as last argumennt
(default-apply fun arguments))
((and (consp fun)
(member (first fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
(optimize-funcall/apply-lambda (macroexpand-lambda-block fun)
arguments t))
((and (consp fun)
(eq (first fun) 'FUNCTION)
(consp (second fun))
(member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
(c1apply (list* (second fun) arguments)))