9 import U_literal ( U_literal ) -- ditto
10 import U_ttype ( U_ttype ) -- interface only
11 data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma U_stringId U_hpragma | U_iinst_const_pragma U_stringId U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma U_numId | U_iupdate_pragma U_stringId | U_ideforest_pragma | U_istrictness_pragma U_hstring U_hpragma | U_imagic_unfolding_pragma U_stringId | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args U_numId U_numId U_stringId U_numId | U_iname_pragma_pr U_unkId U_hpragma | U_itype_pragma_pr U_list U_numId U_hpragma | U_idata_pragma_4s U_list
13 rdU_hpragma :: _Addr -> UgnM U_hpragma
15 = ioToUgnM (_ccall_ thpragma t) `thenUgn` \ tag@(I# _) ->
16 if tag == ``no_pragma'' then
17 returnUgn (U_no_pragma )
18 else if tag == ``idata_pragma'' then
19 ioToUgnM (_ccall_ gprag_data_constrs t) `thenUgn` \ x_gprag_data_constrs ->
20 rdU_list x_gprag_data_constrs `thenUgn` \ y_gprag_data_constrs ->
21 ioToUgnM (_ccall_ gprag_data_specs t) `thenUgn` \ x_gprag_data_specs ->
22 rdU_list x_gprag_data_specs `thenUgn` \ y_gprag_data_specs ->
23 returnUgn (U_idata_pragma y_gprag_data_constrs y_gprag_data_specs)
24 else if tag == ``itype_pragma'' then
25 returnUgn (U_itype_pragma )
26 else if tag == ``iclas_pragma'' then
27 ioToUgnM (_ccall_ gprag_clas t) `thenUgn` \ x_gprag_clas ->
28 rdU_list x_gprag_clas `thenUgn` \ y_gprag_clas ->
29 returnUgn (U_iclas_pragma y_gprag_clas)
30 else if tag == ``iclasop_pragma'' then
31 ioToUgnM (_ccall_ gprag_dsel t) `thenUgn` \ x_gprag_dsel ->
32 rdU_hpragma x_gprag_dsel `thenUgn` \ y_gprag_dsel ->
33 ioToUgnM (_ccall_ gprag_defm t) `thenUgn` \ x_gprag_defm ->
34 rdU_hpragma x_gprag_defm `thenUgn` \ y_gprag_defm ->
35 returnUgn (U_iclasop_pragma y_gprag_dsel y_gprag_defm)
36 else if tag == ``iinst_simpl_pragma'' then
37 ioToUgnM (_ccall_ gprag_imod_simpl t) `thenUgn` \ x_gprag_imod_simpl ->
38 rdU_stringId x_gprag_imod_simpl `thenUgn` \ y_gprag_imod_simpl ->
39 ioToUgnM (_ccall_ gprag_dfun_simpl t) `thenUgn` \ x_gprag_dfun_simpl ->
40 rdU_hpragma x_gprag_dfun_simpl `thenUgn` \ y_gprag_dfun_simpl ->
41 returnUgn (U_iinst_simpl_pragma y_gprag_imod_simpl y_gprag_dfun_simpl)
42 else if tag == ``iinst_const_pragma'' then
43 ioToUgnM (_ccall_ gprag_imod_const t) `thenUgn` \ x_gprag_imod_const ->
44 rdU_stringId x_gprag_imod_const `thenUgn` \ y_gprag_imod_const ->
45 ioToUgnM (_ccall_ gprag_dfun_const t) `thenUgn` \ x_gprag_dfun_const ->
46 rdU_hpragma x_gprag_dfun_const `thenUgn` \ y_gprag_dfun_const ->
47 ioToUgnM (_ccall_ gprag_constms t) `thenUgn` \ x_gprag_constms ->
48 rdU_list x_gprag_constms `thenUgn` \ y_gprag_constms ->
49 returnUgn (U_iinst_const_pragma y_gprag_imod_const y_gprag_dfun_const y_gprag_constms)
50 else if tag == ``igen_pragma'' then
51 ioToUgnM (_ccall_ gprag_arity t) `thenUgn` \ x_gprag_arity ->
52 rdU_hpragma x_gprag_arity `thenUgn` \ y_gprag_arity ->
53 ioToUgnM (_ccall_ gprag_update t) `thenUgn` \ x_gprag_update ->
54 rdU_hpragma x_gprag_update `thenUgn` \ y_gprag_update ->
55 ioToUgnM (_ccall_ gprag_deforest t) `thenUgn` \ x_gprag_deforest ->
56 rdU_hpragma x_gprag_deforest `thenUgn` \ y_gprag_deforest ->
57 ioToUgnM (_ccall_ gprag_strictness t) `thenUgn` \ x_gprag_strictness ->
58 rdU_hpragma x_gprag_strictness `thenUgn` \ y_gprag_strictness ->
59 ioToUgnM (_ccall_ gprag_unfolding t) `thenUgn` \ x_gprag_unfolding ->
60 rdU_hpragma x_gprag_unfolding `thenUgn` \ y_gprag_unfolding ->
61 ioToUgnM (_ccall_ gprag_specs t) `thenUgn` \ x_gprag_specs ->
62 rdU_list x_gprag_specs `thenUgn` \ y_gprag_specs ->
63 returnUgn (U_igen_pragma y_gprag_arity y_gprag_update y_gprag_deforest y_gprag_strictness y_gprag_unfolding y_gprag_specs)
64 else if tag == ``iarity_pragma'' then
65 ioToUgnM (_ccall_ gprag_arity_val t) `thenUgn` \ x_gprag_arity_val ->
66 rdU_numId x_gprag_arity_val `thenUgn` \ y_gprag_arity_val ->
67 returnUgn (U_iarity_pragma y_gprag_arity_val)
68 else if tag == ``iupdate_pragma'' then
69 ioToUgnM (_ccall_ gprag_update_val t) `thenUgn` \ x_gprag_update_val ->
70 rdU_stringId x_gprag_update_val `thenUgn` \ y_gprag_update_val ->
71 returnUgn (U_iupdate_pragma y_gprag_update_val)
72 else if tag == ``ideforest_pragma'' then
73 returnUgn (U_ideforest_pragma )
74 else if tag == ``istrictness_pragma'' then
75 ioToUgnM (_ccall_ gprag_strict_spec t) `thenUgn` \ x_gprag_strict_spec ->
76 rdU_hstring x_gprag_strict_spec `thenUgn` \ y_gprag_strict_spec ->
77 ioToUgnM (_ccall_ gprag_strict_wrkr t) `thenUgn` \ x_gprag_strict_wrkr ->
78 rdU_hpragma x_gprag_strict_wrkr `thenUgn` \ y_gprag_strict_wrkr ->
79 returnUgn (U_istrictness_pragma y_gprag_strict_spec y_gprag_strict_wrkr)
80 else if tag == ``imagic_unfolding_pragma'' then
81 ioToUgnM (_ccall_ gprag_magic_str t) `thenUgn` \ x_gprag_magic_str ->
82 rdU_stringId x_gprag_magic_str `thenUgn` \ y_gprag_magic_str ->
83 returnUgn (U_imagic_unfolding_pragma y_gprag_magic_str)
84 else if tag == ``iunfolding_pragma'' then
85 ioToUgnM (_ccall_ gprag_unfold_guide t) `thenUgn` \ x_gprag_unfold_guide ->
86 rdU_hpragma x_gprag_unfold_guide `thenUgn` \ y_gprag_unfold_guide ->
87 ioToUgnM (_ccall_ gprag_unfold_core t) `thenUgn` \ x_gprag_unfold_core ->
88 rdU_coresyn x_gprag_unfold_core `thenUgn` \ y_gprag_unfold_core ->
89 returnUgn (U_iunfolding_pragma y_gprag_unfold_guide y_gprag_unfold_core)
90 else if tag == ``iunfold_always'' then
91 returnUgn (U_iunfold_always )
92 else if tag == ``iunfold_if_args'' then
93 ioToUgnM (_ccall_ gprag_unfold_if_t_args t) `thenUgn` \ x_gprag_unfold_if_t_args ->
94 rdU_numId x_gprag_unfold_if_t_args `thenUgn` \ y_gprag_unfold_if_t_args ->
95 ioToUgnM (_ccall_ gprag_unfold_if_v_args t) `thenUgn` \ x_gprag_unfold_if_v_args ->
96 rdU_numId x_gprag_unfold_if_v_args `thenUgn` \ y_gprag_unfold_if_v_args ->
97 ioToUgnM (_ccall_ gprag_unfold_if_con_args t) `thenUgn` \ x_gprag_unfold_if_con_args ->
98 rdU_stringId x_gprag_unfold_if_con_args `thenUgn` \ y_gprag_unfold_if_con_args ->
99 ioToUgnM (_ccall_ gprag_unfold_if_size t) `thenUgn` \ x_gprag_unfold_if_size ->
100 rdU_numId x_gprag_unfold_if_size `thenUgn` \ y_gprag_unfold_if_size ->
101 returnUgn (U_iunfold_if_args y_gprag_unfold_if_t_args y_gprag_unfold_if_v_args y_gprag_unfold_if_con_args y_gprag_unfold_if_size)
102 else if tag == ``iname_pragma_pr'' then
103 ioToUgnM (_ccall_ gprag_name_pr1 t) `thenUgn` \ x_gprag_name_pr1 ->
104 rdU_unkId x_gprag_name_pr1 `thenUgn` \ y_gprag_name_pr1 ->
105 ioToUgnM (_ccall_ gprag_name_pr2 t) `thenUgn` \ x_gprag_name_pr2 ->
106 rdU_hpragma x_gprag_name_pr2 `thenUgn` \ y_gprag_name_pr2 ->
107 returnUgn (U_iname_pragma_pr y_gprag_name_pr1 y_gprag_name_pr2)
108 else if tag == ``itype_pragma_pr'' then
109 ioToUgnM (_ccall_ gprag_type_pr1 t) `thenUgn` \ x_gprag_type_pr1 ->
110 rdU_list x_gprag_type_pr1 `thenUgn` \ y_gprag_type_pr1 ->
111 ioToUgnM (_ccall_ gprag_type_pr2 t) `thenUgn` \ x_gprag_type_pr2 ->
112 rdU_numId x_gprag_type_pr2 `thenUgn` \ y_gprag_type_pr2 ->
113 ioToUgnM (_ccall_ gprag_type_pr3 t) `thenUgn` \ x_gprag_type_pr3 ->
114 rdU_hpragma x_gprag_type_pr3 `thenUgn` \ y_gprag_type_pr3 ->
115 returnUgn (U_itype_pragma_pr y_gprag_type_pr1 y_gprag_type_pr2 y_gprag_type_pr3)
116 else if tag == ``idata_pragma_4s'' then
117 ioToUgnM (_ccall_ gprag_data_spec t) `thenUgn` \ x_gprag_data_spec ->
118 rdU_list x_gprag_data_spec `thenUgn` \ y_gprag_data_spec ->
119 returnUgn (U_idata_pragma_4s y_gprag_data_spec)
121 error ("rdU_hpragma: bad tag selection:"++show tag++"\n")