Finished the new dispatch code.

src/cmp/cmpcall.lsp

@@ -157,10 +157,7 @@
   (cond
     ;; Check whether it is a global function that we cannot call directly.
      ((and (or (null loc) (fun-global loc)) (not (inline-possible fname)))
-      (if (and *compile-to-linking-call*
-	       (<= (cmp-env-optimization 'debug) 1))
-	  (call-linking-loc fname narg args)
-	  (call-unknown-global-loc fname nil narg args)))
+      (call-unknown-global-loc fname nil narg args))
 
      ;; Open-codable function call.
      ((and (or (null loc) (fun-global loc))
@@ -193,30 +190,11 @@
      ((multiple-value-setq (found fd minarg maxarg) (si::mangle-name fname t))
       (call-exported-function-loc fname narg args fd minarg maxarg t))
 
-     ;; Linking calls can only be made to symbols
-     ((and *compile-to-linking-call* (<= (cmp-env-optimization 'debug) 1))
-      (call-linking-loc fname narg args))
-
      (t (call-unknown-global-loc fname loc narg args))))
 
 (defun call-loc (fname loc narg args)
   `(CALL-NORMAL ,loc ,(coerce-locs args)))
 
-(defun call-linking-loc (fname narg args &aux i)
-  (let ((fun (second (assoc fname *linking-calls*))))
-    (unless fun
-      (let* ((i (length *linking-calls*))
-             (c-id (lisp-to-c-name fname))
-	     (var-name (format nil "LK~d~A" i c-id))
-	     (c-name (format nil "LKF~d~A" i c-id)))
-	(cmpnote "Emitting linking call for ~a" fname)
-	(setf fun (make-fun :name fname :global t :lambda 'NIL
-			    :cfun (format nil "(*~A)" var-name)
-			    :minarg 0 :maxarg call-arguments-limit))
-	(setf *linking-calls* (cons (list fname fun (add-symbol fname) c-name var-name)
-				    *linking-calls*))))
-    (call-loc fname fun narg args)))
-
 (defun call-exported-function-loc (fname narg args fun-c-name minarg maxarg in-core)
   (unless in-core
     ;; We only write declarations for functions which are not in lisp_external.h
@@ -248,30 +226,15 @@
 ;;;   NARG is a location containing the number of ARGS-PUSHED
 ;;;
 (defun call-unknown-global-loc (fname loc narg args)
-  (unless loc
-    (setq loc
-	  (if (and (symbolp fname)
-		   (not (eql (symbol-package fname) (find-package "CL"))))
-	      (progn
-		(cmpnote "Emitting FUNCALL for ~S" fname)
-		(add-symbol fname))
-	      (progn
-		(cmpnote "Emitting FDEFINITION for ~S" fname)
-		(setq loc (list 'FDEFINITION fname))))))
-  (do ((i 0 (1+ i))
-       (l args (cdr l)))
-      ((endp l)
-       (progn
-	 (cond ((> i *max-stack*)
-		(setf *max-stack* i))
-	       ((zerop *max-stack*)
-		(setf *max-stack* 1)))
-	 (wt-nl +ecl-local-stack-frame-variable+ ".top = "
-		+ecl-local-stack-variable+ "+" i ";")
-	 `(CALL "ecl_apply_from_stack_frame" ((LOCAL-FRAME NIL) ,loc) ,fname)))
-    (wt-nl +ecl-local-stack-variable+ "[" i "]=")
-    (wt-coerce-loc :object (second (first l)))
-    (wt ";")))
+  `(CALL-INDIRECT ,(cond (loc loc)
+                         ((and (symbolp fname)
+                               (not (eql (symbol-package fname) (find-package "CL"))))
+                          (cmpnote "Emitting FUNCALL for ~S" fname)
+                          (add-symbol fname))
+                         (t
+                          (cmpnote "Emitting FDEFINITION for ~S" fname)
+                          (list 'FDEFINITION fname)))
+                  ,(or narg (length args)) ,(coerce-locs args)))
 
 ;;; Functions that use MAYBE-SAVE-VALUE should rebind *temp*.
 (defun maybe-save-value (value &optional (other-forms nil other-forms-flag))
@@ -303,17 +266,24 @@
 
 (defun wt-call (fun args &optional fname env)
   (if env
-    (progn
-     (wt "(cl_env_copy->function=" env ",")
-     (wt-call fun args)
-     (wt ")"))
-    (progn
-     (wt fun "(")
-     (let ((comma ""))
-       (dolist (arg args)
-	 (wt comma arg)
-	 (setf comma ",")))
-     (wt ")")))
+      (progn
+        (wt "(cl_env_copy->function=" env ",")
+        (wt-call fun args)
+        (wt ")"))
+      (progn
+        (wt fun "(")
+        (let ((comma ""))
+          (dolist (arg args)
+            (wt comma arg)
+            (setf comma ",")))
+        (wt ")")))
+  (when fname (wt-comment fname)))
+
+(defun wt-call-indirect (fun-loc narg args &optional fname)
+  (wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg)
+  (dolist (arg args)
+    (wt "," arg))
+  (wt ")")
   (when fname (wt-comment fname)))
 
 (defun wt-call-normal (fun args)
@@ -352,3 +322,4 @@
 
 (put-sysprop 'CALL 'WT-LOC #'wt-call)
 (put-sysprop 'CALL-NORMAL 'WT-LOC #'wt-call-normal)
+(put-sysprop 'CALL-INDIRECT 'WT-LOC #'wt-call-indirect)

src/cmp/cmpcbk.lsp

@@ -109,7 +109,7 @@
                      n "," ct "));")
 	      (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var"
                      n "," ct "," (ffi:size-of-foreign-type type) "));")))
-    (wt-nl "aux = ecl_apply_from_stack_frame(frame,"
+    (wt-nl "aux = ecl_apply_from_stack_frame(cl_env_copy,frame,"
            "ecl_fdefinition(" c-name-constant "));")
     (wt-nl "ecl_stack_frame_close(frame);")
     (when return-p

src/cmp/cmpdefs.lsp

@@ -283,7 +283,7 @@ progress. The default value is T.")
 (defvar *suppress-compiler-notes* nil) ; Deprecated
 (defvar *suppress-compiler-warnings* nil) ; Deprecated
 
-(defvar *compiler-break-enable* nil)
+(defvar *compiler-break-enable* t)
 
 (defvar *compiler-in-use* nil)
 (defvar *compiler-input*)
@@ -339,8 +339,6 @@ progress. The default value is T.")
 (defvar *next-cmacro* 0)	; holds the last cmacro number used.
 (defvar *next-cfun* 0)		; holds the last cfun used.
 
-(defvar *max-stack* 0)		; maximum space used in lisp stack
-
 ;;;
 ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
 ;;; If possible, *tail-recursion-info* holds

src/cmp/cmpenv.lsp

@@ -22,7 +22,6 @@
   '((*compiler-in-use* t)
     (*compiler-phase* 't1)
     (*callbacks* nil)
-    (*max-stack* 0)
     (*max-temp* 0)
     (*temp* 0)
     (*next-cmacro* 0)

src/cmp/cmploc.lsp

@@ -29,6 +29,7 @@
 ;;;	( FRAME ndx )			variable in local frame stack
 ;;;	( CALL c-fun-name args fname )	locs are locations containing the arguments
 ;;;	( CALL-NORMAL fun locs)		similar as CALL, but number of arguments is fixed
+;;;	( CALL-INDIRECT fun narg args)	similar as CALL, but unknown function
 ;;;	( C-INLINE output-type fun/string locs side-effects output-var )
 ;;;	( COERCE-LOC representation-type location)
 ;;;	( CAR lcl )
@@ -68,7 +69,8 @@
 
 (defun set-loc (loc &aux fd
 		    (is-call (and (consp loc)
-				  (member (car loc) '(CALL CALL-NORMAL)  :test #'eq))))
+				  (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT)
+                                          :test #'eq))))
   (when (eql *destination* loc)
     (return-from set-loc))
   (case *destination*
@@ -186,14 +188,8 @@
 (defun values-loc (n)
   (list 'VALUE n))
 
-(defun wt-local-frame (n)
-  (if n
-      (wt +ecl-local-stack-variable+ "[" n "]")
-      (wt "((cl_object)&" +ecl-local-stack-frame-variable+ ")")))
-
 ;;; -----------------------------------------------------------------
 
-(put-sysprop 'LOCAL-FRAME 'WT-LOC #'wt-local-frame)
 (put-sysprop 'TEMP 'WT-LOC #'wt-temp)
 (put-sysprop 'LCL 'WT-LOC #'wt-lcl-loc)
 (put-sysprop 'VV 'WT-LOC #'wt-vv)

src/cmp/cmpstack.lsp

@@ -77,7 +77,7 @@
 
 (defun c1apply-from-stack-frame (args)
   (c1expr `(c-inline ,args (t t) (values &rest t)
-		     "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);"
+		     "cl_env_copy->values[0]=ecl_apply_from_stack_frame(cl_env_copy,#0,#1);"
 		     :one-liner nil :side-effects t)))
 
 (put-sysprop 'with-stack 'C1 #'c1with-stack)

src/cmp/cmptop.lsp

@@ -112,7 +112,6 @@
     (wt-nl-h "#include <string.h>"))
   ;;; Initialization function.
   (let* ((*lcl* 0) (*lex* 0) (*max-lex* 0) (*max-env* 0) (*max-temp* 0)
-	 (*max-stack* 0)
 	 (*reservation-cmacro* (next-cmacro))
 	 (c-output-file *compiler-output1*)
 	 (*compiler-output1* (make-string-output-stream))
@@ -374,10 +373,6 @@
     (wt-h " volatile cl_object lex" *level* "[" *max-lex* "];"))
   (wt-nl-h "#define CLSR" *reservation-cmacro*)
   (wt-nl-h "#define STCK" *reservation-cmacro*)
-  (unless (zerop *max-stack*)
-    (wt-h " cl_object " +ecl-local-stack-variable+ "[" *max-stack* "]; "
-	  "struct ecl_stack_frame " +ecl-local-stack-frame-variable+
-	  " = { t_frame, 0, 0, 0, " +ecl-local-stack-variable+ ", 0, 0 };"))
   (when (plusp *max-env*)
     (unless (eq closure-type 'CLOSURE)
       (wt-h " cl_object " *volatile* "env0;"))

src/cmp/sysfun.lsp

@@ -351,7 +351,6 @@
 (proclaim-function evalhook (t t t *) t)
 (proclaim-function applyhook (t t t t *) t)
 (proclaim-function constantp (t) t :predicate t)
-(proclaim-function si:unlink-symbol (*) t)
 (proclaim-function si::link-enable (*) t)
 
 ;; file file.d