[project @ 2001-10-18 09:17:04 by simonmar]

[ghc-hetmet.git] / ghc / compiler / rename / ParseIface.y

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index e4bcf4b..96b701e 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -36,16 +36,15 @@ import HsSyn                -- quite a bit of stuff
 import RdrHsSyn                -- oodles of synonyms
 import HsTypes         ( mkHsForAllTy, mkHsTupCon )
 import HsCore
-import Demand          ( mkStrictnessInfo )
 import Literal         ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
-import BasicTypes      ( Fixity(..), FixityDirection(..), 
-                         NewOrData(..), Version, initialVersion, Boxity(..)
+import BasicTypes      ( Fixity(..), FixityDirection(..), StrictnessMark(..),
+                         NewOrData(..), Version, initialVersion, Boxity(..),
+                          Activation(..)
                        )
 import CostCentre       ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
-import CallConv         ( cCallConv )
 import Type            ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
 import IdInfo           ( InlinePragInfo(..) )
-import PrimOp           ( CCall(..), CCallTarget(..) )
+import ForeignCall     ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
 import Lex             
 
 import RnMonad         ( ParsedIface(..), ExportItem, IfaceDeprecs ) 
@@ -143,7 +142,7 @@ import FastString   ( tailFS )
  '__A'         { ITarity }
  '__P'         { ITspecialise }
  '__C'         { ITnocaf }
- '__U'         { ITunfold $$ }
+ '__U'         { ITunfold }
  '__S'         { ITstrict $$ }
  '__R'         { ITrules }
  '__M'         { ITcprinfo }
@@ -351,6 +350,8 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
                        { IfaceSig $2 $4 ($5 $2) $1 }
        | src_loc 'type' qtc_name tv_bndrs '=' type                    
                        { TySynonym $3 $4 $6 $1 }
+       | src_loc 'foreign' 'type' qtc_name                    
+                       { ForeignType $4 Nothing DNType $1 }
        | src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs            
                        { mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
        | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
@@ -421,8 +422,12 @@ rules         :: { [RdrNameRuleDecl] }
           | rule ';' rules     { $1:$3 }
 
 rule      :: { RdrNameRuleDecl }
-rule      : src_loc STRING rule_forall qvar_name 
-            core_args '=' core_expr    { IfaceRule $2 $3 $4 $5 $7 $1 } 
+rule      : src_loc STRING activation rule_forall qvar_name 
+            core_args '=' core_expr    { IfaceRule $2 $3 $4 $5 $6 $8 $1 } 
+
+activation :: { Activation }
+activation : {- empty -}                { AlwaysActive }
+           | INTEGER                    { ActiveAfter (fromInteger $1) }
 
 rule_forall    :: { [UfBinder RdrName] }
 rule_forall    : '__forall' '{' core_bndrs '}' { $3 }
@@ -477,9 +482,9 @@ constr              :  src_loc ex_stuff qdata_name batypes          { mk_con_decl $3 $2 (VanillaCon
                 -- We use "data_fs" so as to include ()
 
 newtype_constr :: { [RdrNameConDecl] {- Not allowed to be empty -} }
-newtype_constr : src_loc '=' ex_stuff qdata_name atype { [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] }
+newtype_constr : src_loc '=' ex_stuff qdata_name atype { [mk_con_decl $4 $3 (VanillaCon [unbangedType $5]) $1] }
                | src_loc '=' ex_stuff qdata_name '{' qvar_name '::' atype '}'
-                                                       { [mk_con_decl $4 $3 (RecCon [([$6], Unbanged $8)]) $1] }
+                                                       { [mk_con_decl $4 $3 (RecCon [([$6], unbangedType $8)]) $1] }
 
 ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
 ex_stuff       :                                       { ([],[]) }
@@ -490,18 +495,18 @@ batypes           :                                       { [] }
                |  batype batypes                       { $1 : $2 }
 
 batype         :: { RdrNameBangType }
-batype         :  tatype                               { Unbanged $1 }
-               |  '!' tatype                           { Banged   $2 }
-               |  '!' '!' tatype                       { Unpacked $3 }
+batype         :  tatype                               { unbangedType $1 }
+               |  '!' tatype                           { BangType MarkedStrict    $2 }
+               |  '!' '!' tatype                       { BangType MarkedUnboxed   $3 }
 
 fields1                :: { [([RdrName], RdrNameBangType)] }
 fields1                : field                                 { [$1] }
                | field ',' fields1                     { $1 : $3 }
 
 field          :: { ([RdrName], RdrNameBangType) }
-field          :  qvar_names1 '::' ttype               { ($1, Unbanged $3) }
-               |  qvar_names1 '::' '!' ttype           { ($1, Banged   $4) }
-               |  qvar_names1 '::' '!' '!' ttype       { ($1, Unpacked $5) }
+field          :  qvar_names1 '::' ttype               { ($1, unbangedType $3) }
+               |  qvar_names1 '::' '!' ttype           { ($1, BangType MarkedStrict    $4) }
+               |  qvar_names1 '::' '!' '!' ttype       { ($1, BangType MarkedUnboxed   $5) }
 
 --------------------------------------------------------------------------
 
@@ -596,9 +601,8 @@ mod_name    :: { ModuleName }
 
 
 ---------------------------------------------------
-var_fs         :: { EncodedFS }
+var_fs          :: { EncodedFS }
                : VARID                 { $1 }
-               | '!'                   { SLIT("!") }
                | 'as'                  { SLIT("as") }
                | 'qualified'           { SLIT("qualified") }
                | 'hiding'              { SLIT("hiding") }
@@ -689,7 +693,7 @@ qcls_name   :: { RdrName }
 
 ---------------------------------------------------
 tv_name                :: { RdrName }
-               :  VARID                { mkRdrUnqual (mkSysOccFS tvName $1) }
+               :  var_fs               { mkRdrUnqual (mkSysOccFS tvName $1) }
 
 tv_bndr                :: { HsTyVarBndr RdrName }
                :  tv_name '::' akind   { IfaceTyVar $1 $3 }
@@ -744,22 +748,13 @@ id_info           :: { [HsIdInfo RdrName] }
 id_info_item   :: { HsIdInfo RdrName }
                : '__A' INTEGER                 { HsArity (fromInteger $2) }
                | '__U' inline_prag core_expr   { HsUnfold $2 $3 }
-               | '__M'                         { HsCprInfo }
-               | '__S'                         { HsStrictness (mkStrictnessInfo $1) }
+               | '__S'                         { HsStrictness $1 }
                | '__C'                         { HsNoCafRefs }
                | '__P' qvar_name INTEGER       { HsWorker $2 (fromInteger $3) }
 
 inline_prag     :: { InlinePragInfo }
-                :  {- empty -}                  { NoInlinePragInfo }
-               | '[' from_prag phase ']'       { IMustNotBeINLINEd $2 $3 }
-
-from_prag      :: { Bool }
-               : {- empty -}                   { True }
-               | '!'                           { False }
-
-phase          :: { Maybe Int }
-               : {- empty -}                   { Nothing }
-               | INTEGER                       { Just (fromInteger $1) }
+                :  {- empty -}                  { AlwaysActive }
+               | '[' INTEGER ']'               { ActiveAfter (fromInteger $2) }
 
 -------------------------------------------------------
 core_expr      :: { UfExpr RdrName }
@@ -807,12 +802,13 @@ core_aexpr      : qvar_name                                       { UfVar $1 }
                            { let
                                  (is_dyn, is_casm, may_gc) = $2
 
-                                target | is_dyn    = DynamicTarget (error "CCall dyn target bogus unique")
+                                target | is_dyn    = DynamicTarget
+                                       | is_casm   = CasmTarget $3
                                        | otherwise = StaticTarget $3
 
-                                ccall = CCall target is_casm may_gc cCallConv
+                                ccall = CCallSpec target CCallConv may_gc
                             in
-                            UfCCall ccall $4
+                            UfFCall (CCall ccall) $4
                           }