Commit d133b73a authored by keithw's avatar keithw
Browse files

[project @ 1999-05-11 16:37:29 by keithw]

(this is number 4 of 9 commits to be applied together)

  The major purpose of this commit is to introduce usage information
  and usage analysis into the compiler, per the paper _Once Upon a
  Polymorphic Type_ (Keith Wansbrough and Simon Peyton Jones, POPL'99,
  and Glasgow TR-1998-19).

  Usage information has been added to types, in the form of a new kind
  of NoteTy: (UsgNote UsageAnn(UsOnce|UsMany|UsVar UVar)).  Usages
  print as __o (once), __m (many, usually omitted), or (not in
  interface files) __uvxxxx.  Usage annotations should only appear at
  certain places in a type (see the paper).  The `default' annotation
  is __m, and so an omitted annotation implies __m.  Utility functions
  for handling usage annotations are provided in Type.

  If the compiler is built with -DUSMANY (a flag intended for use in
  debugging by KSW only), __m are *required* and may not be omitted.

  The major constraint is that type arguments (eg to mkAppTy) must be
  unannotated on top.  To maintain this invariant, many functions
  required the insertion of Type.unUsgTy (removing annot from top of a
  type) or UsageSPUtils.unannotTy (removing all annotations from a
  type).  A function returning usage-annotated types for primops has
  been added to PrimOp.

  A new kind of Note, (TermUsg UsageAnn), has been added to annotate
  Terms.  This note is *not* printed in interface files, and for the
  present does not escape the internals of the usage inference engine.
parent f83ad713
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.54 1999/04/13 08:55:52 kglynn Exp $
# $Id: Makefile,v 1.55 1999/05/11 16:37:29 keithw Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
......@@ -49,7 +49,7 @@ $(HS_PROG) :: $(HS_SRCS)
DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
reader profiling parser cprAnalysis
reader profiling parser usageSP cprAnalysis
ifeq ($(GhcWithNativeCodeGen),YES)
......@@ -191,7 +191,7 @@ reader/Lex_HC_OPTS = -K2m -H16m -fvia-C
# Heap was 6m with 2.10
reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m
rename/ParseIface_HC_OPTS += -Onot -H45m -fno-warn-incomplete-patterns
rename/ParseIface_HC_OPTS += -Onot -H45m -dcore-lint -fno-warn-incomplete-patterns
rename/ParseIface_HAPPY_OPTS += -g
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
......
......@@ -31,9 +31,8 @@ import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
import TysWiredIn ( boolTy )
import Type ( Type, ThetaType,
mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
isUnLiftedType, substTopTheta,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitFunTys, splitForAllTys
mkForAllTys, isUnLiftedType, substTopTheta,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, unUsgTy,
)
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
import Class ( Class, classBigSig, classTyCon )
......@@ -44,7 +43,7 @@ import Name ( mkDerivedName, mkWiredInIdName,
mkWorkerOcc, mkSuperDictSelOcc,
Name, NamedThing(..),
)
import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpUniq )
import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels,
dataConArgTys, dataConSig, dataConRawArgTys
)
......@@ -262,7 +261,8 @@ mkRecordSelId field_label selector_ty
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg]
-- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
\end{code}
......@@ -378,7 +378,8 @@ mkPrimitiveId prim_op
where
occ_name = primOpOcc prim_op
key = primOpUniq prim_op
ty = primOpType prim_op
(tyvars,arg_tys,res_ty) = primOpSig prim_op
ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
name = mkWiredInIdName key pREL_GHC occ_name id
id = mkId name ty (ConstantId (PrimOp prim_op)) info
......@@ -391,9 +392,6 @@ mkPrimitiveId prim_op
unfolding = mkUnfolding rhs
(tyvars, tau) = splitForAllTys ty
(arg_tys, _) = splitFunTys tau
args = mkTemplateLocals arg_tys
rhs = mkLams tyvars $ mkLams args $
mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
......
......@@ -11,7 +11,7 @@ module UniqSupply (
uniqFromSupply, uniqsFromSupply, -- basic ops
UniqSM, -- type: unique supply monad
initUs, thenUs, thenUs_, returnUs, fixUs, getUs, setUs,
initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, setUs,
getUniqueUs, getUniquesUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
thenMaybeUs, mapAccumLUs,
......@@ -113,11 +113,12 @@ uniqsFromSupply (I# i) supply = i `get_from` supply
\begin{code}
type UniqSM result = UniqSupply -> (result, UniqSupply)
-- the initUs function also returns the final UniqSupply
-- the initUs function also returns the final UniqSupply; initUs_ drops it
initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
initUs init_us m = case m init_us of { (r,us) -> (r,us) }
initUs :: UniqSupply -> UniqSM a -> a
initUs init_us m = case m init_us of { (r,_) -> r }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case m init_us of { (r,us) -> r }
{-# INLINE thenUs #-}
{-# INLINE returnUs #-}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{@Vars@: Variables}
......@@ -19,6 +19,11 @@ module Var (
newMutTyVar, newSigTyVar,
readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable,
-- UVars
UVar,
isUVar,
mkUVar,
-- Ids
Id, DictId,
idDetails, idName, idType, idUnique, idInfo, modifyIdInfo,
......@@ -80,6 +85,7 @@ data VarDetails
| MutTyVar (IORef (Maybe Type)) -- Used during unification;
Bool -- True <=> this is a type signature variable, which
-- should not be unified with a non-tyvar type
| UVar -- Usage variable
-- For a long time I tried to keep mutable Vars statically type-distinct
-- from immutable Vars, but I've finally given up. It's just too painful.
......@@ -198,9 +204,7 @@ writeMutTyVar (Var {varDetails = MutTyVar loc _}) val = writeIORef loc val
makeTyVarImmutable :: TyVar -> TyVar
makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
\end{code}
\begin{code}
isTyVar :: Var -> Bool
isTyVar (Var {varDetails = details}) = case details of
TyVar -> True
......@@ -217,13 +221,38 @@ isSigTyVar other = False
\end{code}
%************************************************************************
%* *
\subsection{Usage variables}
%* *
%************************************************************************
\begin{code}
type UVar = Var
\end{code}
\begin{code}
mkUVar :: Unique -> UVar
mkUVar unique = Var { varName = mkSysLocalName unique SLIT("u"),
realUnique = getKey unique,
varDetails = UVar }
\end{code}
\begin{code}
isUVar :: Var -> Bool
isUVar (Var {varDetails = details}) = case details of
UVar -> True
other -> False
\end{code}
%************************************************************************
%* *
\subsection{Id Construction}
%* *
%************************************************************************
Most Id-related functions are in Id.lhs and MkId.lhs
Most Id-related functions are in Id.lhs and MkId.lhs
\begin{code}
type Id = Var
......
......@@ -11,7 +11,7 @@ module VarEnv (
extendVarEnv, extendVarEnvList,
plusVarEnv, plusVarEnv_C,
delVarEnvList, delVarEnv,
lookupVarEnv, lookupVarEnv_NF,
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
......@@ -72,6 +72,7 @@ rngVarEnv :: VarEnv a -> [a]
isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a
lookupVarEnv_NF :: VarEnv a -> Var -> a
lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
elemVarEnv :: Var -> VarEnv a -> Bool
foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
\end{code}
......@@ -84,6 +85,7 @@ delVarEnvList = delListFromUFM
delVarEnv = delFromUFM
plusVarEnv = plusUFM
lookupVarEnv = lookupUFM
lookupWithDefaultVarEnv = lookupWithDefaultUFM
mapVarEnv = mapUFM
mkVarEnv = listToUFM
emptyVarEnv = emptyUFM
......
......@@ -31,7 +31,7 @@ import TysWiredIn ( boolTy, stringTy, nilDataCon )
import CostCentre ( CostCentre, isDupdCC, noCostCentre )
import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
import Id ( mkWildId, getInlinePragma )
import Type ( Type, mkTyVarTy, isUnLiftedType )
import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType )
import IdInfo ( InlinePragInfo(..) )
import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
import TysWiredIn ( trueDataCon, falseDataCon )
......@@ -79,6 +79,9 @@ data Note
| InlineCall -- Instructs simplifier to inline
-- the enclosed call
| TermUsg -- A term-level usage annotation
UsageAnn -- (should not be a variable except during UsageSP inference)
\end{code}
......
......@@ -32,19 +32,20 @@ import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
getIdArity, idFreeTyVars,
getIdSpecialisation, setIdSpecialisation,
getInlinePragma, setInlinePragma,
getIdUnfolding, setIdUnfolding
getIdUnfolding, setIdUnfolding, idInfo
)
import IdInfo ( arityLowerBound, InlinePragInfo(..) )
import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
import CostCentre ( CostCentre )
import Const ( Con, conType )
import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy,
splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
fullSubstTy, substTyVar )
import Unique ( buildIdKey, augmentIdKey )
import Util ( zipWithEqual, mapAccumL )
import Outputable
import TysPrim ( alphaTy ) -- Debgging only
import TysPrim ( alphaTy ) -- Debugging only
\end{code}
......@@ -75,11 +76,15 @@ coreExprType (Var var) = idType var
coreExprType (Let _ body) = coreExprType body
coreExprType (Case _ _ alts) = coreAltsType alts
coreExprType (Note (Coerce ty _) e) = ty
coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
coreExprType (Note other_note e) = coreExprType e
coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
coreExprType (Lam binder expr)
| isId binder = idType binder `mkFunTy` coreExprType expr
| isId binder = (case (lbvarInfo . idInfo) binder of
IsOneShotLambda -> mkUsgTy UsOnce
otherwise -> id) $
idType binder `mkFunTy` coreExprType expr
| isTyVar binder = mkForAllTy binder (coreExprType expr)
coreExprType e@(App _ _)
......@@ -99,6 +104,7 @@ applyTypeToArgs e op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
applyTypeToArgs e (applyTys op_ty tys) rest_args
where
(tys, rest_args) = go [ty] args
......
......@@ -261,6 +261,13 @@ ppr_expr pe (Note (Coerce to_ty from_ty) expr)
ppr_expr pe (Note InlineCall expr)
= ptext SLIT("__inline") <+> ppr_parend_expr pe expr
ppr_expr pe (Note (TermUsg u) expr)
= \ sty ->
if ifaceStyle sty then
ppr_expr pe expr sty
else
(ppr u <+> ppr_expr pe expr) sty
ppr_case_pat pe con@(DataCon dc) args
| isTupleCon dc
= parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
......
......@@ -40,7 +40,7 @@ import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
import Type ( splitFunTys, mkTyConApp,
splitAlgTyConApp, splitTyConApp_maybe,
splitAlgTyConApp, splitTyConApp_maybe, isNotUsgTy, unUsgTy,
splitAppTy, isUnLiftedType, Type
)
import TysWiredIn ( tupleCon, unboxedTupleCon,
......@@ -398,6 +398,7 @@ dsExpr (ExplicitListOut ty xs)
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
ASSERT( isNotUsgTy ty )
returnDs (mkConApp consDataCon [Type ty, core_x, core_xs])
dsExpr (ExplicitTuple expr_list boxed)
......@@ -405,18 +406,20 @@ dsExpr (ExplicitTuple expr_list boxed)
returnDs (mkConApp ((if boxed
then tupleCon
else unboxedTupleCon) (length expr_list))
(map (Type . coreExprType) core_exprs ++ core_exprs))
(map (Type . unUsgTy . coreExprType) core_exprs ++ core_exprs))
-- the above unUsgTy is *required* -- KSW 1999-04-07
dsExpr (HsCon con_id [ty] [arg])
| isNewTyCon tycon
= dsExpr arg `thenDs` \ arg' ->
returnDs (Note (Coerce result_ty (coreExprType arg')) arg')
returnDs (Note (Coerce result_ty (unUsgTy (coreExprType arg'))) arg')
where
result_ty = mkTyConApp tycon [ty]
tycon = dataConTyCon con_id
dsExpr (HsCon con_id tys args)
= mapDs dsExpr args `thenDs` \ args2 ->
ASSERT( all isNotUsgTy tys )
returnDs (mkConApp con_id (map Type tys ++ args2))
dsExpr (ArithSeqOut expr (From from))
......@@ -614,7 +617,8 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
let msg = ASSERT( isNotUsgTy b_ty )
"Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
returnDs (mkIfThenElse expr2
rest
(App (App (Var fail_id)
......@@ -644,7 +648,9 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
let
(_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy)
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
ASSERT2( isNotUsgTy b_ty, ppr b_ty )
"Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn)
(Just result_ty) locn
......
......@@ -38,7 +38,7 @@ import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat )
import TcEnv ( ValueEnv )
import Type ( Type )
import UniqSupply ( initUs, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
import UniqFM ( lookupWithDefaultUFM )
......@@ -182,7 +182,7 @@ the @SrcLoc@ being carried around.
uniqSMtoDsM :: UniqSM a -> DsM a
uniqSMtoDsM u_action us genv loc mod_and_grp warns
= (initUs us u_action, warns)
= (initUs_ us u_action, warns)
getSrcLocDs :: DsM SrcLoc
getSrcLocDs us genv loc mod_and_grp warns
......
......@@ -41,7 +41,7 @@ import Const ( Literal(..), Con(..) )
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConStrictMarks, dataConArgTys )
import BasicTypes ( StrictnessMark(..) )
import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
Type
)
import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon )
......@@ -276,7 +276,8 @@ mkErrorAppDs err_id ty msg
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
in
returnDs (mkApps (Var err_id) [Type ty, mkStringLit full_msg])
returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
-- unUsgTy *required* -- KSW 1999-04-07
\end{code}
%************************************************************************
......@@ -363,7 +364,8 @@ mkSelectorBinds pat val_expr
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
has only one element, it is the identity function. Notice we must
throw out any usage annotation on the outside of an Id.
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
......@@ -371,7 +373,7 @@ mkTupleExpr :: [Id] -> CoreExpr
mkTupleExpr [] = mkConApp unitDataCon []
mkTupleExpr [id] = Var id
mkTupleExpr ids = mkConApp (tupleCon (length ids))
(map (Type . idType) ids ++ [ Var i | i <- ids ])
(map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
\end{code}
......
......@@ -21,7 +21,7 @@ module HsTypes (
#include "HsVersions.h"
import Type ( Kind )
import Type ( Kind, UsageAnn(..) )
import PprType ( {- instance Outputable Kind -} )
import Outputable
import Util ( thenCmp, cmpList )
......@@ -54,10 +54,13 @@ data HsType name
| MonoTupleTy [HsType name] -- Element types (length gives arity)
Bool -- boxed?
-- these next two are only used in unfoldings in interfaces
-- these next two are only used in interfaces
| MonoDictTy name -- Class
[HsType name]
| MonoUsgTy UsageAnn
(HsType name)
mkHsForAllTy [] [] ty = ty
mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
......@@ -152,6 +155,10 @@ ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
= ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
= maybeParen (ctxt_prec >= pREC_CON) $
ppr u <+> ppr_mono_ty pREC_CON ty
\end{code}
......@@ -205,6 +212,9 @@ cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
= cmpUsg u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
cmpHsType cmp ty1 ty2 -- tags must be different
= let tag1 = tag ty1
tag2 = tag ty2
......@@ -217,6 +227,7 @@ cmpHsType cmp ty1 ty2 -- tags must be different
tag (MonoTyApp tc1 tys1) = ILIT(4)
tag (MonoFunTy a1 b1) = ILIT(5)
tag (MonoDictTy c1 tys1) = ILIT(7)
tag (MonoUsgTy c1 tys1) = ILIT(6)
tag (HsForAllTy _ _ _) = ILIT(8)
-------------------
......@@ -226,6 +237,14 @@ cmpContext cmp a b
cmp_ctxt (c1, tys1) (c2, tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
-- Should be in Type, perhaps
cmpUsg UsOnce UsOnce = EQ
cmpUsg UsOnce UsMany = LT
cmpUsg UsMany UsOnce = GT
cmpUsg UsMany UsMany = EQ
cmpUsg u1 u2 = pprPanic "cmpUsg:" $
ppr u1 <+> ppr u2
-- Should be in Maybes, I guess
cmpMaybe cmp Nothing Nothing = EQ
cmpMaybe cmp Nothing (Just x) = LT
......
......@@ -60,6 +60,8 @@ module PrelInfo (
monadClass_RDR, enumClass_RDR, ordClass_RDR,
ioDataCon_RDR,
main_RDR,
mkTupConRdrName, mkUbxTupConRdrName
) where
......
......@@ -150,7 +150,9 @@ pAR_ERROR_ID
openAlphaTy = mkTyVarTy openAlphaTyVar
errorTy :: Type
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
errorTy = mkUsgTy UsMany $
mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
(mkUsgTy UsMany openAlphaTy))
-- Notice the openAlphaTyVar. It says that "error" can be applied
-- to unboxed as well as boxed types. This is OK because it never
-- returns, so the return type is irrelevant.
......
......@@ -7,7 +7,7 @@
module PrimOp (
PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
primOpType,
primOpType, primOpSig, primOpUsg,
primOpUniq, primOpOcc,
commutableOp,
......@@ -33,14 +33,14 @@ import CallConv ( CallConv, pprCallConv )
import PprType ( pprParendType )
import OccName ( OccName, pprOccName, mkSrcVarOcc )
import TyCon ( TyCon, tyConArity )
import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
mkTyConTy, mkTyConApp, typePrimRep,
splitAlgTyConApp, Type, isUnboxedTupleType,
splitAlgTyConApp_maybe
splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,
UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
import Outputable
import Util ( assoc )
import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
\end{code}
......@@ -1214,6 +1214,11 @@ primOpInfo DoubleDecodeOp
%* *
%************************************************************************
\begin{verbatim}
newArray# :: Int# -> a -> State# s -> (# State# s, MutArr# s a #)
newFooArray# :: Int# -> State# s -> (# State# s, MutByteArr# s #)
\end{verbatim}
\begin{code}
primOpInfo NewArrayOp
= let {
......@@ -1237,6 +1242,11 @@ primOpInfo (NewByteArrayOp kind)
---------------------------------------------------------------------------
{-
sameMutableArray# :: MutArr# s a -> MutArr# s a -> Bool
sameMutableByteArray# :: MutByteArr# s -> MutByteArr# s -> Bool
-}
primOpInfo SameMutableArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
......@@ -1256,6 +1266,12 @@ primOpInfo SameMutableByteArrayOp
---------------------------------------------------------------------------
-- Primitive arrays of Haskell pointers:
{-
readArray# :: MutArr# s a -> Int# -> State# s -> (# State# s, a #)
writeArray# :: MutArr# s a -> Int# -> a -> State# s -> State# s
indexArray# :: Array# a -> Int# -> (# a #)
-}
primOpInfo ReadArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
......@@ -1336,6 +1352,13 @@ primOpInfo (WriteOffAddrOp kind)
(mkStatePrimTy s)
---------------------------------------------------------------------------
{-
unsafeFreezeArray# :: MutArr# s a -> State# s -> (# State# s, Array# a #)
unsafeFreezeByteArray# :: MutByteArr# s -> State# s -> (# State# s, ByteArray# #)
unsafeThawArray# :: Array# a -> State# s -> (# State# s, MutArr# s a #)
unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s, MutByteArr# s #)
-}
primOpInfo UnsafeFreezeArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
......@@ -1437,8 +1460,8 @@ primOpInfo SameMutVarOp
%* *
%************************************************************************
catch :: IO a -> (IOError -> IO a) -> IO a
catch :: a -> (b -> a) -> a
catch :: IO a -> (IOError -> IO a) -> IO a
catch# :: a -> (b -> a) -> a
\begin{code}
primOpInfo CatchOp
......@@ -1549,7 +1572,7 @@ primOpInfo ForkOp
[alphaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
-- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld
-- killThread# :: ThreadId# -> exception -> State# RealWorld -> State# RealWorld
primOpInfo KillThreadOp
= mkGenPrimOp SLIT("killThread#") [alphaTyVar]
[threadIdPrimTy, alphaTy, realWorldStatePrimTy]
......@@ -1665,7 +1688,7 @@ it is safe to pass a stable pointer to external systems such as C
routines.
\begin{verbatim}
makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, a #)
makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)
freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld
deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#
......@@ -1810,29 +1833,31 @@ primOpInfo ParOp -- par# :: a -> Int#
-- HWL: The first 4 Int# in all par... annotations denote:
-- name, granularity info, size of result, degree of parallelism
-- Same structure as _seq_ i.e. returns Int#
-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine
-- `the processor containing the expression v'; it is not evaluated
primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
primOpInfo ParGlobalOp -- parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
primOpInfo ParLocalOp -- parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
primOpInfo ParAtOp -- parAt# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
primOpInfo ParAtAbsOp -- parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
primOpInfo ParAtRelOp -- parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
primOpInfo ParAtForNowOp -- parAtForNow# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
primOpInfo CopyableOp -- copyable# :: a -> a
primOpInfo CopyableOp -- copyable# :: a -> Int#
= mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
primOpInfo NoFollowOp -- noFollow# :: a -> a
primOpInfo NoFollowOp -- noFollow# :: a -> Int#
= mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
......@@ -2089,7 +2114,7 @@ primOpOcc op
primOpUniq :: PrimOp -> Unique
primOpUniq op = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
primOpType :: PrimOp -> Type
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case (primOpInfo op) of
Dyadic occ ty -> dyadic_fun_ty ty
......@@ -2098,6 +2123,119 @@ primOpType op
GenPrimOp occ tyvars arg_tys res_ty ->
mkForAllTys tyvars (mkFunTys arg_tys res_ty)
-- primOpSig is like primOpType but gives the result split apart:
-- (type variables, argument types, result type)
primOpSig :: PrimOp -> ([TyVar],[Type],Type)
primOpSig op
= case (primOpInfo op) of
Monadic occ ty -> ([], [ty], ty )
Dyadic occ ty -> ([], [ty,ty], ty )