ghc/compiler/yaccParser/U_hpragma.hs

   1
   2
   3 module U_hpragma where
   4 import UgenUtil
   5 import Util
   6
   7 import U_coresyn
   8 import U_list
   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_iinst_spec_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_iinst_pragma_3s U_list U_numId U_hpragma U_list | U_idata_pragma_4s U_list
  12
  13 rdU_hpragma :: _Addr -> UgnM U_hpragma
  14 rdU_hpragma t
  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 == ``iinst_spec_pragma'' then
  51         ioToUgnM (_ccall_ gprag_imod_spec t) `thenUgn` \ x_gprag_imod_spec ->
  52         rdU_stringId x_gprag_imod_spec `thenUgn` \ y_gprag_imod_spec ->
  53         ioToUgnM (_ccall_ gprag_dfun_spec t) `thenUgn` \ x_gprag_dfun_spec ->
  54         rdU_hpragma x_gprag_dfun_spec `thenUgn` \ y_gprag_dfun_spec ->
  55         ioToUgnM (_ccall_ gprag_inst_specs t) `thenUgn` \ x_gprag_inst_specs ->
  56         rdU_list x_gprag_inst_specs `thenUgn` \ y_gprag_inst_specs ->
  57         returnUgn (U_iinst_spec_pragma y_gprag_imod_spec y_gprag_dfun_spec y_gprag_inst_specs)
  58     else if tag == ``igen_pragma'' then
  59         ioToUgnM (_ccall_ gprag_arity t) `thenUgn` \ x_gprag_arity ->
  60         rdU_hpragma x_gprag_arity `thenUgn` \ y_gprag_arity ->
  61         ioToUgnM (_ccall_ gprag_update t) `thenUgn` \ x_gprag_update ->
  62         rdU_hpragma x_gprag_update `thenUgn` \ y_gprag_update ->
  63         ioToUgnM (_ccall_ gprag_deforest t) `thenUgn` \ x_gprag_deforest ->
  64         rdU_hpragma x_gprag_deforest `thenUgn` \ y_gprag_deforest ->
  65         ioToUgnM (_ccall_ gprag_strictness t) `thenUgn` \ x_gprag_strictness ->
  66         rdU_hpragma x_gprag_strictness `thenUgn` \ y_gprag_strictness ->
  67         ioToUgnM (_ccall_ gprag_unfolding t) `thenUgn` \ x_gprag_unfolding ->
  68         rdU_hpragma x_gprag_unfolding `thenUgn` \ y_gprag_unfolding ->
  69         ioToUgnM (_ccall_ gprag_specs t) `thenUgn` \ x_gprag_specs ->
  70         rdU_list x_gprag_specs `thenUgn` \ y_gprag_specs ->
  71         returnUgn (U_igen_pragma y_gprag_arity y_gprag_update y_gprag_deforest y_gprag_strictness y_gprag_unfolding y_gprag_specs)
  72     else if tag == ``iarity_pragma'' then
  73         ioToUgnM (_ccall_ gprag_arity_val t) `thenUgn` \ x_gprag_arity_val ->
  74         rdU_numId x_gprag_arity_val `thenUgn` \ y_gprag_arity_val ->
  75         returnUgn (U_iarity_pragma y_gprag_arity_val)
  76     else if tag == ``iupdate_pragma'' then
  77         ioToUgnM (_ccall_ gprag_update_val t) `thenUgn` \ x_gprag_update_val ->
  78         rdU_stringId x_gprag_update_val `thenUgn` \ y_gprag_update_val ->
  79         returnUgn (U_iupdate_pragma y_gprag_update_val)
  80     else if tag == ``ideforest_pragma'' then
  81         returnUgn (U_ideforest_pragma )
  82     else if tag == ``istrictness_pragma'' then
  83         ioToUgnM (_ccall_ gprag_strict_spec t) `thenUgn` \ x_gprag_strict_spec ->
  84         rdU_hstring x_gprag_strict_spec `thenUgn` \ y_gprag_strict_spec ->
  85         ioToUgnM (_ccall_ gprag_strict_wrkr t) `thenUgn` \ x_gprag_strict_wrkr ->
  86         rdU_hpragma x_gprag_strict_wrkr `thenUgn` \ y_gprag_strict_wrkr ->
  87         returnUgn (U_istrictness_pragma y_gprag_strict_spec y_gprag_strict_wrkr)
  88     else if tag == ``imagic_unfolding_pragma'' then
  89         ioToUgnM (_ccall_ gprag_magic_str t) `thenUgn` \ x_gprag_magic_str ->
  90         rdU_stringId x_gprag_magic_str `thenUgn` \ y_gprag_magic_str ->
  91         returnUgn (U_imagic_unfolding_pragma y_gprag_magic_str)
  92     else if tag == ``iunfolding_pragma'' then
  93         ioToUgnM (_ccall_ gprag_unfold_guide t) `thenUgn` \ x_gprag_unfold_guide ->
  94         rdU_hpragma x_gprag_unfold_guide `thenUgn` \ y_gprag_unfold_guide ->
  95         ioToUgnM (_ccall_ gprag_unfold_core t) `thenUgn` \ x_gprag_unfold_core ->
  96         rdU_coresyn x_gprag_unfold_core `thenUgn` \ y_gprag_unfold_core ->
  97         returnUgn (U_iunfolding_pragma y_gprag_unfold_guide y_gprag_unfold_core)
  98     else if tag == ``iunfold_always'' then
  99         returnUgn (U_iunfold_always )
 100     else if tag == ``iunfold_if_args'' then
 101         ioToUgnM (_ccall_ gprag_unfold_if_t_args t) `thenUgn` \ x_gprag_unfold_if_t_args ->
 102         rdU_numId x_gprag_unfold_if_t_args `thenUgn` \ y_gprag_unfold_if_t_args ->
 103         ioToUgnM (_ccall_ gprag_unfold_if_v_args t) `thenUgn` \ x_gprag_unfold_if_v_args ->
 104         rdU_numId x_gprag_unfold_if_v_args `thenUgn` \ y_gprag_unfold_if_v_args ->
 105         ioToUgnM (_ccall_ gprag_unfold_if_con_args t) `thenUgn` \ x_gprag_unfold_if_con_args ->
 106         rdU_stringId x_gprag_unfold_if_con_args `thenUgn` \ y_gprag_unfold_if_con_args ->
 107         ioToUgnM (_ccall_ gprag_unfold_if_size t) `thenUgn` \ x_gprag_unfold_if_size ->
 108         rdU_numId x_gprag_unfold_if_size `thenUgn` \ y_gprag_unfold_if_size ->
 109         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)
 110     else if tag == ``iname_pragma_pr'' then
 111         ioToUgnM (_ccall_ gprag_name_pr1 t) `thenUgn` \ x_gprag_name_pr1 ->
 112         rdU_unkId x_gprag_name_pr1 `thenUgn` \ y_gprag_name_pr1 ->
 113         ioToUgnM (_ccall_ gprag_name_pr2 t) `thenUgn` \ x_gprag_name_pr2 ->
 114         rdU_hpragma x_gprag_name_pr2 `thenUgn` \ y_gprag_name_pr2 ->
 115         returnUgn (U_iname_pragma_pr y_gprag_name_pr1 y_gprag_name_pr2)
 116     else if tag == ``itype_pragma_pr'' then
 117         ioToUgnM (_ccall_ gprag_type_pr1 t) `thenUgn` \ x_gprag_type_pr1 ->
 118         rdU_list x_gprag_type_pr1 `thenUgn` \ y_gprag_type_pr1 ->
 119         ioToUgnM (_ccall_ gprag_type_pr2 t) `thenUgn` \ x_gprag_type_pr2 ->
 120         rdU_numId x_gprag_type_pr2 `thenUgn` \ y_gprag_type_pr2 ->
 121         ioToUgnM (_ccall_ gprag_type_pr3 t) `thenUgn` \ x_gprag_type_pr3 ->
 122         rdU_hpragma x_gprag_type_pr3 `thenUgn` \ y_gprag_type_pr3 ->
 123         returnUgn (U_itype_pragma_pr y_gprag_type_pr1 y_gprag_type_pr2 y_gprag_type_pr3)
 124     else if tag == ``iinst_pragma_3s'' then
 125         ioToUgnM (_ccall_ gprag_inst_pt1 t) `thenUgn` \ x_gprag_inst_pt1 ->
 126         rdU_list x_gprag_inst_pt1 `thenUgn` \ y_gprag_inst_pt1 ->
 127         ioToUgnM (_ccall_ gprag_inst_pt2 t) `thenUgn` \ x_gprag_inst_pt2 ->
 128         rdU_numId x_gprag_inst_pt2 `thenUgn` \ y_gprag_inst_pt2 ->
 129         ioToUgnM (_ccall_ gprag_inst_pt3 t) `thenUgn` \ x_gprag_inst_pt3 ->
 130         rdU_hpragma x_gprag_inst_pt3 `thenUgn` \ y_gprag_inst_pt3 ->
 131         ioToUgnM (_ccall_ gprag_inst_pt4 t) `thenUgn` \ x_gprag_inst_pt4 ->
 132         rdU_list x_gprag_inst_pt4 `thenUgn` \ y_gprag_inst_pt4 ->
 133         returnUgn (U_iinst_pragma_3s y_gprag_inst_pt1 y_gprag_inst_pt2 y_gprag_inst_pt3 y_gprag_inst_pt4)
 134     else if tag == ``idata_pragma_4s'' then
 135         ioToUgnM (_ccall_ gprag_data_spec t) `thenUgn` \ x_gprag_data_spec ->
 136         rdU_list x_gprag_data_spec `thenUgn` \ y_gprag_data_spec ->
 137         returnUgn (U_idata_pragma_4s y_gprag_data_spec)
 138     else
 139         error ("rdU_hpragma: bad tag selection:"++show tag++"\n")