Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
49e2b9cc
Commit
49e2b9cc
authored
35 years ago
by
ch
Browse files
Options
Downloads
Patches
Plain Diff
More frobs to the type checking macros.
parent
194141a8
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/mips/macros.lisp
+51
-111
51 additions, 111 deletions
compiler/mips/macros.lisp
with
51 additions
and
111 deletions
compiler/mips/macros.lisp
+
51
−
111
View file @
49e2b9cc
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.1
5
1990/02/2
3 20:22:09 wlott
Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.1
6
1990/02/2
5 02:39:32 ch
Exp $
;;;
;;;
;;; This file contains various useful macros for generating MIPS code.
;;; This file contains various useful macros for generating MIPS code.
;;;
;;;
...
@@ -75,9 +75,22 @@
...
@@ -75,9 +75,22 @@
(
error
"Constant ~D cannot be loaded."
,
n-const
)))))
(
error
"Constant ~D cannot be loaded."
,
n-const
)))))
(
defmacro
load-symbol
(
reg
symbol
)
(
defmacro
load-symbol
(
reg
symbol
)
`
(
inst
addi
,
reg
null-tn
(
initial-symbol-offset
,
symbol
)))
`
(
inst
addi
,
reg
null-tn
(
vm:static-symbol-offset
,
symbol
)))
(
defmacro
load-type
(
target
source
&optional
(
offset
0
))
"Loads the type bits of a pointer into target independent of
byte-ordering issues."
(
once-only
((
n-target
target
)
(
n-source
source
)
(
n-offset
offset
))
(
ecase
vm:target-byte-order
(
:little-endian
`
(
inst
lb
,
n-target
,
n-source
,
n-offset
))
(
:big-endian
`
(
inst
lb
,
n-target
,
n-source
(
+
,
n-offset
3
))))))
;;;; Stack TN's
;;; Load-Stack-TN, Store-Stack-TN -- Interface
;;; Load-Stack-TN, Store-Stack-TN -- Interface
;;;
;;;
...
@@ -107,7 +120,8 @@
...
@@ -107,7 +120,8 @@
(
defmacro
simple-test-tag
(
register
temp
target
not-p
tag-type
tag-mask
)
(
defmacro
simple-test-tag
(
register
temp
target
not-p
tag-type
tag-mask
)
`
(
progn
`
(
progn
(
inst
andi
,
temp
,
register
,
tag-mask
)
(
unless
(
zerop
,
tag-mask
)
(
inst
andi
,
temp
,
register
,
tag-mask
))
(
inst
xori
,
temp
,
temp
,
tag-type
)
(
inst
xori
,
temp
,
temp
,
tag-type
)
(
if
,
not-p
(
if
,
not-p
(
inst
bne
,
temp
zero-tn
,
target
)
(
inst
bne
,
temp
zero-tn
,
target
)
...
@@ -126,7 +140,9 @@
...
@@ -126,7 +140,9 @@
(
simple-test-tag
,
n-register
,
n-temp
,
n-target
,
n-not-p
(
simple-test-tag
,
n-register
,
n-temp
,
n-target
,
n-not-p
,
n-type-code
lowtag-mask
))
,
n-type-code
lowtag-mask
))
(
t
(
t
;; nothing clever in this version
;; Nothing clever in this version. Assume other-immediate
;; type is already in register.
;;
(
simple-test-tag
,
n-temp
,
n-temp
,
n-target
,
n-not-p
(
simple-test-tag
,
n-temp
,
n-temp
,
n-target
,
n-not-p
,
n-type-code
type-mask
)))))
,
n-type-code
type-mask
)))))
...
@@ -148,13 +164,14 @@
...
@@ -148,13 +164,14 @@
(
not-other-label
(
if
,
n-not-p
,
n-target
out-label
)))
(
not-other-label
(
if
,
n-not-p
,
n-target
out-label
)))
(
simple-test-tag
,
n-register
,
n-temp
not-other-label
t
(
simple-test-tag
,
n-register
,
n-temp
not-other-label
t
vm:other-pointer-type
vm:lowtag-mask
)
vm:other-pointer-type
vm:lowtag-mask
)
(
inst
lw
,
n-temp
,
n-register
(
-
vm:other-pointer-type
))
(
load-type
,
n-temp
,
n-register
(
-
vm:other-pointer-type
))
(
nop
)
(
nop
)
(
simple-test-tag
,
n-temp
,
n-temp
,
n-target
,
n-not-p
(
simple-test-tag
,
n-temp
,
n-temp
,
n-target
,
n-not-p
,
n-type-code
vm:type-mask
)
,
n-type-code
0
)
(
emit-label
out-label
))))))
(
emit-label
out-label
))))))
;;; Hairy Type Checking Macros
;;;; Hairy Type Checking Macros
(
defun
enumerate-type-codes
(
types
)
(
defun
enumerate-type-codes
(
types
)
(
let
((
type-codes
nil
))
(
let
((
type-codes
nil
))
...
@@ -170,22 +187,24 @@
...
@@ -170,22 +187,24 @@
(
push
(
eval
type
)
type-codes
))))
(
push
(
eval
type
)
type-codes
))))
(
sort
(
remove-duplicates
type-codes
)
#'
<
)))
(
sort
(
remove-duplicates
type-codes
)
#'
<
)))
(
defun
canonicalize-type-codes
(
type-codes
)
(
defun
canonicalize-type-codes
(
type-codes
&optional
(
shift
0
)
)
(
assert
type-codes
)
(
unless
type-codes
(
return-from
canonicalize-
type-codes
nil
)
)
(
let*
((
type-codes
type-codes
)
(
let*
((
type-codes
type-codes
)
(
canonical-type-codes
nil
)
(
canonical-type-codes
nil
)
(
last-type-code
(
pop
type-codes
))
(
first-type-code
(
pop
type-codes
))
(
range-start
last-type-code
)
(
last-type-code
(
ash
first-type-code
shift
))
(
range-start
first-type-code
)
(
range-end
nil
))
(
range-end
nil
))
(
dolist
(
type-code
type-codes
)
(
dolist
(
type-code
type-codes
)
(
cond
((
=
last-type-code
(
1-
type-code
))
(
let
((
shifted-type-code
(
ash
type-code
shift
)))
(
setf
range-end
type-code
))
(
cond
((
=
last-type-code
(
1-
shifted-type-code
))
(
t
(
setf
range-end
type-code
))
(
push
(
if
range-end
(
cons
range-start
range-end
)
range-start
)
(
t
canonical-type-codes
)
(
push
(
if
range-end
(
cons
range-start
range-end
)
range-start
)
(
setf
range-start
type-code
)
canonical-type-codes
)
(
setf
range-end
nil
)))
(
setf
range-start
type-code
)
(
setf
last-type-code
type-code
))
(
setf
range-end
nil
)))
(
setf
last-type-code
shifted-type-code
)))
(
push
(
if
range-end
(
cons
range-start
range-end
)
range-start
)
(
push
(
if
range-end
(
cons
range-start
range-end
)
range-start
)
canonical-type-codes
)
canonical-type-codes
)
(
nreverse
canonical-type-codes
)))
(
nreverse
canonical-type-codes
)))
...
@@ -228,7 +247,8 @@
...
@@ -228,7 +247,8 @@
(
,
in-label
(
if
,
not-p
drop-through
,
target
))
(
,
in-label
(
if
,
not-p
drop-through
,
target
))
(
,
out-label
(
if
,
not-p
,
target
drop-through
)))
(
,
out-label
(
if
,
not-p
,
target
drop-through
)))
,
out-label
; squelch possible warning
,
out-label
; squelch possible warning
(
inst
andi
,
temp
,
register
,
tag-mask
)
(
unless
(
zerop
,
tag-mask
)
(
inst
andi
,
temp
,
register
,
tag-mask
))
,@
(
emit
)
,@
(
emit
)
(
nop
)
(
nop
)
(
emit-label
drop-through
)))))
(
emit-label
drop-through
)))))
...
@@ -260,9 +280,9 @@
...
@@ -260,9 +280,9 @@
(
t
(
t
(
header-word-types
type
))))
(
header-word-types
type
))))
(
let
((
low-tag-types
(
low-tag-types
))
(
let
((
low-tag-types
(
canonicalize-type-codes
(
low-tag-types
))
)
(
header-word-types
(
mapcar
#'
(
lambda
(
x
)
(
ash
x
(
-
vm:lowtag-bits
)))
(
header-word-types
(
canonicalize-type-codes
(
header-word-types
))))
(
header-word-types
)
(
-
(
1-
lowtag-bits
))
)))
;;
;;
;; Generate code
;; Generate code
`
(
let*
((
out-label
(
gen-label
))
`
(
let*
((
out-label
(
gen-label
))
...
@@ -273,20 +293,16 @@
...
@@ -273,20 +293,16 @@
,@
(
when
low-tag-types
,@
(
when
low-tag-types
(
if
header-word-types
(
if
header-word-types
`
((
hairy-test-tag
,
n-register
,
n-temp
in-low-tag-label
nil
`
((
hairy-test-tag
,
n-register
,
n-temp
in-low-tag-label
nil
,
(
canonicalize-type-codes
low-tag-types
)
,
low-tag-types
vm:lowtag-mask
))
vm:lowtag-mask
))
`
((
hairy-test-tag
,
n-register
,
n-temp
,
n-target
,
n-not-p
`
((
hairy-test-tag
,
n-register
,
n-temp
,
n-target
,
n-not-p
,
(
canonicalize-type-codes
low-tag-types
)
,
low-tag-types
vm:lowtag-mask
))))
vm:lowtag-mask
))))
,@
(
when
header-word-types
,@
(
when
header-word-types
`
((
simple-test-tag
,
n-register
,
n-temp
not-other-label
t
`
((
simple-test-tag
,
n-register
,
n-temp
not-other-label
t
vm:other-pointer-type
vm:lowtag-mask
)
vm:other-pointer-type
vm:lowtag-mask
)
(
inst
lw
,
n-temp
,
n-register
(
-
vm:other-pointer-type
))
(
load-type
,
n-temp
,
n-register
(
-
vm:other-pointer-type
))
(
nop
)
(
nop
)
(
inst
srl
,
n-temp
,
n-temp
vm:lowtag-bits
)
(
hairy-test-tag
,
n-register
,
n-temp
,
n-target
,
n-not-p
(
hairy-test-tag
,
n-register
,
n-temp
,
n-target
,
n-not-p
,
(
canonicalize-type-codes
header-word-types
)
,
header-word-types
0
)))
(
ash
vm:type-mask
(
-
vm:lowtag-bits
)))))
(
emit-label
out-label
))))))
(
emit-label
out-label
))))))
(
defmacro
simple-test-hairy-type
(
register
temp
target
not-p
&rest
types
)
(
defmacro
simple-test-hairy-type
(
register
temp
target
not-p
&rest
types
)
...
@@ -330,86 +346,10 @@
...
@@ -330,86 +346,10 @@
(
t
(
t
(
error
"Lost big. Should not be here."
)))))))
(
error
"Lost big. Should not be here."
)))))))
;;;
;;; Old RT code
;;;; Test-Special-Value
;;;
#+
nil
(
defmacro
test-simple-type
(
register
temp
target
not-p
type-code
)
"Emit conditional code that tests whether Register holds an object with the
specified Type-Code. Temp is an unboxed temporary."
(
once-only
((
n-register
register
)
(
n-temp
temp
)
(
n-target
target
)
(
n-not-p
not-p
)
(
n-type-code
type-code
))
`
(
progn
(
inst
niuz
,
n-temp
,
n-register
clc::type-mask-16
)
(
inst
xiu
,
n-temp
,
n-temp
(
ash
,
n-type-code
clc::type-shift-16
))
(
if
,
n-not-p
(
inst
bnb
:eq
,
n-target
)
(
inst
bb
:eq
,
n-target
)))))
#+
nil
;;; ### We may want this.
(
defmacro
test-hairy-type
(
register
temp
target
not-p
&rest
types
)
"Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}*
Test whether Register holds a value with one of a specified union of type
codes. Each separately specified Type is matched, and also all types
between a Low-Type and High-Type pair (inclusive) are matched. All of the
type-code expressions are evaluated at macroexpand time.
Temp may be any register."
(
once-only
((
n-register
register
)
(
n-temp
temp
)
(
n-target
target
)
(
n-not-p
not-p
))
(
assert
types
)
(
let
((
codes
(
sort
(
mapcar
#'
(
lambda
(
x
)
(
if
(
listp
x
)
(
cons
(
eval
(
first
x
))
(
eval
(
second
x
)))
(
eval
x
)))
types
)
#'
<
:key
#'
(
lambda
(
x
)
(
if
(
consp
x
)
(
car
x
)
x
)))))
(
n-drop-thru
(
gensym
))
(
n-in-lab
(
gensym
))
(
n-out-lab
(
gensym
)))
(
collect
((
tests
))
(
do
((
codes
codes
(
cdr
codes
)))
((
null
codes
))
(
let
((
code
(
car
codes
))
(
last
(
null
(
cdr
codes
))))
(
cond
((
consp
code
)
(
tests
`
(
progn
(
cmpi
,
n-temp
,
(
car
code
))
(
inst
bb
:lt
,
n-out-lab
)
(
cmpi
,
n-temp
,
(
cdr
code
))))
(
if
last
(
tests
`
(
if
,
n-not-p
(
inst
bb
:gt
,
n-target
)
(
inst
bnb
:gt
,
n-target
)))
(
tests
`
(
inst
bnb
:gt
,
n-in-lab
))))
(
t
(
tests
`
(
cmpi
,
n-temp
,
code
))
(
if
last
(
tests
`
(
if
,
n-not-p
(
inst
bnb
:eq
,
n-target
)
(
inst
bb
:eq
,
n-target
)))
(
tests
`
(
inst
bb
:eq
,
n-in-lab
)))))))
`
(
let*
((
,
n-drop-thru
(
gen-label
))
(
,
n-in-lab
(
if
,
n-not-p
,
n-drop-thru
,
n-target
))
(
,
n-out-lab
(
if
,
n-not-p
,
n-target
,
n-drop-thru
)))
,
n-out-lab
(
unless
(
location=
,
n-temp
,
n-register
)
(
inst
lr
,
n-temp
,
n-register
))
(
inst
sri16
,
n-temp
clc::type-shift-16
)
,@
(
tests
)
(
emit-label
,
n-drop-thru
)))))
)
#+
nil
#+
nil
(
defmacro
test-special-value
(
reg
temp
value
target
not-p
)
(
defmacro
test-special-value
(
reg
temp
value
target
not-p
)
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment