2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[IdUtils]{Constructing PrimOp Ids}
7 #include "HsVersions.h"
9 module IdUtils ( primOpNameInfo, primOpId ) where
12 import PrelLoop -- here for paranoia checking
15 import CoreUnfold ( UnfoldingGuidance(..) )
16 import Id ( mkPreludeId )
17 import IdInfo -- quite a few things
18 import Name ( mkBuiltinName )
19 import PrelMods ( pRELUDE_BUILTIN )
20 import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
21 PrimOpInfo(..), PrimOpResultInfo(..) )
22 import RnHsSyn ( RnName(..) )
23 import Type ( mkForAllTys, mkFunTys, applyTyCon )
24 import TysWiredIn ( boolTy )
25 import Unique ( mkPrimOpIdUnique )
30 primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
31 primOpId :: PrimOp -> Id
33 primOpNameInfo op = (primOp_str op, WiredInId (primOpId op))
36 = case (primOpInfo op) of
38 mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
41 mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
44 mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
47 mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
49 PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
50 mk_prim_Id op pRELUDE_BUILTIN str
53 (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
54 (length arg_tys) -- arity
56 AlgResult str tyvars arg_tys tycon res_tys ->
57 mk_prim_Id op pRELUDE_BUILTIN str
60 (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
61 (length arg_tys) -- arity
63 mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
64 = mkPreludeId (mkBuiltinName key mod name) ty
65 (noIdInfo `addInfo` (mkArityInfo arity)
66 `addInfo_UF` (mkUnfolding EssentialUnfolding
67 (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
69 key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
74 dyadic_fun_ty ty = mkFunTys [ty, ty] ty
75 monadic_fun_ty ty = mkFunTys [ty] ty
76 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
79 The functions to make common unfoldings are tedious.
82 mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
84 mk_prim_unfold prim_op tvs arg_tys
85 = panic "IdUtils.mk_prim_unfold"
88 (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map uniqueOf tvs)
89 inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
90 vars = mkTemplateLocals inst_arg_tys
92 mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars])