IdUtils.lhs 2.51 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[IdUtils]{Constructing PrimOp Ids}

\begin{code}
#include "HsVersions.h"

module IdUtils ( primOpNameInfo, primOpId ) where

11
12
IMP_Ubiq()
IMPORT_DELOOPER(PrelLoop)		-- here for paranoia checking
13
14
15

import CoreSyn
import CoreUnfold	( UnfoldingGuidance(..) )
16
import Id		( mkImported, mkTemplateLocals )
17
import IdInfo		-- quite a few things
18
19
import Name		( mkPrimitiveName, OrigName(..) )
import PrelMods		( gHC_BUILTINS )
20
import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
21
22
			  PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn		( RnName(..) )
23
import Type		( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
24
25
26
27
28
29
import TysWiredIn	( boolTy )
import Unique		( mkPrimOpIdUnique )
import Util		( panic )
\end{code}

\begin{code}
30
primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
31
32
primOpId       :: PrimOp -> Id

33
primOpNameInfo op = (primOp_str  op, WiredInId (primOpId op))
34
35
36
37

primOpId op
  = case (primOpInfo op) of
      Dyadic str ty ->
38
	mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
39
40

      Monadic str ty ->
41
	mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
42
43

      Compare str ty ->
44
	mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
45

46
      Coercing str ty1 ty2 ->
47
	mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
48
49

      PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
50
	mk_prim_Id op str
51
52
53
54
55
56
	    tyvars
	    arg_tys
	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
	    (length arg_tys) -- arity

      AlgResult str tyvars arg_tys tycon res_tys ->
57
	mk_prim_Id op str
58
59
60
61
62
	    tyvars
	    arg_tys
	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
	    (length arg_tys) -- arity
  where
63
64
    mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
      = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
65
66
67
68
69
	   (noIdInfo `addInfo` (mkArityInfo arity)
	          `addInfo_UF` (mkUnfolding EssentialUnfolding
			         (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
      where
	key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
70
71
72
73
74
\end{code}


\begin{code}
dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
75
monadic_fun_ty ty = ty `mkFunTy` ty
76
77
78
79
80
81
82
83
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-}

84
mk_prim_unfold prim_op tyvars arg_tys
85
  = let
86
	vars = mkTemplateLocals arg_tys
87
    in
88
89
90
    mkLam tyvars vars $
    Prim prim_op
	([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
91
92
\end{code}