-- we only need one rep for both.
{- Not yet:
+ | RepV -- void rep
| RepI8
| RepI64
-}
data IExpr con var
= CaseAlgP Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
| CaseAlgI Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
+ | CaseAlgF Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
+ | CaseAlgD Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
| CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
| CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
+ | CasePrimF Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
+ | CasePrimD Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
-- saturated constructor apps; args are in heap order.
-- The Addrs are the info table pointers. Descriptors refer to the
| ConAppPP con (IExpr con var) (IExpr con var)
| ConAppPPP con (IExpr con var) (IExpr con var) (IExpr con var)
- | PrimOpI PrimOp [(IExpr con var)]
| PrimOpP PrimOp [(IExpr con var)]
+ | PrimOpI PrimOp [(IExpr con var)]
+ | PrimOpF PrimOp [(IExpr con var)]
+ | PrimOpD PrimOp [(IExpr con var)]
| NonRecP (IBind con var) (IExpr con var)
- | RecP [IBind con var] (IExpr con var)
-
| NonRecI (IBind con var) (IExpr con var)
+ | NonRecF (IBind con var) (IExpr con var)
+ | NonRecD (IBind con var) (IExpr con var)
+
+ | RecP [IBind con var] (IExpr con var)
| RecI [IBind con var] (IExpr con var)
+ | RecF [IBind con var] (IExpr con var)
+ | RecD [IBind con var] (IExpr con var)
| LitI Int#
| LitF Float#
| LitD Double#
- | LitS FAST_STRING
{- not yet:
| LitB Int8#
showExprTag :: IExpr c v -> String
showExprTag expr
= case expr of
+
CaseAlgP _ _ _ _ -> "CaseAlgP"
- CasePrimP _ _ _ _ -> "CasePrimP"
CaseAlgI _ _ _ _ -> "CaseAlgI"
+ CaseAlgF _ _ _ _ -> "CaseAlgF"
+ CaseAlgD _ _ _ _ -> "CaseAlgD"
+
+ CasePrimP _ _ _ _ -> "CasePrimP"
CasePrimI _ _ _ _ -> "CasePrimI"
+ CasePrimF _ _ _ _ -> "CasePrimF"
+ CasePrimD _ _ _ _ -> "CasePrimD"
+
ConApp _ -> "ConApp"
ConAppI _ _ -> "ConAppI"
ConAppP _ _ -> "ConAppP"
ConAppPP _ _ _ -> "ConAppPP"
ConAppPPP _ _ _ _ -> "ConAppPPP"
+
+ PrimOpP _ _ -> "PrimOpP"
PrimOpI _ _ -> "PrimOpI"
+ PrimOpF _ _ -> "PrimOpF"
+ PrimOpD _ _ -> "PrimOpD"
+
NonRecP _ _ -> "NonRecP"
- RecP _ _ -> "RecP"
NonRecI _ _ -> "NonRecI"
+ NonRecF _ _ -> "NonRecF"
+ NonRecD _ _ -> "NonRecD"
+
+ RecP _ _ -> "RecP"
RecI _ _ -> "RecI"
+ RecF _ _ -> "RecF"
+ RecD _ _ -> "RecD"
+
LitI _ -> "LitI"
- LitS _ -> "LitS"
+ LitF _ -> "LitF"
+ LitD _ -> "LitD"
+
Native _ -> "Native"
+
VarP _ -> "VarP"
VarI _ -> "VarI"
+ VarF _ -> "VarF"
+ VarD _ -> "VarD"
+
LamPP _ _ -> "LamPP"
LamPI _ _ -> "LamPI"
+ LamPF _ _ -> "LamPF"
+ LamPD _ _ -> "LamPD"
LamIP _ _ -> "LamIP"
LamII _ _ -> "LamII"
+ LamIF _ _ -> "LamIF"
+ LamID _ _ -> "LamID"
+ LamFP _ _ -> "LamFP"
+ LamFI _ _ -> "LamFI"
+ LamFF _ _ -> "LamFF"
+ LamFD _ _ -> "LamFD"
+ LamDP _ _ -> "LamDP"
+ LamDI _ _ -> "LamDI"
+ LamDF _ _ -> "LamDF"
+ LamDD _ _ -> "LamDD"
+
AppPP _ _ -> "AppPP"
AppPI _ _ -> "AppPI"
+ AppPF _ _ -> "AppPF"
+ AppPD _ _ -> "AppPD"
AppIP _ _ -> "AppIP"
AppII _ _ -> "AppII"
+ AppIF _ _ -> "AppIF"
+ AppID _ _ -> "AppID"
+ AppFP _ _ -> "AppFP"
+ AppFI _ _ -> "AppFI"
+ AppFF _ _ -> "AppFF"
+ AppFD _ _ -> "AppFD"
+ AppDP _ _ -> "AppDP"
+ AppDI _ _ -> "AppDI"
+ AppDF _ _ -> "AppDF"
+ AppDD _ _ -> "AppDD"
+
other -> "(showExprTag:unhandled case)"
-----------------------------------------------------------------------------
VarI v -> ppr v
VarP v -> ppr v
LitI i# -> int (I# i#) <> char '#'
- LitS s -> char '"' <> ptext s <> char '"'
LamPP v e -> doLam "PP" v e
LamPI v e -> doLam "PI" v e
MachChar i -> case fromIntegral i of I# i -> LitI i
MachFloat f -> case fromRational f of F# f -> LitF f
MachDouble f -> case fromRational f of D# f -> LitD f
- MachStr s -> LitS s
+ MachStr s ->
+ case s of
+ CharStr s i -> LitI (addr2Int# s)
+
+ FastString _ l ba ->
+ -- sigh, a string in the heap is no good to us. We need a
+ -- static C pointer, since the type of a string literal is
+ -- Addr#. So, copy the string into C land and introduce a
+ -- memory leak at the same time.
+ let n = I# l in
+ case unsafePerformIO (do a <- malloc (n+1);
+ strncpy a ba (fromIntegral n);
+ writeCharOffAddr a n '\0'
+ return a)
+ of A# a -> LitI (addr2Int# a)
+
+ _ -> error "StgInterp.lit2expr: unhandled string constant type"
+
other -> pprPanic "lit2expr" (ppr lit)
stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
mkCasePrim RepI = CasePrimI
mkCasePrim RepP = CasePrimP
-mkCaseAlg RepI = CaseAlgI
-mkCaseAlg RepP = CaseAlgP
+mkCaseAlg RepI = CaseAlgI
+mkCaseAlg RepP = CaseAlgP
-- any var that isn't in scope is turned into a Native
mkVar ie rep var
RecI binds expr -> RecI (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
LitI i -> LitI i
- LitS s -> LitS s
+ LitF i -> LitF i
+ LitD i -> LitD i
Native var -> lookupNative ce var
evalP :: LinkedIExpr -> UniqFM boxed -> boxed
+{-
evalP expr de
-- | trace ("evalP: " ++ showExprTag expr) False
| trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
= error "evalP: ?!?!"
+-}
evalP (Native p) de = unsafeCoerce# p
-- always has pointer rep.
evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
-
+evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
+evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
-- Lambdas always return P-rep, but we need to do different things
-- depending on both the argument and result representations.
evalP (LamPP x b) de
- = unsafeCoerce#
- (\ xP -> evalP b (addToUFM de x xP))
+ = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
evalP (LamPI x b) de
- = unsafeCoerce#
- (\ xP -> evalI b (addToUFM de x xP))
+ = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
+evalP (LamPF x b) de
+ = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
+evalP (LamPD x b) de
+ = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
evalP (LamIP x b) de
- = unsafeCoerce#
- (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
+ = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
evalP (LamII x b) de
- = unsafeCoerce#
- (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
+ = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
+evalP (LamIF x b) de
+ = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
+evalP (LamID x b) de
+ = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
+evalP (LamFP x b) de
+ = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
+evalP (LamFI x b) de
+ = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
+evalP (LamFF x b) de
+ = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
+evalP (LamFD x b) de
+ = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
+evalP (LamDP x b) de
+ = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
+evalP (LamDI x b) de
+ = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
+evalP (LamDF x b) de
+ = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
+evalP (LamDD x b) de
+ = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
--- Evaluator for things of Int# representation
--------------------------------------------------------
-
-- Evaluate something which has an unboxed Int rep
evalI :: LinkedIExpr -> UniqFM boxed -> Int#
evalI (LitI i#) de = i#
-evalI (LitS s) de =
- case s of
- CharStr s i -> addr2Int# s
-
- FastString _ l ba ->
- -- sigh, a string in the heap is no good to us. We need a static
- -- C pointer, since the type of a string literal is Addr#. So,
- -- copy the string into C land and introduce a memory leak at the
- -- same time.
- let n = I# l in
- case unsafePerformIO (do a <- malloc n;
- strncpy a ba (fromIntegral n);
- writeCharOffAddr a n '\0'
- return a)
- of A# a -> addr2Int# a
-
- _ -> error "StgInterp.evalI: unhandled string constant type"
-
evalI (VarI v) de =
case lookupUFM de v of
Just e -> case unsafeCoerce# e of I# i -> i
= unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalI (AppPI e1 e2) de
= unsafeCoerce# (evalP e1 de) (evalP e2 de)
+evalI (AppFI e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalF e2 de)
+evalI (AppDI e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalD e2 de)
-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
-- except in the sense that we go on and evaluate the body with whichever
= error ("evalI: unhandled case: " ++ showExprTag other)
--------------------------------------------------------
+--- Evaluator for things of Float# representation
+--------------------------------------------------------
+
+-- Evaluate something which has an unboxed Int rep
+evalF :: LinkedIExpr -> UniqFM boxed -> Float#
+
+evalF expr de
+-- | trace ("evalF: " ++ showExprTag expr) False
+ | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
+ = error "evalF: ?!?!"
+
+evalF (LitF f#) de = f#
+
+evalF (VarF v) de =
+ case lookupUFM de v of
+ Just e -> case unsafeCoerce# e of F# i -> i
+ Nothing -> error ("evalF: lookupUFM " ++ show v)
+
+-- Deal with application of a function returning an Int# rep
+-- to arguments of any persuasion. Note that the function itself
+-- always has pointer rep.
+evalF (AppIF e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalI e2 de)
+evalF (AppPF e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalP e2 de)
+evalF (AppFF e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalF e2 de)
+evalF (AppDF e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalD e2 de)
+
+-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
+-- except in the sense that we go on and evaluate the body with whichever
+-- evaluator was used for the expression as a whole.
+evalF (NonRecF bind b) de
+ = evalF b (augment_nonrec bind de)
+evalF (RecF binds b) de
+ = evalF b (augment_rec binds de)
+evalF (CaseAlgF bndr expr alts def) de
+ = case helper_caseAlg bndr expr alts def de of
+ (rhs, de') -> evalF rhs de'
+evalF (CasePrimF bndr expr alts def) de
+ = case helper_casePrim bndr expr alts def de of
+ (rhs, de') -> evalF rhs de'
+
+-- evalF can't be applied to a lambda term, by defn, since those
+-- are ptr-rep'd.
+
+evalF (PrimOpF op _) de
+ = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
+
+evalF other de
+ = error ("evalF: unhandled case: " ++ showExprTag other)
+
+--------------------------------------------------------
+--- Evaluator for things of Double# representation
+--------------------------------------------------------
+
+-- Evaluate something which has an unboxed Int rep
+evalD :: LinkedIExpr -> UniqFM boxed -> Double#
+
+evalD expr de
+-- | trace ("evalD: " ++ showExprTag expr) False
+ | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
+ = error "evalD: ?!?!"
+
+evalD (LitD d#) de = d#
+
+evalD (VarD v) de =
+ case lookupUFM de v of
+ Just e -> case unsafeCoerce# e of D# i -> i
+ Nothing -> error ("evalD: lookupUFM " ++ show v)
+
+-- Deal with application of a function returning an Int# rep
+-- to arguments of any persuasion. Note that the function itself
+-- always has pointer rep.
+evalD (AppID e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalI e2 de)
+evalD (AppPD e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalP e2 de)
+evalD (AppFD e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalF e2 de)
+evalD (AppDD e1 e2) de
+ = unsafeCoerce# (evalP e1 de) (evalD e2 de)
+
+-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
+-- except in the sense that we go on and evaluate the body with whichever
+-- evaluator was used for the expression as a whole.
+evalD (NonRecD bind b) de
+ = evalD b (augment_nonrec bind de)
+evalD (RecD binds b) de
+ = evalD b (augment_rec binds de)
+evalD (CaseAlgD bndr expr alts def) de
+ = case helper_caseAlg bndr expr alts def de of
+ (rhs, de') -> evalD rhs de'
+evalD (CasePrimD bndr expr alts def) de
+ = case helper_casePrim bndr expr alts def de of
+ (rhs, de') -> evalD rhs de'
+
+-- evalD can't be applied to a lambda term, by defn, since those
+-- are ptr-rep'd.
+
+evalD (PrimOpD op _) de
+ = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
+
+evalD other de
+ = error ("evalD: unhandled case: " ++ showExprTag other)
+
+--------------------------------------------------------
--- Helper bits and pieces
--------------------------------------------------------
repOf (LamDD _ _) = RepP
repOf (AppPP _ _) = RepP
-repOf (AppPI _ _) = RepP
-repOf (AppPF _ _) = RepP
-repOf (AppPD _ _) = RepP
+repOf (AppPI _ _) = RepI
+repOf (AppPF _ _) = RepF
+repOf (AppPD _ _) = RepD
repOf (AppIP _ _) = RepP
-repOf (AppII _ _) = RepP
-repOf (AppIF _ _) = RepP
-repOf (AppID _ _) = RepP
+repOf (AppII _ _) = RepI
+repOf (AppIF _ _) = RepF
+repOf (AppID _ _) = RepD
repOf (AppFP _ _) = RepP
-repOf (AppFI _ _) = RepP
-repOf (AppFF _ _) = RepP
-repOf (AppFD _ _) = RepP
+repOf (AppFI _ _) = RepI
+repOf (AppFF _ _) = RepF
+repOf (AppFD _ _) = RepD
repOf (AppDP _ _) = RepP
-repOf (AppDI _ _) = RepP
-repOf (AppDF _ _) = RepP
-repOf (AppDD _ _) = RepP
+repOf (AppDI _ _) = RepI
+repOf (AppDF _ _) = RepF
+repOf (AppDD _ _) = RepD
repOf (NonRecP _ _) = RepP
repOf (NonRecI _ _) = RepI
+repOf (NonRecF _ _) = RepF
+repOf (NonRecD _ _) = RepD
repOf (LitI _) = RepI
-repOf (LitS _) = RepI
+repOf (LitF _) = RepF
+repOf (LitD _) = RepD
-repOf (VarI _) = RepI
repOf (VarP _) = RepI
+repOf (VarI _) = RepI
+repOf (VarF _) = RepF
+repOf (VarD _) = RepD
-repOf (PrimOpI _ _) = RepI
repOf (PrimOpP _ _) = RepP
+repOf (PrimOpI _ _) = RepI
+repOf (PrimOpF _ _) = RepF
+repOf (PrimOpD _ _) = RepD
repOf (ConApp _) = RepP
repOf (ConAppI _ _) = RepP
repOf (ConAppPPP _ _ _ _) = RepP
repOf (CaseAlgP _ _ _ _) = RepP
+repOf (CaseAlgI _ _ _ _) = RepI
+repOf (CaseAlgF _ _ _ _) = RepF
+repOf (CaseAlgD _ _ _ _) = RepD
+
+repOf (CasePrimP _ _ _ _) = RepP
+repOf (CasePrimI _ _ _ _) = RepI
+repOf (CasePrimF _ _ _ _) = RepF
+repOf (CasePrimD _ _ _ _) = RepD
repOf other
= error ("repOf: unhandled case: " ++ showExprTag other)
= case repOf expr of
RepI -> unsafeCoerce# (I# (evalI expr de))
RepP -> evalP expr de
-
+ RepF -> unsafeCoerce# (F# (evalF expr de))
+ RepD -> unsafeCoerce# (D# (evalD expr de))
-- Evaluate the scrutinee of a case, select an alternative,
-- augment the environment appropriately, and return the alt
= let exprEv = evalP expr de
in
exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
- trace "returned" $
case select_altAlg (tagOf exprEv) alts def of
(vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
exprEv (vars,1))
projects / ghc-hetmet.git / commitdiff