TickBox representation change

[ghc-hetmet.git] / compiler / basicTypes / MkId.lhs

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index fd4e3e2..8e04b55 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -18,7 +18,7 @@ module MkId (
 
        mkDataConIds,
        mkRecordSelId, 
-       mkPrimOpId, mkFCallId,
+       mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBinaryTickBoxOpId,
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,
@@ -72,6 +72,7 @@ import Util
 import Outputable
 import FastString
 import ListSetOps
+import Module
 \end{code}             
 
 %************************************************************************
@@ -246,6 +247,7 @@ mkDataConIds wrap_name wkr_name data_con
                                                        -- even if arity = 0
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
+       --      Note [Data-con worker strictness]
        -- Notice that we do *not* say the worker is strict
        -- even if the data constructor is declared strict
        --      e.g.    data T = MkT !(Int,Int)
@@ -592,14 +594,14 @@ mkRecordSelId tycon field_label
        --              T1 b' (c : [b]=[b']) (x:Maybe b') 
        --                      -> x `cast` Maybe (sym (right c))
 
-        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
-        (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+
                -- Generate the refinement for b'=b, 
                -- and apply to (Maybe b'), to get (Maybe b)
-
-        rhs = case co_fn of
-               WpCo co -> Cast (Var the_arg_id) co
-               id_co       -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
+        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+       the_arg_id_ty = idType the_arg_id
+        (rhs, res_ty) = case refineType refinement the_arg_id_ty of
+                         Just (co, res_ty) -> (Cast (Var the_arg_id) co, res_ty)
+                         Nothing           -> (Var the_arg_id, the_arg_id_ty)
 
        field_vs    = filter (not . isPredTy . idType) arg_vs 
        the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
@@ -902,6 +904,38 @@ mkFCallId uniq fcall ty
     (arg_tys, _) = tcSplitFunTys tau
     arity       = length arg_tys
     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+
+mkTickBoxOpId :: Unique 
+             -> Module
+             -> TickBoxId
+             -> Id
+mkTickBoxOpId uniq mod ix =  mkGlobalId (TickBoxOpId tickbox) name ty info    
+  where
+    tickbox = TickBox mod ix
+    occ_str = showSDoc (braces (ppr tickbox))
+    name    = mkTickBoxOpName uniq occ_str
+    info    = noCafIdInfo
+    ty      = realWorldStatePrimTy 
+
+mkBinaryTickBoxOpId 
+              :: Unique 
+             -> Module
+             -> TickBoxId
+             -> TickBoxId
+             -> Id
+mkBinaryTickBoxOpId uniq mod ixT ixF =  mkGlobalId (TickBoxOpId tickbox) name ty info    
+  where
+    tickbox  = BinaryTickBox mod ixT ixF
+    occ_str = showSDoc (braces (ppr tickbox))
+    name    = mkTickBoxOpName uniq occ_str
+    info    = noCafIdInfo
+               `setArityInfo`          arity
+               `setAllStrictnessInfo`  Just strict_sig
+    ty      = mkFunTy boolTy boolTy
+
+    arity       = 1
+    strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+                  --- ?? mkStrictSig (mkTopDmdType [seqDmd] TopRes)
 \end{code}