Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

option -O,2 (whole program link at Core level) now also includes fore…

…ign function exports
  • Loading branch information...
commit 83c2f061b1b213c77a7815c53a0d1f02c8ea5114 1 parent 3bee6e3
@atzedijkstra atzedijkstra authored
View
16 EHC/src/ehc/Core/BindExtract.cag
@@ -26,8 +26,8 @@ data BoundSel
, selRelevTy :: ACoreBindAspectKeyS -> RelevTy -> Bool
, selVal :: ACoreBindAspectKeyS -> MetaLev -> CLbl -> Bool
, selTy :: ACoreBindAspectKeyS -> Bool
-%%[[9090
- , selFFE :: -- TBD
+%%[[90
+ , selFFE :: Bool
%%]]
}
@@ -41,8 +41,8 @@ noBoundSel
, selRelevTy = \_ _ -> False
, selVal = \_ _ _ -> False
, selTy = const False
-%%[[9090
- , selFFE = -- TBD
+%%[[90
+ , selFFE = False
%%]]
}
@@ -63,14 +63,16 @@ boundSelMetaLev0
= noBoundSel
{ selBind = True
, selVal = \_ mlev _ -> mlev == 0
+%%[[90
+ , selFFE = True
+%%]]
}
-- | Predefined selection: same MetaLev (i.e. 0), + 1 higher (i.e. has signature)
boundSelMetaLev01 :: BoundSel
boundSelMetaLev01
- = noBoundSel
- { selBind = True
- , selVal = \_ mlev _ -> mlev <= 1
+ = boundSelMetaLev0
+ { selVal = \_ mlev _ -> mlev <= 1
, selTy = const True
}
%%]
View
6 EHC/src/ehc/Core/CommonBindExtract.cag
@@ -60,5 +60,11 @@ SEM CBound
= if selTy @lhs.boundsel @aspectKeyS
then ([@boundval],[])
else ([],[@boundval])
+%%[[90
+ | FFE lhs . (selvalYesL,selvalNoL)
+ = if selFFE @lhs.boundsel
+ then ([@boundval],[])
+ else ([],[@boundval])
+%%]]
%%]
View
76 EHC/src/ehc/Core/ExtractFFE.cag
@@ -0,0 +1,76 @@
+%%[0
+%include lhs2TeX.fmt
+%include afp.fmt
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Extraction of FFE, foreign function exports
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(90 codegen) hs module {%{EH}Core.ExtractFFE}
+%%]
+
+%%[(90 codegen) hs import(qualified Data.Set as Set,qualified Data.Map as Map)
+%%]
+
+%%[(90 codegen) hs import({%{EH}Base.Common},{%{EH}Base.Builtin},{%{EH}Core},{%{EH}Ty})
+%%]
+
+%%[(90 codegen).WRAPPER ag import({Core/AbsSyn},{Core/Trf/CommonFv},{Core/CommonBindNm})
+WRAPPER CodeAGItf
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Haskell itf
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(90 codegen) hs export(cmodExtractFFE)
+cmodExtractFFE :: CModule -> [ExtractFFE]
+cmodExtractFFE m
+ = ffeBinds_Syn_CodeAGItf t
+ where t = wrap_CodeAGItf (sem_CodeAGItf (CodeAGItf_AGItf m)) Inh_CodeAGItf
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Supporting datatypes
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(90 codegen) hs export(ExtractFFE(..))
+-- | Relevant info required outside
+data ExtractFFE
+ = ExtractFFE
+ { effeBind :: CBind -- ^ the actual binding
+ , effeFvS :: FvS -- ^ the free vars occurring in the exported expr
+ }
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Replica
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(90 codegen)
+ATTR AllExpr [ | | self: SELF ]
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% ExtractFFE
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(90 codegen)
+ATTR CodeAGItf CModule AllBind CExpr [ | | ffeBinds USE {++} {[]} : {[ExtractFFE]} ]
+%%]
+
+%%[(90 codegen)
+SEM CBind
+ | Bind lhs . ffeBinds = map (\(b,fv) -> ExtractFFE (CBind_Bind @nm [b]) fv) @bindAspects.ffeBounds
+%%]
+
+%%[(90 codegen)
+ATTR AllBound [ | | ffeBounds USE {++} {[]} : {[(CBound,FvS)]} ]
+%%]
+
+%%[(90 codegen)
+SEM CBound
+ | FFE lhs . ffeBounds = [(@self,@expr.fvS)]
+%%]
+
View
46 EHC/src/ehc/Core/Utils.chs
@@ -31,6 +31,8 @@
%%]
%%[(50 codegen) import({%{EH}Core.FvS}, {%{EH}Core.ModAsMap})
%%]
+%%[(90 codegen) import({%{EH}Core.ExtractFFE})
+%%]
-- debug
%%[(8 codegen) import({%{EH}Base.Debug},EH.Util.Pretty)
@@ -228,29 +230,33 @@ emptyPullState = PullState Seq.empty Set.empty []
-- | merge by pulling in that which is required only
cModMergeByPullingIn
- :: -- function giving bindings for name
- (HsName -- name
+ :: -- ^ function giving bindings for name
+ (HsName -- ^ name
-> Maybe
- ( cat -- category
- , [bind] -- and bindings
- , HsNameS -- pulled in names (might be > 1 for mutual recursiveness)
+ ( cat -- ^ category
+ , [bind] -- ^ and bindings
+ , HsNameS -- ^ pulled in names (might be > 1 for mutual recursiveness)
) )
- -> (expr -> HsNameS) -- extract free vars
- -> (bind -> [expr]) -- extract relevant exprs for binding
+ -> (expr -> HsNameS) -- ^ extract free vars
+ -> (bind -> [expr]) -- ^ extract relevant exprs for binding
-> ([(cat,[bind])] -> mod -> mod)
- -- update module with pulled bindings
- -> expr -- start of pulling in, usually top level name "main"
- -> ( (mod -> mod) -- conversion of resulting module
- , HsNameS -- modules from which something was taken
+ -- ^ update module with pulled bindings
+ -> expr -- ^ start of pulling in, usually top level name "main"
+ -> (cat,[(bind,HsNameS)]) -- ^ exports, providing additional pull starting points
+ -> ( (mod -> mod) -- ^ conversion of resulting module
+ , HsNameS -- ^ modules from which something was taken
)
cModMergeByPullingIn
pullIn getExprFvS getBindExprs updMod
- rootExpr
- = ( updMod (Seq.toList $ pullstBinds st)
- , Set.map (panicJust "cModMergeByPullingIn" . hsnQualifier) $ pullstPulledNmS st
+ rootExpr (exportCateg,rootExports)
+ = ( updMod (Seq.toList $ pullstBinds final)
+ , Set.map (panicJust "cModMergeByPullingIn" . hsnQualifier) $ pullstPulledNmS final
)
- where st = execState (pull) (emptyPullState {pullstToDo = Set.toList $ getExprFvS rootExpr})
- pull = do
+ where final = st {pullstBinds = pullstBinds st `Seq.union` Seq.fromList [ (exportCateg,[b]) | (b,_) <- rootExports ]}
+ where st = execState pull init
+ init = emptyPullState
+ {pullstToDo = Set.toList $ Set.unions $ getExprFvS rootExpr : map snd rootExports}
+ pull = do
s <- get
case pullstToDo s of
(nm:nmRest)
@@ -282,7 +288,7 @@ cModMerge2 (mimpL,mmain)
= mkM mmain
where (mkM,_) = cModMergeByPullingIn lkupPull cexprFvS cbindExprs
(\bs (CModule_Mod modNm _ _) -> CModule_Mod modNm (acoreLetN bs $ rootExpr) allTags)
- rootExpr
+ rootExpr rootExports
rootExpr = cmoddbMainExpr modDbMain
allTags = concatMap cmoddbTagsMp $ modDbMain : modDbImp
modDbMain = cexprModAsDatabase mmain
@@ -299,6 +305,12 @@ cModMerge2 (mimpL,mmain)
, -- (\x -> tr "cModMerge2.lkupPull" (n >#< show x) x) $
Set.fromList $ map cbindNm bs
)
+%%[[50
+ rootExports = (CBindCateg_Rec,[])
+%%][90
+ rootExports = (CBindCateg_FFE,ffes)
+ where ffes = [ (effeBind e, effeFvS e) | m <- mmain : mimpL, e <- cmodExtractFFE m ]
+%%]]
%%]
lkupMod n = do
m <- (\x -> tr "cModMerge2.lkupMod" (n >#< x) x) $
View
1  EHC/src/ehc/files-ag-s.dep
@@ -32,6 +32,7 @@ JVMClass/ToBinary.cag
JavaScript/Pretty.cag
Error/Pretty.cag
Core/BindExtract.cag
+Core/ExtractFFE.cag
Core/ToGrin.cag
Core/ToJazy.cag
Core/ToJavaScript.cag
Please sign in to comment.
Something went wrong with that request. Please try again.