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
1fb13c66
Commit
1fb13c66
authored
22 years ago
by
toy
Browse files
Options
Downloads
Patches
Plain Diff
Revived SGI MIPS port, from Mike McDonald.
parent
d08589d0
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
bootfiles/18d/boot-mips.lisp
+226
-0
226 additions, 0 deletions
bootfiles/18d/boot-mips.lisp
with
226 additions
and
0 deletions
bootfiles/18d/boot-mips.lisp
0 → 100644
+
226
−
0
View file @
1fb13c66
(
in-package
"EXTENSIONS"
)
(
export
'
(
with-float-traps-masked
))
(
in-package
"VM"
)
;;; WITH-FLOAT-TRAPS-MASKED -- Public
;;;
(
defmacro
with-float-traps-masked
(
traps
&body
body
)
"Execute BODY with the floating point exceptions listed in TRAPS
masked (disabled). TRAPS should be a list of possible exceptions
which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
:DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
accrued exceptions are cleared at the start of the body to support
their testing within, and restored on exit."
(
let
((
traps
(
dpb
(
float-trap-mask
traps
)
float-traps-byte
0
))
(
exceptions
(
dpb
(
float-trap-mask
traps
)
float-sticky-bits
0
))
(
trap-mask
(
dpb
(
lognot
(
float-trap-mask
traps
))
float-traps-byte
#xffffffff
))
(
exception-mask
(
dpb
(
lognot
(
vm::float-trap-mask
traps
))
float-sticky-bits
#xffffffff
))
(
orig-modes
(
gensym
)))
`
(
let
((
,
orig-modes
(
floating-point-modes
)))
(
unwind-protect
(
progn
(
setf
(
floating-point-modes
)
(
logand
,
orig-modes
,
(
logand
trap-mask
exception-mask
)))
,@
body
)
;; Restore the original traps and exceptions.
(
setf
(
floating-point-modes
)
(
logior
(
logand
,
orig-modes
,
(
logior
traps
exceptions
))
(
logand
(
floating-point-modes
)
,
(
logand
trap-mask
exception-mask
)
,
(
dpb
0
float-exceptions-byte
#xffffffff
))))
))))
(
in-package
"C"
)
;;; Apply the function F to a bound X. If X is an open bound, then the result
;;; will be open. IF X is NIL, the result is NIL.
;;;
(
defun
bound-func
(
f
x
)
(
and
x
(
with-float-traps-masked
(
:underflow
:overflow
:inexact
:divide-by-zero
)
;; With these traps masked, we might get things like infinity or
;; negative infinity returned. Check for this and return NIL to
;; indicate unbounded.
(
let
((
y
(
funcall
f
(
bound-value
x
))))
(
if
(
and
(
floatp
y
)
(
float-infinity-p
y
))
nil
(
set-bound
(
funcall
f
(
bound-value
x
))
(
consp
x
)))))))
;;; Apply a binary operator OP to two bounds X and Y. The result is NIL if
;;; either is NIL. Otherwise bound is computed and the result is open if
;;; either X or Y is open.
;;;
(
defmacro
bound-binop
(
op
x
y
)
`
(
and
,
x
,
y
(
with-float-traps-masked
(
:underflow
:overflow
:inexact
:divide-by-zero
)
(
set-bound
(
,
op
(
bound-value
,
x
)
(
bound-value
,
y
))
(
or
(
consp
,
x
)
(
consp
,
y
))))))
;;; ONE-ARG-DERIVE-TYPE
;;;
;;; This is used in defoptimizers for computing the resulting type of a
;;; function.
;;;
;;; Given the continuation ARG, derive the resulting type using the
;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some "atomic"
;;; continuation type like numeric-type or member-type (containing just one
;;; element). It should return the resulting type, which can be a list of
;;; types.
;;;
;;; For the case of member types, if a member-fcn is given it is called to
;;; compute the result otherwise the member type is first converted to a
;;; numeric type and the derive-fcn is call.
;;;
(
defun
one-arg-derive-type
(
arg
derive-fcn
member-fcn
&optional
(
convert-type
t
))
(
declare
(
type
function
derive-fcn
)
(
type
(
or
null
function
)
member-fcn
)
#+
negative-zero-is-not-zero
(
ignore
convert-type
))
(
let
((
arg-list
(
prepare-arg-for-derive-type
(
continuation-type
arg
))))
(
when
arg-list
(
flet
((
deriver
(
x
)
(
typecase
x
(
member-type
(
if
member-fcn
(
with-float-traps-masked
(
:underflow
:overflow
:divide-by-zero
)
(
make-member-type
:members
(
list
(
funcall
member-fcn
(
first
(
member-type-members
x
))))))
;; Otherwise convert to a numeric type.
(
let
((
result-type-list
(
funcall
derive-fcn
(
convert-member-type
x
))))
#-
negative-zero-is-not-zero
(
if
convert-type
(
convert-back-numeric-type-list
result-type-list
)
result-type-list
)
#+
negative-zero-is-not-zero
result-type-list
)))
(
numeric-type
#-
negative-zero-is-not-zero
(
if
convert-type
(
convert-back-numeric-type-list
(
funcall
derive-fcn
(
convert-numeric-type
x
)))
(
funcall
derive-fcn
x
))
#+
negative-zero-is-not-zero
(
funcall
derive-fcn
x
))
(
t
*universal-type*
))))
;; Run down the list of args and derive the type of each one, saving
;; all of the results in a list.
(
let
((
results
nil
))
(
dolist
(
arg
arg-list
)
(
let
((
result
(
deriver
arg
)))
(
if
(
listp
result
)
(
setf
results
(
append
results
result
))
(
push
result
results
))))
(
if
(
rest
results
)
(
make-canonical-union-type
results
)
(
first
results
)))))))
;;; TWO-ARG-DERIVE-TYPE
;;;
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes two
;;; arguments. DERIVE-FCN takes 3 args in this case: the two original args
;;; and a third which is T to indicate if the two args really represent the
;;; same continuation. This is useful for deriving the type of things like
;;; (* x x), which should always be positive. If we didn't do this, we
;;; wouldn't be able to tell.
;;;
;;; Without the negative-zero-is-not-zero feature, numeric types are first
;;; converted to the negative-zero-is-not-zero conventions as expected by the
;;; deriver function.
;;;
;;; For the case of two member types, the result may be derived by calling the
;;; given function FCN but if a NaN is generated then an unbounded type is
;;; returned. Alternatively a tighter, less conservative, type can often be
;;; returned by converting to numeric types and calling the deriver function,
;;; which is the default behavior without the conservative-float-type feature.
;;;
(
defun
two-arg-derive-type
(
arg1
arg2
derive-fcn
fcn
&optional
(
convert-type
t
))
#+
negative-zero-is-not-zero
(
declare
(
ignore
convert-type
))
#-
conservative-float-type
(
declare
(
ignore
fcn
))
(
labels
((
maybe-convert-numeric-type
(
type
)
#-
negative-zero-is-not-zero
(
if
convert-type
(
convert-numeric-type
type
)
type
)
#+
negative-zero-is-not-zero
type
)
(
maybe-convert-back-type-list
(
type
)
#-
negative-zero-is-not-zero
(
if
convert-type
(
convert-back-numeric-type-list
type
)
type
)
#+
negative-zero-is-not-zero
type
)
(
deriver
(
x
y
same-arg
)
(
cond
#+
conservative-float-type
((
and
(
member-type-p
x
)
(
member-type-p
y
))
(
let*
((
x
(
first
(
member-type-members
x
)))
(
y
(
first
(
member-type-members
y
)))
(
result
(
with-float-traps-masked
(
:underflow
:overflow
:divide-by-zero
:invalid
)
(
funcall
fcn
x
y
))))
(
cond
((
null
result
))
((
and
(
floatp
result
)
(
float-nan-p
result
))
(
make-numeric-type
:class
'float
:format
(
type-of
result
)
:complexp
:real
))
(
t
(
make-member-type
:members
(
list
result
))))))
#-
conservative-float-type
((
and
(
member-type-p
x
)
(
member-type-p
y
))
(
let*
((
x
(
convert-member-type
x
))
(
y
(
convert-member-type
y
))
(
result
(
funcall
derive-fcn
x
y
same-arg
)))
(
maybe-convert-back-type-list
result
)))
((
and
(
member-type-p
x
)
(
numeric-type-p
y
))
(
let*
((
x
(
convert-member-type
x
))
(
y
(
maybe-convert-numeric-type
y
))
(
result
(
funcall
derive-fcn
x
y
same-arg
)))
(
maybe-convert-back-type-list
result
)))
((
and
(
numeric-type-p
x
)
(
member-type-p
y
))
(
let*
((
x
(
maybe-convert-numeric-type
x
))
(
y
(
convert-member-type
y
))
(
result
(
funcall
derive-fcn
x
y
same-arg
)))
(
maybe-convert-back-type-list
result
)))
((
and
(
numeric-type-p
x
)
(
numeric-type-p
y
))
(
let*
((
x
(
maybe-convert-numeric-type
x
))
(
y
(
maybe-convert-numeric-type
y
))
(
result
(
funcall
derive-fcn
x
y
same-arg
)))
(
maybe-convert-back-type-list
result
)))
(
t
*universal-type*
))))
(
let
((
same-arg
(
same-leaf-ref-p
arg1
arg2
))
(
a1
(
prepare-arg-for-derive-type
(
continuation-type
arg1
)))
(
a2
(
prepare-arg-for-derive-type
(
continuation-type
arg2
))))
(
when
(
and
a1
a2
)
(
let
((
results
nil
))
(
if
same-arg
;; Since the args are the same continuation, just run
;; down the lists.
(
dolist
(
x
a1
)
(
let
((
result
(
deriver
x
x
same-arg
)))
(
if
(
listp
result
)
(
setf
results
(
append
results
result
))
(
push
result
results
))))
;; Try all pairwise combinations.
(
dolist
(
x
a1
)
(
dolist
(
y
a2
)
(
let
((
result
(
or
(
deriver
x
y
same-arg
)
(
numeric-contagion
x
y
))))
(
if
(
listp
result
)
(
setf
results
(
append
results
result
))
(
push
result
results
))))))
(
if
(
rest
results
)
(
make-canonical-union-type
results
)
(
first
results
)))))))
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