Skip to content
Snippets Groups Projects
Commit 2624da01 authored by wlott's avatar wlott
Browse files

Added more gengc stuff.

parent 7fb814be
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.5 1992/12/18 11:19:50 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.6 1993/05/07 07:22:14 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -15,7 +15,8 @@ ...@@ -15,7 +15,8 @@
;;; ;;;
(in-package :c) (in-package :c)
(export '(slot set-slot make-unbound-marker fixed-alloc var-alloc)) (export '(slot set-slot make-unbound-marker fixed-alloc var-alloc
%set-function-self large-alloc))
(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
(let* ((cont (node-cont node)) (let* ((cont (node-cont node))
...@@ -70,13 +71,26 @@ ...@@ -70,13 +71,26 @@
name slot lowtag #+gengc nil)))) name slot lowtag #+gengc nil))))
(assert (null args))) (assert (null args)))
#+gengc
(defun do-fixed-alloc (node block name words type lowtag result)
(if (and (backend-featurep :gengc)
(>= words vm:large-object-cutoff))
(vop large-alloc node block (emit-constant (logandc2 (1+ words) 1))
(emit-constant lowtag) (emit-constant type) (emit-constant 0) name
result)
(vop fixed-alloc node block name words type lowtag result)))
#-gengc
(defun do-fixed-alloc (node block name words type lowtag result)
(vop fixed-alloc node block name words type lowtag result))
(defoptimizer ir2-convert-fixed-allocation (defoptimizer ir2-convert-fixed-allocation
((&rest args) node block name words type lowtag inits) ((&rest args) node block name words type lowtag inits)
(let* ((cont (node-cont node)) (let* ((cont (node-cont node))
(locs (continuation-result-tns (locs (continuation-result-tns
cont (list (backend-any-primitive-type *backend*)))) cont (list (backend-any-primitive-type *backend*))))
(result (first locs))) (result (first locs)))
(vop fixed-alloc node block name words type lowtag result) (do-fixed-alloc node block name words type lowtag result)
(do-inits node block name result lowtag inits args) (do-inits node block name result lowtag inits args)
(move-continuation-result node block locs cont))) (move-continuation-result node block locs cont)))
...@@ -88,22 +102,85 @@ ...@@ -88,22 +102,85 @@
(result (first locs))) (result (first locs)))
(if (constant-continuation-p extra) (if (constant-continuation-p extra)
(let ((words (+ (continuation-value extra) words))) (let ((words (+ (continuation-value extra) words)))
(vop fixed-alloc node block name words type lowtag result)) (do-fixed-alloc node block name words type lowtag result))
(vop var-alloc node block (continuation-tn node block extra) name words (vop var-alloc node block (continuation-tn node block extra) name words
type lowtag result)) type lowtag result))
(do-inits node block name result lowtag inits args) (do-inits node block name result lowtag inits args)
(move-continuation-result node block locs cont))) (move-continuation-result node block locs cont)))
;;;; Other allocation support.
#+gengc
(defoptimizer (make-array-header ir2-convert) ((type rank) node block)
(let* ((cont (node-cont node))
(locs (continuation-result-tns
cont (list (backend-any-primitive-type *backend*))))
(result (first locs)))
(if (and (constant-continuation-p type)
(constant-continuation-p rank))
(do-fixed-alloc node block 'make-array-header
(+ (continuation-value rank)
vm:array-dimensions-offset)
(continuation-value type)
vm:other-pointer-type result)
(vop make-array-header node block (continuation-tn node block type)
(continuation-tn node block rank) result))
(move-continuation-result node block locs cont)))
#+gengc
(setf (function-info-ltn-annotate (function-info-or-lose 'make-array-header))
#'annotate-funny-call)
;;;; Replacements for stuff in ir2tran to make gengc work. ;;;; Replacements for stuff in ir2tran to make gengc work.
#+gengc
(defun ir2-convert-closure (node block leaf res)
(declare (type ref node) (type ir2-block block)
(type functional leaf) (type tn res))
(unless (leaf-info leaf)
(setf (leaf-info leaf) (make-entry-info)))
(let ((entry (make-load-time-constant-tn :entry leaf))
(closure (etypecase leaf
(clambda
(environment-closure (get-lambda-environment leaf)))
(functional
(assert (eq (functional-kind leaf) :top-level-xep))
nil))))
(cond (closure
(let ((this-env (node-environment node)))
(cond
((backend-featurep :gengc)
(do-fixed-alloc node block 'make-closure
(+ (length closure) vm:closure-info-offset)
vm:closure-header-type vm:function-pointer-type
res)
(vop %set-function-self node block res entry))
(t
(vop make-closure node block entry (length closure) res)))
(loop for what in closure and n from 0 do
(unless (and (lambda-var-p what)
(null (leaf-refs what)))
(vop closure-init node block
res
(find-in-environment what this-env)
n
nil)))))
(t
(emit-move node block entry res))))
(undefined-value))
#+gengc #+gengc
(defun ir2-convert-set (node block) (defun ir2-convert-set (node block)
(declare (type cset node) (type ir2-block block)) (declare (type cset node) (type ir2-block block))
(let* ((cont (node-cont node)) (let* ((cont (node-cont node))
(leaf (set-var node)) (leaf (set-var node))
(val (continuation-tn node block (set-value node))) (value (set-value node))
(val-tn (continuation-tn node block value))
(locs (if (continuation-info cont) (locs (if (continuation-info cont)
(continuation-result-tns (continuation-result-tns
cont (list (primitive-type (leaf-type leaf)))) cont (list (primitive-type (leaf-type leaf))))
...@@ -113,18 +190,18 @@ ...@@ -113,18 +190,18 @@
(when (leaf-refs leaf) (when (leaf-refs leaf)
(let ((tn (find-in-environment leaf (node-environment node)))) (let ((tn (find-in-environment leaf (node-environment node))))
(if (lambda-var-indirect leaf) (if (lambda-var-indirect leaf)
(vop value-cell-set node block tn val (vop value-cell-set node block tn val-tn
(needs-remembering val)) (needs-remembering value))
(emit-move node block val tn))))) (emit-move node block val-tn tn)))))
(global-var (global-var
(ecase (global-var-kind leaf) (ecase (global-var-kind leaf)
((:special :global) ((:special :global)
(assert (symbolp (leaf-name leaf))) (assert (symbolp (leaf-name leaf)))
(vop set node block (emit-constant (leaf-name leaf)) val (vop set node block (emit-constant (leaf-name leaf)) val-tn
(needs-remembering val)))))) (needs-remembering value))))))
(when locs (when locs
(emit-move node block val (first locs)) (emit-move node block val-tn (first locs))
(move-continuation-result node block locs cont))) (move-continuation-result node block locs cont)))
(undefined-value)) (undefined-value))
...@@ -140,7 +217,7 @@ ...@@ -140,7 +217,7 @@
#+gengc #+gengc
(defoptimizer (%slot-setter ir2-convert) ((value str) node block) (defoptimizer (%slot-setter ir2-convert) ((value str) node block)
(let ((val (continuation-tn node block value))) (let ((val (continuation-tn node block value)))
(vop structure-set node block (vop instance-set node block
(continuation-tn node block str) (continuation-tn node block str)
val val
(dsd-index (dsd-index
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment