;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;  Copyright (c) 2010-2012, Jean-Claude Beaudoin.
;;;;
;;;;  This program is free software; you can redistribute it and/or
;;;;  modify it under the terms of the GNU Lesser General Public
;;;;  License as published by the Free Software Foundation; either
;;;;  version 3 of the License, or (at your option) any later version.
;;;;
;;;;  See file '../../Copyright' for full details.

;;;; CMPDEF	Definitions

(si::reopen-package "CL")

(defpackage "COMPILER"
  ;;(:nicknames "COMPILER")
  (:use "FFI" "CL")
  (:export "*COMPILER-BREAK-ENABLE*"
	   "*COMPILE-PRINT*"
	   "*COMPILE-VERBOSE*"
	   "BUILD-BUNDLE"
           "BUILD-FASL"
	   "BUILD-PROGRAM"
	   "BUILD-STATIC-LIBRARY"
	   "BUILD-SHARED-LIBRARY"
	   "COMPILER-WARNING"
	   "COMPILER-STYLE-WARNING"
	   "COMPILER-NOTE"
	   "COMPILER-MESSAGE"
	   "COMPILER-ERROR"
	   "COMPILER-FATAL-ERROR"
	   "COMPILER-INTERNAL-ERROR"
	   "COMPILER-UNDEFINED-VARIABLE"
	   "COMPILER-MESSAGE-FILE"
	   "COMPILER-MESSAGE-FILE-END-POSITION"
	   "COMPILER-MESSAGE-FORM"
	   "*SUPPRESS-COMPILER-WARNINGS*"
	   "*SUPPRESS-COMPILER-NOTES*"
	   "*SUPPRESS-COMPILER-MESSAGES*")
  (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" "COMPILER-LET"))

(in-package "COMPILER")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; COMPILER STRUCTURES
;;;

;;;
;;; REF OBJECT
;;;
;;; Base object for functions, variables and statements. We use it to
;;; keep track of references to objects, how many times the object is
;;; referenced, by whom, and whether the references cross some closure
;;; boundaries.
;;;

(defstruct (ref (:print-object print-ref))
  name			;;; Identifier of reference.
  (ref 0 :type fixnum)	;;; Number of references.
  ref-ccb		;;; Cross closure reference.
			;;; During Pass1, T or NIL.
			;;; During Pass2, the index into the closure env
  ref-clb		;;; Cross local function reference.
			;;; During Pass1, T or NIL.
			;;; During Pass2, the lex-address for the
			;;; block id, or NIL.
  read-nodes		;;; Nodes (c1forms) in which the reference occurs
)

(deftype OBJECT () `(not (or fixnum character float)))

(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var))
;  name		;;; Variable name.
;  (ref 0 :type fixnum)
		;;; Number of references to the variable (-1 means IGNORE).
;  ref-ccb	;;; Cross closure reference: T or NIL.
;  ref-clb	;;; Cross local function reference: T or NIL.
;  read-nodes	;;; Nodes (c1forms) in which the reference occurs
  set-nodes	;;; Nodes in which the variable is modified
  kind		;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM,
  		;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for
		;;; LET variables).
  (function *current-function*)
		;;; For local variables, in which function it was created.
		;;; For global variables, it doesn't have a meaning.
  (functions-setting nil)
  (functions-reading nil)
		;;; Functions in which the variable has been modified or read.
  (loc 'OBJECT)	;;; During Pass 1: indicates whether the variable can
		;;; be allocated on the call-stack: OBJECT means
		;;; the variable is declared as OBJECT, and CLB means
		;;; the variable is referenced across Level Boundary and thus
		;;; cannot be allocated on the C stack.  Note that OBJECT is
		;;; set during variable binding and CLB is set when the
		;;; variable is used later, and therefore CLB may supersede
		;;; OBJECT.
		;;; During Pass 2:
  		;;; For REPLACED: the actual location of the variable.
  		;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
  		;;;   the cvar for the C variable that holds the value.
  		;;; For LEXICAL or CLOSURE: the frame-relative address for
		;;; the variable in the form of a cons '(lex-levl . lex-ndx)
		;;;	lex-levl is the level of lexical environment
		;;;	lex-ndx is the index within the array for this env.
		;;; For SPECIAL and GLOBAL: the vv-index for variable name.
  (type t)	;;; Type of the variable.
  (index -1)    ;;; position in *vars*.
  (ignorable nil)
  (cloc nil)    ;;; Closure location. Replacement for "loc". Temporary! JCB
  (extent nil)  ;;; Either NIL (for indefinite) or DYNAMIC. JCB
  )

;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE
;;; Here are examples of function FOO for the 3 cases:
;;; 1.  (flet ((foo () (bar))) (foo))		CFUN
;;; 2.  (flet ((foo () (bar))) #'foo)		CFUN+LISP_CFUN
;;; 3.  (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE
;;; 4.  (flet ((foo () x)) #'foo)		CCLOSURE+LISP_CLOSURE

;;; A function can be referred across a ccb without being a closure, e.g:
;;;   (flet ((foo () (bar))) #'(lambda () (foo)))
;;;   [the lambda also need not be a closure]
;;; and it can be a closure without being referred across ccb, e.g.:
;;;   (flet ((foo () x)) #'foo)  [ is this a mistake in local-function-ref?]
;;; Here instead the lambda must be a closure, but no closure is needed for foo
;;;   (flet ((foo () x)) #'(lambda () (foo)))
;;; So we use two separate fields: ref-ccb and closure.
;;; A CCLOSURE must be created for a function when:
;;; 1. it appears within a FUNCTION construct and
;;; 2. it uses some ccb references (directly or indirectly).
;;; ref-ccb corresponds to the first condition, i.e. function is referred
;;;   across CCB. It is computed during Pass 1. A value of 'RETURNED means
;;;   that it is immediately within FUNCTION.
;;; closure corresponds to second condition and is computed in Pass 2 by
;;;   looking at the info-referred-vars and info-local-referred of its body.

;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned.
;;; The LISP funob may then be referred locally or across LB or CB:
;;;     (flet ((foo (z) (bar z))) (list #'foo)))
;;;     (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar)))
;;;     (flet ((foo (z) (bar z))) #'(lambda () #'foo)))
;;; therefore we need field funob.

(defstruct (fun (:include ref))
;  name			;;; Function name.
;  (ref 0 :type fixnum)	;;; Number of references.
			;;; During Pass1, T or NIL.
			;;; During Pass2, the vs-address for the
			;;; function closure, or NIL.
;  ref-ccb		;;; Cross closure reference.
 			;;; During Pass1, T or NIL, depending on whether a
			;;; function object will be built.
			;;; During Pass2, the vs-address for the function
			;;; closure, or NIL.
;  ref-clb		;;; Unused.
;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
  cfun			;;; The cfun for the function.
  (level 0)		;;; Level of lexical nesting for a function.
  (env 0)     		;;; Size of env of closure.
  (closure-levels nil)  ;;; List of sizes, one for each closure level, in reverse order.
  (global nil)		;;; Global lisp function.
  (exported nil)	;;; Its C name can be seen outside the module.
  (no-entry nil)	;;; NIL if declared as C-LOCAL. Then we create no
			;;; function object and the C function is called
			;;; directly.   Deprecated! JCB
  (shares-with nil)	;;; Deprecated! JCB
			;;; 
  closure		;;; During Pass2, T if env is used inside the function
  var			;;; the variable holding the funob
  description		;;; Text for the object, in case NAME == NIL.
  lambda		;;; Lambda c1-form for this function.
  (minarg 0)		;;; Min. number arguments that the function receives.
  (maxarg call-arguments-limit)
			;;; Max. number arguments that the function receives.
  (parent *current-function*)
			;;; Parent function, NIL if global. (Not quite: NIL if toplevel. JCB)
  (local-vars nil)	;;; List of local variables created here.
  (referred-vars nil)	;;; List of external variables referenced here.
  (referred-funs nil)	;;; List of external functions called in this one.
			;;; We only register direct calls, not calls via object.
  (child-funs nil)	;;; List of local functions defined here.
  (debug 0)		;;; Debug quality
  (file *compile-file-truename*)
			;;; Source file or NIL
  (file-end-position *compile-file-end-position*)
			;;; Top-level form number in source file
  (global-fun-refs nil) ;;; Vector of function references (extensible). JCB
                        ;;;   each element is (symbol . loc)
  (lex-local-p nil)     ;;; T if fun is lexically local (flet/labels). JCB
  (lex-local-funs nil)  ;;; Set of lexically local functions defined inside this fun. JCB
  (name-loc nil)        ;;; vv-location of name at load time. JCB
  (block-index nil)     ;;; Index of this fun object in Cblock. JCB
  )

(defmacro fun-closure-depth (fun)
  `(length (fun-closure-levels ,fun)))

(defstruct (blk (:include ref))
;  name			;;; Block name.
;  (ref 0 :type fixnum)	;;; Number of references.
;  ref-ccb		;;; Cross closure reference.
			;;; During Pass1, T or NIL.
			;;; During Pass2, the ccb-lex for the
			;;; block id, or NIL.
;  ref-clb		;;; Cross local function reference.
			;;; During Pass1, T or NIL.
			;;; During Pass2, the lex-address for the
			;;; block id, or NIL.
;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
  exit			;;; Where to return.  A label.
  destination		;;; Where the value of the block to go.
  var			;;; Variable containing the block ID.
  (type 'NIL)		;;; Estimated type.
  )

(defstruct (tag (:include ref))
;  name			;;; Tag name.
;  (ref 0 :type fixnum)	;;; Number of references.
;  ref-ccb		;;; Cross closure reference.
			;;; During Pass1, T or NIL.
;  ref-clb		;;; Cross local function reference.
			;;; During Pass1, T or NIL.
;  read-nodes		;;; Nodes (c1forms) in which the reference occurs
  label			;;; Where to jump: a label.
  unwind-exit		;;; Where to unwind-no-exit.
  var			;;; Variable containing frame ID.
  index			;;; An integer denoting the label.
  )

(defstruct (info)
  (local-vars nil)	;;; List of var-objects created directly in the form.
  (type t)		;;; Type of the form.
  (sp-change nil)	;;; Whether execution of the form may change
			;;; the value of a special variable.
  (volatile nil)	;;; whether there is a possible setjmp. Beppe
  )

(defstruct (inline-info)
  arg-rep-types		;;; List of representation types for the arguments
  return-rep-type	;;; Representation type for the output
  arg-types		;;; List of lisp types for the arguments
  return-type		;;; Lisp type for the output
  exact-return-type	;;; Only use this expansion when the output is
			;;; declared to have a subtype of RETURN-TYPE
  expansion		;;; C template containing the expansion
  one-liner		;;; Whether the expansion spans more than one line
)

;;;
;;; VARIABLES
;;;

;;; --cmpinline.lsp--
;;;
;;; Empty info struct
;;;
(defvar *info* (make-info))

(defvar *inline-functions* nil)
(defvar *inline-blocks* 0)
;;; *inline-functions* holds:
;;;	(...( function-name . inline-info )...)
;;;
;;; *inline-blocks* holds the number of C blocks opened for declaring
;;; temporaries for intermediate results of the evaluation of inlined
;;; function calls.

;;; --cmputil.lsp--
;;;
;;; Variables and constants for error handling
;;;
(defvar *current-form* '|compiler preprocess|)
(defvar *original-current-form* '|compiler preprocess|)
(defvar *compile-file-end-position* -1)
(defvar *first-error* t)
(defconstant *cmperr-tag* (cons nil nil))

(defvar *active-handlers* nil)
(defvar *active-protection* nil)
(defvar *pending-actions* nil)

(defvar *compiler-conditions* '()
  "This variable determines whether conditions are printed or just accumulated.")

(defvar *compile-print* nil
  "This variable controls whether the compiler displays messages about
each form it processes. The default value is NIL.")

(defvar *compile-verbose* nil
  "This variable controls whether the compiler should display messages about its
progress. The default value is T.")

(defvar *suppress-compiler-messages* ;;nil
  'compiler:compiler-note
  ;;'(or c:compiler-note c:compiler-warning)
  "A type denoting which compiler messages and conditions are _not_ displayed.")

(defvar *suppress-compiler-notes* t)
(defvar *suppress-compiler-warnings* nil)

(defvar *compiler-in-use* nil)
(defvar *compiler-input*)
(defvar *compiler-output1*)
(defvar *compiler-output2*)

;;; --cmpcbk.lsp--
;;;
;;; List of callbacks to be generated
;;;
(defvar *callbacks* nil)

;;; --cmpcall.lsp--
;;;
;;; Whether to use linking calls.
;;;
;;(defvar *compile-to-linking-call* t) ;; unused! JCB 
(defvar *compiler-declared-globals*)

;;; --cmpenv.lsp--
;;;
;;; These default settings are equivalent to (optimize (speed 2) (space 0) (safety 3))
;;;
(defvar *safety* 2)
(defvar *speed* 3)
(defvar *space* 0)
(defvar *debug* 2)

(defconstant *default-optimize-settings*
  `(optimize (safety ,*safety*) (speed ,*speed*) (space ,*space*) (debug ,*debug*)))

;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms.
(defvar *automatic-check-type-in-lambda* t)

;;;
;;; Compiled code uses the following kinds of variables:
;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)
;;; 4. lexi[j], for lexical variables in local functions
;;; 5. CLVi, for lexical variables in closures

(defvar *lcl* 0)		; number of local variables

(defvar *temp* 0)		; number of temporary variables
(defvar *max-temp* 0)		; maximum *temp* reached

(defvar *level* 0)		; nesting level for local functions

(defvar *lex* 0)		; number of lexical variables in local functions
(defvar *max-lex* 0)		; maximum *lex* reached

(defvar *env* 0)		; number of variables in current form
(defvar *max-env* 0)		; maximum *env* in whole function
(defvar *env-lvl* 0)		; number of levels of environments
(defvar *aux-closure* nil)	; stack allocated closure needed for indirect calls
(defvar *closure-levels* nil)   ; list of sizes, one per closure level, in reverse order JCB
(defvar *closure-block-id* 0)   ; JCB
(defvar *cenv0-used* nil)       ; A flag, JCB

(defvar *global-fun-refs* nil)  ; Vector of function references (extensible). JCB
                                ;   each element is (symbol . loc)

(defvar *next-cmacro* 0)	; holds the last cmacro number used.
(defvar *next-cfun* 0)		; holds the last cfun used.

(defvar *debug-fun* 0)		; Level of debugging of functions

;;;
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
;;; If possible, *tail-recursion-info* holds
;;	( c1-lambda-form  required-arg .... required-arg ),
;;; where each required-arg is a var-object.
;;;
(defvar *tail-recursion-info* nil)

;;;
;;; *function-declarations* holds :
;;	(... ( { function-name | fun-object } arg-types return-type ) ...)
;;; Function declarations for global functions are ASSOCed by function names,
;;; whereas those for local functions are ASSOCed by function objects.
;;;
;;; The valid argment type declaration is:
;;	( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
;;; though &optional, &rest, and &key return types are simply ignored.
;;;
(defvar *function-declarations* nil)
(defvar *allow-c-local-declaration* t)
(defvar *notinline* nil)

;;; --cmpexit.lsp--
;;;
;;; *last-label* holds the label# of the last used label.
;;; *exit* holds an 'exit', which is
;;	( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
;;	RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or
;;	RETURN-OBJECT).
;;; *unwind-exit* holds a list consisting of:
;;	( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
;;	JUMP, BDS-BIND (each pushed for a single special binding), or a
;;	LCL (which holds the bind stack pointer used to unbind).
;;;
(defvar *last-label* 0)
(defvar *exit*)
(defvar *unwind-exit*)

(defvar *current-function* nil) ;; bound in pass 1 by c1compile-function.
(defvar *written-function* nil) ;; bound in pass 3 by t3local-fun. JCB

(defun written-function-cname ()
  (if *written-function* (fun-cfun *written-function*) "MKCL__TOPLEVEL_"))

(defvar *cmp-env* (cons nil nil)
"The compiler environment consists of a pair or cons of two
lists, one containing variable records, the other one macro and
function recors:

variable-record = (:block block-name) |
                  (:tag ({tag-name}*)) |
                  (:function function-name) |
                  (var-name {:special | nil} bound-p) |
                  (symbol si::symbol-macro macro-function) |
                  CB | LB | UNWIND-PROTECT
macro-record =	(function-name function) |
                (macro-name si::macro macro-function)
                CB | LB | UNWIND-PROTECT

A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
MACRO-FUNCTION is a function that provides us with the expansion
for that local macro or symbol macro. BOUND-P is true when the
variable has been bound by an enclosing form, while it is NIL if
the variable-record corresponds just to a special declaration.
CB, LB and UNWIND-PROTECT are only used by the C compiler and
they denote closure, lexical environment and unwind-protect
boundaries. Note that compared with the bytecode compiler, these
records contain an additional variable, block, tag or function
object at the end.")

;;; --cmplog.lsp--
;;;
;;; Destination of output of different forms. See cmploc.lsp for types
;;; of destinations.
;;;
(defvar *destination*)

;;; --cmpmain.lsp--
;;;
;;; Do we debug the compiler? Then we need files not to be deleted.
(defvar *delete-compiler-internal-files* t)
(defvar *files-to-be-deleted-on-shutdown* '())

(defvar *compiler-break-enable* nil) ;; set this to true if you want to invoke the debugger on compiler's internal errors.
(defvar *debug-compiler* nil)

;;; This is copied into each .h file generated.
(defvar *cmpinclude* "<mkcl/mkcl-cmp.h>")

(defvar *cc* (or #+(or mingw32 mingw64)
		 (let ((cc-path #P"gcc"))
		   (if (pathname-directory cc-path)
		       cc-path
		     (probe-file (make-pathname :name (pathname-name cc-path) :defaults (si:self-truename)))))
		 "gcc")
"This variable controls how the C compiler is invoked by MKCL.
The default value is \"gcc\".
One can set the variable appropriately adding for instance flags which the 
C compiler may need to exploit special hardware features (e.g. a floating point
coprocessor).")

(defvar *ld* (or #+(or mingw32 mingw64)
		 (let ((cc-path #P"gcc"))
		   (if (pathname-directory cc-path)
		       cc-path
		     (probe-file (make-pathname :name (pathname-name cc-path) :defaults (si:self-truename)))))
		 "gcc")
"This variable controls the linker which is used by MKCL.")

(defvar *ar* (or #+(or mingw32 mingw64) (probe-file (make-pathname :name "ar" :defaults (si:self-truename)))
		 "ar")
"This variable controls the library archiver which is used by MKCL.")

(defvar *ranlib* (or #+(or mingw32 mingw64) (probe-file (make-pathname :name "ranlib" :defaults (si:self-truename)))
		     "ranlib")
"This variable controls the library conditioner which is used by MKCL.")

(defvar *cc-flags* " -fno-strict-aliasing -g -O2  -mthreads -D_MT   -DWin7 ")

(defvar *cc-optimize* #-msvc ""
                      #+msvc "@CFLAGS_OPTIMIZE@")

(defvar *ld-format* #-msvc "\"~A\" -o \"~A\" ~A ~{\"~A\" ~} ~@?"
                    #+msvc "\"~A\" -Fe\"~A\" ~A ~{\"~A\" ~} ~@?")

(defvar *cc-format* #-msvc "\"~A\" ~A ~:[~*~;~A~] \"-I~A\" -c \"~A\" -o \"~A\""
                    #+msvc "\"~A\" ~A ~:[~*~;~A~] -I\"~A\" -w -c \"~A\" -Fo\"~A\"")


(defvar *support-libraries* "libmkclgc.a")

(defvar *external-ld-flags* "   -lws2_32    -lm ") ;; -lws2_32 ??

(defvar *ld-flags*

  #+unix (mkcl:bstr+ "\"~Amkcl_" (si:mkcl-version) ".dll\" " *external-ld-flags*)