mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-06 02:40:26 -08:00
Implemented inlining of LAMBDA expressions when they appear in the place of a function, such as the beginning of a list, or as a first argument to APPLY and FUNCALL. We can now safely remove the mechanism CALL-LAMBDA which inlines LAMBDA forms when the C code is being produced.
This commit is contained in:
jjgarcia
parent
ce0010c2dc
commit
9ff486f0ba
5 changed files with 236 additions and 393 deletions
|
|
@ -12,214 +12,75 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defun c1map-functions (name car-p args &aux funob info)
|
||||
(when (or (endp args) (endp (cdr args)))
|
||||
(too-few-args 'map-function 2 (length args)))
|
||||
(setq funob (c1funob (car args)))
|
||||
(setq info (copy-info (cadr funob)))
|
||||
(list name info funob car-p (c1args (cdr args) info))
|
||||
)
|
||||
(defun my-pprint (o)
|
||||
(pprint o)
|
||||
o)
|
||||
|
||||
(defun c2mapcar (funob car-p args &aux (*inline-blocks* 0))
|
||||
(let ((label (next-label*))
|
||||
(value-loc (make-temp-var))
|
||||
(handy (make-lcl-var :type 'T))
|
||||
(handies (mapcar #'(lambda (x) (declare (ignore x))
|
||||
(make-lcl-var :type 'T))
|
||||
args))
|
||||
(save (save-funob funob)))
|
||||
(setq args (push-changed-vars (coerce-locs (inline-args args)) funob))
|
||||
(wt-nl "{cl_object " handy ";")
|
||||
(dolist (loc handies)
|
||||
(wt-nl "cl_object " loc "= " (car args) ";")
|
||||
(pop args))
|
||||
(cond (*safe-compile*
|
||||
(wt-nl "if(endp(" (car handies) ")")
|
||||
(dolist (loc (cdr handies)) (wt "||endp(" loc ")"))
|
||||
(wt "){"))
|
||||
(t
|
||||
(wt-nl "if(" (car handies) "==Cnil")
|
||||
(dolist (loc (cdr handies)) (wt "||" loc "==Cnil"))
|
||||
(wt "){")))
|
||||
(unwind-exit nil 'jump)
|
||||
(wt "}")
|
||||
(wt-nl value-loc "=" handy "=CONS(Cnil,Cnil);")
|
||||
(wt-label label)
|
||||
(let* ((*destination* (list 'CAR handy))
|
||||
(*exit* (next-label))
|
||||
(*unwind-exit* (cons *exit* *unwind-exit*)))
|
||||
(c2funcall funob
|
||||
(if car-p
|
||||
(mapcar #'(lambda (loc)
|
||||
(list 'LOCATION *info* (list 'CAR loc)))
|
||||
handies)
|
||||
(mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
|
||||
handies))
|
||||
save)
|
||||
(wt-label *exit*))
|
||||
(cond (*safe-compile*
|
||||
(wt-nl "if(endp(" (car handies) "=CDR(" (car handies) "))")
|
||||
(dolist (loc (cdr handies))
|
||||
(wt "||endp(" loc "=CDR(" loc "))"))
|
||||
(wt "){"))
|
||||
(t
|
||||
(wt-nl "if((" (car handies) "=CDR(" (car handies) "))==Cnil")
|
||||
(dolist (loc (cdr handies))
|
||||
(wt "||(" loc "=CDR(" loc "))==Cnil"))
|
||||
(wt "){")))
|
||||
(unwind-exit value-loc 'jump)
|
||||
(wt "}")
|
||||
(wt-nl handy "=CDR(" handy ")=CONS(Cnil,Cnil);")
|
||||
(wt-nl) (wt-go label)
|
||||
(wt "}")
|
||||
(close-inline-blocks)
|
||||
)
|
||||
)
|
||||
(defun map-apply-function (fname args)
|
||||
(mapcar #'(lambda (x) `(,fname ,x)) args))
|
||||
|
||||
(defun c2mapc (funob car-p args &aux (*inline-blocks* 0))
|
||||
(let ((label (next-label*))
|
||||
value-loc
|
||||
(handies (mapcar #'(lambda (x) (declare (ignore x))
|
||||
(make-lcl-var))
|
||||
args))
|
||||
(save (save-funob funob)))
|
||||
(setq args (push-changed-vars (coerce-locs (inline-args args))
|
||||
funob))
|
||||
(wt-nl "{")
|
||||
;; preserve first argument:
|
||||
(if (eq 'RETURN (car args))
|
||||
(progn
|
||||
(setq value-loc (make-lcl-var))
|
||||
(wt-nl "cl_object " value-loc "= " (car args) ";"))
|
||||
(setq value-loc (car args)))
|
||||
(dolist (loc handies)
|
||||
(wt-nl "cl_object " loc "= " (car args) ";")
|
||||
(pop args))
|
||||
(cond (*safe-compile*
|
||||
(wt-nl "if(endp(" (car handies) ")")
|
||||
(dolist (loc (cdr handies)) (wt "||endp(" loc ")"))
|
||||
(wt "){"))
|
||||
(t
|
||||
(wt-nl "if(" (car handies) "==Cnil")
|
||||
(dolist (loc (cdr handies)) (wt "||" loc "==Cnil"))
|
||||
(wt "){")))
|
||||
(unwind-exit nil 'JUMP)
|
||||
(wt "}")
|
||||
(wt-label label)
|
||||
(let* ((*destination* 'TRASH)
|
||||
(*exit* (next-label))
|
||||
(*unwind-exit* (cons *exit* *unwind-exit*)))
|
||||
(c2funcall funob
|
||||
(if car-p
|
||||
(mapcar #'(lambda (loc)
|
||||
(list 'LOCATION *info* (list 'CAR loc)))
|
||||
handies)
|
||||
(mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
|
||||
handies))
|
||||
save)
|
||||
(wt-label *exit*))
|
||||
(cond (*safe-compile*
|
||||
(wt-nl "if(endp(" (car handies) "=CDR(" (car handies) "))")
|
||||
(dolist (loc (cdr handies))
|
||||
(wt "||endp(" loc "=CDR(" loc "))"))
|
||||
(wt "){"))
|
||||
(t
|
||||
(wt-nl "if((" (car handies) "=CDR(" (car handies) "))==Cnil")
|
||||
(dolist (loc (cdr handies))
|
||||
(wt "||(" loc "=CDR(" loc "))==Cnil"))
|
||||
(wt "){")))
|
||||
(unwind-exit value-loc 'JUMP)
|
||||
(wt "}")
|
||||
(wt-nl) (wt-go label)
|
||||
(wt "}")
|
||||
(close-inline-blocks)
|
||||
)
|
||||
)
|
||||
(defun expand-mapcar (function args car-p)
|
||||
(let* ((handy (gensym))
|
||||
(output (gensym))
|
||||
(handies (mapcar #'(lambda (x) (gensym)) args))
|
||||
(test-end `(OR ,@(map-apply-function 'ENDP handies)))
|
||||
(values (if car-p (map-apply-function 'CAR handies) handies))
|
||||
(cdrs (map-apply-function 'CDR handies)))
|
||||
(my-pprint
|
||||
`(do* ((,output (cons nil nil))
|
||||
(,handy ,output)
|
||||
,@(mapcar #'list handies args cdrs))
|
||||
(,test-end (cdr ,output))
|
||||
(setf ,handy (setf (cdr ,handy) (cons nil nil)))
|
||||
(setf (car ,handy) (funcall ,function ,@values))
|
||||
)))
|
||||
)
|
||||
|
||||
(defun c2mapcan (funob car-p args &aux (*inline-blocks* 0))
|
||||
(let ((label (next-label*))
|
||||
(value-loc (make-temp-var))
|
||||
(handy (make-lcl-var))
|
||||
(handies (mapcar #'(lambda (x) (declare (ignore x))
|
||||
(make-lcl-var))
|
||||
args))
|
||||
(save (save-funob funob)))
|
||||
(setq args (push-changed-vars (coerce-locs (inline-args args))
|
||||
funob))
|
||||
(wt-nl "{cl_object " handy ";")
|
||||
(dolist (loc handies)
|
||||
(wt-nl "cl_object " loc "= " (car args) ";")
|
||||
(pop args))
|
||||
(cond (*safe-compile*
|
||||
(wt-nl "if(endp(" (car handies) ")")
|
||||
(dolist (loc (cdr handies)) (wt "||endp(" loc ")"))
|
||||
(wt "){"))
|
||||
(t
|
||||
(wt-nl "if(" (car handies) "==Cnil")
|
||||
(dolist (loc (cdr handies)) (wt "||" loc "==Cnil"))
|
||||
(wt "){")))
|
||||
(unwind-exit nil 'jump)
|
||||
(wt "}")
|
||||
(wt-nl value-loc "=" handy "=CONS(Cnil,Cnil);")
|
||||
(wt-label label)
|
||||
(let* ((*destination* (list 'CDR handy))
|
||||
(*exit* (next-label))
|
||||
(*unwind-exit* (cons *exit* *unwind-exit*))
|
||||
)
|
||||
(c2funcall funob
|
||||
(if car-p
|
||||
(mapcar #'(lambda (loc)
|
||||
(list 'LOCATION *info* (list 'CAR loc)))
|
||||
handies)
|
||||
(mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
|
||||
handies))
|
||||
save)
|
||||
(wt-label *exit*))
|
||||
(cond
|
||||
(*safe-compile*
|
||||
(wt-nl "while(!endp(CDR(" handy ")))" handy "=CDR(" handy ");")
|
||||
(wt-nl "if(endp(" (car handies) "=CDR(" (car handies) "))")
|
||||
(dolist (loc (cdr handies)) (wt "||endp(" loc "=CDR(" loc "))"))
|
||||
(wt "){"))
|
||||
(t
|
||||
(wt-nl "while(CDR(" handy ")!=Cnil)" handy "=CDR(" handy ");")
|
||||
(wt-nl "if((" (car handies) "=CDR(" (car handies) "))==Cnil")
|
||||
(dolist (loc (cdr handies))
|
||||
(wt "||(" loc "=CDR(" loc "))==Cnil"))
|
||||
(wt "){")))
|
||||
(wt-nl value-loc "=CDR(" value-loc ");")
|
||||
(unwind-exit value-loc 'jump)
|
||||
(wt "}")
|
||||
(wt-nl) (wt-go label)
|
||||
(wt "}")
|
||||
(close-inline-blocks)
|
||||
)
|
||||
)
|
||||
(define-compiler-macro mapcar (fname first-arg &rest args)
|
||||
(expand-mapcar fname (list* first-arg args) t))
|
||||
|
||||
(define-compiler-macro maplist (fname first-arg &rest args)
|
||||
(expand-mapcar fname (list* first-arg args) nil))
|
||||
|
||||
(defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob)))
|
||||
(dolist (loc locs (nreverse locs1))
|
||||
(if (and (var-p loc) (var-changed-in-forms loc forms))
|
||||
(let ((temp (make-temp-var)))
|
||||
(wt-nl temp "= " loc ";")
|
||||
(push temp locs1))
|
||||
(push loc locs1))))
|
||||
(defun expand-mapc (function args car-p)
|
||||
(let* ((output (gensym))
|
||||
(handies (mapcar #'(lambda (x) (gensym)) args))
|
||||
(test-end `(OR ,@(map-apply-function 'ENDP handies)))
|
||||
(values (if car-p (map-apply-function 'CAR handies) handies))
|
||||
(cdrs (map-apply-function 'CDR handies)))
|
||||
(my-pprint
|
||||
`(do* (,@(mapcar #'list handies args cdrs)
|
||||
(output ,(first handies)))
|
||||
(,test-end output)
|
||||
(funcall ,function ,@values))))
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
(define-compiler-macro mapc (fname first-arg &rest args)
|
||||
(expand-mapc fname (list* first-arg args) t))
|
||||
|
||||
(put-sysprop 'mapcar 'c1 'c1mapcar)
|
||||
(put-sysprop 'maplist 'c1 'c1maplist)
|
||||
(put-sysprop 'mapcar 'c2 'c2mapcar)
|
||||
(put-sysprop 'mapc 'c1 'c1mapc)
|
||||
(put-sysprop 'mapl 'c1 'c1mapl)
|
||||
(put-sysprop 'mapc 'c2 'c2mapc)
|
||||
(put-sysprop 'mapcan 'c1 'c1mapcan)
|
||||
(put-sysprop 'mapcon 'c1 'c1mapcon)
|
||||
(put-sysprop 'mapcan 'c2 'c2mapcan)
|
||||
(define-compiler-macro mapl (fname first-arg &rest args)
|
||||
(expand-mapc fname (list* first-arg args) nil))
|
||||
|
||||
(defun c1mapcar (args) (c1map-functions 'mapcar t args))
|
||||
(defun c1maplist (args) (c1map-functions 'mapcar nil args))
|
||||
(defun c1mapc (args) (c1map-functions 'mapc t args))
|
||||
(defun c1mapl (args) (c1map-functions 'mapc nil args))
|
||||
(defun c1mapcan (args) (c1map-functions 'mapcan t args))
|
||||
(defun c1mapcon (args) (c1map-functions 'mapcan nil args))
|
||||
(defun expand-mapcan (function args car-p)
|
||||
(let* ((handy (gensym))
|
||||
(value (gensym))
|
||||
(output (gensym))
|
||||
(handies (mapcar #'(lambda (x) (gensym)) args))
|
||||
(test-end `(OR ,@(map-apply-function 'ENDP handies)))
|
||||
(values (if car-p (map-apply-function 'CAR handies) handies)))
|
||||
(my-pprint
|
||||
`(do* (,value
|
||||
(,output (cons nil nil))
|
||||
(,handy ,output)
|
||||
,@(mapcar #'list handies args))
|
||||
(,test-end (cdr ,output))
|
||||
(when (setf value (funcall ,function ,@values))
|
||||
(setf (cdr ,handy) ,value)
|
||||
(setf ,handy (last ,value))))))
|
||||
)
|
||||
|
||||
(define-compiler-macro mapcan (fname first-arg &rest args)
|
||||
(expand-mapcan fname (list* first-arg args) t))
|
||||
|
||||
(define-compiler-macro mapcon (fname first-arg &rest args)
|
||||
(expand-mapcan fname (list* first-arg args) nil))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue