Skip to content

Commit

Permalink
core unparse/parse produces executable but crashes (data constructor …
Browse files Browse the repository at this point in the history 
…info not yet properly propagated)
  • Loading branch information
@atzedijkstra
atzedijkstra committed Jun 13, 2014
1 parent 99b5e3f commit c4ab6ea
Show file tree
Hide file tree
Showing 6 changed files with 111 additions and 45 deletions.
6 changes: 5 additions & 1 deletion EHC/src/ehc/Base/HsName.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -193,6 +193,9 @@ instance HsNameUniqueable UID where
%%[7
uniqifierMpAdd :: HsNameUniqifier -> HsNameUnique -> HsNameUniqifierMp -> HsNameUniqifierMp
uniqifierMpAdd ufier u m = Map.unionWith (++) (Map.singleton ufier [u]) m

uniqifierMpUnion :: HsNameUniqifierMp -> HsNameUniqifierMp -> HsNameUniqifierMp
uniqifierMpUnion = Map.unionWith (++)
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down Expand Up @@ -361,7 +364,8 @@ hsnMkModf :: [String] -> HsName -> HsNameUniqifierMp -> HsName
%%[[1
hsnMkModf = HsName_Modf 0
%%][99
hsnMkModf q b u = hsnFixateHash $ HsName_Modf 0 q b u
-- hsnMkModf q b u = hsnFixateHash $ HsName_Modf 0 q b u
hsnMkModf q b u = hsnFixateHash $ either (\(_,n) -> n {hsnQualifiers = q, hsnUniqifiers = hsnUniqifiers n `uniqifierMpUnion` u}) (\b -> HsName_Modf 0 q b u) $ hsnCanonicSplit b
%%]]
{-# INLINE hsnMkModf #-}
%%]
Expand Down
37 changes: 30 additions & 7 deletions EHC/src/ehc/Core/Check.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@
%%[(50 codegen corein) hs import(UHC.Util.Pretty)
%%]

%%[(50 codegen corein).WRAPPER ag import({Core/AbsSyn},{Core/CommonBindNm},{Core/CommonMetaLev})
%%[(50 codegen corein).WRAPPER ag import({Core/AbsSyn},{Core/CommonBindNm},{Core/CommonLev},{Core/CommonLevLet},{Core/CommonCtxtPred})
WRAPPER CodeAGItf
%%]

Expand Down Expand Up @@ -71,10 +71,10 @@ cmodCheck' opts env cmod
cmodCheck
:: EHCOpts
-> CheckEnv -> CModule
-> ( ErrL -- check errors
, HsName -- the actual name of the module as used.
, [HsName] -- imported modules
, Bool -- has a main
-> ( ErrL -- check errors
, HsName -- the actual name of the module as used.
, [HsName] -- imported modules
, Bool -- has a main
)
cmodCheck opts env cmod
= ( Seq.toList $ errs_Syn_CodeAGItf t
Expand Down Expand Up @@ -113,7 +113,7 @@ ATTR AllCodeNT [ | | self: SELF ]
ATTR CodeAGItf CModule [ | | realModuleNm: HsName ]

SEM CModule
| Mod lhs . realModuleNm = @moduleNm
| Mod lhs . realModuleNm = @moduleNm
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand All @@ -124,7 +124,30 @@ SEM CModule
ATTR CodeAGItf CModule CExpr AllBindOnly [ | | hasMain USE {||} {False} : Bool ]

SEM CBind
| Bind lhs . hasMain = @nm == hsnMain
| Bind lhs . hasMain = @nm == hsnMain

%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Module is already lambda lifted?
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%[(8 codegen corein)
ATTR AllCodeNT [ | | isFreeOfLam USE {&&} {True} : Bool ]
ATTR CExpr [ | | lamBodyIsFreeOfLam: Bool ]
ATTR CodeAGItf CModule CExpr AllBind [ | | isLamLifted USE {&&} {True} : Bool ]

SEM CExpr
| Lam lhs . isFreeOfLam = False
. lamBodyIsFreeOfLam = if @body.whatBelow == ExprIsLam
then @body.lamBodyIsFreeOfLam
else @body.isFreeOfLam
| * - Lam lhs . lamBodyIsFreeOfLam = False

SEM CBound
| Bind Val loc . isLamLifted = if @expr.whatBelow == ExprIsLam
then @lhs.isGlobal && @expr.lamBodyIsFreeOfLam
else @expr.isFreeOfLam

%%]

Expand Down
100 changes: 64 additions & 36 deletions EHC/src/ehc/Core/Trf.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -87,7 +87,8 @@ data TrfCoreExtra
%%[[99
, trfcoreExtraExports :: !FvS -- extra exported names, introduced by transformations
%%]]
, trfcoreECUState :: EHCompileUnitState
, trfcoreECUState :: !EHCompileUnitState
, trfcoreIsLamLifted :: !Bool
}

emptyTrfCoreExtra :: TrfCoreExtra
Expand All @@ -100,6 +101,7 @@ emptyTrfCoreExtra = TrfCoreExtra
Set.empty
%%]]
ECUSUnknown
False
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand All @@ -113,7 +115,9 @@ trfCore :: EHCOpts -> OptimizationScope -> DataGam -> HsName -> TrfCore -> TrfCo
trfCore opts optimScope dataGam modNm trfcore
-- = execState trf trfcore
= runTrf opts modNm ehcOptDumpCoreStages (optimScope `elem`) trfcore trf
where isFromCoreSrc = ecuStateIsCore $ trfcoreECUState $ trfstExtra trfcore
where isFromCoreSrc = ecuStateIsCore $ trfcoreECUState $ trfstExtra trfcore
isLamLifted = trfcoreIsLamLifted $ trfstExtra trfcore
noOptims = ehcOptOptimizationLevel opts <= OptimizationLevel_Off
trf
= do { -- initial is just to obtain Core for dumping stages
t_initial
Expand All @@ -128,8 +132,10 @@ trfCore opts optimScope dataGam modNm trfcore
%%]]

; unless isFromCoreSrc $ do
{ -- removal of unnecessary constructs: simplifications based on annotations (experimential, temporary)
t_ann_simpl
{ unless noOptims $ do
{ -- removal of unnecessary constructs: simplifications based on annotations (experimential, temporary)
t_ann_simpl
}

-- removal of unnecessary constructs: eta expansions
; t_eta_red
Expand All @@ -140,13 +146,16 @@ trfCore opts optimScope dataGam modNm trfcore
}


-- make names unique
; t_ren_uniq emptyRenUniqOpts
-- from now on INVARIANT: keep all names globally unique
-- ASSUME : no need to shadow identifiers
; unless isLamLifted $ do
{
-- make names unique
; t_ren_uniq emptyRenUniqOpts
-- from now on INVARIANT: keep all names globally unique
-- ASSUME : no need to shadow identifiers

-- removal of unnecessary constructs: mutual recursiveness
; t_let_unrec
-- removal of unnecessary constructs: mutual recursiveness
; t_let_unrec
}

; when isFromCoreSrc $ do
{ -- ensure def before use ordering
Expand All @@ -157,11 +166,14 @@ trfCore opts optimScope dataGam modNm trfcore
-- flattening of nested strictness
; t_let_flatstr

-- removal of unnecessary constructs: aliases
; t_inl_letali
; unless noOptims $ do
{
-- removal of unnecessary constructs: aliases
; t_inl_letali

-- removal of unnecessary constructs: trival function applications
; t_elim_trivapp
-- removal of unnecessary constructs: trival function applications
; t_elim_trivapp
}

%%[[99
-- optionally modify to include explicit stack trace
Expand All @@ -174,33 +186,42 @@ trfCore opts optimScope dataGam modNm trfcore
})
%%]]

-- removal of unnecessary constructs: constants
; t_const_prop
; t_inl_letali
; t_elim_trivapp
; unless noOptims $ do
{
-- removal of unnecessary constructs: constants
; t_const_prop
; t_inl_letali
; t_elim_trivapp
}

-- put in A-normal form, where args to app only may be identifiers
; u1 <- freshInfUID
; t_anormal u1
; unless isLamLifted $ do
{
-- put in A-normal form, where args to app only may be identifiers
; u1 <- freshInfUID
; t_anormal u1
}

%%[[(9 wholeprogAnal)
; when (not isFromCoreSrc && targetDoesHPTAnalysis (ehcOptTarget opts))
t_fix_dictfld
%%]]

-- pass all globals used in lambda explicit as argument
; t_lam_asarg

-- pass all globals used in CAF explicit as argument
; t_caf_asarg
; t_let_unrec
; u2 <- freshInfUID
; t_anormal u2

-- float lam/CAF to global level
; t_float_glob
-- from now on INVARIANT: no local lambdas
-- ASSUME :
; unless isLamLifted $ do
{
-- pass all globals used in lambda explicit as argument
; t_lam_asarg

-- pass all globals used in CAF explicit as argument
; t_caf_asarg
; t_let_unrec
; u2 <- freshInfUID
; t_anormal u2

-- float lam/CAF to global level
; t_float_glob
-- from now on INVARIANT: no local lambdas
-- ASSUME :
}

%%[[(8 wholeprogAnal)
; when (targetDoesHPTAnalysis (ehcOptTarget opts))
Expand All @@ -215,6 +236,11 @@ trfCore opts optimScope dataGam modNm trfcore
(do { {- t_let_flatstr
; -} t_ren_uniq (emptyRenUniqOpts {renuniqOptResetOnlyInLam = True})
})
; when True {- isFromCoreSrc -} $ do
{ -- ensure def before use ordering
t_let_defbefuse' osmw

}
}

lamMpPropagate l s@(TrfState {trfstExtra=e@(TrfCoreExtra{trfcoreGathLamMp=gl, trfcoreInhLamMp=il})})
Expand All @@ -227,12 +253,14 @@ trfCore opts optimScope dataGam modNm trfcore
t_sysf_check = liftCheckMod osm "sysf-type-check" $ \s -> cmodSysfCheck opts (emptyCheckEnv {cenvLamMp = trfcoreInhLamMp $ trfstExtra s})
%%]]
t_eta_red = liftTrfModPlain osm "eta-red" $ cmodTrfEtaRed
t_erase_ty = liftTrfModWithStateExtra osm "erase-ty" lamMpPropagate
t_erase_ty = liftTrfModWithStateExtra osmw "erase-ty" lamMpPropagate
$ \_ -> cmodTrfEraseExtractTysigCore opts
t_ann_simpl = liftTrfModPlain osm "ann-simpl" $ cmodTrfAnnBasedSimplify opts
t_ren_uniq o = liftTrfModPlain osm "ren-uniq" $ cmodTrfRenUniq o
t_let_unrec = liftTrfModPlain osm "let-unrec" $ cmodTrfLetUnrec
t_let_defbefuse = liftTrfModPlain osm "let-defbefuse" $ cmodTrfLetDefBeforeUse
t_let_defbefuse' os
= liftTrfModPlain os "let-defbefuse" $ cmodTrfLetDefBeforeUse
t_let_defbefuse = t_let_defbefuse' osm
t_let_flatstr = liftTrfModPlain osm "let-flatstr" $ cmodTrfLetFlattenStrict
t_inl_letali = liftTrfModPlain osm "inl-letali" $ cmodTrfInlineLetAlias
%%[[50
Expand Down
1 change: 1 addition & 0 deletions EHC/src/ehc/EHC/CompilePhase/Semantics.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -86,6 +86,7 @@ cpFoldCoreMod modNm
core = panicJust "cpFoldCoreMod" mbCore
coreSem = Core2ChkSem.cmodCheck' opts Core2ChkSem.emptyCheckEnv core
hasMain = Core2ChkSem.hasMain_Syn_CodeAGItf coreSem
-- ; lift $ putStrLn $ "cpFoldCoreMod " ++ show hasMain
; when (isJust mbCore)
(cpUpdCU modNm ( ecuStoreCoreSemMod coreSem
. ecuSetHasMain hasMain
Expand Down
10 changes: 10 additions & 0 deletions EHC/src/ehc/EHC/CompilePhase/Transformations.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,6 +60,8 @@ Interface/wrapper to various transformations for Core, TyCore, etc.
-- Core semantics
%%[(8 codegen grin) import(qualified {%{EH}Core.ToGrin} as Core2GrSem)
%%]
%%[(50 codegen corein) import(qualified {%{EH}Core.Check} as Core2ChkSem)
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Compile actions: transformations, on core
Expand All @@ -80,6 +82,11 @@ cpTransformCore optimScope modNm
, trfstUniq = crsiNextUID crsi
, trfstExtra = emptyTrfCoreExtra
{ trfcoreECUState = ecuState ecu
%%[[8
, trfcoreIsLamLifted = False
%%][(50 corein)
, trfcoreIsLamLifted = maybe False Core2ChkSem.isLamLifted_Syn_CodeAGItf $ ecuMbCoreSemMod ecu
%%]]
%%[[50
, trfcoreExpNmOffMp = crsiExpNmOffMp modNm crsi
, trfcoreInhLamMp = Core2GrSem.lamMp_Inh_CodeAGItf $ crsiCoreInh crsi
Expand All @@ -88,6 +95,9 @@ cpTransformCore optimScope modNm
}
trfcoreOut = trfCore opts optimScope (Core2GrSem.dataGam_Inh_CodeAGItf $ crsiCoreInh crsi) modNm trfcoreIn

%%[[(50 corein)
-- ; lift $ putStrLn $ "cpTransformCore trfcoreIsLamLifted: " ++ show (trfcoreIsLamLifted $ trfstExtra trfcoreIn)
%%]]
-- put back result: Core
; cpUpdCU modNm $! ecuStoreCore (trfstMod trfcoreOut)

Expand Down
2 changes: 1 addition & 1 deletion EHC/src/ehc/EHC/CompileUnit.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -342,7 +342,7 @@ ecuIsOrphan = const False
%%]]
%%]

%%[50 export(ecuIsFromCoreSrc)
%%[5050 export(ecuIsFromCoreSrc)
-- | Is compilation from Core source
ecuIsFromCoreSrc :: EHCompileUnit -> Bool
ecuIsFromCoreSrc = ecuStateIsCore . ecuState
Expand Down

0 comments on commit c4ab6ea

Please sign in to comment.