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_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
  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 == ``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)
 120     else
 121         error ("rdU_hpragma: bad tag selection:"++show tag++"\n")