Commit 8f37eddd authored by simonmar's avatar simonmar
Browse files

[project @ 2000-10-09 11:42:49 by simonmar]

Fill in some gaps; add Float# and Double# reps
parent e030f38c
......@@ -41,6 +41,7 @@ data Rep
-- we only need one rep for both.
{- Not yet:
| RepV -- void rep
| RepI8
| RepI64
-}
......@@ -55,9 +56,13 @@ data Rep
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
......@@ -68,19 +73,24 @@ data IExpr con var
| 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#
......@@ -139,33 +149,83 @@ data IExpr con var
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)"
-----------------------------------------------------------------------------
......@@ -219,7 +279,6 @@ pprIExpr (expr:: IExpr con var)
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
......
......@@ -280,7 +280,24 @@ lit2expr lit
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
......@@ -354,8 +371,8 @@ stg2expr ie stgexpr
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
......@@ -484,7 +501,8 @@ linkIExpr ie ce expr = case expr of
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
......@@ -559,10 +577,12 @@ linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
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
......@@ -581,22 +601,43 @@ evalP (VarP v) de
-- 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,
......@@ -663,7 +704,6 @@ evalP other de
--- Evaluator for things of Int# representation
--------------------------------------------------------
-- Evaluate something which has an unboxed Int rep
evalI :: LinkedIExpr -> UniqFM boxed -> Int#
......@@ -674,24 +714,6 @@ evalI expr de
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
......@@ -704,6 +726,10 @@ evalI (AppII e1 e2) de
= 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
......@@ -731,6 +757,114 @@ evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
evalI other de
= 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
--------------------------------------------------------
......@@ -756,33 +890,40 @@ repOf (LamDF _ _) = RepP
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
......@@ -791,6 +932,14 @@ repOf (ConAppPP _ _ _) = 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)
......@@ -811,7 +960,8 @@ eval expr de
= 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
......@@ -823,7 +973,6 @@ helper_caseAlg bndr expr alts def de
= 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))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment