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

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

module IdUtils ( primOpNameInfo, primOpId ) where

import Ubiq
import PrelLoop		-- here for paranoia checking

import CoreSyn
import CoreUnfold	( UnfoldingGuidance(..) )
import Id		( mkPreludeId )
import IdInfo		-- quite a few things
18
import Name		( mkBuiltinName )
19 20
import PrelMods		( pRELUDE_BUILTIN )
import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
21 22
			  PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn		( RnName(..) )
23 24 25 26 27 28 29
import Type		( mkForAllTys, mkFunTys, applyTyCon )
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 38 39 40 41 42 43 44 45

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

      Monadic str ty ->
	mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1

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

46
      Coercing str ty1 ty2 ->
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
	mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1

      PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
	mk_prim_Id op pRELUDE_BUILTIN str
	    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 ->
	mk_prim_Id op pRELUDE_BUILTIN str
	    tyvars
	    arg_tys
	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
	    (length arg_tys) -- arity
  where
    mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
64 65 66 67 68 69
      = mkPreludeId (mkBuiltinName key mod name) ty
	   (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 75 76 77 78 79 80 81 82 83 84 85 86 87
\end{code}


\begin{code}
dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTys [ty] 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 tvs arg_tys
  = panic "IdUtils.mk_prim_unfold"
{-
  = let
88
	(inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map uniqueOf tvs)
89 90 91 92 93 94 95
	inst_arg_tys		      = map (instantiateTauTy inst_env) arg_tys
	vars	    		      = mkTemplateLocals inst_arg_tys
    in
    mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars])
-}
\end{code}