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
9734fb44
Commit
9734fb44
authored
32 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Added stuff for new var-alloc and fixed-alloc vops.
parent
6cada56f
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
compiler/hppa/alloc.lisp
+64
-73
64 additions, 73 deletions
compiler/hppa/alloc.lisp
with
64 additions
and
73 deletions
compiler/hppa/alloc.lisp
+
64
−
73
View file @
9734fb44
...
@@ -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/hppa/alloc.lisp,v 1.
1
199
2
/0
7
/1
3
0
3:48:14
wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.
2
199
3
/0
1
/1
5
0
1:33:03
wlott Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -120,78 +120,69 @@
...
@@ -120,78 +120,69 @@
(
storew
null-tn
result
fdefn-function-slot
other-pointer-type
)
(
storew
null-tn
result
fdefn-function-slot
other-pointer-type
)
(
storew
temp
result
fdefn-raw-addr-slot
other-pointer-type
))))
(
storew
temp
result
fdefn-raw-addr-slot
other-pointer-type
))))
(
define-vop
(
make-closure
)
(
:args
(
function
:to
:save
:scs
(
descriptor-reg
)))
(
:info
length
)
(
:temporary
(
:scs
(
non-descriptor-reg
))
temp
)
(
:results
(
result
:scs
(
descriptor-reg
)))
(
:generator
10
(
let
((
size
(
+
length
closure-info-offset
)))
(
pseudo-atomic
(
:extra
(
pad-data-block
size
))
(
inst
move
alloc-tn
result
)
(
inst
dep
function-pointer-type
31
3
result
)
(
inst
li
(
logior
(
ash
(
1-
size
)
type-bits
)
closure-header-type
)
temp
)
(
storew
temp
result
0
function-pointer-type
)))
(
storew
function
result
closure-function-slot
function-pointer-type
)))
;;; The compiler likes to be able to directly make value cells.
;;;
(
define-vop
(
make-value-cell
)
(
:args
(
value
:to
:save
:scs
(
descriptor-reg
any-reg
)))
(
:temporary
(
:scs
(
non-descriptor-reg
))
temp
)
(
:results
(
result
:scs
(
descriptor-reg
)))
(
:generator
10
(
with-fixed-allocation
(
result
temp
value-cell-header-type
value-cell-size
))
(
storew
value
result
value-cell-value-slot
other-pointer-type
)))
;;;; Automatic allocators for primitive objects.
;;;; Automatic allocators for primitive objects.
(
define-for-each-primitive-object
(
obj
)
(
define-vop
(
make-unbound-marker
)
(
collect
((
forms
))
(
:args
)
(
let*
((
options
(
primitive-object-options
obj
))
(
:results
(
result
:scs
(
any-reg
)))
(
alloc-trans
(
getf
options
:alloc-trans
))
(
:generator
1
(
alloc-vop
(
getf
options
:alloc-vop
alloc-trans
))
(
inst
li
unbound-marker-type
result
)))
(
header
(
primitive-object-header
obj
))
(
lowtag
(
primitive-object-lowtag
obj
))
(
define-vop
(
fixed-alloc
)
(
size
(
primitive-object-size
obj
))
(
:args
)
(
variable-length
(
primitive-object-variable-length
obj
))
(
:info
name
words
type
lowtag
)
(
need-unbound-marker
nil
))
(
:ignore
name
)
(
collect
((
args
)
(
init-forms
))
(
:results
(
result
:scs
(
descriptor-reg
)))
(
when
(
and
alloc-vop
variable-length
)
(
:temporary
(
:scs
(
non-descriptor-reg
))
temp
)
(
args
'extra-words
))
(
:generator
4
(
dolist
(
slot
(
primitive-object-slots
obj
))
(
pseudo-atomic
(
:extra
(
pad-data-block
words
))
(
let*
((
name
(
slot-name
slot
))
(
inst
move
alloc-tn
result
)
(
offset
(
slot-offset
slot
)))
(
inst
dep
lowtag
31
3
result
)
(
ecase
(
getf
(
slot-options
slot
)
:init
:zero
)
(
when
type
(
:zero
)
(
inst
li
(
logior
(
ash
(
1-
words
)
type-bits
)
type
)
temp
)
(
:null
(
storew
temp
result
0
lowtag
)))))
(
init-forms
`
(
storew
null-tn
result
,
offset
,
lowtag
)))
(
:unbound
(
define-vop
(
var-alloc
)
(
setf
need-unbound-marker
t
)
(
:args
(
extra
:scs
(
any-reg
)))
(
init-forms
`
(
storew
temp
result
,
offset
,
lowtag
)))
(
:arg-types
positive-fixnum
)
(
:arg
(
:info
name
words
type
lowtag
)
(
args
name
)
(
:ignore
name
)
(
init-forms
`
(
storew
,
name
result
,
offset
,
lowtag
))))))
(
:results
(
result
:scs
(
descriptor-reg
)))
(
when
(
and
(
null
alloc-vop
)
(
args
))
(
:temporary
(
:scs
(
any-reg
))
bytes
header
)
(
error
"Slots ~S want to be initialized, but there is no alloc vop ~
(
:generator
6
defined for ~S."
(
inst
addi
(
*
(
1+
words
)
word-bytes
)
extra
bytes
)
(
args
)
(
primitive-object-name
obj
)))
(
inst
sll
bytes
(
-
type-bits
2
)
header
)
(
when
alloc-vop
(
inst
addi
(
+
(
ash
-2
type-bits
)
type
)
header
header
)
(
forms
(
inst
dep
0
31
3
bytes
)
`
(
define-vop
(
,
alloc-vop
)
(
pseudo-atomic
()
(
:args
,@
(
mapcar
#'
(
lambda
(
name
)
(
inst
move
alloc-tn
result
)
`
(
,
name
:scs
(
any-reg
descriptor-reg
)))
(
inst
dep
lowtag
31
3
result
)
(
args
)))
(
storew
header
result
0
lowtag
)
,@
(
when
(
or
need-unbound-marker
header
variable-length
)
(
inst
add
alloc-tn
bytes
alloc-tn
))))
`
((
:temporary
(
:scs
(
non-descriptor-reg
))
temp
)))
(
:results
(
result
:scs
(
descriptor-reg
)
:from
:load
))
(
:policy
:fast-safe
)
,@
(
when
alloc-trans
`
((
:translate
,
alloc-trans
)))
(
:generator
37
(
pseudo-atomic
(
,@
(
unless
variable-length
`
(
:extra
(
pad-data-block
,
size
))))
(
move
alloc-tn
result
)
(
inst
dep
,
lowtag
31
3
result
)
,@
(
cond
((
and
header
variable-length
)
`
((
inst
addi
(
*
(
1+
,
size
)
word-bytes
)
extra-words
temp
)
(
inst
dep
0
31
3
temp
)
(
inst
add
temp
alloc-tn
alloc-tn
)
(
inst
sll
extra-words
(
-
type-bits
word-shift
)
temp
)
(
inst
addi
(
+
(
ash
(
1-
,
size
)
type-bits
)
,
header
)
temp
temp
)
(
storew
temp
result
0
,
lowtag
)))
(
variable-length
(
error
":REST-P T with no header in ~S?"
(
primitive-object-name
obj
)))
(
header
`
((
inst
li
,
(
logior
(
ash
(
1-
size
)
type-bits
)
(
symbol-value
header
))
temp
)
(
storew
temp
result
0
,
lowtag
)))
(
t
nil
))
,@
(
when
need-unbound-marker
`
((
inst
li
unbound-marker-type
temp
)))
,@
(
init-forms
))))))))
(
when
(
forms
)
`
(
progn
,@
(
forms
)))))
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