- other -> text "pprExpr: unimplemented tag:"
- <+> text (showExprTag other)
- where
- doAppCon repstr itbl args
- = text "Con" <> text repstr <> char '_' <> (int (addrToInt itbl))
- <+> char '[' <> hsep (map pprExpr args) <> char ']'
- doPrimOp repchar op args
- = char repchar <> ppr op <+> char '[' <> hsep (map pprExpr args) <> char ']'
- doNonRec repchr bind body
- = vcat [text "let" <> char repchr <+> pprBind bind, text "in", pprExpr body]
- doCasePrim repchr b sc alts def
- = sep [text "CasePrim" <> char repchr
- <+> pprExpr sc <+> text "of" <+> ppr b <+> char '{',
- nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
- char '}'
- ]
-
- doCaseAlg repchr b sc alts def
- = sep [text "CaseAlg" <> char repchr
- <+> pprExpr sc <+> text "of" <+> ppr b <+> char '{',
- nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
- char '}'
- ]
-
- doApp repstr f a
- = text "(@" <> text repstr <+> pprExpr f <+> pprExpr a <> char ')'
- doLam repstr v e
- = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprExpr e
-
-data VoidStar
- = VoidStar
-
-
-
-showExprTag :: Expr -> String
-showExprTag expr
- = case expr of
- CaseAlgP _ _ _ _ -> "CaseAlgP"
- CasePrimP _ _ _ _ -> "CasePrimP"
- CaseAlgI _ _ _ _ -> "CaseAlgI"
- CasePrimI _ _ _ _ -> "CasePrimI"
- AppCon _ -> "AppCon"
- AppConI _ _ -> "AppConI"
- AppConP _ _ -> "AppConP"
- AppConPP _ _ _ -> "AppConPP"
- AppConPPP _ _ _ _ -> "AppConPPP"
- PrimOpI _ _ -> "PrimOpI"
- Native _ -> "Native"
- NonRecP _ _ -> "NonRecP"
- RecP _ _ -> "RecP"
- NonRecI _ _ -> "NonRecI"
- RecI _ _ -> "RecI"
- LitI _ -> "LitI"
- LitS _ -> "LitS"
- VarP _ -> "VarP"
- VarI _ -> "VarI"
- LamPP _ _ -> "LamPP"
- LamPI _ _ -> "LamPI"
- LamIP _ _ -> "LamIP"
- LamII _ _ -> "LamII"
- AppPP _ _ -> "AppPP"
- AppPI _ _ -> "AppPI"
- AppIP _ _ -> "AppIP"
- AppII _ _ -> "AppII"
- other -> "(showExprTag:unhandled case)"
+linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] ->
+ ([LinkedIBind], ItblEnv, ClosureEnv)
+linkIBinds ie ce binds
+ = (new_binds, ie, ce)
+ where new_binds = map (linkIBind ie ce) binds
+
+linkIBinds' ie ce binds
+ = new_binds where (new_binds, ie, ce) = linkIBinds ie ce binds
+
+linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
+
+linkIExpr ie ce expr = case expr of
+
+ CaseAlgP bndr expr alts dflt ->
+ CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
+ CaseAlgI bndr expr alts dflt ->
+ CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
+ CasePrimP bndr expr alts dflt ->
+ CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
+ CasePrimI bndr expr alts dflt ->
+ CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
+ ConApp con ->
+ ConApp (lookupCon ie con)
+
+ ConAppI con arg0 ->
+ ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
+
+ ConAppP con arg0 ->
+ ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
+
+ ConAppPP con arg0 arg1 ->
+ ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
+
+ ConAppPPP con arg0 arg1 arg2 ->
+ ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
+ (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
+
+ PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
+ PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
+
+ NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
+ RecP binds expr -> RecP (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
+
+ NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
+ RecI binds expr -> RecI (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
+
+ LitI i -> LitI i
+ LitS s -> LitS s
+
+ Native var -> lookupNative ce var
+
+ VarP v -> lookupVar ce VarP v
+ VarI v -> lookupVar ce VarI v
+
+ LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
+ LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
+ LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
+ LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
+
+ AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+
+lookupCon ie con =
+ case lookupFM ie con of
+ Just addr -> addr
+ Nothing ->
+ -- try looking up in the object files.
+ case {-HACK!!!-}
+ unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
+ Just addr -> addr
+ Nothing -> pprPanic "linkIExpr" (ppr con)
+
+lookupNative ce var =
+ case lookupFM ce var of
+ Just e -> Native e
+ Nothing ->
+ -- try looking up in the object files.
+ let lbl = (rdrNameToCLabel var "closure")
+ addr = unsafePerformIO (lookupSymbol lbl) in
+ case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
+ Just (A# addr) -> Native (unsafeCoerce# addr)
+ Nothing -> pprPanic "linkIExpr" (ppr var)
+
+-- some VarI/VarP refer to top-level interpreted functions; we change
+-- them into Natives here.
+lookupVar ce f v =
+ case lookupFM ce (toRdrName v) of
+ Nothing -> f v
+ Just e -> Native e
+
+-- HACK!!! ToDo: cleaner
+rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
+rdrNameToCLabel rn suffix =
+ _UNPK_(rdrNameModule rn) ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
+
+linkAlgAlts ie ce = map (linkAlgAlt ie ce)
+linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
+
+linkPrimAlts ie ce = map (linkPrimAlt ie ce)
+linkPrimAlt ie ce (AltPrim lit rhs)
+ = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
+
+linkDefault ie ce Nothing = Nothing
+linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
+
+-- ---------------------------------------------------------------------------
+-- The interpreter proper
+-- ---------------------------------------------------------------------------