From 985e7f7ebbf907330b0d71896e1cba799210c78b Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sun, 13 Dec 1992 15:14:50 +0000 Subject: [PATCH] Initial revision --- compiler/generic/vm-ir2tran.lisp | 91 ++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 compiler/generic/vm-ir2tran.lisp diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp new file mode 100644 index 000000000..ade65200f --- /dev/null +++ b/compiler/generic/vm-ir2tran.lisp @@ -0,0 +1,91 @@ +;;; -*- Package: C -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.1 1992/12/13 15:14:50 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file +;;; +(in-package :c) + +(export '(slot set-slot make-unbound-marker fixed-alloc var-alloc)) + +(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) + (let* ((cont (node-cont node)) + (locs (continuation-result-tns + cont (list (backend-any-primitive-type *backend*)))) + (res (first locs))) + (vop slot node block (continuation-tn node block object) + name offset lowtag res) + (move-continuation-result node block locs cont))) + +(defoptimizer ir2-convert-setter ((object value) node block name offset lowtag) + (let ((value-tn (continuation-tn node block value))) + (vop set-slot node block (continuation-tn node block object) value-tn + name offset lowtag) + (move-continuation-result node block (list value-tn) (node-cont node)))) + +(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag) + (let ((value-tn (continuation-tn node block value))) + (vop set-slot node block (continuation-tn node block object) value-tn + name offset lowtag) + (move-continuation-result node block (list value-tn) (node-cont node)))) + +(defun do-inits (node block name result lowtag inits args) + (let ((unbound-marker-tn nil)) + (dolist (init inits) + (let ((kind (car init)) + (slot (cdr init))) + (vop set-slot node block result + (ecase kind + (:arg + (assert args) + (continuation-tn node block (pop args))) + (:unbound + (or unbound-marker-tn + (setf unbound-marker-tn + (let ((tn (make-normal-tn + (primitive-type-or-lose 'positive-fixnum + *backend*)))) + (vop make-unbound-marker node block tn) + tn)))) + (:null + (emit-constant nil))) + name slot lowtag)))) + (assert (null args))) + +(defoptimizer ir2-convert-fixed-allocation + ((&rest args) node block name words type lowtag inits) + (let* ((cont (node-cont node)) + (locs (continuation-result-tns + cont (list (backend-any-primitive-type *backend*)))) + (result (first locs))) + (vop fixed-alloc node block name words + (and type (logior (ash words vm:type-bits) type)) + lowtag result) + (do-inits node block name result lowtag inits args) + (move-continuation-result node block locs cont))) + +(defoptimizer ir2-convert-variable-allocation + ((extra &rest args) node block name words type lowtag inits) + (let* ((cont (node-cont node)) + (locs (continuation-result-tns + cont (list (backend-any-primitive-type *backend*)))) + (result (first locs))) + (if (constant-continuation-p extra) + (let ((words (+ (continuation-value extra) words))) + (vop fixed-alloc node block name words + (logior (ash words vm:type-bits) type) + lowtag result)) + (vop var-alloc node block (continuation-tn extra) name words + (logior (ash words vm:type-bits) type) + lowtag result)) + (do-inits node block name result lowtag inits args) + (move-continuation-result node block locs cont))) -- GitLab