From ce3cab1dc3f3d03d43cf1b8cfc848c1ccaa00a84 Mon Sep 17 00:00:00 2001
From: sof <unknown>
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 61ce1e657500..6e02ef831f7c 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 91f0101ed321..73630c661ce6 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 1e374ce353ec..f44a90a29344 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 000000000000..2a855aff37de
--- /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 19a4c33b40e6..bea0247f85be 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 a32f33e739f3..f9e39bb27f2d 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
--
GitLab