Commit ce3cab1d authored by sof's avatar sof
Browse files

[project @ 1998-08-14 12:09:33 by sof]

Painfully desugaring foreign decls
parent 14ac360a
......@@ -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}
......@@ -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:
......
......@@ -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) ->
......
This diff is collapsed.
......@@ -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 ->
......
......@@ -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
......
Supports Markdown
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