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_DELOOPER(PrelLoop) -- here for paranoia checking
13 IMPORT_DELOOPER(IdLoop) (SpecEnv)
16 import CoreUnfold ( UnfoldingGuidance(..), Unfolding )
17 import Id ( mkImported, mkTemplateLocals )
18 import IdInfo -- quite a few things
19 import Name ( mkPrimitiveName, OrigName(..) )
20 import PrelMods ( gHC_BUILTINS )
21 import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
22 PrimOpInfo(..), PrimOpResultInfo(..) )
23 import RnHsSyn ( RnName(..) )
24 import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
25 import TysWiredIn ( boolTy )
26 import Unique ( mkPrimOpIdUnique )
31 primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
32 primOpId :: PrimOp -> Id
34 primOpNameInfo op = (primOp_str op, WiredInId (primOpId op))
37 = case (primOpInfo op) of
39 mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
42 mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
45 mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
47 Coercing str ty1 ty2 ->
48 mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
50 PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
54 (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
55 (length arg_tys) -- arity
57 AlgResult str tyvars arg_tys tycon res_tys ->
61 (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
62 (length arg_tys) -- arity
64 mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
65 = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
66 (noIdInfo `addInfo` (mkArityInfo arity)
67 `addInfo_UF` (mkUnfolding UnfoldAlways
68 (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
70 key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
75 dyadic_fun_ty ty = mkFunTys [ty, ty] ty
76 monadic_fun_ty ty = ty `mkFunTy` ty
77 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
80 The functions to make common unfoldings are tedious.
83 mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
85 mk_prim_unfold prim_op tyvars arg_tys
87 vars = mkTemplateLocals arg_tys
91 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])