From ce3cab1dc3f3d03d43cf1b8cfc848c1ccaa00a84 Mon Sep 17 00:00:00 2001 From: sof Date: Fri, 14 Aug 1998 12:09:40 +0000 Subject: [PATCH] [project @ 1998-08-14 12:09:33 by sof] Painfully desugaring foreign decls --- ghc/compiler/deSugar/Desugar.lhs | 19 +- ghc/compiler/deSugar/DsCCall.lhs | 29 +- ghc/compiler/deSugar/DsExpr.lhs | 17 +- ghc/compiler/deSugar/DsForeign.lhs | 808 ++++++++++++++++++++++++++++++++++++ ghc/compiler/deSugar/DsMonad.lhs | 17 +- ghc/compiler/deSugar/MatchLit.lhs | 4 +- 6 files changed, 867 insertions(+), 27 deletions(-) create mode 100644 ghc/compiler/deSugar/DsForeign.lhs diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 61ce1e6..6e02ef8 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -10,11 +10,13 @@ module Desugar ( deSugar, pprDsWarnings ) where import CmdLineOpts ( opt_D_dump_ds ) import HsSyn ( MonoBinds ) -import TcHsSyn ( TypecheckedMonoBinds ) +import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl ) + import CoreSyn import PprCore ( pprCoreBindings ) import DsMonad import DsBinds ( dsMonoBinds ) +import DsForeign ( dsForeigns ) import DsUtils import Bag ( isEmptyBag ) @@ -35,11 +37,13 @@ start. deSugar :: UniqSupply -- name supply -> Module -- module name -> TypecheckedMonoBinds - -> IO [CoreBinding] -- output + -> [TypecheckedForeignDecl] + -> IO ([CoreBinding], SDoc, SDoc, SDoc) -- output -deSugar us mod_name all_binds +deSugar us mod_name all_binds fo_decls = let (us1, us2) = splitUniqSupply us + (us3, us4) = splitUniqSupply us2 module_and_group = (mod_name, grp_name) grp_name = case opt_SccGroup of @@ -49,7 +53,12 @@ deSugar us mod_name all_binds (core_prs, ds_warns) = initDs us1 nullIdEnv module_and_group (dsMonoBinds opt_SccProfilingOn all_binds []) - ds_binds = liftCoreBindings us2 [Rec core_prs] + ((fi_binds, fe_binds, hc_code, h_code, c_code), ds_warns2) = + initDs us3 nullIdEnv module_and_group + (dsForeigns fo_decls) + + ds_binds' = liftCoreBindings us4 [Rec (core_prs)] + ds_binds = fi_binds ++ ds_binds' ++ fe_binds in -- Display any warnings @@ -63,5 +72,5 @@ deSugar us mod_name all_binds dumpIfSet opt_D_dump_ds "Desugared:" (pprCoreBindings ds_binds) >> - return ds_binds + return (ds_binds, hc_code, h_code, c_code) \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 91f0101..73630c6 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -4,7 +4,14 @@ \section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s} \begin{code} -module DsCCall ( dsCCall ) where +module DsCCall + ( + dsCCall + , getIoOkDataCon + , unboxArg + , boxResult + , can'tSeeDataConsPanic + ) where #include "HsVersions.h" @@ -19,6 +26,7 @@ import Id ( Id, dataConArgTys, idType ) import Maybes ( maybeToBool ) import PrelVals ( packStringForCId ) import PrimOp ( PrimOp(..) ) +import CallConv import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type @@ -82,13 +90,13 @@ dsCCall label args may_gc is_asm io_result_ty mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> let final_args = Var old_s : unboxed_args - (ioOkDataCon, result_ty) = getIoOkDataCon io_result_ty + (ioOkDataCon, _, result_ty) = getIoOkDataCon io_result_ty in boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) -> let - the_ccall_op = CCallOp label is_asm may_gc + the_ccall_op = CCallOp (Just label) is_asm may_gc cCallConv (map coreExprType final_args) final_result_ty in @@ -121,7 +129,6 @@ unboxArg arg -- Strings | arg_ty == stringTy - -- ToDo (ADR): - allow synonyms of Strings too? = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg -> mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn -> returnDs (Var prim_arg, @@ -131,7 +138,7 @@ unboxArg arg | null data_cons -- oops: we can't see the data constructors!!! - = can't_see_datacons_error "argument" arg_ty + = can'tSeeDataConsPanic "argument" arg_ty -- Byte-arrays, both mutable and otherwise; hack warning | is_data_type && @@ -174,8 +181,8 @@ unboxArg arg maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2 Just (arg2_tycon,_) = maybe_arg2_tycon -can't_see_datacons_error thing ty - = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ " +can'tSeeDataConsPanic thing ty + = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration" (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"]) \end{code} @@ -189,7 +196,7 @@ boxResult :: Id -- IOok constructor boxResult ioOkDataCon result_ty | null data_cons -- oops! can't see the data constructors - = can't_see_datacons_error "result" result_ty + = can'tSeeDataConsPanic "result" result_ty -- Data types with a single constructor, which has a single, primitive-typed arg | (maybeToBool maybe_data_type) && -- Data type @@ -257,8 +264,8 @@ newtype IO a = IO (State# RealWorld -> IOResult a) the constructor IO has type (State# RealWorld -> IOResult a) -> IO a \begin{code} -getIoOkDataCon :: Type -- IO t - -> (Id,Type) -- Returns (IOok, t) +getIoOkDataCon :: Type -- IO t + -> (Id, Id, Type) -- Returns (IOok, IO, t) getIoOkDataCon io_ty = let @@ -271,7 +278,7 @@ getIoOkDataCon io_ty Just (io_result_tycon, _) = splitTyConApp_maybe io_result_ty [ioOkDataCon,ioFailDataCon] = tyConDataCons io_result_tycon in - (ioOkDataCon, t) + (ioOkDataCon, ioDataCon, t) \end{code} Another way to do it, more sensitive: diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 1e374ce..f44a90a 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -154,10 +154,10 @@ dsExpr (HsLitOut (HsFrac r) ty) -- others where we know what to do: dsExpr (HsLitOut (HsIntPrim i) _) - = if (i >= toInteger minInt && i <= toInteger maxInt) then - returnDs (Lit (mkMachInt i)) - else - error ("ERROR: Int constant " ++ show i ++ out_of_range_msg) + | i >= toInteger minInt && i <= toInteger maxInt + = returnDs (Lit (mkMachInt (fromInteger i))) + | otherwise + = error ("ERROR: Int constant " ++ show i ++ out_of_range_msg) dsExpr (HsLitOut (HsFloatPrim f) _) = returnDs (Lit (MachFloat f)) @@ -593,10 +593,13 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty zero_expr = TyApp (HsVar zero_id) [b_ty] main_match = PatMatch pat (SimpleMatch ( HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)) + the_matches - = if failureFreePat pat - then [main_match] - else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)] + | failureFreePat pat = [main_match] + | otherwise = + [ main_match + , PatMatch (WildPat a_ty) (SimpleMatch zero_expr) + ] in matchWrapper DoBindMatch the_matches match_msg `thenDs` \ (binders, matching_code) -> diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs new file mode 100644 index 0000000..2a855af --- /dev/null +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -0,0 +1,808 @@ +% +% (c) The AQUA Project, Glasgow University, 1998 +% +\section[DsCCall]{Desugaring \tr{foreign} declarations} + +Expanding out @foreign import@ and @foreign export@ declarations. + +\begin{code} +module DsForeign ( dsForeigns ) where + + +#include "HsVersions.h" + +import CoreSyn + +import DsCCall ( getIoOkDataCon, boxResult, unboxArg, + can'tSeeDataConsPanic + ) +import DsMonad +import DsUtils + +import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic ) +import CallConv +import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl ) +import CoreUtils ( coreExprType ) +import Id ( Id, dataConArgTys, idType, idName, + mkVanillaId, dataConRawArgTys, + dataConTyCon, mkIdVisible + ) +import IdInfo ( noIdInfo ) +import Literal ( Literal(..), mkMachInt ) +import Maybes ( maybeToBool ) +import Name ( nameString, occNameString, nameOccName, nameUnique ) +import PrelVals ( packStringForCId, eRROR_ID ) +import PrimOp ( PrimOp(..) ) +import Type ( isUnpointedType, splitAlgTyConApp_maybe, + splitTyConApp_maybe, splitFunTys, splitForAllTys, + Type, mkFunTys, applyTy, mkForAllTys, mkTyConApp, + typePrimRep, mkTyVarTy, mkFunTy, splitAppTy + ) +import PrimRep ( showPrimRepToUser, PrimRep(..) ) +import TyVar ( TyVar ) +import TyCon ( tyConDataCons ) +import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon, + realWorldTy, addrPrimTy, mkStablePtrPrimTy, + intPrimTy + ) +import TysWiredIn ( getStatePairingConInfo, + unitDataCon, stringTy, + realWorldStateTy, stateDataCon, + isFFIArgumentTy, unitTy, + addrTy, stablePtrTyCon, + stateAndPtrPrimDataCon + ) +import Outputable +\end{code} + +Desugaring of @foreign@ declarations is naturally split up into +parts, an @import@ and an @export@ part. A @foreign import@ +declaration + + foreign import cc nm f :: prim_args -> IO prim_res + +is the same as + + f :: prim_args -> IO prim_res + f a1 ... an = _ccall_ nm cc a1 ... an + +so we reuse the desugaring code in @DsCCall@ to deal with these. + +\begin{code} +dsForeigns :: [TypecheckedForeignDecl] + -> DsM ( [CoreBinding] -- desugared foreign imports + , [CoreBinding] -- helper functions for foreign exports + , SDoc -- auxilliary code to emit into .hc file + , SDoc -- Header file prototypes for "foreign exported" functions. + , SDoc -- C stubs to use when calling "foreign exported" funs. + ) +dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos + where + combine (acc_fi, acc_fe, acc_hc, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) + | isForeignImport = + dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b -> + returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c) + | isDynamic ext_nm = + dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) -> + returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c) + | otherwise = + dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,hc,h,c) -> + returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c) + + where + isForeignImport = maybeToBool imp_exp + (Just uns) = imp_exp + +\end{code} + +Desugaring foreign imports is just the matter of creating a binding +that on its RHS unboxes its arguments, performs the external call +(using the CCallOp primop), before boxing the result up and returning it. + +\begin{code} +dsFImport :: Id + -> Type -- Type of foreign import. + -> Bool -- True <=> might cause Haskell GC + -> ExtName + -> CallConv + -> DsM CoreBinding +dsFImport nm ty may_not_gc ext_name cconv = + newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s -> + mkArgs ty `thenDs` \ (tvs, args, io_res_ty) -> + mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> + let + final_args = Var old_s : unboxed_args + (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty + in + boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) -> + let + label = + case ext_name of + Dynamic -> Nothing + ExtName fs _ -> Just fs + + the_ccall_op = CCallOp label False (not may_not_gc) cconv + (map coreExprType final_args) + final_result_ty + in + mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app -> + let + the_body = mkValLam [old_s] + (foldr ($) (res_wrapper the_prim_app) arg_wrappers) + in + newSysLocalDs (coreExprType the_body) `thenDs` \ ds -> + let + io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds] + fo_rhs = mkTyLam tvs $ + mkValLam (map (\ (Var x) -> x) args) + (mkCoLetAny (NonRec ds the_body) io_app) + in + returnDs (NonRec nm fo_rhs) + +mkArgs :: Type -> DsM ([TyVar], [CoreExpr], Type) +mkArgs ty = + case splitFunTys sans_foralls of + (arg_tys, res_ty) -> + newSysLocalsDs arg_tys `thenDs` \ ds_args -> + returnDs (tvs, map Var ds_args, res_ty) + where + (tvs, sans_foralls) = splitForAllTys ty + +\end{code} + +\begin{code} +dsFExport :: Id + -> Type -- Type of foreign export. + -> ExtName + -> CallConv + -> Bool -- True => invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM (CoreBinding, SDoc, SDoc, SDoc) +dsFExport i ty ext_name cconv isDyn = + newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 -> + newSysLocalDs helper_ty `thenDs` \ f_helper -> + newSysLocalsDs helper_arg_tys `thenDs` \ helper_args -> + newSysLocalDs res_ty `thenDs` \ v1 -> + unboxResult the_prim_result_ty res_ty s3 v1 `thenDs` \ (state_and_prim_ty, unpack_result) -> + zipWithDs boxArg fe_arg_tys helper_args `thenDs` \ stuff -> + (if isDyn then + newSysLocalDs realWorldStatePrimTy `thenDs` \ s11 -> + newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> + newSysLocalDs stbl_ptr_to_ty `thenDs` \ f -> + mkPrimDs DeRefStablePtrOp + [TyArg stbl_ptr_to_ty, + VarArg (Var stbl_ptr), + VarArg (Var s1)] `thenDs` \ the_deref_app -> + let + stbl_app = \ cont -> + Case the_deref_app + (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)] + NoDefault) + in + returnDs (f, stbl_app, s11, stbl_ptr) + else + returnDs (i, + \ body -> body, + s1, + panic "stbl_ptr" -- should never be touched. + )) `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) -> + let + (boxed_args, arg_wrappers) = unzip stuff + + wrapper_args + | isDyn = stbl_ptr:helper_args + | otherwise = helper_args + + wrapper_arg_tys + | isDyn = stbl_ptr_ty:helper_arg_tys + | otherwise = helper_arg_tys + + fe_app = mkGenApp (Var i) (map (TyArg . mkTyVarTy) tvs ++ map VarArg boxed_args) + the_app = + getFun_wrapper $ + mkValApp (Note (Coerce io_result_ty io_res) fe_app) + [VarArg s2] + in + newFailLocalDs (coreExprType the_app) `thenDs` \ wild -> + getModuleAndGroupDs `thenDs` \ (mod,_) -> + getUniqueDs `thenDs` \ uniq -> + let + + the_body = + mkTyLam tvs $ + mkValLam wrapper_args $ + mkValLam [s1] $ + foldr ($) (perform_and_unpack) arg_wrappers + + perform_and_unpack = + Case the_app (AlgAlts [(ioOkDataCon, [s3, v1], unpack_result)] + (BindDefault wild err)) + + c_nm = + case ext_name of + ExtName fs _ -> fs + + full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i)) + msg = NoRepStr (_PK_ full_msg) + err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg] + + f_helper_glob = (mkIdVisible mod uniq f_helper) + (hc_stub, h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_prim_result_ty cconv + in + returnDs (NonRec f_helper_glob the_body, hc_stub, h_stub, c_stub) + where + (tvs,sans_foralls) = splitForAllTys ty + (fe_arg_tys', io_res) = splitFunTys sans_foralls + (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res + + maybe_data_type = splitAlgTyConApp_maybe res_ty + Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type + (the_data_con : other_data_cons) = data_cons + + data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys + (prim_result_ty : other_args_tys) = data_con_arg_tys + + ioDataConTy = idType ioDataCon + (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy + ([arg_ty], _) = splitFunTys ioDataConTy' + io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty + + (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty + (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty' + + fe_arg_tys + | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + (stbl_ptr_ty, helper_arg_tys) = + case (map unboxTy fe_arg_tys') of + (x:xs) | isDyn -> (x,xs) + ls -> (error "stbl_ptr_ty", ls) + + helper_ty = + mkForAllTys tvs $ + mkFunTys (arg_tys ++ [realWorldStatePrimTy]) + state_and_prim_ty + where + arg_tys + | isDyn = stbl_ptr_ty : helper_arg_tys + | otherwise = helper_arg_tys + + the_prim_result_ty + | null data_con_arg_tys = Nothing + | otherwise = Just prim_result_ty + + state_and_prim_ty + | (null other_data_cons) && + (null data_con_arg_tys) = realWorldStateTy + | otherwise = snd (getStatePairingConInfo (unboxTy res_ty)) +\end{code} + +"foreign export dynamic" lets you dress up Haskell IO actions +of some fixed type behind an externally callable interface (i.e., +as a C function pointer). Useful for callbacks and stuff. + +\begin{verbatim} +foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr + +-- Haskell-visible constructor, which is generated from the +-- above: + +f :: (Addr -> Int -> IO Int) -> IO Addr +f cback = IO ( \ s1# -> + case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# -> + case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of + StateAndAddr# s3# a# -> + case addr2Int# a# of + 0# -> IOfail s# err + _ -> + let + a :: Addr + a = A# a# + in + IOok s3# a) + +foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int +-- `special' foreign export that invokes the closure pointed to by the +-- first argument. +\end{verbatim} + +\begin{code} +dsFExportDynamic :: Id + -> Type -- Type of foreign export. + -> ExtName + -> CallConv + -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc) +dsFExportDynamic i ty ext_name cconv = + newSysLocalDs ty `thenDs` \ fe_id -> + let + -- hack: need to get at the name of the C stub we're about to generate. + fe_nm = toCName fe_id + fe_ext_name = ExtName (_PK_ fe_nm) Nothing + in + dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), hc_code, h_code, c_code) -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ s2 -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 -> + newSysLocalDs arg_ty `thenDs` \ cback_arg -> + newSysLocalDs arg_ty `thenDs` \ cback -> + newSysLocalDs (mkStablePtrPrimTy arg_ty) `thenDs` \ stbl -> + newSysLocalDs addrPrimTy `thenDs` \ addrPrim -> + newSysLocalDs addrTy `thenDs` \ addr -> + mkPrimDs MakeStablePtrOp [TyArg arg_ty, + VarArg (Var cback), + VarArg (Var s1)] `thenDs` \ mkStablePtr_app -> + mkPrimDs Addr2IntOp [VarArg (Var addrPrim)] `thenDs` \ the_addr2Int_app -> + boxArg addrTy addrPrim `thenDs` \ (addr_result, addrPrim_wrapper) -> + let + (stateAndStablePtrPrimDataCon, _) = getStatePairingConInfo (mkStablePtrPrimTy arg_ty) + (stateAndAddrPrimDataCon, stateAndAddrPrimTy) = getStatePairingConInfo addrPrimTy + + cc + | cconv == stdCallConv = 1 + | otherwise = 0 + + ccall_args = [Var s2, Lit (mkMachInt cc), + Var stbl, + Lit (MachLitLit (_PK_ fe_nm) AddrRep)] + + label = Just SLIT("createAdjustor") + the_ccall_op = CCallOp label False False{-won't GC-} cCallConv + (map coreExprType ccall_args) + stateAndAddrPrimTy + in + mkPrimDs the_ccall_op (map VarArg ccall_args) `thenDs` \ the_ccall_app -> + mkConDs ioOkDataCon + [TyArg res_ty, VarArg (Var s3), VarArg (Var addr_result)] + `thenDs` \ ioOkApp -> + newSysLocalDs intPrimTy `thenDs` \ default_val -> + let + the_mkStablePtr = \ cont -> + Case mkStablePtr_app + (AlgAlts [(stateAndStablePtrPrimDataCon, [s2, stbl], cont)] + NoDefault) + + the_ccall = \ cont -> + Case the_ccall_app + (AlgAlts [(stateAndAddrPrimDataCon, [s3, addrPrim], cont)] + NoDefault) + the_addr2Int = \ cont -> + Case the_addr2Int_app + (PrimAlts [(mkMachInt 0, io_fail)] + (BindDefault default_val cont)) + + io_fail = mkApp (Var eRROR_ID) [coreExprType wrap_res] [LitArg msg] + full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i)) + msg = NoRepStr (_PK_ full_msg) + + wrap_res = addrPrim_wrapper ioOkApp + the_body = + mkTyLam tvs $ + mkValLam [cback,s1] $ + the_mkStablePtr $ + the_ccall $ + the_addr2Int wrap_res + + in + newSysLocalDs (coreExprType the_body) `thenDs` \ ds -> + newSysLocalDs (mkFunTy realWorldStatePrimTy + (coreExprType ioOkApp)) `thenDs` \ ap -> + let + io_app = mkValApp (mkTyApp (Var ioDataCon) [res_ty]) [VarArg ap] + io_action = + mkTyLam tvs $ + mkValLam [cback_arg] $ + mkCoLetAny (NonRec ds the_body) $ + mkCoLetAny (NonRec ap (mkValApp (mkTyApp (Var ds) (map mkTyVarTy tvs)) [VarArg cback_arg])) $ + io_app + in + returnDs (NonRec i io_action, fe, hc_code, h_code, c_code) + where + (tvs,sans_foralls) = splitForAllTys ty + ([arg_ty], io_res) = splitFunTys sans_foralls + (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res + + ioDataConTy = idType ioDataCon + (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy +-- ([arg_ty], _) = splitFunTys ioDataConTy' + io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty + + export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty + +toCName :: Id -> String +toCName i = showSDoc (pprCode CStyle (ppr (idName i))) + +\end{code} + +%* +% +\subsection{Helper functions} +% +%* + +@boxArg@ boxes up an argument in preparation for calling +a function that maybe expects a boxed version of it, i.e., + +\begin{verbatim} +boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo.. +\end{verbatim} + +\begin{code} +boxArg :: Type -- Expected type after possible boxing of arg. + -> Id -- The (unboxed) argument + -> DsM (Id, -- To pass as the actual, boxed argument + CoreExpr -> CoreExpr -- Wrapper to box the arg + ) +boxArg box_ty prim_arg + | isUnpointedType box_ty = returnDs (prim_arg, \body -> body) + -- Data types with a single constructor, + -- which has a single, primitive-typed arg + | otherwise + = newSysLocalDs box_ty `thenDs` \ box_arg -> + returnDs ( box_arg + , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg])) + ) + where + maybe_boxed_prim_arg_ty = maybeBoxedPrimType box_ty + (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty + (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty +\end{code} + +@foreign export@ed functions may return a value back to the outside world. +@unboxResult@ takes care of converting from the (boxed) value that the +exported action returns to the (unboxed) value that is returned across +the border. + +\begin{code} +unboxResult :: Maybe Type -- the (unboxed) type we want to return (along with the state token) + -- Nothing => no result, just the state token. + -> Type -- the (boxed) type we have in our hand. + -> Id -- the state token + -> Id -- boxed arg + -> DsM (Type, -- type of returned expression. + CoreExpr) -- expr that unboxes result and returns state+unboxed result. + +unboxResult mb_res_uboxed_ty res_ty new_s v_boxed + | not (maybeToBool mb_res_uboxed_ty) + = -- no result, just return state token + mkConDs stateDataCon [ TyArg realWorldTy + , VarArg (Var new_s)] `thenDs` \ the_st -> + returnDs (realWorldStateTy, the_st) + + | null data_cons + -- oops! can't see the data constructors + = can'tSeeDataConsPanic "result" res_ty + + | (maybeToBool maybe_data_type) && -- Data type + (null other_data_cons) && -- - with one constructor, + isUnpointedType res_uboxed_ty -- - and of primitive type. + -- (Glasgow extension) + = + newSysLocalDs res_uboxed_ty `thenDs` \ v_unboxed -> + mkConDs state_and_prim_datacon + ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++ + [ VarArg (Var new_s) + , VarArg (Var v_unboxed)]) `thenDs` \ the_result -> + let + the_alt = (the_data_con, [v_unboxed], the_result) + in + returnDs (state_and_prim_ty, + Case (Var v_boxed) (AlgAlts [the_alt] NoDefault)) + + | otherwise + = pprPanic "unboxResult: " (ppr res_ty) + where + (Just res_uboxed_ty) = mb_res_uboxed_ty + + maybe_data_type = splitAlgTyConApp_maybe res_ty + Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type + (the_data_con : other_data_cons) = data_cons + + (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty + +\end{code} + +Returned the unboxed type of a (primitive) type: + +\begin{code} +unboxTy :: Type -> Type +unboxTy ty + | isUnpointedType ty || (ty == unitTy) = ty + | otherwise = + ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types. + case splitTyConApp_maybe ty of + Just (tyc,ts) -> + case (tyConDataCons tyc) of + [dc] -> case (dataConArgTys dc ts) of + [ubox] -> ubox + -- HACK: for the array types, the prim type is + -- the second tycon arg. + [_,ubox] -> ubox + _ -> pprPanic "unboxTy: " (ppr ty) + _ -> pprPanic "unboxTy: " (ppr ty) + _ -> pprPanic "unboxTy: " (ppr ty) + +\end{code} + +%* +% +\subsection{Generating @foreign export@ stubs} +% +%* + +[Severe hack to get @foreign export@ off the ground:] + +For each @foreign export@ function, a C stub together with a @.hc@ stub +is generated. The C stub enters the .hc stub, setting up the passing of +parameters from C land to STG land through the use of global variables +(don't worry, this just a temporary solution!). Ditto for the result. + +[ +The generation of .hc code will go once the transition is +made over to the new rts. Hence the hack, instead of extending +AbsCSyn to cope with the .hc code generated. +] + +\begin{code} +fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc, SDoc) +fexportEntry c_nm helper args res cc = + ( paramArea $$ stopTemplate $$ startTemplate $$ vtblTemplate, h_code, c_code ) + where + (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc + + paramArea = + vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) ) + + -- name of the (Haskell) helper function generated by the desugarer. + h_nm = ppr helper + h_stub_nm = text foreign_export_prefix <> h_nm + closure = h_nm <> text "_closure" + + param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args + param_tys = map (ppr.typePrimRep) args + + (res_name, res_ty) = + case res of + Nothing -> (empty, empty) + Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t)) + + startTemplate = + vcat + [ text "extern realWorldZh_closure;" + , ptext SLIT("STGFUN") <> parens (h_stub_nm) + , lbrace + , ptext SLIT("FUNBEGIN;") + , text "RestoreAllStgRegs();" + , stackCheck param_names + , pushRetReg + , pushCont + , pushRealWorld + , vcat (map pushArg (reverse param_names)) + , text "Node=" <> closure <> semi + , text "ENT_VIA_NODE();" -- ticky count + , text "InfoPtr=(D_)(INFO_PTR(Node));" + , text "JMP_(ENTRY_CODE(InfoPtr));" + , text "FUNEND;" + , rbrace + ] + + stopTemplate = + vcat + [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn") + , lbrace + , ptext SLIT("FUNBEGIN;") + , assignResult + , popRetReg + , text "#if defined(__STG_GCC_REGS__)" + , text "SaveAllStgRegs();" + , text "#else" + , text "SAVE_Hp = Hp;" + , text "SAVE_HpLim = HpLim;" + , text "#endif" + , text "JMP_(miniInterpretEnd);" + , text "FUNEND;" + , rbrace + ] + + vtblTemplate = + vcat + [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {" + , vcat (punctuate comma (replicate 8 dir_ret)) + , text "};" + ] + where + dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn" + + assignResult = + case res of + Nothing -> empty + Just _ -> res_name <> equals <> text "R3.i;" -- wrong + + pushRetReg = + text "SpB -= BREL(1);" $$ + text "*SpB = (W_)RetReg;" + + popRetReg = + text "RetReg=(StgRetAddr)*SpB;" $$ + text "SpB += BREL(1);" + + pushCont = + text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <> + text "DirectReturn,vtbl_" <> h_stub_nm <> text ");" + + pushRealWorld = + text "SpB -= BREL(1);" $$ + text "*SpB = (W_)realWorldZh_closure;" + + + pushArg nm = + text "SpB -= BREL(1);" $$ + text "*SpB = (W_)" <> nm <> semi + + stackCheck args = + text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);" + where + sz = parens $ + hsep $ punctuate (text " + ") (text "1":(map sizer args)) + + sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x) + +foreign_export_prefix :: String +foreign_export_prefix = "__fexp_" + +mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc) +mkCStub c_nm h_stub_nm args res cc = + ( hsep [ ptext SLIT("extern") + , cResType + , pprCconv + , ptext c_nm + , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs))) + , semi + ] + , vcat + [ externDecls + , cResType + , pprCconv + , ptext c_nm <> parens (hsep (punctuate comma stubArgs)) + , vcat (zipWith declVar stubParamTypes stubArgs) + , lbrace + , vcat (zipWith assignArgs param_names c_args) + , text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi + , returnResult + , rbrace + ] + ) + where + -- tedious hack to let us deal with caller-cleans-up-stack + -- discipline that the C calling convention uses. + stubParamTypes + | cc == cCallConv = ptext SLIT("void*") : cParamTypes + | otherwise = cParamTypes + stubArgs + | cc == cCallConv = ptext SLIT("_a0") : c_args + | otherwise = c_args + + param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args + cParamTypes = map (text.showPrimRepToUser.typePrimRep) args + (cResType, cResDecl) = + case res of + Nothing -> (text "void", empty) + Just t -> (text (showPrimRepToUser (typePrimRep t)), + text "extern" <+> cResType <+> res_name <> semi) + + pprCconv + | cc == cCallConv = empty + | otherwise = pprCallConv cc + + externDecls = + vcat (zipWith mkExtern cParamTypes param_names) $$ + cResDecl $$ + text "extern void" <+> h_stub_nm <> text "();" + + mkExtern ty nm = text "extern" <+> ty <+> nm <> semi + + c_args = zipWith (\ _ n -> text ('a':show n)) args [0..] + + assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi + + returnResult = + case res of + Nothing -> empty + Just _ -> text "return" <+> res_name <> semi + + (res_name, res_ty) = + case res of + Nothing -> (empty, empty) + Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t)) + +declVar :: SDoc -> SDoc -> SDoc +declVar ty var = ty <+> var <> semi + +\end{code} + +When exporting + + f :: Int -> Int -> Int -> IO Int + +we'll emit the following stuff into the .hc file + +\begin{pseudocode} +StgInt __f_param_1; +StgInt __f_param_2; +StgInt __f_param_3; +StgInt __f_res; + +STGFUN(ds_f) +{ + FUNBEGIN; + RestoreAllStgRegs(); + STK_CHK(LivenessReg,0/*A*/,(SIZE_IN_WORDS(StgInt) + + SIZE_IN_WORDS(StgInt) + + SIZE_IN_WORDS(StgInt) + 1)/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/); + RetReg = (StgRetAddr) UNVEC(stopds_fDirectReturn,vtbl_stopds_f); + SpB -= BREL(1); + *SpB = (W_)__f_param_3; + SpB -= BREL(1); + *SpB = (W_)__f_param_2; + SpB -= BREL(1); + *SpB = (W_)__f_param_1; + + SpB -= BREL(1); + *SpB = (W_) realWorldZh_closure; + + Node = ds_f_helper_closure; + ENT_VIA_NODE(); + InfoPtr=(D_)(INFO_PTR(Node)); + JMP_(ENTRY_CODE(InfoPtr)); + FUNEND; +} + +STGFUN(stop_ds_fDirectReturn) +{ + FUNBEGIN; + __f_res=R1.i; + SaveAllStgRegs(); + RESUME(miniInterpretEnd); + FUNEND; +} + +const W_ vtbl_stopds_f[] = { + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn, + (W_) stopds_fDirectReturn +}; + +\end{pseudocode} + +and a C stub + +\begin{pseudocode} +extern StgInt __f_param_1; +extern StgInt __f_param_2; +extern StgInt __f_param_3; +extern StgInt __f_res; + +extern void ds_f(); +extern void miniInterpret(StgAddr); + +int +f(a1,a2,a3) +int a1; +int a2; +int a3; +{ + __f_param_1=a1; + __f_param_2=a2; + __f_param_3=a3; + miniInterpret((StgAddr)ds_f); + return (__f_res); +} + +\end{pseudocode} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 19a4c33..bea0247 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -7,13 +7,13 @@ module DsMonad ( DsM, initDs, returnDs, thenDs, andDs, mapDs, listDs, - mapAndUnzipDs, zipWithDs, + mapAndUnzipDs, zipWithDs, foldlDs, uniqSMtoDsM, newTyVarsDs, cloneTyVarsDs, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newFailLocalDs, getSrcLocDs, putSrcLocDs, - getModuleAndGroupDs, + getModuleAndGroupDs, getUniqueDs, extendEnvDs, lookupEnvDs, DsIdEnv, @@ -39,6 +39,7 @@ import Type ( Type ) import TyVar ( cloneTyVar, TyVar ) import UniqSupply ( splitUniqSupply, getUnique, getUniques, UniqSM, UniqSupply ) +import Unique ( Unique ) import Util ( zipWithEqual, panic ) infixr 9 `thenDs` @@ -108,6 +109,13 @@ mapDs f (x:xs) mapDs f xs `thenDs` \ rs -> returnDs (r:rs) +foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a + +foldlDs k z [] = returnDs z +foldlDs k z (x:xs) = k z x `thenDs` \ r -> + foldlDs k r xs + + mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c]) mapAndUnzipDs f [] = returnDs ([], []) @@ -140,6 +148,11 @@ newSysLocalDs = newLocalDs SLIT("ds") newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys newFailLocalDs = newLocalDs SLIT("fail") +getUniqueDs :: DsM Unique +getUniqueDs us loc mod_and_grp env warns + = case (getUnique us) of { assigned_uniq -> + (assigned_uniq, warns) } + duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local us loc mod_and_grp env warns = case (getUnique us) of { assigned_uniq -> diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index a32f33e..f9e39bb 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -20,7 +20,7 @@ import Id ( Id ) import DsMonad import DsUtils -import Literal ( mkMachInt, Literal(..) ) +import Literal ( mkMachInt_safe, Literal(..) ) import PrimRep ( PrimRep(IntRep) ) import Maybes ( catMaybes ) import Type ( Type, isUnpointedType ) @@ -68,7 +68,7 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t where mk_core_lit :: Type -> HsLit -> Literal - mk_core_lit ty (HsIntPrim i) = mkMachInt i + mk_core_lit ty (HsIntPrim i) = mkMachInt_safe i mk_core_lit ty (HsCharPrim c) = MachChar c mk_core_lit ty (HsStringPrim s) = MachStr s mk_core_lit ty (HsFloatPrim f) = MachFloat f -- 1.7.10.4