mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-02-08 00:20:41 -08:00
8f07cd58d8
by spaces. A custom script was used to insert/replace Emacs and ViM per-file editor settings according to their type and the new ECL coding style.
331 lines
11 KiB
Common Lisp
331 lines
11 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
|
|
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
|
|
|
;;;;
|
|
;;;; Copyright (c) 2010, 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.
|
|
|
|
;;;; CMPPROP Type propagation.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(eval-when (:compile-toplevel :execute)
|
|
(defconstant +all-c1-forms+
|
|
'((LOCATION loc :pure :single-valued)
|
|
(VAR var :single-valued)
|
|
(SETQ var value-c1form :side-effects)
|
|
(PSETQ var-list value-c1form-list :side-effects)
|
|
(BLOCK blk-var progn-c1form :pure)
|
|
(PROGN body :pure)
|
|
(PROGV symbols values form :side-effects)
|
|
(TAGBODY tag-var tag-body :pure)
|
|
(RETURN-FROM blk-var return-type value variable-or-nil :side-effects)
|
|
(FUNCALL fun-value (arg-value*) :side-effects)
|
|
(CALL-LOCAL obj-fun (arg-value*) :side-effects)
|
|
(CALL-GLOBAL fun-name (arg-value*))
|
|
(CATCH catch-value body :side-effects)
|
|
(UNWIND-PROTECT protected-c1form body :side-effects)
|
|
(THROW catch-value output-value :side-effects)
|
|
(GO tag-var return-type :side-effects)
|
|
(C-INLINE (arg-c1form*)
|
|
(arg-type-symbol*)
|
|
output-rep-type
|
|
c-expression-string
|
|
side-effects-p
|
|
one-liner-p)
|
|
(C-PROGN variables forms)
|
|
(LOCALS local-fun-list body labels-p :pure)
|
|
(IF fmla-c1form true-c1form false-c1form :pure)
|
|
(FMLA-NOT fmla-c1form :pure)
|
|
(FMLA-AND * :pure)
|
|
(FMLA-OR * :pure)
|
|
(LAMBDA lambda-list doc body-c1form)
|
|
(LET* vars-list var-init-c1form-list decl-body-c1form :pure)
|
|
(VALUES values-c1form-list :pure)
|
|
(MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
|
|
(MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
|
|
(COMPILER-LET symbols values body)
|
|
(FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
|
|
(RPLACD (dest-c1form value-c1form) :side-effects)
|
|
|
|
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
|
|
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
|
|
|
|
(WITH-STACK body :side-effects)
|
|
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
|
|
|
|
(ORDINARY c1form :pure)
|
|
(LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
|
|
(SI:FSET function-object vv-loc macro-p pprint-p lambda-form
|
|
:side-effects)
|
|
(MAKE-FORM vv-loc value-c1form :side-effects)
|
|
(INIT-FORM vv-loc value-c1form :side-effects)
|
|
(EXT:COMPILER-TYPECASE var expressions)
|
|
(CHECKED-VALUE type value-c1form let-form))))
|
|
|
|
(defconstant +c1-form-hash+
|
|
#.(loop with hash = (make-hash-table :size 128 :test #'eq)
|
|
for (name . rest) in +all-c1-forms+
|
|
for length = (if (member '* rest) nil (length rest))
|
|
for side-effects = (if (member :side-effects rest)
|
|
(progn (and length (decf length)) t)
|
|
nil)
|
|
for movable = (if (member :pure rest)
|
|
(progn (and length (decf length)) t)
|
|
nil)
|
|
for single-valued = (if (member :single-valued rest)
|
|
(progn (and length (decf length)) t)
|
|
nil)
|
|
do (setf (gethash name hash) (list length side-effects movable single-valued))
|
|
finally (return hash)))
|
|
|
|
(defconstant +c1-dispatch-alist+
|
|
'((block . c1block) ; c1special
|
|
(return-from . c1return-from) ; c1special
|
|
(funcall . c1funcall) ; c1
|
|
(catch . c1catch) ; c1special
|
|
(unwind-protect . c1unwind-protect) ; c1special
|
|
(throw . c1throw) ; c1special
|
|
(ffi:defcallback . c1-defcallback) ; c1
|
|
(progn . c1progn) ; c1special
|
|
(ext:with-backend . c1with-backend) ; c1special
|
|
(ffi:clines . c1clines) ; c1special
|
|
(ffi:c-inline . c1c-inline) ; c1special
|
|
(ffi:c-progn . c1c-progn) ; c1special
|
|
(flet . c1flet) ; c1special
|
|
(labels . c1labels) ; c1special
|
|
(locally . c1locally) ; c1special
|
|
(macrolet . c1macrolet) ; c1special
|
|
(symbol-macrolet . c1symbol-macrolet) ; c1special
|
|
|
|
(if . c1if) ; c1special
|
|
(not . c1not) ; c1special
|
|
(and . c1and) ; c1special
|
|
(or . c1or) ; c1special
|
|
|
|
(let . c1let) ; c1special
|
|
(let* . c1let*) ; c1special
|
|
|
|
(multiple-value-call . c1multiple-value-call) ; c1special
|
|
(multiple-value-prog1 . c1multiple-value-prog1) ; c1special
|
|
(values . c1values) ; c1
|
|
(multiple-value-setq . c1multiple-value-setq) ; c1
|
|
(multiple-value-bind . c1multiple-value-bind) ; c1
|
|
|
|
(ext:compiler-typecase . c1compiler-typecase) ; c1special
|
|
(checked-value . c1checked-value) ; c1special
|
|
|
|
(quote . c1quote) ; c1special
|
|
(function . c1function) ; c1special
|
|
(the . c1the) ; c1special
|
|
(ext:truly-the . c1truly-the) ; c1special
|
|
(eval-when . c1eval-when) ; c1special
|
|
(declare . c1declare) ; c1special
|
|
(ext:compiler-let . c1compiler-let) ; c1special
|
|
|
|
(with-stack . c1with-stack) ; c1
|
|
(innermost-stack-frame . c1innermost-stack-frame) ; c1
|
|
(stack-push . c1stack-push) ; c1
|
|
(stack-push-values . c1stack-push-values) ; c1
|
|
(stack-pop . c1stack-pop) ; c1
|
|
(si::apply-from-stack-frame . c1apply-from-stack-frame) ; c1
|
|
|
|
(tagbody . c1tagbody) ; c1special
|
|
(go . c1go) ; c1special
|
|
|
|
(setq . c1setq) ; c1special
|
|
(progv . c1progv) ; c1special
|
|
(psetq . c1psetq) ; c1special
|
|
|
|
(load-time-value . c1load-time-value) ; c1
|
|
|
|
(apply . c1apply) ; c1
|
|
))
|
|
|
|
(defconstant +t1-dispatch-alist+
|
|
'((ext:with-backend . c1with-backend) ; t1
|
|
|
|
(defmacro . t1defmacro)
|
|
(compiler-let . c1compiler-let)
|
|
(eval-when . c1eval-when)
|
|
(progn . c1progn)
|
|
(macrolet . c1macrolet)
|
|
(locally . c1locally)
|
|
(symbol-macrolet . c1symbol-macrolet)
|
|
(si:fset . t1fset)
|
|
))
|
|
|
|
(defconstant +set-loc-dispatch-alist+
|
|
'((bind . bind)
|
|
(jump-true . set-jump-true)
|
|
(jump-false . set-jump-false)
|
|
|
|
(values . set-values-loc)
|
|
(value0 . set-value0-loc)
|
|
(return . set-return-loc)
|
|
(trash . set-trash-loc)
|
|
|
|
(the . set-the-loc)
|
|
))
|
|
|
|
(defconstant +wt-loc-dispatch-alist+
|
|
'((call-normal . wt-call-normal)
|
|
(call-indirect . wt-call-indirect)
|
|
(ffi:c-inline . wt-c-inline-loc)
|
|
(coerce-loc . wt-coerce-loc)
|
|
|
|
(temp . wt-temp)
|
|
(lcl . wt-lcl-loc)
|
|
(fixnum-value . wt-number)
|
|
(long-float-value . wt-number)
|
|
(double-float-value . wt-number)
|
|
(single-float-value . wt-number)
|
|
(short-float-value . wt-number)
|
|
(character-value . wt-character)
|
|
(value . wt-value)
|
|
(keyvars . wt-keyvars)
|
|
(the . wt-the)
|
|
|
|
(fdefinition . wt-fdefinition)
|
|
(make-cclosure . wt-make-closure)
|
|
|
|
(structure-ref . wt-structure-ref)
|
|
|
|
(nil . "ECL_NIL")
|
|
(t . "ECL_T")
|
|
(return . "value0")
|
|
(values . "cl_env_copy->values[0]")
|
|
(va-arg . "va_arg(args,cl_object)")
|
|
(cl-va-arg . "ecl_va_arg(args)")
|
|
(value0 . "value0")
|
|
))
|
|
|
|
(defconstant +c2-dispatch-alist+
|
|
'((block . c2block) ; c2
|
|
(return-from . c2return-from) ; c2
|
|
(funcall . c2funcall) ; c2
|
|
(call-global . c2call-global) ; c2
|
|
(catch . c2catch) ; c2
|
|
(unwind-protect . c2unwind-protect) ; c2
|
|
(throw . c2throw) ; c2
|
|
(progn . c2progn) ; c2
|
|
(ffi:c-inline . c2c-inline) ; c2
|
|
(ffi:c-progn . c2c-progn) ; c2
|
|
(locals . c2locals) ; c2
|
|
(call-local . c2call-local) ; c2
|
|
|
|
(if . c2if)
|
|
(fmla-not . c2fmla-not)
|
|
(fmla-and . c2fmla-and)
|
|
(fmla-or . c2fmla-or)
|
|
|
|
(let* . c2let*)
|
|
|
|
(values . c2values) ; c2
|
|
(multiple-value-setq . c2multiple-value-setq) ; c2
|
|
(multiple-value-bind . c2multiple-value-bind) ; c2
|
|
|
|
(function . c2function) ; c2
|
|
(ext:compiler-let . c2compiler-let) ; c2
|
|
|
|
(with-stack . c2with-stack) ; c2
|
|
(stack-push-values . c2stack-push-values) ; c2
|
|
|
|
(tagbody . c2tagbody) ; c2
|
|
(go . c2go) ; c2
|
|
|
|
(var . c2var/location) ; c2
|
|
(location . c2var/location) ; c2
|
|
(setq . c2setq) ; c2
|
|
(progv . c2progv) ; c2
|
|
(psetq . c2psetq) ; c2
|
|
|
|
(si:fset . c2fset)
|
|
|
|
(ext:compiler-typecase . c2compiler-typecase)
|
|
(checked-value . c2checked-value)
|
|
))
|
|
|
|
(defconstant +t2-dispatch-alist+
|
|
'((compiler-let . t2compiler-let)
|
|
(progn . t2progn)
|
|
(ordinary . t2ordinary)
|
|
(load-time-value . t2load-time-value)
|
|
(make-form . t2make-form)
|
|
(init-form . t2init-form)
|
|
(si:fset . t2fset)
|
|
))
|
|
|
|
(defconstant +p1-dispatch-alist+
|
|
'((block . p1block)
|
|
(return-from . p1return-from)
|
|
(call-global . p1call-global)
|
|
(call-local . p1call-local)
|
|
(catch . p1catch)
|
|
(throw . p1throw)
|
|
(if . p1if)
|
|
(fmla-not . p1fmla-not)
|
|
(fmla-and . p1fmla-and)
|
|
(fmla-or . p1fmla-or)
|
|
(lambda . p1lambda)
|
|
(let* . p1let*)
|
|
(locals . p1locals)
|
|
(multiple-value-bind . p1multiple-value-bind)
|
|
(multiple-value-setq . p1multiple-value-setq)
|
|
(progn . p1progn)
|
|
(progv . p1progv)
|
|
(setq . p1setq)
|
|
(psetq . p1psetq)
|
|
(tagbody . p1tagbody)
|
|
(go . p1go)
|
|
(unwind-protect . p1unwind-protect)
|
|
(ordinary . p1ordinary)
|
|
(sys::fset . p1fset)
|
|
(var . p1var)
|
|
(values . p1values)
|
|
(location . p1trivial) ;; Some of these can be improved
|
|
(ffi:c-inline . p1trivial)
|
|
(ffi:c-progn . p1trivial)
|
|
(function . p1trivial)
|
|
(funcall . p1trivial)
|
|
(load-time-value . p1trivial)
|
|
(make-form . p1trivial)
|
|
(init-form . p1trivial)
|
|
(c::with-stack . p1with-stack)
|
|
(c::stack-push-values . p1stack-push-values)
|
|
(ext:compiler-typecase . p1compiler-typecase)
|
|
(checked-value . p1checked-value)
|
|
))
|
|
|
|
(defun make-dispatch-table (alist)
|
|
(loop with hash = (make-hash-table :size (max 128 (* 2 (length alist)))
|
|
:test #'eq)
|
|
for (name . function) in alist
|
|
do (setf (gethash name hash) function)
|
|
finally (return hash)))
|
|
|
|
(defparameter *c1-dispatch-table* (make-dispatch-table +c1-dispatch-alist+))
|
|
|
|
(defparameter *t1-dispatch-table* (make-dispatch-table +t1-dispatch-alist+))
|
|
|
|
(defparameter *c2-dispatch-table* (make-dispatch-table +c2-dispatch-alist+))
|
|
|
|
(defparameter *set-loc-dispatch-table* (make-dispatch-table +set-loc-dispatch-alist+))
|
|
|
|
(defparameter *wt-loc-dispatch-table* (make-dispatch-table +wt-loc-dispatch-alist+))
|
|
|
|
(defparameter *t2-dispatch-table* (make-dispatch-table +t2-dispatch-alist+))
|
|
|
|
(defparameter *p1-dispatch-table* (make-dispatch-table +p1-dispatch-alist+)
|
|
"Dispatch table for type propagators associated to C1FORMs.")
|
|
|
|
(defparameter *p0-dispatch-table* (make-dispatch-table '())
|
|
"Type propagators for known functions.")
|
|
|
|
(defparameter *cinline-dispatch-table* (make-dispatch-table '()))
|