summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorXavier Leroy <xavier.leroy@inria.fr>2000-03-17 13:24:17 +0000
committerXavier Leroy <xavier.leroy@inria.fr>2000-03-17 13:24:17 +0000
commit485d38567d396b3c9460b8c634d3b6b74ffb90a4 (patch)
tree29ac4a9a7f26a54e06fded0c5a28bf4ac804f3a3
parenta2d805dc319661489f54133ef3ea3263582ff38f (diff)
Retour de Cconst_pointer et ajout de Cconst_natpointer (necessaires pour un bon typage du code C-- et donc des racines du GC, voire PR#58)
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2972 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat
-rw-r--r--asmcomp/cmm.ml2
-rw-r--r--asmcomp/cmm.mli2
-rw-r--r--asmcomp/cmmgen.ml20
-rw-r--r--asmcomp/i386/selection.ml6
-rw-r--r--asmcomp/printcmm.ml2
-rw-r--r--asmcomp/selectgen.ml29
6 files changed, 51 insertions, 10 deletions
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 2e7242487..87d5525f2 100644
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -89,6 +89,8 @@ type expression =
| Cconst_natint of nativeint
| Cconst_float of string
| Cconst_symbol of string
+ | Cconst_pointer of int
+ | Cconst_natpointer of nativeint
| Cvar of Ident.t
| Clet of Ident.t * expression * expression
| Cassign of Ident.t * expression
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index f3334a956..ba3b9dfa9 100644
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -75,6 +75,8 @@ type expression =
| Cconst_natint of nativeint
| Cconst_float of string
| Cconst_symbol of string
+ | Cconst_pointer of int
+ | Cconst_natpointer of nativeint
| Cvar of Ident.t
| Clet of Ident.t * expression * expression
| Cassign of Ident.t * expression
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 569f7c459..77fe5cb6f 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -27,12 +27,14 @@ open Cmm
let bind name arg fn =
match arg with
- Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> fn arg
+ Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
+ | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
| _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
let bind_nonvar name arg fn =
match arg with
- Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> fn arg
+ Cconst_int _ | Cconst_natint _ | Cconst_symbol _
+ | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
| _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
(* Block headers. Meaning of the tag field:
@@ -212,11 +214,11 @@ let subst_boxed_float boxed_id unboxed_id exp =
(* Unit *)
-let return_unit c = Csequence(c, Cconst_int 1)
+let return_unit c = Csequence(c, Cconst_pointer 1)
let rec remove_unit = function
- Cconst_int 1 -> Ctuple []
- | Csequence(c, Cconst_int 1) -> c
+ Cconst_pointer 1 -> Ctuple []
+ | Csequence(c, Cconst_pointer 1) -> c
| Csequence(c1, c2) ->
Csequence(c1, remove_unit c2)
| Cifthenelse(cond, ifso, ifnot) ->
@@ -405,7 +407,11 @@ let transl_constant = function
| Const_base(Const_char c) ->
Cconst_int(((Char.code c) lsl 1) + 1)
| Const_pointer n ->
- int_const n
+ if n <= max_repr_int && n >= min_repr_int
+ then Cconst_pointer((n lsl 1) + 1)
+ else Cconst_natpointer(Nativeint.add
+ (Nativeint.shift_left (Nativeint.of_int n) 1)
+ Nativeint.one)
| cst ->
let lbl =
try
@@ -759,7 +765,7 @@ let rec transl = function
bind "switch" (untag_int (transl arg)) (fun idx ->
Cifthenelse(
Cop(Ccmpa Cge,
- [idx; Cconst_int(Array.length s.us_index_consts)]),
+ [idx; Cconst_pointer(Array.length s.us_index_consts)]),
Cexit,
transl_switch idx s.us_index_consts s.us_cases_consts))
else
diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml
index 221c6ddef..2f8f9513a 100644
--- a/asmcomp/i386/selection.ml
+++ b/asmcomp/i386/selection.ml
@@ -164,6 +164,10 @@ method select_store addr exp =
(Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
| Cconst_natint n ->
(Ispecific(Istore_int(n, addr)), Ctuple [])
+ | Cconst_pointer n ->
+ (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
+ | Cconst_natpointer n ->
+ (Ispecific(Istore_int(n, addr)), Ctuple [])
| Cconst_symbol s ->
(Ispecific(Istore_symbol(s, addr)), Ctuple [])
| _ ->
@@ -256,6 +260,8 @@ method select_push exp =
match exp with
Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
| Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple [])
+ | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple [])
+ | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
| Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
| Cop(Cload Word, [loc]) ->
let (addr, arg) = self#select_addressing loc in
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 2a734cc74..149fb86b6 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -92,6 +92,8 @@ let rec expr ppf = function
| Cconst_natint n -> print_string(Nativeint.to_string n)
| Cconst_float s -> print_string s
| Cconst_symbol s -> printf "\"%s\"" s
+ | Cconst_pointer n -> printf "%ia" n
+ | Cconst_natpointer n -> printf "%sa" (Nativeint.to_string n)
| Cvar id -> Ident.print ppf id
| Clet(id, def, (Clet(_, _, _) as body)) ->
let print_binding id ppf def =
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 25da4da1c..7693dfc1b 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -50,7 +50,8 @@ let oper_result_type = function
let size_expr env exp =
let rec size localenv = function
Cconst_int _ | Cconst_natint _ -> Arch.size_int
- | Cconst_symbol _ -> Arch.size_addr
+ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ ->
+ Arch.size_addr
| Cconst_float _ -> Arch.size_float
| Cvar id ->
begin try
@@ -87,6 +88,8 @@ let rec is_simple_expr = function
| Cconst_natint _ -> true
| Cconst_float _ -> true
| Cconst_symbol _ -> true
+ | Cconst_pointer _ -> true
+ | Cconst_natpointer _ -> true
| Cvar _ -> true
| Ctuple el -> List.for_all is_simple_expr el
| Clet(id, arg, body) -> is_simple_expr arg && is_simple_expr body
@@ -248,14 +251,20 @@ method select_operation op args =
method private select_arith_comm op = function
[arg; Cconst_int n] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
+ | [arg; Cconst_pointer n] when self#is_immediate n ->
+ (Iintop_imm(op, n), [arg])
| [Cconst_int n; arg] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
+ | [Cconst_pointer n; arg] when self#is_immediate n ->
+ (Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)
method private select_arith op = function
[arg; Cconst_int n] when self#is_immediate n ->
(Iintop_imm(op, n), [arg])
+ | [arg; Cconst_pointer n] when self#is_immediate n ->
+ (Iintop_imm(op, n), [arg])
| args ->
(Iintop op, args)
@@ -268,8 +277,12 @@ method private select_shift op = function
method private select_arith_comp cmp = function
[arg; Cconst_int n] when self#is_immediate n ->
(Iintop_imm(Icomp cmp, n), [arg])
+ | [arg; Cconst_pointer n] when self#is_immediate n ->
+ (Iintop_imm(Icomp cmp, n), [arg])
| [Cconst_int n; arg] when self#is_immediate n ->
(Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
+ | [Cconst_pointer n; arg] when self#is_immediate n ->
+ (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
| args ->
(Iintop(Icomp cmp), args)
@@ -280,11 +293,15 @@ method select_condition = function
(Iinttest_imm(Isigned cmp, n), arg1)
| Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
(Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
+ | Cop(Ccmpi cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
+ (Iinttest_imm(Isigned cmp, n), arg1)
+ | Cop(Ccmpi cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
+ (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
| Cop(Ccmpi cmp, args) ->
(Iinttest(Isigned cmp), Ctuple args)
- | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n ->
+ | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
(Iinttest_imm(Iunsigned cmp, n), arg1)
- | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
+ | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
(Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
| Cop(Ccmpa cmp, args) ->
(Iinttest(Iunsigned cmp), Ctuple args)
@@ -355,6 +372,12 @@ method emit_expr env exp =
| Cconst_symbol n ->
let r = Reg.createv typ_addr in
self#insert_op (Iconst_symbol n) [||] r
+ | Cconst_pointer n ->
+ let r = Reg.createv typ_addr in
+ self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r
+ | Cconst_natpointer n ->
+ let r = Reg.createv typ_addr in
+ self#insert_op (Iconst_int n) [||] r
| Cvar v ->
begin try
Tbl.find v env
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-30 22:29:46 +0000