Commit f1c0fd99 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Massive patch for the first months work adding System FC to GHC #12

Broken up massive patch -=chak
Original log message:  
This is (sadly) all done in one patch to avoid Darcs bugs.
It's not complete work... more FC stuff to come.  A compiler
using just this patch will fail dismally.
parent a1433cc9
......@@ -17,7 +17,7 @@ import DsUtils ( mkErrorAppDs,
import DsMonad
import HsSyn
import TcHsSyn ( hsPatType )
import TcHsSyn ( hsLPatType )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
......@@ -262,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
`thenDs` \ match_code ->
let
pat_ty = hsPatType pat
pat_ty = hsLPatType pat
proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
(Lam var match_code)
core_cmd
......@@ -511,10 +511,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
dsLookupDataCon leftDataConName `thenDs` \ left_con ->
dsLookupDataCon rightDataConName `thenDs` \ right_con ->
let
left_id = nlHsVar (dataConWrapId left_con)
right_id = nlHsVar (dataConWrapId right_con)
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
left_id = HsVar (dataConWrapId left_con)
right_id = HsVar (dataConWrapId right_con)
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (CoTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (CoTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
......@@ -742,10 +742,10 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
= dsfixCmd ids local_vars [] (hsPatType pat) cmd
= dsfixCmd ids local_vars [] (hsLPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
pat_ty = hsPatType pat
pat_ty = hsLPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
env_ty2 = mkTupleType env_ids2
......
......@@ -323,6 +323,7 @@ simpleSubst subst expr
= go expr
where
go (Var v) = lookupVarEnv subst v `orElse` Var v
go (Cast e co) = Cast (go e) co
go (Type ty) = Type ty
go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
......@@ -421,16 +422,18 @@ addDictScc var rhs = returnDs rhs
dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
dsCoercion CoHole thing_inside = thing_inside
dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
dsCoercion (CoLams ids c) thing_inside = do { expr <- dsCoercion c thing_inside
dsCoercion (ExprCoFn co) thing_inside = do { expr <- thing_inside
; return (Cast expr co) }
dsCoercion (CoLams ids) thing_inside = do { expr <- thing_inside
; return (mkLams ids expr) }
dsCoercion (CoTyLams tvs c) thing_inside = do { expr <- dsCoercion c thing_inside
dsCoercion (CoTyLams tvs) thing_inside = do { expr <- thing_inside
; return (mkLams tvs expr) }
dsCoercion (CoApps c ids) thing_inside = do { expr <- dsCoercion c thing_inside
dsCoercion (CoApps ids) thing_inside = do { expr <- thing_inside
; return (mkVarApps expr ids) }
dsCoercion (CoTyApps c tys) thing_inside = do { expr <- dsCoercion c thing_inside
dsCoercion (CoTyApps tys) thing_inside = do { expr <- thing_inside
; return (mkTyApps expr tys) }
dsCoercion (CoLet bs c) thing_inside = do { prs <- dsLHsBinds bs
; expr <- dsCoercion c thing_inside
dsCoercion (CoLet bs) thing_inside = do { prs <- dsLHsBinds bs
; expr <- thing_inside
; return (Let (Rec prs) expr) }
\end{code}
......
......@@ -19,7 +19,7 @@ import CoreSyn
import DsMonad
import CoreUtils ( exprType, coreAltType, mkCoerce2 )
import CoreUtils ( exprType, coreAltType, mkCoerce )
import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
......@@ -34,7 +34,7 @@ import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
splitRecNewType_maybe, splitForAllTy_maybe,
isUnboxedTupleType
)
import Coercion ( Coercion, splitRecNewTypeCo_maybe, mkSymCoercion )
import PrimOp ( PrimOp(..) )
import TysPrim ( realWorldStatePrimTy, intPrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
......@@ -109,7 +109,7 @@ dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Safety -- Safety of the call
-> Type -- Type of the result: IO t
-> DsM CoreExpr
-> DsM CoreExpr -- Result, of type ???
dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
......@@ -160,8 +160,8 @@ unboxArg arg
= returnDs (arg, \body -> body)
-- Recursive newtypes
| Just rep_ty <- splitRecNewType_maybe arg_ty
= unboxArg (mkCoerce2 rep_ty arg_ty arg)
| Just(rep_ty, co) <- splitRecNewTypeCo_maybe arg_ty
= unboxArg (mkCoerce (mkSymCoercion co) arg)
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
......@@ -399,9 +399,9 @@ resultWrapper result_ty
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just rep_ty <- splitRecNewType_maybe result_ty
| Just (rep_ty, co) <- splitRecNewTypeCo_maybe result_ty
= resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
returnDs (maybe_ty, \e -> mkCoerce co (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
......
......@@ -34,7 +34,7 @@ import DsMeta ( dsBracket )
#endif
import HsSyn
import TcHsSyn ( hsPatType, mkVanillaTuplePat )
import TcHsSyn ( hsLPatType, mkVanillaTuplePat )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
......@@ -130,9 +130,9 @@ ds_val_bind (NonRecursive, hsbinds) body
putSrcSpanDs loc $
do { rhs <- dsGuarded grhss ty
; let upat = unLoc pat
eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat],
eqn = EqnInfo { eqn_pats = [upat],
eqn_rhs = cantFailMatchResult body_w_exports }
; var <- selectMatchVar upat ty
; var <- selectMatchVar upat
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (scrungleMatch var rhs result) }
......@@ -205,6 +205,7 @@ dsExpr (HsVar var) = returnDs (Var var)
dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
dsExpr (NegApp expr neg_expr)
= do { core_expr <- dsLExpr expr
......@@ -232,9 +233,9 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
extractIds (HsApp fn arg)
| HsVar argId <- unLoc arg
= argId:extractIds (unLoc fn)
| TyApp arg' ts <- unLoc arg
, HsVar argId <- unLoc arg'
= error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
| HsCoerce co_fn arg' <- unLoc arg
, HsVar argId <- arg' -- SLPJ: not sure what is going on here
= error (showSDoc (ppr co_fn)) -- argId:extractIds (unLoc fn)
extractIds x = []
extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
-- checks for tyvars and unlifted kinds.
......@@ -351,20 +352,6 @@ dsExpr (HsIf guard_expr then_expr else_expr)
\end{code}
\noindent
\underline{\bf Type lambda and application}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (TyLam tyvars expr)
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (mkLams tyvars core_expr)
dsExpr (TyApp expr tys)
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (mkTyApps core_expr tys)
\end{code}
\noindent
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -530,20 +517,18 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
[] -> nlHsVar old_arg_id
mk_alt con
= newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
= ASSERT( isVanillaDataCon con )
newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
-- This call to dataConInstOrigArgTys won't work for existentials
-- but existentials don't have record types anyway
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
rhs = foldl (\a b -> nlHsApp a b)
(noLoc $ TyApp (nlHsVar (dataConWrapId con))
out_inst_tys)
val_args
(nlHsTyApp (dataConWrapId con) out_inst_tys)
val_args
in
returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds
(PrefixCon (map nlVarPat arg_ids)) record_in_ty]
rhs)
returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
in
-- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
......@@ -578,27 +563,6 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
con_fields = dataConFieldLabels con_id
\end{code}
\noindent
\underline{\bf Dictionary lambda and application}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@DictLam@ and @DictApp@ turn into the regular old things.
(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
complicated; reminiscent of fully-applied constructors.
\begin{code}
dsExpr (DictLam dictvars expr)
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (mkLams dictvars core_expr)
------------------
dsExpr (DictApp expr dicts) -- becomes a curried application
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
\end{code}
Here is where we desugar the Template Haskell brackets and escapes
\begin{code}
......@@ -720,7 +684,7 @@ dsMDo tbl stmts body result_ty
; match_code <- extractMatchResult match fail_expr
; rhs' <- dsLExpr rhs
; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
......@@ -738,7 +702,7 @@ dsMDo tbl stmts body result_ty
later_ids' = filter (`notElem` mono_rec_ids) later_ids
mono_rec_ids = [ id | HsVar id <- rec_rets ]
mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
......@@ -755,7 +719,7 @@ dsMDo tbl stmts body result_ty
tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-- mkCoreTupTy deals with singleton case
return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty])
return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
(mk_ret_tup rets)
mk_wild_pat :: Id -> LPat Id
......
......@@ -31,6 +31,7 @@ import Literal ( Literal(..), mkStringLit )
import Module ( moduleNameFS, moduleName )
import Name ( getOccString, NamedThing(..) )
import Type ( repType, coreEqType )
import Coercion ( mkUnsafeCoercion )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
......@@ -324,7 +325,7 @@ f :: Fun -> IO (FunPtr Fun)
f cback =
bindIO (newStablePtr cback)
(\StablePtr sp# -> IO (\s1# ->
case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
(# s2#, a# #) -> (# s2#, A# a# #)))
foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
......@@ -402,8 +403,9 @@ dsFExportDynamic id cconv
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
Note (Coerce io_res_ty ccall_adj_ty)
ccall_adj
(pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
(Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty )))
io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
......
......@@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
import BasicTypes ( Boxity(..) )
import HsSyn
import TcHsSyn ( hsPatType, mkVanillaTuplePat )
import TcHsSyn ( hsLPatType, mkVanillaTuplePat )
import CoreSyn
import DsMonad -- the monadery used in the desugarer
......@@ -197,7 +197,7 @@ deBindComp pat core_list1 quals body core_list2
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
u2_ty = hsPatType pat
u2_ty = hsLPatType pat
res_ty = exprType core_list2
h_ty = u1_ty `mkFunTy` res_ty
......@@ -313,7 +313,7 @@ dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
= dsLExpr list1 `thenDs` \ core_list1 ->
-- find the required type
let x_ty = hsPatType pat
let x_ty = hsLPatType pat
b_ty = idType n_id
in
......
......@@ -73,8 +73,7 @@ data DsMatchContext
deriving ()
data EquationInfo
= EqnInfo { eqn_wrap :: DsWrapper, -- Bindings
eqn_pats :: [Pat Id], -- The patterns for an eqn
= EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
eqn_rhs :: MatchResult } -- What to do after match
type DsWrapper = CoreExpr -> CoreExpr
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment