diff --git a/compiler/old-rt/char.lisp b/compiler/old-rt/char.lisp index d74ebde85b2331b0e3889054b72f5aa52abd0e2a..4254d0f70fcbb2b1a5782a6bfadae152a62614d0 100644 --- a/compiler/old-rt/char.lisp +++ b/compiler/old-rt/char.lisp @@ -13,53 +13,71 @@ ;;; (in-package 'c) + +;;;; Moves and coercions: + +;;; Move untagged string-char values. +;;; (define-vop (string-char-move) (:args (x :target y :scs (string-char-reg) - :load nil)) + :load-if (not (location= x y)))) (:results (y :scs (string-char-reg) - :load nil)) - (:temporary (:scs (string-char-reg) :type string-char - :from :argument :to :result) - temp) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 - (sc-case x ((string-char-reg string-char-stack immediate-string-char - descriptor-reg any-reg stack))) - (sc-case y ((string-char-reg string-char-stack - descriptor-reg any-reg stack))) - - (let* ((x-char (sc-is x string-char-reg string-char-stack - immediate-string-char)) - (y-char (sc-is y string-char-reg string-char-stack)) - (same-rep (if x-char y-char (not y-char))) - (src (if (sc-is x stack string-char-stack immediate-string-char) - temp x)) - (dest (if (sc-is y stack string-char-stack) temp y))) - - (unless (and same-rep (location= x y)) - - (unless (eq x src) - (sc-case x - ((string-char-stack stack) - (load-stack-tn src x)) - (immediate-string-char - (loadi src (char-code (tn-value x)))))) - - (if same-rep - (unless (location= src dest) - (inst lr dest src)) - (if x-char - (inst oiu dest src (ash system:%string-char-type - clc::type-shift-16)) - (inst nilz dest src system:%character-code-mask))) - - (unless (eq y dest) - (store-stack-tn y dest)))))) - -(primitive-type-vop string-char-move (:coerce-to-t :coerce-from-t :move) - string-char) + (unless (location= x y) + (inst lr y x)))) +;;; +(define-move-vop string-char-move :move (string-char-reg) (string-char-reg)) + + +;;; Move untagged string-char arguments/return-values. +;;; +(define-vop (move-string-char-argument) + (:args (x :target y + :scs (string-char-reg)) + (fp :scs (descriptor-reg) + :load-if (not (sc-is y string-char-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + (string-char-reg + (unless (location= x y) + (inst lr y x))) + (string-char-stack + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-string-char-argument :move-argument + (string-char-reg) (string-char-reg)) + + +;;; Move a tagged string char to an untagged representation. +;;; +(define-vop (move-to-string-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (string-char-reg))) + (:generator 1 + (inst nilz y x system:%character-code-mask))) +;;; +(define-move-vop move-to-string-char :move + (any-reg descriptor-reg) (string-char-reg)) + + +;;; Move an untagged string char to a tagged representation. +;;; +(define-vop (move-from-string-char) + (:args (x :scs (string-char-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:generator 1 + (inst oiu y x (ash system:%string-char-type clc::type-shift-16)))) +;;; +(define-move-vop move-from-string-char :move + (string-char-reg) (any-reg descriptor-reg)) + + +;;;; Other operations: (define-vop (char-code) (:args (ch :scs (string-char-reg) :target res)) @@ -74,7 +92,6 @@ (define-vop (code-char) (:args (code :scs (any-reg descriptor-reg) :target res)) (:results (res :scs (string-char-reg))) - (:result-types string-char) (:translate code-char) (:policy :fast-safe) (:generator 0 diff --git a/compiler/old-rt/move.lisp b/compiler/old-rt/move.lisp index d6063dcfdd8e4f0093b87418db2e23974a8e4177..8796ab2db72ccb1857beb10abfebb68df6489feb 100644 --- a/compiler/old-rt/move.lisp +++ b/compiler/old-rt/move.lisp @@ -14,83 +14,62 @@ ;;; (in-package 'c) -;;; Load-Constant-TN -- Internal -;;; -;;; Load the Constant or immediate constant TN X into Y. Temp is a -;;; descriptor register temp or NIL, if none is available. Temp must be -;;; supplied if Y may be in memory. Node is for souce context. -;;; -(defun load-constant-tn (x y temp node) - (declare (type tn x y) (type (or tn null temp)) (type node node)) - (assemble node - (sc-case x - ((short-immediate unsigned-immediate immediate random-immediate - immediate-string-char) - (let ((val (tn-value x)) - (dest (sc-case y - ((any-reg descriptor-reg string-char-reg) y) - (stack temp)))) - (etypecase val - (integer - (loadi dest val)) - (null - (inst cau dest zero-tn clc::nil-16)) - ((member t) - (inst cau dest zero-tn clc::t-16)) - (string-char - (let ((code (char-code val))) - (loadi dest code) - (unless (sc-is y string-char-reg) - (inst oiu dest dest (ash system:%string-char-type - clc::type-shift-16)))))) - (unless (eq dest y) - (store-stack-tn y temp)))) - (constant - (sc-case y - ((any-reg descriptor-reg) - (load-slot y env-tn (tn-offset x))) - (stack - (load-slot temp env-tn (tn-offset x)) - (store-stack-tn y temp))))))) + +;;;; Move functions: + +(define-move-function (load-immediate 1) (node x y) + ((short-immediate unsigned-immediate immediate random-immediate) + (any-reg descriptor-reg)) + (let ((val (tn-value x))) + (etypecase val + (integer + (loadi y val)) + (null + (inst cau y zero-tn clc::nil-16)) + ((member t) + (inst cau y zero-tn clc::t-16))))) + +(define-move-function (load-string-char 1) (node x y) + ((immediate-string-char) (string-char-reg)) + (loadi y (char-code (tn-value x)))) + +(define-move-function (load-tagged-string-char 2) (node x y) + ((immediate-string-char) (any-reg descriptor-reg)) + (loadi y (char-code (tn-value x))) + (inst oiu y y (ash system:%string-char-type clc::type-shift-16))) + +(define-move-function (load-constant 5) (node x y) + ((constant) (any-reg descriptor-reg)) + (load-slot y env-tn (tn-offset x))) + +(define-move-function (load-stack 5) (node x y) + ((stack) (any-reg descriptor-reg) + (string-char-stack) (string-char-reg)) + (load-stack-tn y x)) + +(define-move-function (store-stack 5) (node x y) + ((any-reg descriptor-reg) (stack) + (string-char-reg) (string-char-stack)) + (store-stack-tn y x)) -;;;; The Move VOP: -;;; +;;;; Move and Move-Argument VOPs: + + ;;; The Move VOP is used for doing arbitrary moves when there is no ;;; type-specific move/coerce operation. - -;;; We need a register to do a memory-memory move. ;;; (define-vop (move) (:args (x :target y :scs (any-reg descriptor-reg) - :load nil)) + :load-if (not (location= x y)))) (:results (y :scs (any-reg descriptor-reg) - :load nil)) - (:temporary (:scs (descriptor-reg) - :from :argument :to :result) - temp) - (:node-var node) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 (unless (location= x y) - (sc-case x - ((any-reg descriptor-reg) - (sc-case y - ((any-reg descriptor-reg) - (inst lr y x)) - (stack - (store-stack-tn y x)))) - (stack - (sc-case y - ((any-reg descriptor-reg) - (load-stack-tn y x)) - (stack - (load-stack-tn temp x) - (store-stack-tn y temp)))) - (t - (unassemble (load-constant-tn x y temp node))))))) + (inst lr y x)))) ;;; Make Move the check VOP for T so that type check generation doesn't think @@ -99,84 +78,23 @@ ;;; (primitive-type-vop move (:check) t) - -;;;; ILLEGAL-MOVE -;;; This VOP is emitted when we attempt to do a move between incompatible -;;; primitive types. We signal an error, and ignore the result (which is -;;; specified only to terminate its lifetime.) +;;; The Move-Argument VOP is used for moving descriptor values into another +;;; frame for argument or known value passing. ;;; -(define-vop (illegal-move three-arg-miscop) - (:args (x :scs (any-reg descriptor-reg) :target a1) - (y-type :scs (any-reg descriptor-reg) :target a2)) - (:variant-vars) - (:ignore r a3 nl0 nl1 misc-pc) - (:generator 666 - (loadi a0 clc::error-object-not-type) - (unless (location= x a1) - (inst lr a1 x)) - (unless (location= y-type a2) - (inst lr a2 y-type)) - (inst miscop 'clc::error2) - (note-this-location vop :internal-error))) - - -;;;; Operand loading and saving: -;;; -;;; These are the VOPs used for loading or saving Load-TNs. They cannot -;;; allocate any temporaries since packing has already been done by the time -;;; that these VOPs are emitted. It can be assumed that the loaded (saved) TN -;;; is free before (after) the load (save) (so may be used as a temporary.) -;;; - -(define-vop (load-operand) - (:args (x)) - (:results (y)) - (:node-var node) - (:generator 5 - (sc-case x - (stack - (sc-case y - ((any-reg descriptor-reg) - (load-stack-tn y x)) - (string-char-reg - (load-stack-tn y x) - (inst nilz y y system:%character-code-mask)))) - (string-char-stack - (sc-case y - (string-char-reg - (load-stack-tn y x)))) - (t - (unassemble (load-constant-tn x y nil node)))))) - -(define-vop (store-operand) - (:args (x)) +(define-vop (move-argument) + (:args (x :target y + :scs (any-reg descriptor-reg)) + (fp :scs (descriptor-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) (:results (y)) - (:generator 5 + (:generator 0 (sc-case y + ((any-reg descriptor-reg) + (unless (location= x y) + (inst lr y x))) (stack - (sc-case x - ((any-reg descriptor-reg) - (store-stack-tn y x)) - (string-char-reg - (inst oiu x x (ash system:%string-char-type clc::type-shift-16)) - (store-stack-tn y x)))) - (string-char-stack - (sc-case x - (string-char-reg - (store-stack-tn y x))))))) - - -;;;; Register saving and restoring VOPs. - -(define-vop (save-reg) - (:args (reg)) - (:results (stack)) - (:generator 5 - (store-stack-tn stack reg))) - -(define-vop (restore-reg) - (:args (stack)) - (:results (reg)) - (:generator 5 - (load-stack-tn reg stack))) + (storew x fp (tn-offset y)))))) +;;; +(define-move-vop move-argument :move-argument + (any-reg descriptor-reg) (any-reg descriptor-reg))