X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdUtils.lhs;h=fa75ed4ae3b7496d3fc7de376b9a11fe88ff871c;hb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;hp=94703c3fd594d60bc36d2eee0307fc7117e99f32;hpb=f7ecf7234c224489be8a5e63fced903b655d92ee;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index 94703c3..fa75ed4 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -4,90 +4,65 @@
 \section[IdUtils]{Constructing PrimOp Ids}
 
 \begin{code}
-#include "HsVersions.h"
-
-module IdUtils ( primOpNameInfo, primOpId ) where
+module IdUtils ( primOpName ) where
 
-IMP_Ubiq()
-IMPORT_DELOOPER(PrelLoop)		-- here for paranoia checking
-IMPORT_DELOOPER(IdLoop) (SpecEnv)
+#include "HsVersions.h"
 
 import CoreSyn
-import CoreUnfold	( UnfoldingGuidance(..), Unfolding )
-import Id		( mkImported, mkTemplateLocals )
+import CoreUnfold	( UnfoldingGuidance(..), Unfolding, mkUnfolding )
+import Id		( mkPrimitiveId )
 import IdInfo		-- quite a few things
-import Name		( mkPrimitiveName, OrigName(..) )
-import PrelMods		( gHC_BUILTINS )
+import StdIdInfo
+import Name		( mkWiredInIdName, Name )
 import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
-			  PrimOpInfo(..), PrimOpResultInfo(..) )
-import RnHsSyn		( RnName(..) )
-import Type		( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
+			  PrimOpInfo(..), PrimOpResultInfo(..), PrimOp )
+import PrelMods		( gHC__ )
+import Type		( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, mkTyConApp )
 import TysWiredIn	( boolTy )
 import Unique		( mkPrimOpIdUnique )
 import Util		( panic )
 \end{code}
 
 \begin{code}
-primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
-primOpId       :: PrimOp -> Id
-
-primOpNameInfo op = (primOp_str  op, WiredInId (primOpId op))
-
-primOpId op
+primOpName       :: PrimOp -> Name
+primOpName op
   = case (primOpInfo op) of
       Dyadic str ty ->
-	mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
+	mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
 
       Monadic str ty ->
-	mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
+	mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
 
       Compare str ty ->
-	mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
+	mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
 
       Coercing str ty1 ty2 ->
-	mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
+	mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
 
       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
-	mk_prim_Id op str
+	mk_prim_name op str
 	    tyvars
 	    arg_tys
-	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
+	    (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp prim_tycon res_tys)))
 	    (length arg_tys) -- arity
 
       AlgResult str tyvars arg_tys tycon res_tys ->
-	mk_prim_Id op str
+	mk_prim_name op str
 	    tyvars
 	    arg_tys
-	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
+	    (mkForAllTys tyvars (mkFunTys arg_tys (mkTyConApp tycon res_tys)))
 	    (length arg_tys) -- arity
   where
-    mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
-      = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
-	   (noIdInfo `addInfo` (mkArityInfo arity)
-	          `addInfo_UF` (mkUnfolding UnfoldAlways
-			         (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+    mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
+      = name
       where
-	key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+	key     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+	name    = mkWiredInIdName key gHC__ occ_name the_id
+	the_id  = mkPrimitiveId name ty prim_op
 \end{code}
 
-
 \begin{code}
 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 monadic_fun_ty ty = ty `mkFunTy` ty
 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 \end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
-
-mk_prim_unfold prim_op tyvars arg_tys
-  = let
-	vars = mkTemplateLocals arg_tys
-    in
-    mkLam tyvars vars $
-    Prim prim_op
-	([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
-\end{code}
-