Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add %frame_pointers #10419

Merged
merged 3 commits into from
May 20, 2021
Merged

Add %frame_pointers #10419

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
62e2d21
Add %frame_pointers
dra27 May 19, 2021
7995503
Simpler implementation in Translprim
dra27 May 19, 2021
aaa9e25
make depend
dra27 May 19, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
2 changes: 0 additions & 2 deletions .depend
View file
Open in desktop
Expand Up @@ -2992,15 +2992,13 @@ asmcomp/selection.cmi : \
asmcomp/spill.cmo : \
asmcomp/reg.cmi \
asmcomp/proc.cmi \
utils/misc.cmi \
asmcomp/mach.cmi \
asmcomp/cmm.cmi \
utils/clflags.cmi \
asmcomp/spill.cmi
asmcomp/spill.cmx : \
asmcomp/reg.cmx \
asmcomp/proc.cmx \
utils/misc.cmx \
asmcomp/mach.cmx \
asmcomp/cmm.cmx \
utils/clflags.cmx \
Expand Down
4 changes: 4 additions & 0 deletions Changes
View file
Open in desktop
Expand Up @@ -124,6 +124,10 @@ Working version
in the spilling and reloading passes
(Xavier Leroy, review by Vincent Laviron)

- #10419: Add %frame_pointers primitive which is true only in native code with
frame pointers mode enabled.
(David Allsopp, review by Vincent Laviron and Mark Shinwell)

### Type system:

* #10081: Typecheck `x |> f` and `f @@ x` as `(f x)`
Expand Down
12 changes: 10 additions & 2 deletions lambda/translprim.ml
View file
Open in desktop
Expand Up @@ -88,6 +88,7 @@ type prim =
| Send
| Send_self
| Send_cache
| Frame_pointers

let used_primitives = Hashtbl.create 7
let add_used_primitive loc env path =
Expand Down Expand Up @@ -143,6 +144,7 @@ let primitives_table =
"%ostype_unix", Primitive ((Pctconst Ostype_unix), 1);
"%ostype_win32", Primitive ((Pctconst Ostype_win32), 1);
"%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1);
"%frame_pointers", Frame_pointers;
"%negint", Primitive (Pnegint, 1);
"%succint", Primitive ((Poffsetint 1), 1);
"%predint", Primitive ((Poffsetint(-1)), 1);
Expand Down Expand Up @@ -695,9 +697,14 @@ let lambda_of_prim prim_name prim loc args arg_exps =
Lsend(Cached, meth, obj, [cache; pos], loc)
else
Lsend(Public, meth, obj, [], loc)
| Frame_pointers, [] ->
let frame_pointers =
if !Clflags.native_code && Config.with_frame_pointers then 1 else 0
in
Lconst (const_int frame_pointers)
| (Raise _ | Raise_with_backtrace
| Lazy_force | Loc _ | Primitive _ | Comparison _
| Send | Send_self | Send_cache), _ ->
| Send | Send_self | Send_cache | Frame_pointers), _ ->
raise(Error(to_location loc, Wrong_arity_builtin_primitive prim_name))

let check_primitive_arity loc p =
Expand All @@ -713,6 +720,7 @@ let check_primitive_arity loc p =
| Loc _ -> p.prim_arity = 1 || p.prim_arity = 0
| Send | Send_self -> p.prim_arity = 2
| Send_cache -> p.prim_arity = 4
| Frame_pointers -> p.prim_arity = 0
in
if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name))

Expand Down Expand Up @@ -782,7 +790,7 @@ let primitive_needs_event_after = function
| Comparison(comp, knd) ->
lambda_primitive_needs_event_after (comparison_primitive comp knd)
| Lazy_force | Send | Send_self | Send_cache -> true
| Raise _ | Raise_with_backtrace | Loc _ -> false
| Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers -> false

let transl_primitive_application loc p env ty path exp args arg_exps =
let prim =
Expand Down