Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

added examples fib.hs and simple.hs that don't require the Prelude.

They work well without transformation ORC, but they fail with this transformation turned on,
giving the runtime error "non partial apply applied".

changed transformation ORC so that definitions of FFI functions are moved to the outermost level,
satisfying some invariant of the Core-to-GRIN transformation.
  • Loading branch information...
commit be132110d6fc3acde7920f76b0d94c9aa5cc9c0e 1 parent 3108410
HolgerSiegel authored
View
12 EHC/ehclib/ehcbase/EHC/Prelude.hs
@@ -3,7 +3,7 @@ module EHC.Prelude -- adapted from thye Hugs prelude
-- Debugging primitives
Oracle, primInitOracle, primOracleEnter, primOracleLeave,
primOracleNewEntry, primWhatIsNextOracle, primDumpOracle,
- underscore, runOracleProgram, bindOracleStrict, returnOracleStrict,
+ underscore, runProgramStrict, bindOracleStrict, returnOracleStrict,
thunkIsEvaluated,
primRawShow,
-- rawShow, RawShow, primRawShow,
@@ -2420,8 +2420,8 @@ foreign import ccall primRawShow :: a -> a
underscore :: a
underscore = error "underscore"
-oracleToList :: () -> [Int]
-oracleToList _ = reverse (go [])
+oracleToListStrict :: () -> [Int]
+oracleToListStrict _ = reverse (go [])
where
go :: [Int] -> [Int]
go o = letstrict entry = primWhatIsNextOracle
@@ -2431,10 +2431,10 @@ oracleToList _ = reverse (go [])
type OrcM a = [Int] -> ([Int], a )
-runOracleProgram :: a -> OrcM a -> a
-runOracleProgram a b = letstrict h = primInitOracle
+runProgramStrict :: a -> OrcM a -> a
+runProgramStrict a b = letstrict h = primInitOracle
in letstrict lazyResult = a
- in letstrict oracle = oracleToList ()
+ in letstrict oracle = oracleToListStrict ()
in letstrict r2 = b oracle
in case r2 of (_, strictResult) -> strictResult
View
2  EHC/ehclib/ehcbase/compile
@@ -1 +1 @@
-./ehc --dump-core-stages=1 $@
+./ehc --no-prelude --dump-core-stages=1 $@
View
79 EHC/ehclib/ehcbase/t/fib.hs
@@ -0,0 +1,79 @@
+-- Prelude -----------------------
+
+
+-- standard definitions
+
+id :: a -> a
+id x = x
+
+undefined = undefined
+
+
+-- Int
+
+infixl 6 +, -
+
+foreign import ccall primAddInt :: Int -> Int -> Int
+foreign import ccall primSubInt :: Int -> Int -> Int
+(+) = primAddInt
+(-) = primSubInt
+
+data Bool = False | True
+
+foreign import ccall primLtInt :: Int -> Int -> Bool
+(<) = primLtInt
+
+
+data PackedString
+foreign import ccall "primCStringToInteger" packedStringToInteger :: PackedString -> Integer
+
+
+foreign import ccall primIntegerToInt :: Integer -> Int
+fromInteger = primIntegerToInt
+
+
+-- Mini-IO
+
+newtype IO a = IO (IOWorld -> IOResult a)
+
+newtype IOResult a = IOResult a
+
+data IOWorld
+
+foreign import ccall primRawShow :: a -> a
+
+primretIO :: IO ()
+primretIO = IO (\_ -> IOResult ())
+
+print :: Int -> IO ()
+print n = letstrict n' = n
+ in letstrict n'' = primRawShow n
+ in primretIO
+
+
+-- Wrapper around 'main', invoked as 'ehcRunMain main'
+
+ehcRunMain :: IO a -> IO a
+ehcRunMain m = m
+
+
+
+-- Debugging primitives
+
+data Oracle
+
+foreign import ccall primDumpOracle :: Int -- length
+foreign import ccall primInitOracle :: ()
+foreign import ccall primOracleEnter :: Oracle -> Oracle
+foreign import ccall primOracleLeave :: Oracle -> a -> a
+foreign import ccall primOracleNewEntry :: Oracle
+
+-- Fib ---------------------------
+
+
+
+fib n = if n <2 then n else fib (n-1) + fib (n-2)
+
+main = letstrict x = primInitOracle
+ in print (fib 10)
+
View
52 EHC/ehclib/ehcbase/t/simple.hs
@@ -0,0 +1,52 @@
+-- Prelude -----------------------
+
+-- standard definitions
+
+id :: a -> a
+id x = x
+
+undefined = undefined
+
+
+-- Int
+
+
+-- Mini-IO
+
+newtype IO a = IO (IOWorld -> IOResult a)
+
+newtype IOResult a = IOResult a
+
+data IOWorld
+
+foreign import ccall primRawShow :: a -> a
+
+primretIO :: IO ()
+primretIO = IO (\_ -> IOResult ())
+
+
+-- Wrapper around 'main', invoked as 'ehcRunMain main'
+
+ehcRunMain :: IO a -> IO a
+ehcRunMain m = m
+
+
+
+-- Debugging primitives
+
+data Oracle
+
+foreign import ccall primDumpOracle :: Int -- length
+foreign import ccall primInitOracle :: ()
+foreign import ccall primOracleEnter :: Oracle -> Oracle
+foreign import ccall primOracleLeave :: Oracle -> a -> a
+foreign import ccall primOracleNewEntry :: Oracle
+
+-- Fib ---------------------------
+
+
+
+main = --letstrict x = primInitOracle
+ --in
+ primretIO
+
View
4 EHC/ehclib/ehcbase/t/test_x.hs
@@ -1,2 +1,2 @@
-main = let x= True
- in return()
+main = case primRawShow (True, False) of
+ a@(True, x) -> print x
View
12 EHC/src/ehc/Core/Trf/DebugStrict.cag
@@ -77,7 +77,9 @@ SEM CExpr
case @binds.cTrf of
[] -> @body.cTrf
[CBind_Bind v m e]
- | not @binds.whnf && False
+ | not @binds.whnf &&
+ not (isProtected v) &&
+ m ==CMeta_Val
-- XXX only non-DICT
-> let lambody = CExpr_Lam v m @body.cTrf
in libcallE "bindOracleStrict" [e, lambody]
@@ -119,5 +121,13 @@ localVar s = CExpr_Var $ qualify s
qualify :: String -> HsName
qualify n = hsnFromString n
+
+{-
+ returns True if the argument is a Prelude function that may not
+ be transformed to a strict version (because the transformed version
+ uses it internally)
+-}
+isProtected :: HsName -> Bool
+isProtected _ = False
}
%%]
View
38 EHC/src/ehc/Core/Trf/LetUnMutual.cag
@@ -66,6 +66,18 @@ ATTR AllBind [ | | bindMp USE {`Map.union`} {Map.empty}: BindMp ]
SEM CBind
| Bind lhs . bindMp = @nm `Map.singleton` (@expr.cTrf,@bindMeta.cTrf)
+
+
+
+ATTR CExpr AllBind [ | | whnf USE {&&} {False}: {Bool} ]
+
+SET WHNF = Lam Tup Int Char String
+
+SEM CExpr
+ | Lam Tup Int Char String lhs. whnf = True
+ | * - Lam Tup Int Char String lhs. whnf = False
+
+
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -75,15 +87,15 @@ SEM CBind
%%[8
SEM CExpr
| Let loc . cTrf
- = if @categ == CBindRec
+ = if @categ == CBindRec && not @binds.whnf
then let mk n b = let (e,m) = rhs n
in mkCExprLet CBindPlain [ mkCBind1Meta n m e] b
mkLets = foldr mk
(bs, rs, fbs)
- = feedbackSet @body.fvS @binds.fvSMp
+ = trc "fbs" $ feedbackSet @body.fvS @binds.fvSMp
rhs x = let err= error "internal error"
in Map.findWithDefault err x @binds.bindMp
- recname = qualify @lhs.moduleNm "r"
+ recname = hsnFromString "_letunmutual_r"
recs = mkFbSelectors recname fbs $ mkLets (feedbackTuple rhs fbs) rs
body = mkFbSelectors recname fbs $ mkLets @body.cTrf bs
in mkCExprLet CBindRec [mkCBind1Meta recname CMeta_Val recs] body
@@ -123,16 +135,16 @@ fbPat fbs = mkCPatCon (CTagRec) (length fbs) (Just fbs)
case rec of (Tup f1 f2 .. fn) -> v
-}
-mkFeedbackRhs :: HsName -> HsName -> [HsName] -> CExpr
-mkFeedbackRhs r v [fv] = CExpr_Var r
-mkFeedbackRhs r v fvs = CExpr_Case (CExpr_Var r) [alt] (preludeVar "undefined")
+mkFeedbackSelector :: HsName -> HsName -> [HsName] -> CExpr
+mkFeedbackSelector r v [fv] = CExpr_Var r
+mkFeedbackSelector r v fvs = CExpr_Case (CExpr_Var r) [alt] (preludeVar "undefined")
where alt :: CAlt
alt = CAlt_Alt (fbPat fvs) (CExpr_Var v)
{-
surrounds the body with defintions for the
- feebback vars:
+ feedback vars:
let f1 = case r of (Tup f1 ..) -> f1
in let f2 = case r of (Tup f1 f2 ..) -> f2
@@ -140,7 +152,7 @@ mkFeedbackRhs r v fvs = CExpr_Case (CExpr_Var r) [alt] (preludeVar "undefined")
-}
mkFbSelectors :: HsName -> [HsName] -> CExpr -> CExpr
mkFbSelectors v fbs body = foldr mkFbLet body fbs
- where mkFbLet f b = let e = mkFeedbackRhs v f fbs
+ where mkFbLet f b = let e = mkFeedbackSelector v f fbs
m = CMeta_Val
in mkCExprLet CBindPlain [ mkCBind1Meta f m e] b
@@ -182,14 +194,6 @@ feedbackSet pulling deps = let sccs = sccFromMap deps (Map.keys deps)
-qualify :: HsName -> String -> HsName
-qualify q n = hsnSetQual q $ hsnFromString n
-
-
-qualvar :: HsName -> String -> CExpr
-qualvar q n
- = CExpr_Var $ qualify q n
-
preludeVar :: String -> CExpr
preludeVar n = CExpr_Var $ mkHNm [ehcname, prelname, hsnFromString n]
where ehcname = hsnFromString "EHC"
@@ -216,7 +220,7 @@ sccFromMap m n = let m' = filter (\(x,_)->x `elem` n) $ Map.toList m
in map f (scc m'')
--- trc t x= trace (t ++ ": " ++ show x) x
+trc t x= trace (t ++ ": " ++ show x) x
%%]
View
124 EHC/src/ehc/Core/Trf/OracleCreation.cag
@@ -36,6 +36,10 @@ cmodTrfOracleCreation cmod
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Transformation
+%%%
+%%% We have to move all FFI declarations to the outermost level, because otherwise
+%%% invalid GRIN code will be generated.
+%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[8
@@ -44,6 +48,23 @@ ATTR CodeAGItf [ | | cTrf: CModule ]
ATTR AllExpr [ moduleNm : {HsName} | | ]
+ATTR AllExpr [ isHead : {Bool} | | ]
+
+
+
+SEM CModule
+ | Mod expr . isHead = True
+
+SEM CExpr
+ | Let binds.isHead = False
+
+
+
+ATTR AllExpr [ | | ffiDecls USE {++} {[]}: CBindL ]
+
+SEM CBind
+ | FFI lhs . ffiDecls = [CBind_FFI @callconv @safety @impEnt @nm @ty]
+
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -54,7 +75,7 @@ ATTR AllExpr [ moduleNm : {HsName} | | ]
%%[8
-ATTR CExpr AllBind [ | | whnf USE {&&} {False}: {Bool} ]
+ATTR CExpr AllBind [ | | whnf USE {&&} {True}: {Bool} ]
SEM CExpr
| Lam lhs. whnf = True
@@ -64,33 +85,38 @@ SEM CExpr
SEM CModule
| Mod expr . moduleNm = @moduleNm
- | Mod loc . cTrf = let expr' = letS "o" (libcall "primInitOracle" [])
- (letS "r" @expr.cTrf
- (letS "l" (libcall "primDumpOrace" [])
- (libcall "print" ["l"])
+ | Mod loc . cTrf = let expr' = CExpr_Let CBindPlain @expr.ffiDecls
+ (letS "x_o" (libcall @moduleNm "primInitOracle" [])
+ (letS "x_r" @expr.cTrf
+ (letS "x_l" (libcall @moduleNm "primDumpOracle" [])
+ (libcall @moduleNm "print" ["x_l"])
)
- )
- in CModule_Mod @moduleNm @expr.cTrf @ctagsMp
+ ))
+ in CModule_Mod @moduleNm expr' @ctagsMp
SEM CExpr
- | App loc . cTrf = strictifyApp @func.cTrf @arg.cTrf @argMeta.cTrf
- | Let loc . cTrf = let tr = trace (show $ CExpr_Let @categ @binds.cTrf @body.cTrf)
- in case @categ of
- CBindRec
- -> trace ("recursive bind in DBGS stage")
- $ CExpr_Let @categ @binds.cTrf @body.cTrf
- CBindPlain ->
- case @binds.cTrf of
- [] -> @body.cTrf
- [CBind_Bind v m e]
- | not @binds.whnf && False
- -> strictifyLet v m e @body.cTrf
- [_] -> CExpr_Let @categ @binds.cTrf @body.cTrf
- _ -> error "Core.Trf.DBGS: more than one bind in plain let"
- _ ->
- CExpr_Let @categ @binds.cTrf @body.cTrf
-
+ | App loc . cTrf = strictifyApp @lhs.moduleNm @func.cTrf @arg.cTrf @argMeta.cTrf
+ | Let loc . cTrf = let tr = trace (show $ CExpr_Let @categ @binds.cTrf @body.cTrf)
+ binds = filter noFFI @binds.cTrf
+ noFFI (CBind_FFI _ _ _ _ _) = False
+ noFFI _ = True
+ in if null binds then
+ @body.cTrf
+ else case @categ of
+ CBindPlain ->
+ case binds of
+ [] -> @body.cTrf
+ [CBind_Bind v m e]
+ | not @binds.whnf -- && False
+ -> strictifyLet @lhs.moduleNm v m e @body.cTrf
+ [_] -> CExpr_Let @categ binds @body.cTrf
+ _ -> error $ "Core.Trf.ORC: more than one bind in plain let"
+ ++ show binds
+ _ -> -- if the bound expr is in whnf, then it may be recursive
+ CExpr_Let @categ binds @body.cTrf
+
+
%%]
@@ -112,14 +138,14 @@ SEM CExpr
in primOracleLeave o2 r)
-}
-strictifyApp :: CExpr -> CExpr -> CMeta -> CExpr
-strictifyApp f x m
- = letS "o" newEntry
+strictifyApp :: HsName -> CExpr -> CExpr -> CMeta -> CExpr
+strictifyApp m f x meta
+ = letS "o" (newEntry m)
(CExpr_App f
- (letS "o2" (enterOrc "o")
+ (letS "o2" (enterOrc m "o")
(letS "r" x
- (leaveOrc "o2" "r")))
- m)
+ (leaveOrc m "o2" "r")))
+ meta)
{-
@@ -135,42 +161,42 @@ strictifyApp f x m
in primOracleLeave o2 r
in e2
-}
-strictifyLet :: HsName -> CMeta -> CExpr -> CExpr -> CExpr
-strictifyLet v m e1 e2
- = let inner = letS "o2" (enterOrc "o")
+strictifyLet :: HsName -> HsName -> CMeta -> CExpr -> CExpr -> CExpr
+strictifyLet m v meta e1 e2
+ = let inner = letS "o2" (enterOrc m "o")
(letS "r" e1
- (leaveOrc "o2" "r"))
- in letS "o" newEntry
+ (leaveOrc m "o2" "r"))
+ in letS "o" (newEntry m)
(letL v inner
e2)
+-- qualify q n = hsnSetQual q $ hsnFromString n
-qualify :: String -> HsName
-qualify n = hsnFromString n
localVar :: String -> CExpr
-localVar s = CExpr_Var $ qualify s
+localVar s = CExpr_Var $ hsnFromString s
letS :: String -> CExpr -> CExpr -> CExpr
-letS v e1 e2 = CExpr_Let CBindStrict [CBind_Bind (qualify v) CMeta_Val e1] e2
+letS v e1 e2 = CExpr_Let CBindStrict [CBind_Bind (hsnFromString v) CMeta_Val e1] e2
letL :: HsName -> CExpr -> CExpr -> CExpr
letL v e1 e2 = CExpr_Let CBindPlain [CBind_Bind v CMeta_Val e1] e2
-dumpOrc, newEntry :: CExpr
-dumpOrc = libcall "primDumpOracle" []
-newEntry = libcall "primOracleNewEntry" []
+dumpOrc, newEntry :: HsName -> CExpr
+dumpOrc m = libcall m "primDumpOracle" []
+newEntry m = libcall m "primOracleNewEntry" []
-enterOrc :: String -> CExpr
-enterOrc x = libcall "primOracleEnter" [x]
+enterOrc :: HsName -> String -> CExpr
+enterOrc m x = libcall m "primOracleEnter" [x]
-leaveOrc :: String -> String -> CExpr
-leaveOrc x y = libcall "primOracleLeave" [x, y]
+leaveOrc :: HsName -> String -> String -> CExpr
+leaveOrc m x y = libcall m "primOracleLeave" [x, y]
-libcall :: String -> [String] -> CExpr
-libcall f xs = foldr appV prelfun xs
+libcall :: HsName -> String -> [String] -> CExpr
+libcall modname f xs = foldr appV prelfun xs
where
- prelfun = CExpr_Var $ mkHNm $ map hsnFromString ["EHC", "Prelude", f]
+ -- prelfun = CExpr_Var $ mkHNm $ map hsnFromString ["EHC", "Prelude", f]
+ prelfun = CExpr_Var $ hsnSetQual modname $ hsnFromString f
appV :: String -> CExpr -> CExpr
appV v f = CExpr_App f (localVar v) CMeta_Val
}
View
44 EHC/src/ehc/Core/Trf/RenAddSuffix.cag
@@ -63,40 +63,48 @@ ATTR CodeAGItf [ | | cTrf: CModule ]
%%% alpha renaming so all identifiers are unique
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[8 hs
-type ARenMp = Map.Map HsName HsName
-%%]
-
-
%%[8
SEM CPat
- | Var Con loc . nm = @pnm
- loc . nm : {HsName}
+ | * loc . nm = @pnm
+ loc . nm : {HsName}
-%%]
-%%[8
SEM CExpr
- | Var lhs . cTrf = CExpr_Var (addSuffix @nm @lhs.suffix)
- | Lam lhs . cTrf = CExpr_Lam (addSuffix @arg @lhs.suffix) @argMeta.cTrf @body.cTrf
+ | Var lhs . cTrf = CExpr_Var (addSuffix @nm @lhs.suffix)
+ | Lam lhs . cTrf = CExpr_Lam (addSuffix @arg @lhs.suffix) @argMeta.cTrf @body.cTrf
+ | TupDel lhs . cTrf = let nm' = addSuffix @nm @lhs.suffix
+ in CExpr_TupDel @expr.cTrf @tag nm' @offset.cTrf
+ | TupIns lhs . cTrf = let nm' = addSuffix @nm @lhs.suffix
+ in CExpr_TupIns @expr.cTrf @tag nm' @offset.cTrf @fldExpr.cTrf
+ | TupUpd lhs . cTrf = let nm' = addSuffix @nm @lhs.suffix
+ in CExpr_TupUpd @expr.cTrf @tag nm' @offset.cTrf @fldExpr.cTrf
SEM CBind
- | Bind lhs . cTrf = CBind_Bind (addSuffix @nm @lhs.suffix) @bindMeta.cTrf @expr.cTrf
+ | Bind lhs . cTrf = let nm' = addSuffix @nm @lhs.suffix
+ in CBind_Bind nm' @bindMeta.cTrf @expr.cTrf
+ | FFI lhs . cTrf = let nm' = addSuffix @nm @lhs.suffix
+ in CBind_FFI @callconv @safety @impEnt nm' @ty
+ | FFE lhs . cTrf = let nm' = addSuffix @nm @lhs.suffix
+ in CBind_FFE nm' @callconv @expEnt @expNm @ty
SEM CPatBind
- | Bind lhs . cTrf = CPatBind_Bind @lbl @offset.cTrf (addSuffix @nm @lhs.suffix) @pat.cTrf
+ | Bind lhs . cTrf = CPatBind_Bind @lbl @offset.cTrf (addSuffix @nm @lhs.suffix) @pat.cTrf
SEM CPat
- | Var lhs . cTrf = CPat_Var (addSuffix @nm @lhs.suffix)
- | Con lhs . cTrf = CPat_Con (addSuffix @nm @lhs.suffix) @tag @rest.cTrf @binds.cTrf
+ | Var lhs . cTrf = CPat_Var (addSuffix @nm @lhs.suffix)
+ | Con lhs . cTrf = CPat_Con (addSuffix @nm @lhs.suffix) @tag @rest.cTrf @binds.cTrf
+ | Int lhs . cTrf = CPat_Int (addSuffix @nm @lhs.suffix) @int
+ | Char lhs . cTrf = CPat_Char (addSuffix @nm @lhs.suffix) @char
SEM CPatRest
- | Var lhs . cTrf = CPatRest_Var (addSuffix @nm @lhs.suffix)
+ | Var lhs . cTrf = CPatRest_Var (addSuffix @nm @lhs.suffix)
{
--- XXX is this right?
+addSuffix = hsnSuffix
+
+{-
addSuffix :: HsName -> String -> HsName
addSuffix (HNm s) suf = HNm $ s ++ suf
addSuffix (HNmQ ns@(_:_)) suf
@@ -104,7 +112,7 @@ addSuffix (HNmQ ns@(_:_)) suf
where repLast [s] = [addSuffix s suf]
repLast (s:ss) = s : repLast ss
addSuffix h _ = h
-
+-}
}
%%]
View
9 EHC/src/ehc/EHC.chs
@@ -1585,6 +1585,7 @@ cpCore1Trf modNm trfNm
"CLFR" -> cmodTrfLetFixrec
"DBGS" -> cmodTrfDebugStrict
"ORC" -> cmodTrfOracleCreation
+ "SUFS" -> cmodTrfRenAddSuffix "_strict"
%%]]
-- "CLL" -> cmodTrfLamLift
_ -> id
@@ -1648,18 +1649,18 @@ cpProcessEH modNm
]
cpProcessCoreBasic :: HsName -> EHCompilePhase ()
-cpProcessCoreBasic modNm
+cpProcessCoreBasic modNm
= cpSeq [ cpTransformCore
modNm
(
%%[[102
-- [ "CS" ] ++
%%]]
- [ "CER"]
+ [ "CER", "CRU", "CLU"]
%%[[103
- ++ [ "CRU", "CLU", "CLM", "CLFR", "DBGS"]
+ ++ [ "CLM", "CLFR", "ORC", "CRU", "CLU"]
%%]]
- ++ ["CRU", "CLU", "CILA", "CETA", "CCP", "CILA", "CETA"
+ ++ [ "CILA", "CETA", "CCP", "CILA", "CETA"
, "CFL", "CLGA", "CCGA", "CLU", "CFL", {- "CLGA", -} "CLFG"
%%[[8_2
, "CPRNM"
Please sign in to comment.
Something went wrong with that request. Please try again.