Permalink
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...
1 parent 3108410 commit be132110d6fc3acde7920f76b0d94c9aa5cc9c0e HolgerSiegel committed Jun 19, 2008
@@ -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
@@ -1 +1 @@
-./ehc --dump-core-stages=1 $@
+./ehc --no-prelude --dump-core-stages=1 $@
@@ -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)
+
@@ -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
+
@@ -1,2 +1,2 @@
-main = let x= True
- in return()
+main = case primRawShow (True, False) of
+ a@(True, x) -> print x
@@ -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
}
%%]
@@ -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,24 +135,24 @@ 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
in body
-}
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
%%]
Oops, something went wrong.

0 comments on commit be13211

Please sign in to comment.