Direct function calls

compiler/src/AST/Optimized.hs

@@ -53,7 +53,7 @@ data Expr
  | VarDebug A.Region Name ModuleName.Canonical (Maybe Name)
  | VarKernel A.Region Name Name
  | Array A.Region [Expr]
- | Function [A.Located Name] Expr
+ | Function A.Region [A.Located Name] Expr
  | Call A.Region Expr [Expr]
  | TailCall Name [(Name, Expr)]
  | If [(Expr, Expr)] Expr
@@ -64,24 +64,29 @@ data Expr
  | Access Expr A.Region Name
  | Update A.Region Expr (Map.Map (A.Located Name) Expr)
  | Record A.Region (Map.Map (A.Located Name) Expr)
+ deriving (Show)
 
 data Global = Global ModuleName.Canonical Name
+ deriving (Show)
 
 -- DEFINITIONS
 
 data Def
  = Def A.Region Name Expr
  | TailDef A.Region Name [A.Located Name] Expr
+ deriving (Show)
 
 data Destructor
  = Destructor Name Path
+ deriving (Show)
 
 data Path
  = Index Index.ZeroBased Path
  | ArrayIndex Index.ZeroBased Path
  | Field Name Path
  | Unbox Path
  | Root Name
+ deriving (Show)
 
 -- BRANCHING
 
@@ -97,11 +102,12 @@ data Decider a
  _tests :: [(DT.Test, Decider a)],
  _fallback :: Decider a
  }
- deriving (Eq)
+ deriving (Show, Eq)
 
 data Choice
  = Inline Expr
  | Jump Int
+ deriving (Show)
 
 -- OBJECT GRAPH
 
@@ -219,7 +225,7 @@ instance Binary Expr where
  VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d
  VarKernel a b c -> putWord8 11 >> put a >> put b >> put c
  Array a b -> putWord8 12 >> put a >> put b
- Function a b -> putWord8 13 >> put a >> put b
+ Function a b c -> putWord8 13 >> put a >> put b >> put c
  Call a b c -> putWord8 14 >> put a >> put b >> put c
  TailCall a b -> putWord8 15 >> put a >> put b
  If a b -> putWord8 16 >> put a >> put b
@@ -248,7 +254,7 @@ instance Binary Expr where
  10 -> liftM4 VarDebug get get get get
  11 -> liftM3 VarKernel get get get
  12 -> liftM2 Array get get
- 13 -> liftM2 Function get get
+ 13 -> liftM3 Function get get get
  14 -> liftM3 Call get get get
  15 -> liftM2 TailCall get get
  16 -> liftM2 If get get

compiler/src/Generate/JavaScript.hs

@@ -36,13 +36,41 @@ import Prelude hiding (cycle, print)
 
 type Graph = Map.Map Opt.Global Opt.Node
 
+type FnArgLookup = ModuleName.Canonical -> Name.Name -> Maybe Int
+
 type Mains = Map.Map ModuleName.Canonical Opt.Main
 
 data GeneratedResult = GeneratedResult
  { _source :: B.Builder,
  _sourceMap :: SourceMap.SourceMap
  }
 
+makeArgLookup :: Graph -> ModuleName.Canonical -> Name.Name -> Maybe Int
+makeArgLookup graph home name =
+ case Map.lookup (Opt.Global home name) graph of
+ Just (Opt.Define _ (Opt.Function _ args _) _) ->
+ Just (length args)
+ Just (Opt.Ctor _ arity) ->
+ Just arity
+ Just (Opt.Link global) ->
+ case Map.lookup global graph of
+ Just (Opt.Cycle names _ defs _) ->
+ case List.find (\d -> defName d == name) defs of
+ Just (Opt.Def _ _ (Opt.Function _ args _)) ->
+ Just (length args)
+ Just (Opt.TailDef _ _ args _) ->
+ Just (length args)
+ _ ->
+ error (show names)
+ _ ->
+ Nothing
+ _ ->
+ Nothing
+
+defName :: Opt.Def -> Name.Name
+defName (Opt.Def _ name _) = name
+defName (Opt.TailDef _ name _ _) = name
+
 prelude :: B.Builder
 prelude =
  "(function(scope){\n'use strict';"
@@ -140,18 +168,32 @@ addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
 addGlobalHelp mode graph global@(Opt.Global home _) state =
  let addDeps deps someState =
  Set.foldl' (addGlobal mode graph) someState deps
+
+ argLookup = makeArgLookup graph
  in case graph ! global of
+ Opt.Define region (Opt.Function (A.Region funcStart _) args body) deps
+ | length args > 1 ->
+ addStmt
+ (addDeps deps state)
+ ( trackedFn region global args (Expr.generateFunctionImplementation mode argLookup home funcStart args body)
+ )
  Opt.Define region expr deps ->
  addStmt
  (addDeps deps state)
- ( trackedVar region global (Expr.generate mode home expr)
+ ( trackedVar region global (Expr.generate mode argLookup home expr)
  )
  Opt.DefineTailFunc region argNames body deps ->
  addStmt
  (addDeps deps state)
  ( let (Opt.Global _ name) = global
- in trackedVar region global (Expr.generateTailDef mode home name argNames body)
+ in trackedVar region global (Expr.generateTailDef mode argLookup home name argNames body)
  )
+ Opt.Ctor index arity
+ | arity > 1 ->
+ addStmt
+ state
+ ( ctor global arity (Expr.generateCtorImplementation mode global index arity)
+ )
  Opt.Ctor index arity ->
  addStmt
  state
@@ -162,7 +204,7 @@ addGlobalHelp mode graph global@(Opt.Global home _) state =
  Opt.Cycle names values functions deps ->
  addStmt
  (addDeps deps state)
- ( generateCycle mode global names values functions
+ ( generateCycle mode argLookup global names values functions
  )
  Opt.Manager effectsType ->
  generateManager mode graph global effectsType state
@@ -207,17 +249,35 @@ trackedVar :: A.Region -> Opt.Global -> Expr.Code -> JS.Stmt
 trackedVar (A.Region startPos _) (Opt.Global home name) code =
  JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) (Expr.codeToExpr code)
 
+trackedFn :: A.Region -> Opt.Global -> [A.Located Name.Name] -> Expr.Code -> JS.Stmt
+trackedFn (A.Region startPos _) (Opt.Global home name) args code =
+ let directFnName = JsName.fromGlobalDirectFn home name
+ argNames = map (\(A.At _ arg) -> JsName.fromLocal arg) args
+ in JS.Block
+ [ JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) directFnName (Expr.codeToExpr code),
+ JS.Var (JsName.fromGlobal home name) $ Expr.codeToExpr (Expr.generateCurriedFunctionRef argNames directFnName)
+ ]
+
+ctor :: Opt.Global -> Int -> Expr.Code -> JS.Stmt
+ctor (Opt.Global home name) arity code =
+ let directFnName = JsName.fromGlobalDirectFn home name
+ argNames = Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity]
+ in JS.Block
+ [ JS.Var directFnName (Expr.codeToExpr code),
+ JS.Var (JsName.fromGlobal home name) $ Expr.codeToExpr (Expr.generateCurriedFunctionRef argNames directFnName)
+ ]
+
 isDebugger :: Opt.Global -> Bool
 isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
  home == Name.debugger
 
 -- GENERATE CYCLES
 
-generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
-generateCycle mode (Opt.Global home _) names values functions =
+generateCycle :: Mode.Mode -> FnArgLookup -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
+generateCycle mode argLookup (Opt.Global home _) names values functions =
  JS.Block
- [ JS.Block $ map (generateCycleFunc mode home) functions,
- JS.Block $ map (generateSafeCycle mode home) values,
+ [ JS.Block $ map (generateCycleFunc mode argLookup home) functions,
+ JS.Block $ map (generateSafeCycle mode argLookup home) values,
  case map (generateRealCycle home) values of
  [] ->
  JS.EmptyStmt
@@ -238,18 +298,29 @@ generateCycle mode (Opt.Global home _) names values functions =
  <> " to learn how to fix it!"
  ]
 
-generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
-generateCycleFunc mode home def =
+generateCycleFunc :: Mode.Mode -> FnArgLookup -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
+generateCycleFunc mode argLookup home def =
  case def of
- Opt.Def _ name expr ->
- JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode home expr))
- Opt.TailDef _ name args expr ->
- JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode home name args expr))
-
-generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
-generateSafeCycle mode home (name, expr) =
+ Opt.Def region name (Opt.Function (A.Region funcStartPos _) args body)
+ | length args > 1 ->
+ trackedFn region (Opt.Global home name) args (Expr.generateFunctionImplementation mode argLookup home funcStartPos args body)
+ Opt.Def (A.Region startPos _) name expr ->
+ JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode argLookup home expr))
+ Opt.TailDef (A.Region startPos _) name args expr
+ | length args > 1 ->
+ let directFnName = JsName.fromGlobalDirectFn home name
+ argNames = map (\(A.At _ arg) -> JsName.fromLocal arg) args
+ in JS.Block
+ [ JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) directFnName (Expr.codeToExpr (Expr.generateTailDefImplementation mode argLookup home name args expr)),
+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateCurriedFunctionRef argNames directFnName))
+ ]
+ Opt.TailDef (A.Region startPos _) name args expr ->
+ JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode argLookup home name args expr))
+
+generateSafeCycle :: Mode.Mode -> FnArgLookup -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
+generateSafeCycle mode argLookup home (name, expr) =
  JS.FunctionStmt (JsName.fromCycle home name) [] $
- Expr.codeToStmtList (Expr.generate mode home expr)
+ Expr.codeToStmtList (Expr.generate mode argLookup home expr)
 
 generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
 generateRealCycle home (name, _) =
@@ -338,7 +409,7 @@ generatePort mode (Opt.Global home name) makePort converter =
  JS.Call
  (JS.Ref (JsName.fromKernel Name.platform makePort))
  [ JS.String (Name.toBuilder name),
- Expr.codeToExpr (Expr.generate mode home converter)
+ Expr.codeToExpr (Expr.generate mode (\_ _ -> Nothing) home converter)
  ]
 
 -- GENERATE MANAGER
@@ -408,7 +479,7 @@ generateExports mode (Trie maybeMain subs) =
  "{"
  Just (home, main) ->
  "{'init':"
- <> JS._code (JS.exprToBuilder (Expr.generateMain mode home main) (JS.emptyBuilder 0))
+ <> JS._code (JS.exprToBuilder (Expr.generateMain mode (\_ _ -> Nothing) home main) (JS.emptyBuilder 0))
  <> end
  in case Map.toList subs of
  [] ->

compiler/src/Generate/JavaScript/Builder.hs

@@ -63,7 +63,7 @@ data Expr
  | Call Expr [Expr]
  | TrackedNormalCall ModuleName.Canonical A.Position Expr Expr [Expr]
  | Function (Maybe Name) [Name] [Stmt]
- | TrackedFunction ModuleName.Canonical [A.Located Name] [Stmt]
+ | TrackedFunction ModuleName.Canonical A.Position [A.Located Name] [Stmt]
 
 data LValue
  = LRef Name
@@ -627,9 +627,12 @@ fromExpr level@(Level indent nextLevel) grouping expression builder =
  & fromStmtBlock nextLevel stmts
  & addByteString indent
  & addAscii "}"
- TrackedFunction moduleName args stmts ->
+ TrackedFunction moduleName startPos args stmts ->
  builder
- & addAscii "function"
+ & ( if startPos == A.zeroPosition
+ then addAscii "function"
+ else addTrackedByteString moduleName startPos "function"
+ )
  & addAscii "("
  & commaSepExpr (\(A.At (A.Region start _) name) -> addName moduleName start name name) args
  & addAscii ") {"